{-# 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, (<+>), ($$))



------------------------------------------------------------------------------
-- | All of the things from "polysemy" that we need access to in the plugin.
-- When @l ~ 'Locations@, each of these is just a pair of strings. When @l
-- ~ 'Things@, it's actually references to the stuff.
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
  }


------------------------------------------------------------------------------
-- | All of the things we need to lookup.
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")
  }


------------------------------------------------------------------------------
-- | Lookup all of the 'PolysemyStuff'.
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 kind for 'ThingOf'.
data LookupState
  = Locations
  | Things


------------------------------------------------------------------------------
-- | HKD indexed by the 'LookupState'; used by 'PolysemyStuff'.
type family ThingOf (l :: LookupState) (a :: Type) :: Type where
  ThingOf 'Locations _ = (String, String)
  ThingOf 'Things    a = a


------------------------------------------------------------------------------
-- | Things that can be found in a 'TcPluginM' environment.
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


------------------------------------------------------------------------------
-- | Transform a @'ThingOf' 'Locations@ into a @'ThingOf' 'Things@.
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