{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if __GLASGOW_HASKELL__ < 802
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif
module Data.Constraint.Deriving.CorePluginM
( CorePluginM (), runCorePluginM
, CorePluginEnv (), CorePluginEnvRef, initCorePluginEnv
, liftCoreM, runTcM, liftIO, lookupName
, try, exception
, ask
, tyConDict, tyConBareConstraint, tyConDeriveContext
, funDictToBare, tyEmptyConstraint, classTypeEq
, pluginWarning, pluginLocatedWarning
, pluginError, pluginLocatedError
, pluginDebug, pluginTrace
, newName, newTyVar, freshenTyVar, newLocalVar, getInstEnvs, getModuleAnns
) where
#if PLUGIN_DEBUG
import GHC.Stack (withFrozenCallStack)
#endif
import Control.Applicative (Alternative (..))
import Control.Monad (join, (>=>))
import Data.Data (Data, typeRep)
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Data.Maybe (catMaybes)
import Data.Proxy (Proxy (..))
import Data.Constraint.Deriving.Import
newtype CorePluginM a = CorePluginM
{ CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
_runCorePluginM :: IORef CorePluginEnv -> CoreM (Either (IO ()) a) }
runCorePluginM :: CorePluginM a -> IORef CorePluginEnv -> CoreM (Maybe a)
runCorePluginM :: CorePluginM a -> IORef CorePluginEnv -> CoreM (Maybe a)
runCorePluginM CorePluginM a
m IORef CorePluginEnv
e = CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
forall a.
CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
_runCorePluginM CorePluginM a
m IORef CorePluginEnv
e CoreM (Either (IO ()) a)
-> (Either (IO ()) a -> CoreM (Maybe a)) -> CoreM (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left IO ()
er -> Maybe a
forall a. Maybe a
Nothing Maybe a -> CoreM () -> CoreM (Maybe a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
er
Right a
a -> Maybe a -> CoreM (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> CoreM (Maybe a)) -> Maybe a -> CoreM (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a
instance Functor CorePluginM where
fmap :: (a -> b) -> CorePluginM a -> CorePluginM b
fmap a -> b
f CorePluginM a
m = (IORef CorePluginEnv -> CoreM (Either (IO ()) b)) -> CorePluginM b
forall a.
(IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
CorePluginM ((IORef CorePluginEnv -> CoreM (Either (IO ()) b))
-> CorePluginM b)
-> (IORef CorePluginEnv -> CoreM (Either (IO ()) b))
-> CorePluginM b
forall a b. (a -> b) -> a -> b
$ (Either (IO ()) a -> Either (IO ()) b)
-> CoreM (Either (IO ()) a) -> CoreM (Either (IO ()) b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Either (IO ()) a -> Either (IO ()) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (CoreM (Either (IO ()) a) -> CoreM (Either (IO ()) b))
-> (IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> IORef CorePluginEnv
-> CoreM (Either (IO ()) b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
forall a.
CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
_runCorePluginM CorePluginM a
m
instance Applicative CorePluginM where
pure :: a -> CorePluginM a
pure = (IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
forall a.
(IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
CorePluginM ((IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> CorePluginM a)
-> (a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> a
-> CorePluginM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreM (Either (IO ()) a)
-> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
forall a b. a -> b -> a
const (CoreM (Either (IO ()) a)
-> IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> (a -> CoreM (Either (IO ()) a))
-> a
-> IORef CorePluginEnv
-> CoreM (Either (IO ()) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (IO ()) a -> CoreM (Either (IO ()) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (IO ()) a -> CoreM (Either (IO ()) a))
-> (a -> Either (IO ()) a) -> a -> CoreM (Either (IO ()) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either (IO ()) a
forall a b. b -> Either a b
Right
CorePluginM (a -> b)
mf <*> :: CorePluginM (a -> b) -> CorePluginM a -> CorePluginM b
<*> CorePluginM a
ma = (IORef CorePluginEnv -> CoreM (Either (IO ()) b)) -> CorePluginM b
forall a.
(IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
CorePluginM ((IORef CorePluginEnv -> CoreM (Either (IO ()) b))
-> CorePluginM b)
-> (IORef CorePluginEnv -> CoreM (Either (IO ()) b))
-> CorePluginM b
forall a b. (a -> b) -> a -> b
$ \IORef CorePluginEnv
e -> Either (IO ()) (a -> b) -> Either (IO ()) a -> Either (IO ()) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (Either (IO ()) (a -> b) -> Either (IO ()) a -> Either (IO ()) b)
-> CoreM (Either (IO ()) (a -> b))
-> CoreM (Either (IO ()) a -> Either (IO ()) b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CorePluginM (a -> b)
-> IORef CorePluginEnv -> CoreM (Either (IO ()) (a -> b))
forall a.
CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
_runCorePluginM CorePluginM (a -> b)
mf IORef CorePluginEnv
e CoreM (Either (IO ()) a -> Either (IO ()) b)
-> CoreM (Either (IO ()) a) -> CoreM (Either (IO ()) b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
forall a.
CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
_runCorePluginM CorePluginM a
ma IORef CorePluginEnv
e
instance Alternative CorePluginM where
empty :: CorePluginM a
empty = (IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
forall a.
(IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
CorePluginM ((IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> CorePluginM a)
-> (CoreM (Either (IO ()) a)
-> IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> CoreM (Either (IO ()) a)
-> CorePluginM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreM (Either (IO ()) a)
-> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
forall a b. a -> b -> a
const (CoreM (Either (IO ()) a) -> CorePluginM a)
-> CoreM (Either (IO ()) a) -> CorePluginM a
forall a b. (a -> b) -> a -> b
$ Either (IO ()) a -> CoreM (Either (IO ()) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (IO ()) a -> CoreM (Either (IO ()) a))
-> Either (IO ()) a -> CoreM (Either (IO ()) a)
forall a b. (a -> b) -> a -> b
$ IO () -> Either (IO ()) a
forall a b. a -> Either a b
Left (IO () -> Either (IO ()) a) -> IO () -> Either (IO ()) a
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
CorePluginM a
ma <|> :: CorePluginM a -> CorePluginM a -> CorePluginM a
<|> CorePluginM a
mb = (IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
forall a.
(IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
CorePluginM ((IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> CorePluginM a)
-> (IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> CorePluginM a
forall a b. (a -> b) -> a -> b
$ \IORef CorePluginEnv
e -> Either (IO ()) a -> Either (IO ()) a -> Either (IO ()) a
forall a b. Either a b -> Either a b -> Either a b
f (Either (IO ()) a -> Either (IO ()) a -> Either (IO ()) a)
-> CoreM (Either (IO ()) a)
-> CoreM (Either (IO ()) a -> Either (IO ()) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
forall a.
CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
_runCorePluginM CorePluginM a
ma IORef CorePluginEnv
e CoreM (Either (IO ()) a -> Either (IO ()) a)
-> CoreM (Either (IO ()) a) -> CoreM (Either (IO ()) a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
forall a.
CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
_runCorePluginM CorePluginM a
mb IORef CorePluginEnv
e
where
f :: Either a b -> Either a b -> Either a b
f (Left a
_) = Either a b -> Either a b
forall a. a -> a
id
f Either a b
rx = Either a b -> Either a b -> Either a b
forall a b. a -> b -> a
const Either a b
rx
instance Monad CorePluginM where
return :: a -> CorePluginM a
return = a -> CorePluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
CorePluginM a
ma >>= :: CorePluginM a -> (a -> CorePluginM b) -> CorePluginM b
>>= a -> CorePluginM b
k = (IORef CorePluginEnv -> CoreM (Either (IO ()) b)) -> CorePluginM b
forall a.
(IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
CorePluginM ((IORef CorePluginEnv -> CoreM (Either (IO ()) b))
-> CorePluginM b)
-> (IORef CorePluginEnv -> CoreM (Either (IO ()) b))
-> CorePluginM b
forall a b. (a -> b) -> a -> b
$ \IORef CorePluginEnv
e -> CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
forall a.
CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
_runCorePluginM CorePluginM a
ma IORef CorePluginEnv
e CoreM (Either (IO ()) a)
-> (Either (IO ()) a -> CoreM (Either (IO ()) b))
-> CoreM (Either (IO ()) b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left IO ()
a -> Either (IO ()) b -> CoreM (Either (IO ()) b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> Either (IO ()) b
forall a b. a -> Either a b
Left IO ()
a)
Right a
a -> CorePluginM b -> IORef CorePluginEnv -> CoreM (Either (IO ()) b)
forall a.
CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
_runCorePluginM (a -> CorePluginM b
k a
a) IORef CorePluginEnv
e
instance MonadIO CorePluginM where
liftIO :: IO a -> CorePluginM a
liftIO = CoreM a -> CorePluginM a
forall a. CoreM a -> CorePluginM a
liftCoreM (CoreM a -> CorePluginM a)
-> (IO a -> CoreM a) -> IO a -> CorePluginM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
instance MonadThings CorePluginM where
lookupThing :: Name -> CorePluginM TyThing
lookupThing = CoreM TyThing -> CorePluginM TyThing
forall a. CoreM a -> CorePluginM a
liftCoreM (CoreM TyThing -> CorePluginM TyThing)
-> (Name -> CoreM TyThing) -> Name -> CorePluginM TyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> CoreM TyThing
forall (m :: * -> *). MonadThings m => Name -> m TyThing
lookupThing
instance MonadUnique CorePluginM where
getUniqueSupplyM :: CorePluginM UniqSupply
getUniqueSupplyM = (IORef CorePluginEnv -> CoreM (Either (IO ()) UniqSupply))
-> CorePluginM UniqSupply
forall a.
(IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
CorePluginM ((IORef CorePluginEnv -> CoreM (Either (IO ()) UniqSupply))
-> CorePluginM UniqSupply)
-> (IORef CorePluginEnv -> CoreM (Either (IO ()) UniqSupply))
-> CorePluginM UniqSupply
forall a b. (a -> b) -> a -> b
$ CoreM (Either (IO ()) UniqSupply)
-> IORef CorePluginEnv -> CoreM (Either (IO ()) UniqSupply)
forall a b. a -> b -> a
const (CoreM (Either (IO ()) UniqSupply)
-> IORef CorePluginEnv -> CoreM (Either (IO ()) UniqSupply))
-> CoreM (Either (IO ()) UniqSupply)
-> IORef CorePluginEnv
-> CoreM (Either (IO ()) UniqSupply)
forall a b. (a -> b) -> a -> b
$ UniqSupply -> Either (IO ()) UniqSupply
forall a b. b -> Either a b
Right (UniqSupply -> Either (IO ()) UniqSupply)
-> CoreM UniqSupply -> CoreM (Either (IO ()) UniqSupply)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
liftCoreM :: CoreM a -> CorePluginM a
liftCoreM :: CoreM a -> CorePluginM a
liftCoreM = (IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
forall a.
(IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
CorePluginM ((IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> CorePluginM a)
-> (CoreM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> CoreM a
-> CorePluginM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreM (Either (IO ()) a)
-> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
forall a b. a -> b -> a
const (CoreM (Either (IO ()) a)
-> IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> (CoreM a -> CoreM (Either (IO ()) a))
-> CoreM a
-> IORef CorePluginEnv
-> CoreM (Either (IO ()) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Either (IO ()) a) -> CoreM a -> CoreM (Either (IO ()) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either (IO ()) a
forall a b. b -> Either a b
Right
exception :: CorePluginM a
exception :: CorePluginM a
exception = CorePluginM a
forall (f :: * -> *) a. Alternative f => f a
empty
try :: CorePluginM a -> CorePluginM (Maybe a)
try :: CorePluginM a -> CorePluginM (Maybe a)
try CorePluginM a
m = (IORef CorePluginEnv -> CoreM (Either (IO ()) (Maybe a)))
-> CorePluginM (Maybe a)
forall a.
(IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
CorePluginM ((IORef CorePluginEnv -> CoreM (Either (IO ()) (Maybe a)))
-> CorePluginM (Maybe a))
-> (IORef CorePluginEnv -> CoreM (Either (IO ()) (Maybe a)))
-> CorePluginM (Maybe a)
forall a b. (a -> b) -> a -> b
$ CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
forall a.
CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
_runCorePluginM CorePluginM a
m (IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> (Either (IO ()) a -> CoreM (Either (IO ()) (Maybe a)))
-> IORef CorePluginEnv
-> CoreM (Either (IO ()) (Maybe a))
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Either (IO ()) a -> CoreM (Either (IO ()) (Maybe a))
forall (f :: * -> *) b a a.
MonadIO f =>
Either (IO b) a -> f (Either a (Maybe a))
f
where
f :: Either (IO b) a -> f (Either a (Maybe a))
f (Left IO b
e) = Maybe a -> Either a (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing Either a (Maybe a) -> f b -> f (Either a (Maybe a))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IO b -> f b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO b
e
f (Right a
a) = Either a (Maybe a) -> f (Either a (Maybe a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a (Maybe a) -> f (Either a (Maybe a)))
-> (Maybe a -> Either a (Maybe a))
-> Maybe a
-> f (Either a (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> Either a (Maybe a)
forall a b. b -> Either a b
Right (Maybe a -> f (Either a (Maybe a)))
-> Maybe a -> f (Either a (Maybe a))
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a
try' :: CorePluginM a -> CorePluginM ()
try' :: CorePluginM a -> CorePluginM ()
try' CorePluginM a
m = () () -> CorePluginM (Maybe a) -> CorePluginM ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ CorePluginM a -> CorePluginM (Maybe a)
forall a. CorePluginM a -> CorePluginM (Maybe a)
try CorePluginM a
m
type CorePluginEnvRef = IORef CorePluginEnv
data CorePluginEnv = CorePluginEnv
{ CorePluginEnv -> CorePluginM Module
modConstraint :: CorePluginM Module
, CorePluginEnv -> CorePluginM Module
modConstraintBare :: CorePluginM Module
, CorePluginEnv -> CorePluginM Module
modDeriveAll :: CorePluginM Module
, CorePluginEnv -> CorePluginM Module
modToInstance :: CorePluginM Module
, CorePluginEnv -> CorePluginM Module
modDataTypeEquality :: CorePluginM Module
, CorePluginEnv -> CorePluginM TyCon
tyConDict :: CorePluginM TyCon
, CorePluginEnv -> CorePluginM TyCon
tyConBareConstraint :: CorePluginM TyCon
, CorePluginEnv -> CorePluginM TyCon
tyConDeriveContext :: CorePluginM TyCon
, CorePluginEnv -> CorePluginM Id
funDictToBare :: CorePluginM Id
, CorePluginEnv -> CorePluginM Type
tyEmptyConstraint :: CorePluginM Type
, CorePluginEnv -> CorePluginM Class
classTypeEq :: CorePluginM Class
, CorePluginEnv -> CorePluginM InstEnv
globalInstEnv :: CorePluginM InstEnv
}
ask :: (CorePluginEnv -> CorePluginM a) -> CorePluginM a
ask :: (CorePluginEnv -> CorePluginM a) -> CorePluginM a
ask CorePluginEnv -> CorePluginM a
f = CorePluginM (CorePluginM a) -> CorePluginM a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (CorePluginM (CorePluginM a) -> CorePluginM a)
-> CorePluginM (CorePluginM a) -> CorePluginM a
forall a b. (a -> b) -> a -> b
$ (IORef CorePluginEnv -> CoreM (Either (IO ()) (CorePluginM a)))
-> CorePluginM (CorePluginM a)
forall a.
(IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
CorePluginM ((IORef CorePluginEnv -> CoreM (Either (IO ()) (CorePluginM a)))
-> CorePluginM (CorePluginM a))
-> (IORef CorePluginEnv -> CoreM (Either (IO ()) (CorePluginM a)))
-> CorePluginM (CorePluginM a)
forall a b. (a -> b) -> a -> b
$ IO (Either (IO ()) (CorePluginM a))
-> CoreM (Either (IO ()) (CorePluginM a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (IO ()) (CorePluginM a))
-> CoreM (Either (IO ()) (CorePluginM a)))
-> (IORef CorePluginEnv -> IO (Either (IO ()) (CorePluginM a)))
-> IORef CorePluginEnv
-> CoreM (Either (IO ()) (CorePluginM a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CorePluginEnv -> Either (IO ()) (CorePluginM a))
-> IO CorePluginEnv -> IO (Either (IO ()) (CorePluginM a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CorePluginM a -> Either (IO ()) (CorePluginM a)
forall a b. b -> Either a b
Right (CorePluginM a -> Either (IO ()) (CorePluginM a))
-> (CorePluginEnv -> CorePluginM a)
-> CorePluginEnv
-> Either (IO ()) (CorePluginM a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CorePluginEnv -> CorePluginM a
f) (IO CorePluginEnv -> IO (Either (IO ()) (CorePluginM a)))
-> (IORef CorePluginEnv -> IO CorePluginEnv)
-> IORef CorePluginEnv
-> IO (Either (IO ()) (CorePluginM a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef CorePluginEnv -> IO CorePluginEnv
forall a. IORef a -> IO a
readIORef
initCorePluginEnv :: CoreM (IORef CorePluginEnv)
initCorePluginEnv :: CoreM (IORef CorePluginEnv)
initCorePluginEnv = do
IORef CorePluginEnv
env <- IO (IORef CorePluginEnv) -> CoreM (IORef CorePluginEnv)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef CorePluginEnv) -> CoreM (IORef CorePluginEnv))
-> IO (IORef CorePluginEnv) -> CoreM (IORef CorePluginEnv)
forall a b. (a -> b) -> a -> b
$ CorePluginEnv -> IO (IORef CorePluginEnv)
forall a. a -> IO (IORef a)
newIORef CorePluginEnv
defCorePluginEnv
Either (IO ()) InstEnv
gie <- CorePluginM InstEnv
-> IORef CorePluginEnv -> CoreM (Either (IO ()) InstEnv)
forall a.
CorePluginM a -> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
_runCorePluginM ((CorePluginEnv -> CorePluginM InstEnv) -> CorePluginM InstEnv
forall a. (CorePluginEnv -> CorePluginM a) -> CorePluginM a
ask CorePluginEnv -> CorePluginM InstEnv
globalInstEnv) IORef CorePluginEnv
env
Either (IO ()) InstEnv
-> CoreM (IORef CorePluginEnv) -> CoreM (IORef CorePluginEnv)
seq Either (IO ()) InstEnv
gie (CoreM (IORef CorePluginEnv) -> CoreM (IORef CorePluginEnv))
-> CoreM (IORef CorePluginEnv) -> CoreM (IORef CorePluginEnv)
forall a b. (a -> b) -> a -> b
$ IORef CorePluginEnv -> CoreM (IORef CorePluginEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return IORef CorePluginEnv
env
defCorePluginEnv :: CorePluginEnv
defCorePluginEnv :: CorePluginEnv
defCorePluginEnv = CorePluginEnv :: CorePluginM Module
-> CorePluginM Module
-> CorePluginM Module
-> CorePluginM Module
-> CorePluginM Module
-> CorePluginM TyCon
-> CorePluginM TyCon
-> CorePluginM TyCon
-> CorePluginM Id
-> CorePluginM Type
-> CorePluginM Class
-> CorePluginM InstEnv
-> CorePluginEnv
CorePluginEnv
{ modConstraint :: CorePluginM Module
modConstraint = do
Maybe Module
mm <- CorePluginM Module -> CorePluginM (Maybe Module)
forall a. CorePluginM a -> CorePluginM (Maybe a)
try (CorePluginM Module -> CorePluginM (Maybe Module))
-> CorePluginM Module -> CorePluginM (Maybe Module)
forall a b. (a -> b) -> a -> b
$ ModuleName -> [FastString] -> CorePluginM Module
lookupModule ModuleName
mnConstraint [FastString
pnConstraintsDeriving, FastString
pnConstraints]
Maybe Module
-> (CorePluginM Module -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Module
forall a.
Maybe a
-> (CorePluginM a -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM a
saveAndReturn Maybe Module
mm ((CorePluginM Module -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Module)
-> (CorePluginM Module -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Module
forall a b. (a -> b) -> a -> b
$ \CorePluginM Module
a CorePluginEnv
e -> CorePluginEnv
e { modConstraint :: CorePluginM Module
modConstraint = CorePluginM Module
a }
, modConstraintBare :: CorePluginM Module
modConstraintBare = do
Maybe Module
mm <- CorePluginM Module -> CorePluginM (Maybe Module)
forall a. CorePluginM a -> CorePluginM (Maybe a)
try (CorePluginM Module -> CorePluginM (Maybe Module))
-> CorePluginM Module -> CorePluginM (Maybe Module)
forall a b. (a -> b) -> a -> b
$ ModuleName -> [FastString] -> CorePluginM Module
lookupModule ModuleName
mnConstraintBare [FastString
pnConstraintsDeriving]
Maybe Module
-> (CorePluginM Module -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Module
forall a.
Maybe a
-> (CorePluginM a -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM a
saveAndReturn Maybe Module
mm ((CorePluginM Module -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Module)
-> (CorePluginM Module -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Module
forall a b. (a -> b) -> a -> b
$ \CorePluginM Module
a CorePluginEnv
e -> CorePluginEnv
e { modConstraintBare :: CorePluginM Module
modConstraintBare = CorePluginM Module
a }
, modDeriveAll :: CorePluginM Module
modDeriveAll = do
Maybe Module
mm <- CorePluginM Module -> CorePluginM (Maybe Module)
forall a. CorePluginM a -> CorePluginM (Maybe a)
try (CorePluginM Module -> CorePluginM (Maybe Module))
-> CorePluginM Module -> CorePluginM (Maybe Module)
forall a b. (a -> b) -> a -> b
$ ModuleName -> [FastString] -> CorePluginM Module
lookupModule ModuleName
mnDeriveAll [FastString
pnConstraintsDeriving]
Maybe Module
-> (CorePluginM Module -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Module
forall a.
Maybe a
-> (CorePluginM a -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM a
saveAndReturn Maybe Module
mm ((CorePluginM Module -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Module)
-> (CorePluginM Module -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Module
forall a b. (a -> b) -> a -> b
$ \CorePluginM Module
a CorePluginEnv
e -> CorePluginEnv
e { modDeriveAll :: CorePluginM Module
modDeriveAll = CorePluginM Module
a }
, modToInstance :: CorePluginM Module
modToInstance = do
Maybe Module
mm <- CorePluginM Module -> CorePluginM (Maybe Module)
forall a. CorePluginM a -> CorePluginM (Maybe a)
try (CorePluginM Module -> CorePluginM (Maybe Module))
-> CorePluginM Module -> CorePluginM (Maybe Module)
forall a b. (a -> b) -> a -> b
$ ModuleName -> [FastString] -> CorePluginM Module
lookupModule ModuleName
mnToInstance [FastString
pnConstraintsDeriving]
Maybe Module
-> (CorePluginM Module -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Module
forall a.
Maybe a
-> (CorePluginM a -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM a
saveAndReturn Maybe Module
mm ((CorePluginM Module -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Module)
-> (CorePluginM Module -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Module
forall a b. (a -> b) -> a -> b
$ \CorePluginM Module
a CorePluginEnv
e -> CorePluginEnv
e { modToInstance :: CorePluginM Module
modToInstance = CorePluginM Module
a }
, modDataTypeEquality :: CorePluginM Module
modDataTypeEquality = do
Maybe Module
mm <- CorePluginM Module -> CorePluginM (Maybe Module)
forall a. CorePluginM a -> CorePluginM (Maybe a)
try (CorePluginM Module -> CorePluginM (Maybe Module))
-> CorePluginM Module -> CorePluginM (Maybe Module)
forall a b. (a -> b) -> a -> b
$ ModuleName -> [FastString] -> CorePluginM Module
lookupModule ModuleName
mnDataTypeEquality [FastString
pnBase]
Maybe Module
-> (CorePluginM Module -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Module
forall a.
Maybe a
-> (CorePluginM a -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM a
saveAndReturn Maybe Module
mm ((CorePluginM Module -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Module)
-> (CorePluginM Module -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Module
forall a b. (a -> b) -> a -> b
$ \CorePluginM Module
a CorePluginEnv
e -> CorePluginEnv
e { modDataTypeEquality :: CorePluginM Module
modDataTypeEquality = CorePluginM Module
a }
, tyConDict :: CorePluginM TyCon
tyConDict = do
Module
m <- (CorePluginEnv -> CorePluginM Module) -> CorePluginM Module
forall a. (CorePluginEnv -> CorePluginM a) -> CorePluginM a
ask CorePluginEnv -> CorePluginM Module
modConstraint
Maybe TyCon
mtc <- CorePluginM TyCon -> CorePluginM (Maybe TyCon)
forall a. CorePluginM a -> CorePluginM (Maybe a)
try (CorePluginM TyCon -> CorePluginM (Maybe TyCon))
-> CorePluginM TyCon -> CorePluginM (Maybe TyCon)
forall a b. (a -> b) -> a -> b
$ Module -> OccName -> CorePluginM Name
lookupName Module
m OccName
tnDict CorePluginM Name
-> (Name -> CorePluginM TyCon) -> CorePluginM TyCon
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> CorePluginM TyCon
forall (m :: * -> *). MonadThings m => Name -> m TyCon
lookupTyCon
Maybe TyCon
-> (CorePluginM TyCon -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM TyCon
forall a.
Maybe a
-> (CorePluginM a -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM a
saveAndReturn Maybe TyCon
mtc ((CorePluginM TyCon -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM TyCon)
-> (CorePluginM TyCon -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM TyCon
forall a b. (a -> b) -> a -> b
$ \CorePluginM TyCon
a CorePluginEnv
e -> CorePluginEnv
e { tyConDict :: CorePluginM TyCon
tyConDict = CorePluginM TyCon
a }
, tyConBareConstraint :: CorePluginM TyCon
tyConBareConstraint = do
Module
m <- (CorePluginEnv -> CorePluginM Module) -> CorePluginM Module
forall a. (CorePluginEnv -> CorePluginM a) -> CorePluginM a
ask CorePluginEnv -> CorePluginM Module
modConstraintBare
Maybe TyCon
mtc <- CorePluginM TyCon -> CorePluginM (Maybe TyCon)
forall a. CorePluginM a -> CorePluginM (Maybe a)
try (CorePluginM TyCon -> CorePluginM (Maybe TyCon))
-> CorePluginM TyCon -> CorePluginM (Maybe TyCon)
forall a b. (a -> b) -> a -> b
$ Module -> OccName -> CorePluginM Name
lookupName Module
m OccName
tnBareConstraint CorePluginM Name
-> (Name -> CorePluginM TyCon) -> CorePluginM TyCon
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> CorePluginM TyCon
forall (m :: * -> *). MonadThings m => Name -> m TyCon
lookupTyCon
Maybe TyCon
-> (CorePluginM TyCon -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM TyCon
forall a.
Maybe a
-> (CorePluginM a -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM a
saveAndReturn Maybe TyCon
mtc ((CorePluginM TyCon -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM TyCon)
-> (CorePluginM TyCon -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM TyCon
forall a b. (a -> b) -> a -> b
$ \CorePluginM TyCon
a CorePluginEnv
e -> CorePluginEnv
e { tyConBareConstraint :: CorePluginM TyCon
tyConBareConstraint = CorePluginM TyCon
a }
, tyConDeriveContext :: CorePluginM TyCon
tyConDeriveContext = do
Module
m <- (CorePluginEnv -> CorePluginM Module) -> CorePluginM Module
forall a. (CorePluginEnv -> CorePluginM a) -> CorePluginM a
ask CorePluginEnv -> CorePluginM Module
modDeriveAll
Maybe TyCon
mtc <- CorePluginM TyCon -> CorePluginM (Maybe TyCon)
forall a. CorePluginM a -> CorePluginM (Maybe a)
try (CorePluginM TyCon -> CorePluginM (Maybe TyCon))
-> CorePluginM TyCon -> CorePluginM (Maybe TyCon)
forall a b. (a -> b) -> a -> b
$ Module -> OccName -> CorePluginM Name
lookupName Module
m OccName
tnDeriveContext CorePluginM Name
-> (Name -> CorePluginM TyCon) -> CorePluginM TyCon
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> CorePluginM TyCon
forall (m :: * -> *). MonadThings m => Name -> m TyCon
lookupTyCon
Maybe TyCon
-> (CorePluginM TyCon -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM TyCon
forall a.
Maybe a
-> (CorePluginM a -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM a
saveAndReturn Maybe TyCon
mtc ((CorePluginM TyCon -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM TyCon)
-> (CorePluginM TyCon -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM TyCon
forall a b. (a -> b) -> a -> b
$ \CorePluginM TyCon
a CorePluginEnv
e -> CorePluginEnv
e { tyConDeriveContext :: CorePluginM TyCon
tyConDeriveContext = CorePluginM TyCon
a }
, funDictToBare :: CorePluginM Id
funDictToBare = do
Module
m <- (CorePluginEnv -> CorePluginM Module) -> CorePluginM Module
forall a. (CorePluginEnv -> CorePluginM a) -> CorePluginM a
ask CorePluginEnv -> CorePluginM Module
modConstraintBare
Maybe Id
mf <- CorePluginM Id -> CorePluginM (Maybe Id)
forall a. CorePluginM a -> CorePluginM (Maybe a)
try (CorePluginM Id -> CorePluginM (Maybe Id))
-> CorePluginM Id -> CorePluginM (Maybe Id)
forall a b. (a -> b) -> a -> b
$ Module -> OccName -> CorePluginM Name
lookupName Module
m OccName
vnDictToBare CorePluginM Name -> (Name -> CorePluginM Id) -> CorePluginM Id
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> CorePluginM Id
forall (m :: * -> *). MonadThings m => Name -> m Id
lookupId
Maybe Id
-> (CorePluginM Id -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Id
forall a.
Maybe a
-> (CorePluginM a -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM a
saveAndReturn Maybe Id
mf ((CorePluginM Id -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Id)
-> (CorePluginM Id -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Id
forall a b. (a -> b) -> a -> b
$ \CorePluginM Id
a CorePluginEnv
e -> CorePluginEnv
e { funDictToBare :: CorePluginM Id
funDictToBare = CorePluginM Id
a }
, tyEmptyConstraint :: CorePluginM Type
tyEmptyConstraint = do
Type
ec <- (TyCon -> [Type] -> Type) -> [Type] -> TyCon -> Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip TyCon -> [Type] -> Type
mkTyConApp [] (TyCon -> Type) -> CorePluginM TyCon -> CorePluginM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> CorePluginM TyCon
forall (m :: * -> *). MonadThings m => Name -> m TyCon
lookupTyCon (Arity -> Name
cTupleTyConName Arity
0)
Maybe Type
-> (CorePluginM Type -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Type
forall a.
Maybe a
-> (CorePluginM a -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM a
saveAndReturn (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
ec) ((CorePluginM Type -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Type)
-> (CorePluginM Type -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM Type
forall a b. (a -> b) -> a -> b
$ \CorePluginM Type
a CorePluginEnv
e -> CorePluginEnv
e { tyEmptyConstraint :: CorePluginM Type
tyEmptyConstraint = CorePluginM Type
a }
#if __GLASGOW_HASKELL__ >= 808
, classTypeEq :: CorePluginM Class
classTypeEq = Class -> CorePluginM Class
forall (f :: * -> *) a. Applicative f => a -> f a
pure Class
eqClass
#else
, classTypeEq = do
m <- ask modDataTypeEquality
mc <- try $ lookupName m (mkTcOcc "~") >>= lookupThing >>= \case
ATyCon tc | Just cls <- tyConClass_maybe tc
-> return cls
_ -> exception
saveAndReturn mc $ \a e -> e { classTypeEq = a }
#endif
, globalInstEnv :: CorePluginM InstEnv
globalInstEnv = do
HscEnv
hscEnv <- CoreM HscEnv -> CorePluginM HscEnv
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM HscEnv
getHscEnv
ModuleName
mn <- Module -> ModuleName
moduleName (Module -> ModuleName)
-> CorePluginM Module -> CorePluginM ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreM Module -> CorePluginM Module
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM Module
forall (m :: * -> *). HasModule m => m Module
getModule
ModSummary
mdesc
<- case [ ModSummary
m | ModSummary
m <- ModuleGraph -> [ModSummary]
mgModSummaries (ModuleGraph -> [ModSummary]) -> ModuleGraph -> [ModSummary]
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hscEnv
, ModSummary -> ModuleName
ms_mod_name ModSummary
m ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
mn
, ModSummary -> Bool
isNotBootFile ModSummary
m ] of
[] -> SDoc -> CorePluginM ModSummary
forall a. SDoc -> CorePluginM a
pluginError (SDoc -> CorePluginM ModSummary) -> SDoc -> CorePluginM ModSummary
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep
[ String -> SDoc
text String
"Could not find"
, ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mn
, String -> SDoc
text String
"in the module graph."
]
[ModSummary
md] -> ModSummary -> CorePluginM ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
md
[ModSummary]
_ -> SDoc -> CorePluginM ModSummary
forall a. SDoc -> CorePluginM a
pluginError (SDoc -> CorePluginM ModSummary) -> SDoc -> CorePluginM ModSummary
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep
[ String -> SDoc
text String
"Found multiple modules"
, ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mn
, String -> SDoc
text String
"in the module graph."
]
[Module]
modsDirect <- ([Maybe Module] -> [Module])
-> CorePluginM [Maybe Module] -> CorePluginM [Module]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe Module] -> [Module]
forall a. [Maybe a] -> [a]
catMaybes
(CorePluginM [Maybe Module] -> CorePluginM [Module])
-> ([(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> CorePluginM [Maybe Module])
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> CorePluginM [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe FastString, GenLocated SrcSpan ModuleName)
-> CorePluginM (Maybe Module))
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> CorePluginM [Maybe Module]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (HscEnv
-> (Maybe FastString, GenLocated SrcSpan ModuleName)
-> CorePluginM (Maybe Module)
lookupDep HscEnv
hscEnv)
([(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> CorePluginM [Module])
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> CorePluginM [Module]
forall a b. (a -> b) -> a -> b
$ ModSummary -> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_srcimps ModSummary
mdesc [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
forall a. [a] -> [a] -> [a]
++ ModSummary -> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_textual_imps ModSummary
mdesc
let
mSetDirect :: UniqSet Module
mSetDirect = [Module] -> UniqSet Module
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ([Module] -> UniqSet Module) -> [Module] -> UniqSet Module
forall a b. (a -> b) -> a -> b
$ (Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filter Module -> Bool
notMyOwn [Module]
modsDirect
reexportedDeps :: ModIface_ phase -> UniqSet Module
reexportedDeps ModIface_ phase
i = [Module] -> UniqSet Module
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ([Module] -> UniqSet Module) -> [Module] -> UniqSet Module
forall a b. (a -> b) -> a -> b
$ do
a :: IfaceExport
a@AvailTC{} <- ModIface_ phase -> [IfaceExport]
forall (phase :: ModIfacePhase). ModIface_ phase -> [IfaceExport]
mi_exports ModIface_ phase
i
let m :: Module
m = HasDebugCallStack => Name -> Module
Name -> Module
nameModule (Name -> Module) -> Name -> Module
forall a b. (a -> b) -> a -> b
$ IfaceExport -> Name
availName IfaceExport
a
[ Module
m | Module
m Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= ModIface_ phase -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface_ phase
i, Module -> Bool
notMyOwn Module
m]
loadRec :: UniqSet Module -> IOEnv (Env TcGblEnv TcLclEnv) (UniqSet Module)
loadRec UniqSet Module
ms = do
[ModIface]
ifs <- (Module -> IOEnv (Env TcGblEnv TcLclEnv) ModIface)
-> [Module] -> IOEnv (Env TcGblEnv TcLclEnv) [ModIface]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SDoc -> Module -> IOEnv (Env TcGblEnv TcLclEnv) ModIface
loadModuleInterface SDoc
reason)
([Module] -> IOEnv (Env TcGblEnv TcLclEnv) [ModIface])
-> [Module] -> IOEnv (Env TcGblEnv TcLclEnv) [ModIface]
forall a b. (a -> b) -> a -> b
$ UniqSet Module -> [Module]
forall elt. UniqSet elt -> [elt]
backToList UniqSet Module
ms
let ms' :: UniqSet Module
ms' = (ModIface -> UniqSet Module -> UniqSet Module)
-> UniqSet Module -> [ModIface] -> UniqSet Module
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (UniqSet Module -> UniqSet Module -> UniqSet Module
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets (UniqSet Module -> UniqSet Module -> UniqSet Module)
-> (ModIface -> UniqSet Module)
-> ModIface
-> UniqSet Module
-> UniqSet Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> UniqSet Module
forall (phase :: ModIfacePhase). ModIface_ phase -> UniqSet Module
reexportedDeps) UniqSet Module
ms [ModIface]
ifs
if UniqSet Module -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet (UniqSet Module -> Bool) -> UniqSet Module -> Bool
forall a b. (a -> b) -> a -> b
$ UniqSet Module
ms' UniqSet Module -> UniqSet Module -> UniqSet Module
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` UniqSet Module
ms
then UniqSet Module -> IOEnv (Env TcGblEnv TcLclEnv) (UniqSet Module)
forall (m :: * -> *) a. Monad m => a -> m a
return UniqSet Module
ms
else UniqSet Module -> IOEnv (Env TcGblEnv TcLclEnv) (UniqSet Module)
loadRec UniqSet Module
ms'
InstEnv
gie <- TcM InstEnv -> CorePluginM InstEnv
forall a. TcM a -> CorePluginM a
runTcM (TcM InstEnv -> CorePluginM InstEnv)
-> TcM InstEnv -> CorePluginM InstEnv
forall a b. (a -> b) -> a -> b
$ do
[Module]
mods <- UniqSet Module -> [Module]
forall elt. UniqSet elt -> [elt]
backToList (UniqSet Module -> [Module])
-> IOEnv (Env TcGblEnv TcLclEnv) (UniqSet Module)
-> IOEnv (Env TcGblEnv TcLclEnv) [Module]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UniqSet Module -> IOEnv (Env TcGblEnv TcLclEnv) (UniqSet Module)
loadRec UniqSet Module
mSetDirect
SDoc -> [Module] -> TcM ()
loadModuleInterfaces SDoc
reason [Module]
mods
ExternalPackageState -> InstEnv
eps_inst_env (ExternalPackageState -> InstEnv)
-> IOEnv (Env TcGblEnv TcLclEnv) ExternalPackageState
-> TcM InstEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) ExternalPackageState
forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps
Maybe InstEnv
-> (CorePluginM InstEnv -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM InstEnv
forall a.
Maybe a
-> (CorePluginM a -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM a
saveAndReturn (InstEnv -> Maybe InstEnv
forall a. a -> Maybe a
Just InstEnv
gie) ((CorePluginM InstEnv -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM InstEnv)
-> (CorePluginM InstEnv -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM InstEnv
forall a b. (a -> b) -> a -> b
$ \CorePluginM InstEnv
a CorePluginEnv
e -> CorePluginEnv
e { globalInstEnv :: CorePluginM InstEnv
globalInstEnv = CorePluginM InstEnv
a }
}
where
saveAndReturn :: Maybe a
-> (CorePluginM a -> CorePluginEnv -> CorePluginEnv)
-> CorePluginM a
saveAndReturn Maybe a
Nothing CorePluginM a -> CorePluginEnv -> CorePluginEnv
f = (IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
forall a.
(IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
CorePluginM ((IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> CorePluginM a)
-> (IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> CorePluginM a
forall a b. (a -> b) -> a -> b
$ \IORef CorePluginEnv
eref ->
IO () -> Either (IO ()) a
forall a b. a -> Either a b
Left (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Either (IO ()) a -> CoreM () -> CoreM (Either (IO ()) a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef CorePluginEnv -> (CorePluginEnv -> CorePluginEnv) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef CorePluginEnv
eref ((CorePluginEnv -> CorePluginEnv) -> IO ())
-> (CorePluginEnv -> CorePluginEnv) -> IO ()
forall a b. (a -> b) -> a -> b
$ CorePluginM a -> CorePluginEnv -> CorePluginEnv
f CorePluginM a
forall a. CorePluginM a
exception)
saveAndReturn (Just a
x) CorePluginM a -> CorePluginEnv -> CorePluginEnv
f = (IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
forall a.
(IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
CorePluginM ((IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> CorePluginM a)
-> (IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> CorePluginM a
forall a b. (a -> b) -> a -> b
$ \IORef CorePluginEnv
eref ->
a -> Either (IO ()) a
forall a b. b -> Either a b
Right a
x Either (IO ()) a -> CoreM () -> CoreM (Either (IO ()) a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IO () -> CoreM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef CorePluginEnv -> (CorePluginEnv -> CorePluginEnv) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef CorePluginEnv
eref ((CorePluginEnv -> CorePluginEnv) -> IO ())
-> (CorePluginEnv -> CorePluginEnv) -> IO ()
forall a b. (a -> b) -> a -> b
$ CorePluginM a -> CorePluginEnv -> CorePluginEnv
f (a -> CorePluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x))
maybeFound :: FindResult -> Maybe Module
maybeFound (Found ModLocation
_ Module
m) = Module -> Maybe Module
forall a. a -> Maybe a
Just Module
m
maybeFound FindResult
_ = Maybe Module
forall a. Maybe a
Nothing
lookupDep :: HscEnv
-> (Maybe FastString, GenLocated SrcSpan ModuleName)
-> CorePluginM (Maybe Module)
lookupDep :: HscEnv
-> (Maybe FastString, GenLocated SrcSpan ModuleName)
-> CorePluginM (Maybe Module)
lookupDep HscEnv
hsce (Maybe FastString
mpn, GenLocated SrcSpan ModuleName
mn)
= FindResult -> Maybe Module
maybeFound (FindResult -> Maybe Module)
-> CorePluginM FindResult -> CorePluginM (Maybe Module)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
IO FindResult -> CorePluginM FindResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
hsce (GenLocated SrcSpan ModuleName
-> SrcSpanLess (GenLocated SrcSpan ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc GenLocated SrcSpan ModuleName
mn) Maybe FastString
mpn)
reason :: SDoc
reason = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"Constraints.Deriving.CorePluginM "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"itinialization of global InstEnv"
notMyOwn :: Module -> Bool
notMyOwn Module
m = ModuleName -> String
moduleNameString (Module -> ModuleName
moduleName Module
m) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`
[ String
"Data.Constraint.Deriving"
, String
"Data.Constraint.Deriving.Import"
, String
"Data.Constraint.Deriving.Compat"
, String
"Data.Constraint.Deriving.DeriveAll"
, String
"Data.Constraint.Deriving.ToInstance"
, String
"Data.Constraint.Deriving.CorePluginM"
]
#if __GLASGOW_HASKELL__ < 804
mgModSummaries = id
#endif
#if __GLASGOW_HASKELL__ >= 802
backToList :: UniqSet elt -> [elt]
backToList = UniqSet elt -> [elt]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet
#else
backToList = uniqSetToList
#endif
lookupName :: Module -> OccName -> CorePluginM Name
lookupName :: Module -> OccName -> CorePluginM Name
lookupName Module
m OccName
occn = do
HscEnv
hscEnv <- CoreM HscEnv -> CorePluginM HscEnv
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM HscEnv
getHscEnv
IO Name -> CorePluginM Name
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Name -> CorePluginM Name) -> IO Name -> CorePluginM Name
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> OccName -> IO Name
lookupOrigIO HscEnv
hscEnv Module
m OccName
occn
runTcM :: TcM a -> CorePluginM a
runTcM :: TcM a -> CorePluginM a
runTcM TcM a
mx = do
HscEnv
hsce <- CoreM HscEnv -> CorePluginM HscEnv
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM HscEnv
getHscEnv
Module
modu <- CoreM Module -> CorePluginM Module
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM Module
forall (m :: * -> *). HasModule m => m Module
getModule
let sp :: RealSrcSpan
sp = RealSrcLoc -> RealSrcSpan
realSrcLocSpan (RealSrcLoc -> RealSrcSpan) -> RealSrcLoc -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ FastString -> Arity -> Arity -> RealSrcLoc
mkRealSrcLoc (String -> FastString
fsLit String
"<CorePluginM.runTcM>") Arity
1 Arity
1
((WarningMessages
warns, WarningMessages
errs), Maybe a
my) <- IO (Messages, Maybe a) -> CorePluginM (Messages, Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages, Maybe a) -> CorePluginM (Messages, Maybe a))
-> IO (Messages, Maybe a) -> CorePluginM (Messages, Maybe a)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM a
-> IO (Messages, Maybe a)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages, Maybe r)
initTc HscEnv
hsce HscSource
HsSrcFile Bool
False Module
modu RealSrcSpan
sp TcM a
mx
(SDoc -> CorePluginM ()) -> [SDoc] -> CorePluginM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SDoc -> CorePluginM ()
pluginWarning ([SDoc] -> CorePluginM ()) -> [SDoc] -> CorePluginM ()
forall a b. (a -> b) -> a -> b
$ WarningMessages -> [SDoc]
pprErrMsgBagWithLoc WarningMessages
warns
case Maybe a
my of
Maybe a
Nothing ->
let f :: [SDoc] -> CorePluginM a
f [] = SDoc -> CorePluginM a
forall a. SDoc -> CorePluginM a
pluginError (SDoc -> CorePluginM a) -> SDoc -> CorePluginM a
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"runTcM failed"
f [SDoc
x] = SDoc -> CorePluginM a
forall a. SDoc -> CorePluginM a
pluginError SDoc
x
f (SDoc
x:[SDoc]
xs) = SDoc -> CorePluginM ()
pluginWarning SDoc
x CorePluginM () -> CorePluginM a -> CorePluginM a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [SDoc] -> CorePluginM a
f [SDoc]
xs
in [SDoc] -> CorePluginM a
forall a. [SDoc] -> CorePluginM a
f ([SDoc] -> CorePluginM a) -> [SDoc] -> CorePluginM a
forall a b. (a -> b) -> a -> b
$ WarningMessages -> [SDoc]
pprErrMsgBagWithLoc WarningMessages
errs
Just a
y -> do
(SDoc -> CorePluginM ()) -> [SDoc] -> CorePluginM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SDoc -> CorePluginM ()
pluginWarning ([SDoc] -> CorePluginM ()) -> [SDoc] -> CorePluginM ()
forall a b. (a -> b) -> a -> b
$ WarningMessages -> [SDoc]
pprErrMsgBagWithLoc WarningMessages
errs
a -> CorePluginM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
y
getInstEnvs :: ModGuts
-> CorePluginM InstEnvs
getInstEnvs :: ModGuts -> CorePluginM InstEnvs
getInstEnvs ModGuts
guts = do
InstEnv
globalInsts <- (CorePluginEnv -> CorePluginM InstEnv) -> CorePluginM InstEnv
forall a. (CorePluginEnv -> CorePluginM a) -> CorePluginM a
ask CorePluginEnv -> CorePluginM InstEnv
globalInstEnv
InstEnvs -> CorePluginM InstEnvs
forall (m :: * -> *) a. Monad m => a -> m a
return (InstEnvs -> CorePluginM InstEnvs)
-> InstEnvs -> CorePluginM InstEnvs
forall a b. (a -> b) -> a -> b
$ InstEnvs :: InstEnv -> InstEnv -> VisibleOrphanModules -> InstEnvs
InstEnvs
{ ie_global :: InstEnv
ie_global = InstEnv
globalInsts
, ie_local :: InstEnv
ie_local = ModGuts -> InstEnv
mg_inst_env ModGuts
guts
, ie_visible :: VisibleOrphanModules
ie_visible = [Module] -> VisibleOrphanModules
mkModuleSet ([Module] -> VisibleOrphanModules)
-> (Dependencies -> [Module])
-> Dependencies
-> VisibleOrphanModules
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> [Module]
dep_orphs (Dependencies -> VisibleOrphanModules)
-> Dependencies -> VisibleOrphanModules
forall a b. (a -> b) -> a -> b
$ ModGuts -> Dependencies
mg_deps ModGuts
guts
}
lookupModule :: ModuleName
-> [FastString]
-> CorePluginM Module
lookupModule :: ModuleName -> [FastString] -> CorePluginM Module
lookupModule ModuleName
mdName [FastString]
pkgs = do
HscEnv
hscEnv <- CoreM HscEnv -> CorePluginM HscEnv
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM HscEnv
getHscEnv
HscEnv -> [Maybe FastString] -> CorePluginM Module
go HscEnv
hscEnv ([Maybe FastString] -> CorePluginM Module)
-> [Maybe FastString] -> CorePluginM Module
forall a b. (a -> b) -> a -> b
$ (FastString -> Maybe FastString)
-> [FastString] -> [Maybe FastString]
forall a b. (a -> b) -> [a] -> [b]
map FastString -> Maybe FastString
forall a. a -> Maybe a
Just [FastString]
pkgs [Maybe FastString] -> [Maybe FastString] -> [Maybe FastString]
forall a. [a] -> [a] -> [a]
++ [FastString -> Maybe FastString
forall a. a -> Maybe a
Just (String -> FastString
fsLit String
"this"), Maybe FastString
forall a. Maybe a
Nothing]
where
go :: HscEnv -> [Maybe FastString] -> CorePluginM Module
go HscEnv
_ [] = SDoc -> CorePluginM Module
forall a. SDoc -> CorePluginM a
pluginError (SDoc -> CorePluginM Module) -> SDoc -> CorePluginM Module
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"Could not find module", ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mdName]
go HscEnv
he (Maybe FastString
x:[Maybe FastString]
xs) = HscEnv -> Maybe FastString -> CorePluginM (Maybe Module)
forall (f :: * -> *).
MonadIO f =>
HscEnv -> Maybe FastString -> f (Maybe Module)
findIt HscEnv
he Maybe FastString
x CorePluginM (Maybe Module)
-> (Maybe Module -> CorePluginM Module) -> CorePluginM Module
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Module
Nothing -> HscEnv -> [Maybe FastString] -> CorePluginM Module
go HscEnv
he [Maybe FastString]
xs
Just Module
md -> Module -> CorePluginM Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
md
findIt :: HscEnv -> Maybe FastString -> f (Maybe Module)
findIt HscEnv
he = (FindResult -> Maybe Module) -> f FindResult -> f (Maybe Module)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FindResult -> Maybe Module
getIt (f FindResult -> f (Maybe Module))
-> (Maybe FastString -> f FindResult)
-> Maybe FastString
-> f (Maybe Module)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO FindResult -> f FindResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FindResult -> f FindResult)
-> (Maybe FastString -> IO FindResult)
-> Maybe FastString
-> f FindResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
he ModuleName
mdName
getIt :: FindResult -> Maybe Module
getIt (Found ModLocation
_ Module
md) = Module -> Maybe Module
forall a. a -> Maybe a
Just Module
md
getIt (FoundMultiple ((Module
md, ModuleOrigin
_):[(Module, ModuleOrigin)]
_)) = Module -> Maybe Module
forall a. a -> Maybe a
Just Module
md
getIt FindResult
_ = Maybe Module
forall a. Maybe a
Nothing
newTyVar :: Kind -> CorePluginM TyVar
newTyVar :: Type -> CorePluginM Id
newTyVar Type
k = (Name -> Type -> Id) -> Type -> Name -> Id
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Type -> Id
mkTyVar Type
k (Name -> Id) -> CorePluginM Name -> CorePluginM Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameSpace -> String -> CorePluginM Name
newName NameSpace
tvName String
"gen"
freshenTyVar :: TyVar -> CorePluginM TyVar
freshenTyVar :: Id -> CorePluginM Id
freshenTyVar Id
tv = do
Unique
u <- CorePluginM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
Name
nn <-
if Name -> Bool
isInternalName Name
n
then Name -> CorePluginM Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> CorePluginM Name) -> Name -> CorePluginM Name
forall a b. (a -> b) -> a -> b
$ (OccName -> OccName) -> Unique -> Name -> Name
mkDerivedInternalName (String -> OccName -> OccName
repOccN (Unique -> String
forall a. Show a => a -> String
show Unique
u)) Unique
u Name
n
else do
Module
md <- CoreM Module -> CorePluginM Module
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM Module
forall (m :: * -> *). HasModule m => m Module
getModule
SrcSpan
loc <- CoreM SrcSpan -> CorePluginM SrcSpan
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM SrcSpan
getSrcSpanM
Name -> CorePluginM Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> CorePluginM Name) -> Name -> CorePluginM Name
forall a b. (a -> b) -> a -> b
$ Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
u Module
md (String -> OccName -> OccName
repOccN (Unique -> String
forall a. Show a => a -> String
show Unique
u) OccName
on) SrcSpan
loc
Id -> CorePluginM Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CorePluginM Id) -> Id -> CorePluginM Id
forall a b. (a -> b) -> a -> b
$ Name -> Type -> Id
mkTyVar Name
nn Type
k
where
n :: Name
n = Id -> Name
tyVarName Id
tv
k :: Type
k = Id -> Type
tyVarKind Id
tv
on :: OccName
on = Name -> OccName
nameOccName Name
n
repOccN :: String -> OccName -> OccName
repOccN String
s OccName
oc = case OccName -> String
occNameString OccName
oc of
String
"_" -> NameSpace -> String -> OccName
mkOccName (OccName -> NameSpace
occNameSpace OccName
oc) (String
"fresh_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
String
_ -> OccName
on
newLocalVar :: Type -> String -> CorePluginM Var
newLocalVar :: Type -> String -> CorePluginM Id
newLocalVar Type
ty String
nameStr = do
SrcSpan
loc <- CoreM SrcSpan -> CorePluginM SrcSpan
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM SrcSpan
getSrcSpanM
Unique
u <- CorePluginM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
Id -> CorePluginM Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CorePluginM Id) -> Id -> CorePluginM Id
forall a b. (a -> b) -> a -> b
$
Name -> Mult -> Type -> Id
mkLocalIdCompat (Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
u (NameSpace -> String -> OccName
mkOccName NameSpace
varName String
nameStr) SrcSpan
loc) Mult
Many Type
ty
newName :: NameSpace -> String -> CorePluginM Name
newName :: NameSpace -> String -> CorePluginM Name
newName NameSpace
nspace String
nameStr = do
Module
md <- CoreM Module -> CorePluginM Module
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM Module
forall (m :: * -> *). HasModule m => m Module
getModule
SrcSpan
loc <- CoreM SrcSpan -> CorePluginM SrcSpan
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM SrcSpan
getSrcSpanM
Unique
u <- CorePluginM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
Name -> CorePluginM Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> CorePluginM Name) -> Name -> CorePluginM Name
forall a b. (a -> b) -> a -> b
$ Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
u Module
md OccName
occname SrcSpan
loc
where
occname :: OccName
occname = NameSpace -> String -> OccName
mkOccName NameSpace
nspace String
nameStr
pluginError :: SDoc -> CorePluginM a
pluginError :: SDoc -> CorePluginM a
pluginError = Maybe SrcSpan -> Severity -> SDoc -> CorePluginM a
forall a. Maybe SrcSpan -> Severity -> SDoc -> CorePluginM a
pluginProblemMsg Maybe SrcSpan
forall a. Maybe a
Nothing Severity
SevError
pluginLocatedError :: SrcSpan -> SDoc -> CorePluginM a
pluginLocatedError :: SrcSpan -> SDoc -> CorePluginM a
pluginLocatedError SrcSpan
loc = Maybe SrcSpan -> Severity -> SDoc -> CorePluginM a
forall a. Maybe SrcSpan -> Severity -> SDoc -> CorePluginM a
pluginProblemMsg (SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just SrcSpan
loc) Severity
SevError
pluginWarning :: SDoc -> CorePluginM ()
pluginWarning :: SDoc -> CorePluginM ()
pluginWarning = CorePluginM Any -> CorePluginM ()
forall a. CorePluginM a -> CorePluginM ()
try' (CorePluginM Any -> CorePluginM ())
-> (SDoc -> CorePluginM Any) -> SDoc -> CorePluginM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SrcSpan -> Severity -> SDoc -> CorePluginM Any
forall a. Maybe SrcSpan -> Severity -> SDoc -> CorePluginM a
pluginProblemMsg Maybe SrcSpan
forall a. Maybe a
Nothing Severity
SevWarning
pluginLocatedWarning :: SrcSpan -> SDoc -> CorePluginM ()
pluginLocatedWarning :: SrcSpan -> SDoc -> CorePluginM ()
pluginLocatedWarning SrcSpan
loc = CorePluginM Any -> CorePluginM ()
forall a. CorePluginM a -> CorePluginM ()
try' (CorePluginM Any -> CorePluginM ())
-> (SDoc -> CorePluginM Any) -> SDoc -> CorePluginM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SrcSpan -> Severity -> SDoc -> CorePluginM Any
forall a. Maybe SrcSpan -> Severity -> SDoc -> CorePluginM a
pluginProblemMsg (SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just SrcSpan
loc) Severity
SevWarning
pluginDebug :: SDoc -> CorePluginM ()
#if PLUGIN_DEBUG
pluginDebug = try' . pluginProblemMsg Nothing SevDump
#else
pluginDebug :: SDoc -> CorePluginM ()
pluginDebug = CorePluginM () -> SDoc -> CorePluginM ()
forall a b. a -> b -> a
const (() -> CorePluginM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
#endif
{-# INLINE pluginDebug #-}
pluginTrace :: HasCallStack => SDoc -> a -> a
#if PLUGIN_DEBUG
pluginTrace = withFrozenCallStack pprSTrace
#else
pluginTrace :: SDoc -> a -> a
pluginTrace = (a -> a) -> SDoc -> a -> a
forall a b. a -> b -> a
const a -> a
forall a. a -> a
id
#endif
{-# INLINE pluginTrace #-}
pluginProblemMsg :: Maybe SrcSpan
-> Severity
-> SDoc
-> CorePluginM a
pluginProblemMsg :: Maybe SrcSpan -> Severity -> SDoc -> CorePluginM a
pluginProblemMsg Maybe SrcSpan
mspan Severity
sev SDoc
msg = do
DynFlags
dflags <- CoreM DynFlags -> CorePluginM DynFlags
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
SrcSpan
loc <- case Maybe SrcSpan
mspan of
Just SrcSpan
sp -> SrcSpan -> CorePluginM SrcSpan
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcSpan
sp
Maybe SrcSpan
Nothing -> CoreM SrcSpan -> CorePluginM SrcSpan
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM SrcSpan
getSrcSpanM
PrintUnqualified
unqual <- CoreM PrintUnqualified -> CorePluginM PrintUnqualified
forall a. CoreM a -> CorePluginM a
liftCoreM CoreM PrintUnqualified
getPrintUnqualified
(IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
forall a.
(IORef CorePluginEnv -> CoreM (Either (IO ()) a)) -> CorePluginM a
CorePluginM ((IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> CorePluginM a)
-> (IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> CorePluginM a
forall a b. (a -> b) -> a -> b
$ CoreM (Either (IO ()) a)
-> IORef CorePluginEnv -> CoreM (Either (IO ()) a)
forall a b. a -> b -> a
const (CoreM (Either (IO ()) a)
-> IORef CorePluginEnv -> CoreM (Either (IO ()) a))
-> CoreM (Either (IO ()) a)
-> IORef CorePluginEnv
-> CoreM (Either (IO ()) a)
forall a b. (a -> b) -> a -> b
$ Either (IO ()) a -> CoreM (Either (IO ()) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (IO ()) a -> CoreM (Either (IO ()) a))
-> Either (IO ()) a -> CoreM (Either (IO ()) a)
forall a b. (a -> b) -> a -> b
$ IO () -> Either (IO ()) a
forall a b. a -> Either a b
Left (IO () -> Either (IO ()) a) -> IO () -> Either (IO ()) a
forall a b. (a -> b) -> a -> b
$
DynFlags
-> WarnReason
-> Severity
-> SrcSpan
-> PrintUnqualified
-> SDoc
-> IO ()
putLogMsgCompat DynFlags
dflags WarnReason
NoReason Severity
sev SrcSpan
loc PrintUnqualified
unqual SDoc
msg
getModuleAnns :: forall a . Data a => ModGuts -> UniqMap [(Name, a)]
getModuleAnns :: ModGuts -> UniqMap [(Name, a)]
getModuleAnns = [Annotation] -> UniqMap [(Name, a)]
go ([Annotation] -> UniqMap [(Name, a)])
-> (ModGuts -> [Annotation]) -> ModGuts -> UniqMap [(Name, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModGuts -> [Annotation]
mg_anns
where
valTRep :: TypeRep
valTRep = Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
go :: [Annotation] -> UniqMap [(Name, a)]
go :: [Annotation] -> UniqMap [(Name, a)]
go [] = UniqMap [(Name, a)]
forall elt. UniqFM elt
emptyUFM
go (Annotation
(NamedTarget Name
n)
(Serialized TypeRep
trep [Word8]
bytes)
: [Annotation]
as)
| TypeRep
trep TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep
valTRep
= ((Name, a) -> [(Name, a)] -> [(Name, a)])
-> ((Name, a) -> [(Name, a)])
-> UniqMap [(Name, a)]
-> Unique
-> (Name, a)
-> UniqMap [(Name, a)]
forall key elt elts.
Uniquable key =>
(elt -> elts -> elts)
-> (elt -> elts) -> UniqFM elts -> key -> elt -> UniqFM elts
addToUFM_Acc (:) ((Name, a) -> [(Name, a)] -> [(Name, a)]
forall a. a -> [a] -> [a]
:[]) ([Annotation] -> UniqMap [(Name, a)]
go [Annotation]
as) (Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
n) (Name
n, [Word8] -> a
forall a. Data a => [Word8] -> a
deserializeWithData [Word8]
bytes)
go (Annotation
_:[Annotation]
as) = [Annotation] -> UniqMap [(Name, a)]
go [Annotation]
as
pnConstraintsDeriving :: FastString
pnConstraintsDeriving :: FastString
pnConstraintsDeriving = String -> FastString
mkFastString String
"constraints-deriving"
pnConstraints :: FastString
pnConstraints :: FastString
pnConstraints = String -> FastString
mkFastString String
"constraints"
pnBase :: FastString
pnBase :: FastString
pnBase = String -> FastString
mkFastString String
"base"
mnConstraint :: ModuleName
mnConstraint :: ModuleName
mnConstraint = String -> ModuleName
mkModuleName String
"Data.Constraint"
mnConstraintBare :: ModuleName
mnConstraintBare :: ModuleName
mnConstraintBare = String -> ModuleName
mkModuleName String
"Data.Constraint.Bare"
mnDeriveAll :: ModuleName
mnDeriveAll :: ModuleName
mnDeriveAll = String -> ModuleName
mkModuleName String
"Data.Constraint.Deriving.DeriveAll"
mnToInstance :: ModuleName
mnToInstance :: ModuleName
mnToInstance = String -> ModuleName
mkModuleName String
"Data.Constraint.Deriving.ToInstance"
mnDataTypeEquality :: ModuleName
mnDataTypeEquality :: ModuleName
mnDataTypeEquality = String -> ModuleName
mkModuleName String
"Data.Type.Equality"
tnDict :: OccName
tnDict :: OccName
tnDict = String -> OccName
mkTcOcc String
"Dict"
tnBareConstraint :: OccName
tnBareConstraint :: OccName
tnBareConstraint = String -> OccName
mkTcOcc String
"BareConstraint"
tnDeriveContext :: OccName
tnDeriveContext :: OccName
tnDeriveContext = String -> OccName
mkTcOcc String
"DeriveContext"
vnDictToBare :: OccName
vnDictToBare :: OccName
vnDictToBare = String -> OccName
mkVarOcc String
"dictToBare"