module Data.Singletons.TH.Promote.Monad (
PrM, promoteM, promoteM_, promoteMDecs, VarPromotions,
allLocals, emitDecs, emitDecsM,
lambdaBind, LetBind, letBind, lookupVarE
) where
import Control.Monad.Reader
import Control.Monad.Writer
import Language.Haskell.TH.Syntax hiding ( lift )
import Language.Haskell.TH.Desugar
import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap
import Language.Haskell.TH.Desugar.OMap.Strict (OMap)
import Data.Singletons.TH.Options
import Data.Singletons.TH.Syntax
type LetExpansions = OMap Name DType
data PrEnv =
PrEnv { PrEnv -> Options
pr_options :: Options
, PrEnv -> OMap Name Name
pr_lambda_bound :: OMap Name Name
, PrEnv -> LetExpansions
pr_let_bound :: LetExpansions
, PrEnv -> [Dec]
pr_local_decls :: [Dec]
}
emptyPrEnv :: PrEnv
emptyPrEnv :: PrEnv
emptyPrEnv = PrEnv { pr_options :: Options
pr_options = Options
defaultOptions
, pr_lambda_bound :: OMap Name Name
pr_lambda_bound = OMap Name Name
forall k v. OMap k v
OMap.empty
, pr_let_bound :: LetExpansions
pr_let_bound = LetExpansions
forall k v. OMap k v
OMap.empty
, pr_local_decls :: [Dec]
pr_local_decls = [] }
newtype PrM a = PrM (ReaderT PrEnv (WriterT [DDec] Q) a)
deriving ( (forall a b. (a -> b) -> PrM a -> PrM b)
-> (forall a b. a -> PrM b -> PrM a) -> Functor PrM
forall a b. a -> PrM b -> PrM a
forall a b. (a -> b) -> PrM a -> PrM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> PrM a -> PrM b
fmap :: forall a b. (a -> b) -> PrM a -> PrM b
$c<$ :: forall a b. a -> PrM b -> PrM a
<$ :: forall a b. a -> PrM b -> PrM a
Functor, Functor PrM
Functor PrM =>
(forall a. a -> PrM a)
-> (forall a b. PrM (a -> b) -> PrM a -> PrM b)
-> (forall a b c. (a -> b -> c) -> PrM a -> PrM b -> PrM c)
-> (forall a b. PrM a -> PrM b -> PrM b)
-> (forall a b. PrM a -> PrM b -> PrM a)
-> Applicative PrM
forall a. a -> PrM a
forall a b. PrM a -> PrM b -> PrM a
forall a b. PrM a -> PrM b -> PrM b
forall a b. PrM (a -> b) -> PrM a -> PrM b
forall a b c. (a -> b -> c) -> PrM a -> PrM b -> PrM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> PrM a
pure :: forall a. a -> PrM a
$c<*> :: forall a b. PrM (a -> b) -> PrM a -> PrM b
<*> :: forall a b. PrM (a -> b) -> PrM a -> PrM b
$cliftA2 :: forall a b c. (a -> b -> c) -> PrM a -> PrM b -> PrM c
liftA2 :: forall a b c. (a -> b -> c) -> PrM a -> PrM b -> PrM c
$c*> :: forall a b. PrM a -> PrM b -> PrM b
*> :: forall a b. PrM a -> PrM b -> PrM b
$c<* :: forall a b. PrM a -> PrM b -> PrM a
<* :: forall a b. PrM a -> PrM b -> PrM a
Applicative, Applicative PrM
Applicative PrM =>
(forall a b. PrM a -> (a -> PrM b) -> PrM b)
-> (forall a b. PrM a -> PrM b -> PrM b)
-> (forall a. a -> PrM a)
-> Monad PrM
forall a. a -> PrM a
forall a b. PrM a -> PrM b -> PrM b
forall a b. PrM a -> (a -> PrM b) -> PrM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. PrM a -> (a -> PrM b) -> PrM b
>>= :: forall a b. PrM a -> (a -> PrM b) -> PrM b
$c>> :: forall a b. PrM a -> PrM b -> PrM b
>> :: forall a b. PrM a -> PrM b -> PrM b
$creturn :: forall a. a -> PrM a
return :: forall a. a -> PrM a
Monad, MonadFail PrM
MonadIO PrM
PrM FilePath
PrM [Extension]
PrM Loc
Bool -> FilePath -> PrM (Maybe Name)
Bool -> FilePath -> PrM ()
FilePath -> PrM FilePath
FilePath -> PrM Name
FilePath -> PrM ()
[Dec] -> PrM ()
Q () -> PrM ()
Name -> PrM [Role]
Name -> PrM [DecidedStrictness]
Name -> PrM (Maybe Fixity)
Name -> PrM Type
Name -> PrM Info
Name -> [Type] -> PrM [Dec]
(MonadIO PrM, MonadFail PrM) =>
(FilePath -> PrM Name)
-> (Bool -> FilePath -> PrM ())
-> (forall a. PrM a -> PrM a -> PrM a)
-> (Bool -> FilePath -> PrM (Maybe Name))
-> (Name -> PrM Info)
-> (Name -> PrM (Maybe Fixity))
-> (Name -> PrM Type)
-> (Name -> [Type] -> PrM [Dec])
-> (Name -> PrM [Role])
-> (forall a. Data a => AnnLookup -> PrM [a])
-> (Module -> PrM ModuleInfo)
-> (Name -> PrM [DecidedStrictness])
-> PrM Loc
-> (forall a. IO a -> PrM a)
-> PrM FilePath
-> (FilePath -> PrM ())
-> (FilePath -> PrM FilePath)
-> ([Dec] -> PrM ())
-> (ForeignSrcLang -> FilePath -> PrM ())
-> (Q () -> PrM ())
-> (FilePath -> PrM ())
-> (forall a. Typeable a => PrM (Maybe a))
-> (forall a. Typeable a => a -> PrM ())
-> (Extension -> PrM Bool)
-> PrM [Extension]
-> (DocLoc -> FilePath -> PrM ())
-> (DocLoc -> PrM (Maybe FilePath))
-> Quasi PrM
ForeignSrcLang -> FilePath -> PrM ()
Extension -> PrM Bool
DocLoc -> PrM (Maybe FilePath)
DocLoc -> FilePath -> PrM ()
Module -> PrM ModuleInfo
forall a. Data a => AnnLookup -> PrM [a]
forall a. Typeable a => PrM (Maybe a)
forall a. Typeable a => a -> PrM ()
forall a. IO a -> PrM a
forall a. PrM a -> PrM a -> PrM a
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
(FilePath -> m Name)
-> (Bool -> FilePath -> m ())
-> (forall a. m a -> m a -> m a)
-> (Bool -> FilePath -> m (Maybe Name))
-> (Name -> m Info)
-> (Name -> m (Maybe Fixity))
-> (Name -> m Type)
-> (Name -> [Type] -> m [Dec])
-> (Name -> m [Role])
-> (forall a. Data a => AnnLookup -> m [a])
-> (Module -> m ModuleInfo)
-> (Name -> m [DecidedStrictness])
-> m Loc
-> (forall a. IO a -> m a)
-> m FilePath
-> (FilePath -> m ())
-> (FilePath -> m FilePath)
-> ([Dec] -> m ())
-> (ForeignSrcLang -> FilePath -> m ())
-> (Q () -> m ())
-> (FilePath -> m ())
-> (forall a. Typeable a => m (Maybe a))
-> (forall a. Typeable a => a -> m ())
-> (Extension -> m Bool)
-> m [Extension]
-> (DocLoc -> FilePath -> m ())
-> (DocLoc -> m (Maybe FilePath))
-> Quasi m
$cqNewName :: FilePath -> PrM Name
qNewName :: FilePath -> PrM Name
$cqReport :: Bool -> FilePath -> PrM ()
qReport :: Bool -> FilePath -> PrM ()
$cqRecover :: forall a. PrM a -> PrM a -> PrM a
qRecover :: forall a. PrM a -> PrM a -> PrM a
$cqLookupName :: Bool -> FilePath -> PrM (Maybe Name)
qLookupName :: Bool -> FilePath -> PrM (Maybe Name)
$cqReify :: Name -> PrM Info
qReify :: Name -> PrM Info
$cqReifyFixity :: Name -> PrM (Maybe Fixity)
qReifyFixity :: Name -> PrM (Maybe Fixity)
$cqReifyType :: Name -> PrM Type
qReifyType :: Name -> PrM Type
$cqReifyInstances :: Name -> [Type] -> PrM [Dec]
qReifyInstances :: Name -> [Type] -> PrM [Dec]
$cqReifyRoles :: Name -> PrM [Role]
qReifyRoles :: Name -> PrM [Role]
$cqReifyAnnotations :: forall a. Data a => AnnLookup -> PrM [a]
qReifyAnnotations :: forall a. Data a => AnnLookup -> PrM [a]
$cqReifyModule :: Module -> PrM ModuleInfo
qReifyModule :: Module -> PrM ModuleInfo
$cqReifyConStrictness :: Name -> PrM [DecidedStrictness]
qReifyConStrictness :: Name -> PrM [DecidedStrictness]
$cqLocation :: PrM Loc
qLocation :: PrM Loc
$cqRunIO :: forall a. IO a -> PrM a
qRunIO :: forall a. IO a -> PrM a
$cqGetPackageRoot :: PrM FilePath
qGetPackageRoot :: PrM FilePath
$cqAddDependentFile :: FilePath -> PrM ()
qAddDependentFile :: FilePath -> PrM ()
$cqAddTempFile :: FilePath -> PrM FilePath
qAddTempFile :: FilePath -> PrM FilePath
$cqAddTopDecls :: [Dec] -> PrM ()
qAddTopDecls :: [Dec] -> PrM ()
$cqAddForeignFilePath :: ForeignSrcLang -> FilePath -> PrM ()
qAddForeignFilePath :: ForeignSrcLang -> FilePath -> PrM ()
$cqAddModFinalizer :: Q () -> PrM ()
qAddModFinalizer :: Q () -> PrM ()
$cqAddCorePlugin :: FilePath -> PrM ()
qAddCorePlugin :: FilePath -> PrM ()
$cqGetQ :: forall a. Typeable a => PrM (Maybe a)
qGetQ :: forall a. Typeable a => PrM (Maybe a)
$cqPutQ :: forall a. Typeable a => a -> PrM ()
qPutQ :: forall a. Typeable a => a -> PrM ()
$cqIsExtEnabled :: Extension -> PrM Bool
qIsExtEnabled :: Extension -> PrM Bool
$cqExtsEnabled :: PrM [Extension]
qExtsEnabled :: PrM [Extension]
$cqPutDoc :: DocLoc -> FilePath -> PrM ()
qPutDoc :: DocLoc -> FilePath -> PrM ()
$cqGetDoc :: DocLoc -> PrM (Maybe FilePath)
qGetDoc :: DocLoc -> PrM (Maybe FilePath)
Quasi
, MonadReader PrEnv, MonadWriter [DDec]
, Monad PrM
Monad PrM => (forall a. FilePath -> PrM a) -> MonadFail PrM
forall a. FilePath -> PrM a
forall (m :: * -> *).
Monad m =>
(forall a. FilePath -> m a) -> MonadFail m
$cfail :: forall a. FilePath -> PrM a
fail :: forall a. FilePath -> PrM a
MonadFail, Monad PrM
Monad PrM => (forall a. IO a -> PrM a) -> MonadIO PrM
forall a. IO a -> PrM a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> PrM a
liftIO :: forall a. IO a -> PrM a
MonadIO )
instance DsMonad PrM where
localDeclarations :: PrM [Dec]
localDeclarations = (PrEnv -> [Dec]) -> PrM [Dec]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrEnv -> [Dec]
pr_local_decls
instance OptionsMonad PrM where
getOptions :: PrM Options
getOptions = (PrEnv -> Options) -> PrM Options
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrEnv -> Options
pr_options
allLocals :: MonadReader PrEnv m => m [Name]
allLocals :: forall (m :: * -> *). MonadReader PrEnv m => m [Name]
allLocals = do
[(Name, Name)]
lambdas <- (PrEnv -> [(Name, Name)]) -> m [(Name, Name)]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (OMap Name Name -> [(Name, Name)]
forall k v. OMap k v -> [(k, v)]
OMap.assocs (OMap Name Name -> [(Name, Name)])
-> (PrEnv -> OMap Name Name) -> PrEnv -> [(Name, Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrEnv -> OMap Name Name
pr_lambda_bound)
LetExpansions
lets <- (PrEnv -> LetExpansions) -> m LetExpansions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrEnv -> LetExpansions
pr_let_bound
[Name] -> m [Name]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Name
typeName
| (Name
termName, Name
typeName) <- [(Name, Name)]
lambdas
, case Name -> LetExpansions -> Maybe DType
forall k v. Ord k => k -> OMap k v -> Maybe v
OMap.lookup Name
termName LetExpansions
lets of
Just (DVarT Name
typeName') | Name
typeName' Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeName -> Bool
True
Maybe DType
_ -> Bool
False ]
emitDecs :: MonadWriter [DDec] m => [DDec] -> m ()
emitDecs :: forall (m :: * -> *). MonadWriter [DDec] m => [DDec] -> m ()
emitDecs = [DDec] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
emitDecsM :: MonadWriter [DDec] m => m [DDec] -> m ()
emitDecsM :: forall (m :: * -> *). MonadWriter [DDec] m => m [DDec] -> m ()
emitDecsM m [DDec]
action = do
[DDec]
decs <- m [DDec]
action
[DDec] -> m ()
forall (m :: * -> *). MonadWriter [DDec] m => [DDec] -> m ()
emitDecs [DDec]
decs
lambdaBind :: VarPromotions -> PrM a -> PrM a
lambdaBind :: forall a. [(Name, Name)] -> PrM a -> PrM a
lambdaBind [(Name, Name)]
binds = (PrEnv -> PrEnv) -> PrM a -> PrM a
forall a. (PrEnv -> PrEnv) -> PrM a -> PrM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local PrEnv -> PrEnv
add_binds
where add_binds :: PrEnv -> PrEnv
add_binds env :: PrEnv
env@(PrEnv { pr_lambda_bound :: PrEnv -> OMap Name Name
pr_lambda_bound = OMap Name Name
lambdas
, pr_let_bound :: PrEnv -> LetExpansions
pr_let_bound = LetExpansions
lets }) =
let new_lets :: LetExpansions
new_lets = [(Name, DType)] -> LetExpansions
forall k v. Ord k => [(k, v)] -> OMap k v
OMap.fromList [ (Name
tmN, Name -> DType
DVarT Name
tyN) | (Name
tmN, Name
tyN) <- [(Name, Name)]
binds ] in
PrEnv
env { pr_lambda_bound = OMap.fromList binds `OMap.union` lambdas
, pr_let_bound = new_lets `OMap.union` lets }
type LetBind = (Name, DType)
letBind :: [LetBind] -> PrM a -> PrM a
letBind :: forall a. [(Name, DType)] -> PrM a -> PrM a
letBind [(Name, DType)]
binds = (PrEnv -> PrEnv) -> PrM a -> PrM a
forall a. (PrEnv -> PrEnv) -> PrM a -> PrM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local PrEnv -> PrEnv
add_binds
where add_binds :: PrEnv -> PrEnv
add_binds env :: PrEnv
env@(PrEnv { pr_let_bound :: PrEnv -> LetExpansions
pr_let_bound = LetExpansions
lets }) =
PrEnv
env { pr_let_bound = OMap.fromList binds `OMap.union` lets }
lookupVarE :: Name -> PrM DType
lookupVarE :: Name -> PrM DType
lookupVarE Name
n = do
Options
opts <- PrM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
LetExpansions
lets <- (PrEnv -> LetExpansions) -> PrM LetExpansions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrEnv -> LetExpansions
pr_let_bound
case Name -> LetExpansions -> Maybe DType
forall k v. Ord k => k -> OMap k v -> Maybe v
OMap.lookup Name
n LetExpansions
lets of
Just DType
ty -> DType -> PrM DType
forall a. a -> PrM a
forall (m :: * -> *) a. Monad m => a -> m a
return DType
ty
Maybe DType
Nothing -> DType -> PrM DType
forall a. a -> PrM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> PrM DType) -> DType -> PrM DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT (Name -> DType) -> Name -> DType
forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
defunctionalizedName0 Options
opts Name
n
promoteM :: OptionsMonad q => [Dec] -> PrM a -> q (a, [DDec])
promoteM :: forall (q :: * -> *) a.
OptionsMonad q =>
[Dec] -> PrM a -> q (a, [DDec])
promoteM [Dec]
locals (PrM ReaderT PrEnv (WriterT [DDec] Q) a
rdr) = do
Options
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
[Dec]
other_locals <- q [Dec]
forall (m :: * -> *). DsMonad m => m [Dec]
localDeclarations
let wr :: WriterT [DDec] Q a
wr = ReaderT PrEnv (WriterT [DDec] Q) a -> PrEnv -> WriterT [DDec] Q a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT PrEnv (WriterT [DDec] Q) a
rdr (PrEnv
emptyPrEnv { pr_options = opts
, pr_local_decls = other_locals ++ locals })
q :: Q (a, [DDec])
q = WriterT [DDec] Q a -> Q (a, [DDec])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT [DDec] Q a
wr
Q (a, [DDec]) -> q (a, [DDec])
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ Q (a, [DDec])
q
promoteM_ :: OptionsMonad q => [Dec] -> PrM () -> q [DDec]
promoteM_ :: forall (q :: * -> *). OptionsMonad q => [Dec] -> PrM () -> q [DDec]
promoteM_ [Dec]
locals PrM ()
thing = do
((), [DDec]
decs) <- [Dec] -> PrM () -> q ((), [DDec])
forall (q :: * -> *) a.
OptionsMonad q =>
[Dec] -> PrM a -> q (a, [DDec])
promoteM [Dec]
locals PrM ()
thing
[DDec] -> q [DDec]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [DDec]
decs
promoteMDecs :: OptionsMonad q => [Dec] -> PrM [DDec] -> q [DDec]
promoteMDecs :: forall (q :: * -> *).
OptionsMonad q =>
[Dec] -> PrM [DDec] -> q [DDec]
promoteMDecs [Dec]
locals PrM [DDec]
thing = do
([DDec]
decs1, [DDec]
decs2) <- [Dec] -> PrM [DDec] -> q ([DDec], [DDec])
forall (q :: * -> *) a.
OptionsMonad q =>
[Dec] -> PrM a -> q (a, [DDec])
promoteM [Dec]
locals PrM [DDec]
thing
[DDec] -> q [DDec]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DDec] -> q [DDec]) -> [DDec] -> q [DDec]
forall a b. (a -> b) -> a -> b
$ [DDec]
decs1 [DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [DDec]
decs2