{-# LANGUAGE TemplateHaskellQuotes #-}
module Data.Singletons.TH.Single.Monad (
SgM, bindLets, bindContext, askContext, lookupVarE, lookupConE,
wrapSingFun,
singM, singDecsM,
emitDecs, emitDecsM
) where
import Prelude hiding ( exp )
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Singletons
import Data.Singletons.TH.Options
import Data.Singletons.TH.Promote.Monad ( emitDecs, emitDecsM )
import Data.Singletons.TH.Util
import Language.Haskell.TH.Syntax hiding ( lift )
import Language.Haskell.TH.Desugar
import Control.Monad ( liftM2 )
import Control.Monad.IO.Class ( MonadIO )
import Control.Monad.Reader ( MonadReader(..), ReaderT(..), asks )
import Control.Monad.Writer ( MonadWriter, WriterT(..) )
import Control.Applicative
data SgEnv =
SgEnv { SgEnv -> Options
sg_options :: Options
, SgEnv -> Map Name DExp
sg_let_binds :: Map Name DExp
, SgEnv -> DCxt
sg_context :: DCxt
, SgEnv -> [Dec]
sg_local_decls :: [Dec]
}
emptySgEnv :: SgEnv
emptySgEnv :: SgEnv
emptySgEnv = SgEnv { sg_options :: Options
sg_options = Options
defaultOptions
, sg_let_binds :: Map Name DExp
sg_let_binds = Map Name DExp
forall k a. Map k a
Map.empty
, sg_context :: DCxt
sg_context = []
, sg_local_decls :: [Dec]
sg_local_decls = []
}
newtype SgM a = SgM (ReaderT SgEnv (WriterT [DDec] Q) a)
deriving ( (forall a b. (a -> b) -> SgM a -> SgM b)
-> (forall a b. a -> SgM b -> SgM a) -> Functor SgM
forall a b. a -> SgM b -> SgM a
forall a b. (a -> b) -> SgM a -> SgM 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) -> SgM a -> SgM b
fmap :: forall a b. (a -> b) -> SgM a -> SgM b
$c<$ :: forall a b. a -> SgM b -> SgM a
<$ :: forall a b. a -> SgM b -> SgM a
Functor, Functor SgM
Functor SgM =>
(forall a. a -> SgM a)
-> (forall a b. SgM (a -> b) -> SgM a -> SgM b)
-> (forall a b c. (a -> b -> c) -> SgM a -> SgM b -> SgM c)
-> (forall a b. SgM a -> SgM b -> SgM b)
-> (forall a b. SgM a -> SgM b -> SgM a)
-> Applicative SgM
forall a. a -> SgM a
forall a b. SgM a -> SgM b -> SgM a
forall a b. SgM a -> SgM b -> SgM b
forall a b. SgM (a -> b) -> SgM a -> SgM b
forall a b c. (a -> b -> c) -> SgM a -> SgM b -> SgM 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 -> SgM a
pure :: forall a. a -> SgM a
$c<*> :: forall a b. SgM (a -> b) -> SgM a -> SgM b
<*> :: forall a b. SgM (a -> b) -> SgM a -> SgM b
$cliftA2 :: forall a b c. (a -> b -> c) -> SgM a -> SgM b -> SgM c
liftA2 :: forall a b c. (a -> b -> c) -> SgM a -> SgM b -> SgM c
$c*> :: forall a b. SgM a -> SgM b -> SgM b
*> :: forall a b. SgM a -> SgM b -> SgM b
$c<* :: forall a b. SgM a -> SgM b -> SgM a
<* :: forall a b. SgM a -> SgM b -> SgM a
Applicative, Applicative SgM
Applicative SgM =>
(forall a b. SgM a -> (a -> SgM b) -> SgM b)
-> (forall a b. SgM a -> SgM b -> SgM b)
-> (forall a. a -> SgM a)
-> Monad SgM
forall a. a -> SgM a
forall a b. SgM a -> SgM b -> SgM b
forall a b. SgM a -> (a -> SgM b) -> SgM 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. SgM a -> (a -> SgM b) -> SgM b
>>= :: forall a b. SgM a -> (a -> SgM b) -> SgM b
$c>> :: forall a b. SgM a -> SgM b -> SgM b
>> :: forall a b. SgM a -> SgM b -> SgM b
$creturn :: forall a. a -> SgM a
return :: forall a. a -> SgM a
Monad
, MonadReader SgEnv, MonadWriter [DDec]
, Monad SgM
Monad SgM => (forall a. String -> SgM a) -> MonadFail SgM
forall a. String -> SgM a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall a. String -> SgM a
fail :: forall a. String -> SgM a
MonadFail, Monad SgM
Monad SgM => (forall a. IO a -> SgM a) -> MonadIO SgM
forall a. IO a -> SgM a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> SgM a
liftIO :: forall a. IO a -> SgM a
MonadIO, MonadFail SgM
MonadIO SgM
SgM String
SgM [Extension]
SgM Loc
Bool -> String -> SgM (Maybe Name)
Bool -> String -> SgM ()
String -> SgM String
String -> SgM Name
String -> SgM ()
[Dec] -> SgM ()
Q () -> SgM ()
Name -> SgM [Role]
Name -> SgM [DecidedStrictness]
Name -> SgM (Maybe Fixity)
Name -> SgM Type
Name -> SgM Info
Name -> [Type] -> SgM [Dec]
(MonadIO SgM, MonadFail SgM) =>
(String -> SgM Name)
-> (Bool -> String -> SgM ())
-> (forall a. SgM a -> SgM a -> SgM a)
-> (Bool -> String -> SgM (Maybe Name))
-> (Name -> SgM Info)
-> (Name -> SgM (Maybe Fixity))
-> (Name -> SgM Type)
-> (Name -> [Type] -> SgM [Dec])
-> (Name -> SgM [Role])
-> (forall a. Data a => AnnLookup -> SgM [a])
-> (Module -> SgM ModuleInfo)
-> (Name -> SgM [DecidedStrictness])
-> SgM Loc
-> (forall a. IO a -> SgM a)
-> SgM String
-> (String -> SgM ())
-> (String -> SgM String)
-> ([Dec] -> SgM ())
-> (ForeignSrcLang -> String -> SgM ())
-> (Q () -> SgM ())
-> (String -> SgM ())
-> (forall a. Typeable a => SgM (Maybe a))
-> (forall a. Typeable a => a -> SgM ())
-> (Extension -> SgM Bool)
-> SgM [Extension]
-> (DocLoc -> String -> SgM ())
-> (DocLoc -> SgM (Maybe String))
-> Quasi SgM
ForeignSrcLang -> String -> SgM ()
Extension -> SgM Bool
DocLoc -> SgM (Maybe String)
DocLoc -> String -> SgM ()
Module -> SgM ModuleInfo
forall a. Data a => AnnLookup -> SgM [a]
forall a. Typeable a => SgM (Maybe a)
forall a. Typeable a => a -> SgM ()
forall a. IO a -> SgM a
forall a. SgM a -> SgM a -> SgM a
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
(String -> m Name)
-> (Bool -> String -> m ())
-> (forall a. m a -> m a -> m a)
-> (Bool -> String -> 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 String
-> (String -> m ())
-> (String -> m String)
-> ([Dec] -> m ())
-> (ForeignSrcLang -> String -> m ())
-> (Q () -> m ())
-> (String -> m ())
-> (forall a. Typeable a => m (Maybe a))
-> (forall a. Typeable a => a -> m ())
-> (Extension -> m Bool)
-> m [Extension]
-> (DocLoc -> String -> m ())
-> (DocLoc -> m (Maybe String))
-> Quasi m
$cqNewName :: String -> SgM Name
qNewName :: String -> SgM Name
$cqReport :: Bool -> String -> SgM ()
qReport :: Bool -> String -> SgM ()
$cqRecover :: forall a. SgM a -> SgM a -> SgM a
qRecover :: forall a. SgM a -> SgM a -> SgM a
$cqLookupName :: Bool -> String -> SgM (Maybe Name)
qLookupName :: Bool -> String -> SgM (Maybe Name)
$cqReify :: Name -> SgM Info
qReify :: Name -> SgM Info
$cqReifyFixity :: Name -> SgM (Maybe Fixity)
qReifyFixity :: Name -> SgM (Maybe Fixity)
$cqReifyType :: Name -> SgM Type
qReifyType :: Name -> SgM Type
$cqReifyInstances :: Name -> [Type] -> SgM [Dec]
qReifyInstances :: Name -> [Type] -> SgM [Dec]
$cqReifyRoles :: Name -> SgM [Role]
qReifyRoles :: Name -> SgM [Role]
$cqReifyAnnotations :: forall a. Data a => AnnLookup -> SgM [a]
qReifyAnnotations :: forall a. Data a => AnnLookup -> SgM [a]
$cqReifyModule :: Module -> SgM ModuleInfo
qReifyModule :: Module -> SgM ModuleInfo
$cqReifyConStrictness :: Name -> SgM [DecidedStrictness]
qReifyConStrictness :: Name -> SgM [DecidedStrictness]
$cqLocation :: SgM Loc
qLocation :: SgM Loc
$cqRunIO :: forall a. IO a -> SgM a
qRunIO :: forall a. IO a -> SgM a
$cqGetPackageRoot :: SgM String
qGetPackageRoot :: SgM String
$cqAddDependentFile :: String -> SgM ()
qAddDependentFile :: String -> SgM ()
$cqAddTempFile :: String -> SgM String
qAddTempFile :: String -> SgM String
$cqAddTopDecls :: [Dec] -> SgM ()
qAddTopDecls :: [Dec] -> SgM ()
$cqAddForeignFilePath :: ForeignSrcLang -> String -> SgM ()
qAddForeignFilePath :: ForeignSrcLang -> String -> SgM ()
$cqAddModFinalizer :: Q () -> SgM ()
qAddModFinalizer :: Q () -> SgM ()
$cqAddCorePlugin :: String -> SgM ()
qAddCorePlugin :: String -> SgM ()
$cqGetQ :: forall a. Typeable a => SgM (Maybe a)
qGetQ :: forall a. Typeable a => SgM (Maybe a)
$cqPutQ :: forall a. Typeable a => a -> SgM ()
qPutQ :: forall a. Typeable a => a -> SgM ()
$cqIsExtEnabled :: Extension -> SgM Bool
qIsExtEnabled :: Extension -> SgM Bool
$cqExtsEnabled :: SgM [Extension]
qExtsEnabled :: SgM [Extension]
$cqPutDoc :: DocLoc -> String -> SgM ()
qPutDoc :: DocLoc -> String -> SgM ()
$cqGetDoc :: DocLoc -> SgM (Maybe String)
qGetDoc :: DocLoc -> SgM (Maybe String)
Quasi )
instance DsMonad SgM where
localDeclarations :: SgM [Dec]
localDeclarations = (SgEnv -> [Dec]) -> SgM [Dec]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SgEnv -> [Dec]
sg_local_decls
instance OptionsMonad SgM where
getOptions :: SgM Options
getOptions = (SgEnv -> Options) -> SgM Options
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SgEnv -> Options
sg_options
bindLets :: [(Name, DExp)] -> SgM a -> SgM a
bindLets :: forall a. [(Name, DExp)] -> SgM a -> SgM a
bindLets [(Name, DExp)]
lets1 =
(SgEnv -> SgEnv) -> SgM a -> SgM a
forall a. (SgEnv -> SgEnv) -> SgM a -> SgM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: SgEnv
env@(SgEnv { sg_let_binds :: SgEnv -> Map Name DExp
sg_let_binds = Map Name DExp
lets2 }) ->
SgEnv
env { sg_let_binds = (Map.fromList lets1) `Map.union` lets2 })
bindContext :: DCxt -> SgM a -> SgM a
bindContext :: forall a. DCxt -> SgM a -> SgM a
bindContext DCxt
ctxt1
= (SgEnv -> SgEnv) -> SgM a -> SgM a
forall a. (SgEnv -> SgEnv) -> SgM a -> SgM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: SgEnv
env@(SgEnv { sg_context :: SgEnv -> DCxt
sg_context = DCxt
ctxt2 }) ->
SgEnv
env { sg_context = ctxt1 ++ ctxt2 })
askContext :: SgM DCxt
askContext :: SgM DCxt
askContext = (SgEnv -> DCxt) -> SgM DCxt
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SgEnv -> DCxt
sg_context
lookupVarE :: Name -> SgM DExp
lookupVarE :: Name -> SgM DExp
lookupVarE Name
name = do
Options
opts <- SgM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
(Name -> Name) -> (Name -> DExp) -> Name -> SgM DExp
lookup_var_con (Options -> Name -> Name
singledValueName Options
opts)
(Name -> DExp
DVarE (Name -> DExp) -> (Name -> Name) -> Name -> DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Name -> Name
singledValueName Options
opts) Name
name
lookupConE :: Name -> SgM DExp
lookupConE :: Name -> SgM DExp
lookupConE Name
name = do
Options
opts <- SgM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
(Name -> Name) -> (Name -> DExp) -> Name -> SgM DExp
lookup_var_con (Options -> Name -> Name
singledDataConName Options
opts)
(Name -> DExp
DConE (Name -> DExp) -> (Name -> Name) -> Name -> DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Name -> Name
singledDataConName Options
opts) Name
name
lookup_var_con :: (Name -> Name) -> (Name -> DExp) -> Name -> SgM DExp
lookup_var_con :: (Name -> Name) -> (Name -> DExp) -> Name -> SgM DExp
lookup_var_con Name -> Name
mk_sing_name Name -> DExp
mk_exp Name
name = do
Options
opts <- SgM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
Map Name DExp
letExpansions <- (SgEnv -> Map Name DExp) -> SgM (Map Name DExp)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SgEnv -> Map Name DExp
sg_let_binds
Name
sName <- String -> SgM Name
forall (q :: * -> *). Quasi q => String -> q Name
mkDataName (Name -> String
nameBase (Name -> Name
mk_sing_name Name
name))
case Name -> Map Name DExp -> Maybe DExp
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name DExp
letExpansions of
Maybe DExp
Nothing -> do
Maybe DInfo
m_dinfo <- (Maybe DInfo -> Maybe DInfo -> Maybe DInfo)
-> SgM (Maybe DInfo) -> SgM (Maybe DInfo) -> SgM (Maybe DInfo)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Maybe DInfo -> Maybe DInfo -> Maybe DInfo
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (Name -> SgM (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify Name
sName) (Name -> SgM (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify Name
name)
case Maybe DInfo
m_dinfo of
Just (DVarI Name
_ DType
ty Maybe Name
_) ->
let num_args :: Int
num_args = DType -> Int
countArgs DType
ty in
DExp -> SgM DExp
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> SgM DExp) -> DExp -> SgM DExp
forall a b. (a -> b) -> a -> b
$ Int -> DType -> DExp -> DExp
wrapSingFun Int
num_args (Name -> DType
DConT (Name -> DType) -> Name -> DType
forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
defunctionalizedName0 Options
opts Name
name)
(Name -> DExp
mk_exp Name
name)
Maybe DInfo
_ -> DExp -> SgM DExp
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> SgM DExp) -> DExp -> SgM DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
mk_exp Name
name
Just DExp
exp -> DExp -> SgM DExp
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
exp
wrapSingFun :: Int -> DType -> DExp -> DExp
wrapSingFun :: Int -> DType -> DExp -> DExp
wrapSingFun Int
0 DType
_ = DExp -> DExp
forall a. a -> a
id
wrapSingFun Int
n DType
ty =
let wrap_fun :: DExp
wrap_fun = Name -> DExp
DVarE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ case Int
n of
Int
1 -> 'singFun1
Int
2 -> 'singFun2
Int
3 -> 'singFun3
Int
4 -> 'singFun4
Int
5 -> 'singFun5
Int
6 -> 'singFun6
Int
7 -> 'singFun7
Int
_ -> String -> Name
forall a. HasCallStack => String -> a
error String
"No support for functions of arity > 7."
in
(DExp
wrap_fun DExp -> DType -> DExp
`DAppTypeE` DType
ty `DAppE`)
singM :: OptionsMonad q => [Dec] -> SgM a -> q (a, [DDec])
singM :: forall (q :: * -> *) a.
OptionsMonad q =>
[Dec] -> SgM a -> q (a, [DDec])
singM [Dec]
locals (SgM ReaderT SgEnv (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 SgEnv (WriterT [DDec] Q) a -> SgEnv -> WriterT [DDec] Q a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT SgEnv (WriterT [DDec] Q) a
rdr (SgEnv
emptySgEnv { sg_options = opts
, sg_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
singDecsM :: OptionsMonad q => [Dec] -> SgM [DDec] -> q [DDec]
singDecsM :: forall (q :: * -> *).
OptionsMonad q =>
[Dec] -> SgM [DDec] -> q [DDec]
singDecsM [Dec]
locals SgM [DDec]
thing = do
([DDec]
decs1, [DDec]
decs2) <- [Dec] -> SgM [DDec] -> q ([DDec], [DDec])
forall (q :: * -> *) a.
OptionsMonad q =>
[Dec] -> SgM a -> q (a, [DDec])
singM [Dec]
locals SgM [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