{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.TH.LetRec (
letrecE,
typedLetrecE,
) where
import Control.Monad.Fix (MonadFix)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Lazy (StateT, get, modify, runStateT)
import Language.Haskell.TH.Lib (letE, normalB, sigD, valD, varE, varP)
import Language.Haskell.TH.Syntax (Exp, Name, Quote (newName), Type)
import qualified Data.Map.Lazy as Map
letrecE
:: forall q tag. (Ord tag, Quote q, MonadFix q)
=> (tag -> String)
-> (forall m. Monad m => (tag -> m (q Exp)) -> (tag -> m (q Exp)))
-> (forall m. Monad m => (tag -> m (q Exp)) -> m (q Exp))
-> q Exp
letrecE :: forall (q :: * -> *) tag.
(Ord tag, Quote q, MonadFix q) =>
(tag -> String)
-> (forall (m :: * -> *).
Monad m =>
(tag -> m (q Exp)) -> tag -> m (q Exp))
-> (forall (m :: * -> *).
Monad m =>
(tag -> m (q Exp)) -> m (q Exp))
-> q Exp
letrecE tag -> String
nameOf = (tag -> String)
-> (tag -> Maybe (q Type))
-> (forall (m :: * -> *).
Monad m =>
(tag -> m (q Exp)) -> tag -> m (q Exp))
-> (forall (m :: * -> *).
Monad m =>
(tag -> m (q Exp)) -> m (q Exp))
-> q Exp
forall (q :: * -> *) tag.
(Ord tag, Quote q, MonadFix q) =>
(tag -> String)
-> (tag -> Maybe (q Type))
-> (forall (m :: * -> *).
Monad m =>
(tag -> m (q Exp)) -> tag -> m (q Exp))
-> (forall (m :: * -> *).
Monad m =>
(tag -> m (q Exp)) -> m (q Exp))
-> q Exp
typedLetrecE tag -> String
nameOf (Maybe (q Type) -> tag -> Maybe (q Type)
forall a b. a -> b -> a
const Maybe (q Type)
forall a. Maybe a
Nothing)
typedLetrecE
:: forall q tag. (Ord tag, Quote q, MonadFix q)
=> (tag -> String)
-> (tag -> Maybe (q Type))
-> (forall m. Monad m => (tag -> m (q Exp)) -> (tag -> m (q Exp)))
-> (forall m. Monad m => (tag -> m (q Exp)) -> m (q Exp))
-> q Exp
typedLetrecE :: forall (q :: * -> *) tag.
(Ord tag, Quote q, MonadFix q) =>
(tag -> String)
-> (tag -> Maybe (q Type))
-> (forall (m :: * -> *).
Monad m =>
(tag -> m (q Exp)) -> tag -> m (q Exp))
-> (forall (m :: * -> *).
Monad m =>
(tag -> m (q Exp)) -> m (q Exp))
-> q Exp
typedLetrecE tag -> String
nameOf tag -> Maybe (q Type)
typeOf forall (m :: * -> *).
Monad m =>
(tag -> m (q Exp)) -> tag -> m (q Exp)
recf forall (m :: * -> *). Monad m => (tag -> m (q Exp)) -> m (q Exp)
exprf = do
(q Exp
expr0, Map tag (Name, Maybe (q Type), q Exp)
bindings) <- StateT (Map tag (Name, Maybe (q Type), q Exp)) q (q Exp)
-> Map tag (Name, Maybe (q Type), q Exp)
-> q (q Exp, Map tag (Name, Maybe (q Type), q Exp))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((tag -> StateT (Map tag (Name, Maybe (q Type), q Exp)) q (q Exp))
-> StateT (Map tag (Name, Maybe (q Type), q Exp)) q (q Exp)
forall (m :: * -> *). Monad m => (tag -> m (q Exp)) -> m (q Exp)
exprf tag -> StateT (Map tag (Name, Maybe (q Type), q Exp)) q (q Exp)
loop) Map tag (Name, Maybe (q Type), q Exp)
forall k a. Map k a
Map.empty
[q Dec] -> q Exp -> q Exp
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE ([[q Dec]] -> [q Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ Name -> q Type -> q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
name q Type
ty' | Just q Type
ty' <- [Maybe (q Type)
ty] ] [q Dec] -> [q Dec] -> [q Dec]
forall a. [a] -> [a] -> [a]
++
[ q Pat -> q Body -> [q Dec] -> q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
name) (q Exp -> q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB q Exp
expr) [] ]
| (tag
_tag, (Name
name, Maybe (q Type)
ty, q Exp
expr)) <- Map tag (Name, Maybe (q Type), q Exp)
-> [(tag, (Name, Maybe (q Type), q Exp))]
forall k a. Map k a -> [(k, a)]
Map.toList Map tag (Name, Maybe (q Type), q Exp)
bindings
])
q Exp
expr0
where
loop :: tag -> StateT (Map.Map tag (Name, Maybe (q Type), q Exp)) q (q Exp)
loop :: tag -> StateT (Map tag (Name, Maybe (q Type), q Exp)) q (q Exp)
loop tag
tag = do
Map tag (Name, Maybe (q Type), q Exp)
m <- StateT
(Map tag (Name, Maybe (q Type), q Exp))
q
(Map tag (Name, Maybe (q Type), q Exp))
forall (m :: * -> *) s. Monad m => StateT s m s
get
case tag
-> Map tag (Name, Maybe (q Type), q Exp)
-> Maybe (Name, Maybe (q Type), q Exp)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup tag
tag Map tag (Name, Maybe (q Type), q Exp)
m of
Just (Name
name, Maybe (q Type)
_ty, q Exp
_exp) -> q Exp -> StateT (Map tag (Name, Maybe (q Type), q Exp)) q (q Exp)
forall a. a -> StateT (Map tag (Name, Maybe (q Type), q Exp)) q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name)
Maybe (Name, Maybe (q Type), q Exp)
Nothing -> mdo
Name
name <- q Name -> StateT (Map tag (Name, Maybe (q Type), q Exp)) q Name
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map tag (Name, Maybe (q Type), q Exp)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (tag -> String
nameOf tag
tag))
(Map tag (Name, Maybe (q Type), q Exp)
-> Map tag (Name, Maybe (q Type), q Exp))
-> StateT (Map tag (Name, Maybe (q Type), q Exp)) q ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (tag
-> (Name, Maybe (q Type), q Exp)
-> Map tag (Name, Maybe (q Type), q Exp)
-> Map tag (Name, Maybe (q Type), q Exp)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert tag
tag (Name
name, tag -> Maybe (q Type)
typeOf tag
tag, q Exp
expr))
q Exp
expr <- (tag -> StateT (Map tag (Name, Maybe (q Type), q Exp)) q (q Exp))
-> tag -> StateT (Map tag (Name, Maybe (q Type), q Exp)) q (q Exp)
forall (m :: * -> *).
Monad m =>
(tag -> m (q Exp)) -> tag -> m (q Exp)
recf tag -> StateT (Map tag (Name, Maybe (q Type), q Exp)) q (q Exp)
loop tag
tag
q Exp -> StateT (Map tag (Name, Maybe (q Type), q Exp)) q (q Exp)
forall a. a -> StateT (Map tag (Name, Maybe (q Type), q Exp)) q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name)