{-# LANGUAGE CPP #-}
module Polysemy.Plugin.Fundep.Stuff
( PolysemyStuff (..)
, LookupState (..)
, polysemyStuff
) where
import Data.Kind (Type)
import FastString (fsLit)
import GHC (Name, Class, TyCon, mkModuleName)
import GHC.TcPluginM.Extra (lookupModule, lookupName)
import OccName (mkTcOcc)
import TcPluginM (TcPluginM, tcLookupClass, tcLookupTyCon, unsafeTcPluginTcM)
import GhcPlugins (getDynFlags)
import Packages (lookupModuleWithSuggestions, LookupResult (..))
import Outputable (pprPanic, empty, text, (<+>), ($$))
data PolysemyStuff (l :: LookupState) = PolysemyStuff
{ PolysemyStuff l -> ThingOf l Class
findClass :: ThingOf l Class
, PolysemyStuff l -> ThingOf l TyCon
semTyCon :: ThingOf l TyCon
, PolysemyStuff l -> ThingOf l TyCon
ifStuckTyCon :: ThingOf l TyCon
, PolysemyStuff l -> ThingOf l TyCon
locateEffectTyCon :: ThingOf l TyCon
}
polysemyStuffLocations :: PolysemyStuff 'Locations
polysemyStuffLocations :: PolysemyStuff 'Locations
polysemyStuffLocations = PolysemyStuff :: forall (l :: LookupState).
ThingOf l Class
-> ThingOf l TyCon
-> ThingOf l TyCon
-> ThingOf l TyCon
-> PolysemyStuff l
PolysemyStuff
{ findClass :: ThingOf 'Locations Class
findClass = ([Char]
"Polysemy.Internal.Union", [Char]
"Find")
, semTyCon :: ThingOf 'Locations TyCon
semTyCon = ([Char]
"Polysemy.Internal", [Char]
"Sem")
, ifStuckTyCon :: ThingOf 'Locations TyCon
ifStuckTyCon = ([Char]
"Polysemy.Internal.CustomErrors.Redefined", [Char]
"IfStuck")
, locateEffectTyCon :: ThingOf 'Locations TyCon
locateEffectTyCon = ([Char]
"Polysemy.Internal.Union", [Char]
"LocateEffect")
}
polysemyStuff :: TcPluginM (PolysemyStuff 'Things)
polysemyStuff :: TcPluginM (PolysemyStuff 'Things)
polysemyStuff = do
DynFlags
dflags <- TcM DynFlags -> TcPluginM DynFlags
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM TcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let error_msg :: a
error_msg = [Char] -> SDoc -> a
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"polysemy-plugin"
(SDoc -> a) -> SDoc -> a
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
text [Char]
""
SDoc -> SDoc -> SDoc
$$ [Char] -> SDoc
text [Char]
"--------------------------------------------------------------------------------"
SDoc -> SDoc -> SDoc
$$ [Char] -> SDoc
text [Char]
"`polysemy-plugin` is loaded, but"
SDoc -> SDoc -> SDoc
<+> [Char] -> SDoc
text [Char]
"`polysemy` isn't available as a package."
SDoc -> SDoc -> SDoc
$$ [Char] -> SDoc
text [Char]
"Probable fix: add `polysemy` to your cabal `build-depends`"
SDoc -> SDoc -> SDoc
$$ [Char] -> SDoc
text [Char]
"--------------------------------------------------------------------------------"
SDoc -> SDoc -> SDoc
$$ [Char] -> SDoc
text [Char]
""
case DynFlags -> ModuleName -> Maybe FastString -> LookupResult
lookupModuleWithSuggestions DynFlags
dflags ([Char] -> ModuleName
mkModuleName [Char]
"Polysemy") Maybe FastString
forall a. Maybe a
Nothing of
LookupHidden [(Module, ModuleOrigin)]
_ [(Module, ModuleOrigin)]
_ -> TcPluginM ()
forall a. a
error_msg
LookupNotFound [ModuleSuggestion]
_ -> TcPluginM ()
forall a. a
error_msg
#if __GLASGOW_HASKELL__ >= 806
LookupUnusable [(Module, ModuleOrigin)]
_ -> TcPluginM ()
forall a. a
error_msg
#endif
LookupResult
_ -> () -> TcPluginM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
let PolysemyStuff ThingOf 'Locations Class
a ThingOf 'Locations TyCon
b ThingOf 'Locations TyCon
c ThingOf 'Locations TyCon
d = PolysemyStuff 'Locations
polysemyStuffLocations
Class -> TyCon -> TyCon -> TyCon -> PolysemyStuff 'Things
forall (l :: LookupState).
ThingOf l Class
-> ThingOf l TyCon
-> ThingOf l TyCon
-> ThingOf l TyCon
-> PolysemyStuff l
PolysemyStuff (Class -> TyCon -> TyCon -> TyCon -> PolysemyStuff 'Things)
-> TcPluginM Class
-> TcPluginM (TyCon -> TyCon -> TyCon -> PolysemyStuff 'Things)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ThingOf 'Locations Class -> TcPluginM (ThingOf 'Things Class)
forall a.
CanLookup a =>
ThingOf 'Locations a -> TcPluginM (ThingOf 'Things a)
doLookup ([Char], [Char])
ThingOf 'Locations Class
a
TcPluginM (TyCon -> TyCon -> TyCon -> PolysemyStuff 'Things)
-> TcPluginM TyCon
-> TcPluginM (TyCon -> TyCon -> PolysemyStuff 'Things)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ThingOf 'Locations TyCon -> TcPluginM (ThingOf 'Things TyCon)
forall a.
CanLookup a =>
ThingOf 'Locations a -> TcPluginM (ThingOf 'Things a)
doLookup ([Char], [Char])
ThingOf 'Locations TyCon
b
TcPluginM (TyCon -> TyCon -> PolysemyStuff 'Things)
-> TcPluginM TyCon -> TcPluginM (TyCon -> PolysemyStuff 'Things)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ThingOf 'Locations TyCon -> TcPluginM (ThingOf 'Things TyCon)
forall a.
CanLookup a =>
ThingOf 'Locations a -> TcPluginM (ThingOf 'Things a)
doLookup ([Char], [Char])
ThingOf 'Locations TyCon
c
TcPluginM (TyCon -> PolysemyStuff 'Things)
-> TcPluginM TyCon -> TcPluginM (PolysemyStuff 'Things)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ThingOf 'Locations TyCon -> TcPluginM (ThingOf 'Things TyCon)
forall a.
CanLookup a =>
ThingOf 'Locations a -> TcPluginM (ThingOf 'Things a)
doLookup ([Char], [Char])
ThingOf 'Locations TyCon
d
data LookupState
= Locations
| Things
type family ThingOf (l :: LookupState) (a :: Type) :: Type where
ThingOf 'Locations _ = (String, String)
ThingOf 'Things a = a
class CanLookup a where
lookupStrategy :: Name -> TcPluginM a
instance CanLookup Class where
lookupStrategy :: Name -> TcPluginM Class
lookupStrategy = Name -> TcPluginM Class
tcLookupClass
instance CanLookup TyCon where
lookupStrategy :: Name -> TcPluginM TyCon
lookupStrategy = Name -> TcPluginM TyCon
tcLookupTyCon
doLookup :: CanLookup a => ThingOf 'Locations a -> TcPluginM (ThingOf 'Things a)
doLookup :: ThingOf 'Locations a -> TcPluginM (ThingOf 'Things a)
doLookup (mdname, name) = do
Module
md <- ModuleName -> FastString -> TcPluginM Module
lookupModule ([Char] -> ModuleName
mkModuleName [Char]
mdname) (FastString -> TcPluginM Module) -> FastString -> TcPluginM Module
forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
fsLit [Char]
"polysemy"
Name
nm <- Module -> OccName -> TcPluginM Name
lookupName Module
md (OccName -> TcPluginM Name) -> OccName -> TcPluginM Name
forall a b. (a -> b) -> a -> b
$ [Char] -> OccName
mkTcOcc [Char]
name
Name -> TcPluginM a
forall a. CanLookup a => Name -> TcPluginM a
lookupStrategy Name
nm