{-# 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
    -- * Error handling
  , try, exception
    -- * Accessing read-only on-demand variables
  , ask
  , tyConDict, tyConBareConstraint, tyConDeriveContext
  , funDictToBare, tyEmptyConstraint, classTypeEq
    -- * Reporting
  , pluginWarning, pluginLocatedWarning
  , pluginError, pluginLocatedError
    -- * Debugging
  , pluginDebug, pluginTrace
    -- * Tools
  , 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

-- | Since I do not have access to the guts of CoreM monad,
--   I implement a wrapper on top of it here.
--
--   It provides two pieces of functionality:
--
--     * Possibility to fail a computation with IO error action
--       (to show a nice error to a user and continue the work if possible);
--
--     * An environment with things that computed on demand, once at most.
--
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


-- | Wrap CoreM action
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

-- | Synonym for `fail`
exception :: CorePluginM a
exception :: CorePluginM a
exception = CorePluginM a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Return `Nothing` if the computation fails
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 and ignore the result
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

-- | Reference to the plugin environment variables.
type CorePluginEnvRef = IORef CorePluginEnv

-- | Plugin environment
--
--   Its components are supposed to be computed at most once, when they are needed.
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 a field of the CorePluginEnv environment.
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

-- | Init the `CorePluginM` environment and save it to IORef.
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
  -- need to force globalInstEnv as early as possible to make sure
  -- that ExternalPackageState var is not yet contaminated with
  -- many unrelated modules.
  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


-- | Lookup necessary environment components on demand.
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."
                  ]
        -- direct module dependencies
        [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 -- direct dependencies; must be in the explicit depenencies anyway
            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
            -- Modules that we definitely need to look through,
            -- even if they are from other, hidden packages
            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]
            -- Load reexportedDeps recursively.
            -- This enumerate all modules that export some type constructors
            -- visible from the current module;
            -- this includes our base types and also all classes in scope.
            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"
    -- Ignore my own modules: they do not contain any classes.
    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


-- | Generate new unique type variable
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"

-- | Assign a new unique to a type variable;
--   also assign a whole new name if the input is a wildcard.
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

-- | Generate a new unique local var (not be exported!)
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

-- | Generate new unique name
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


-- | Similar to `getAnnotations`, but keeps the annotation target.
--   Also, it is hardcoded to `deserializeWithData`.
--   Looks only for annotations defined in this module.
--   Ignores module annotations.
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) -- ignore module targets
         (Serialized TypeRep
trep [Word8]
bytes)
        : [Annotation]
as)
      | TypeRep
trep TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep
valTRep -- match type representations
      = ((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)
    -- ignore non-matching annotations
    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"