{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.TH.LetRec (
letrecE,
) 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, valD, varE, varP)
import Language.Haskell.TH.Syntax (Exp, Name, Quote (newName))
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 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, q Exp)
bindings) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall (m :: * -> *). Monad m => (tag -> m (q Exp)) -> m (q Exp)
exprf tag -> StateT (Map tag (Name, q Exp)) q (q Exp)
loop) forall k a. Map k a
Map.empty
forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
letE
[ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
name) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB q Exp
expr) []
| (tag
_tag, (Name
name, q Exp
expr)) <- forall k a. Map k a -> [(k, a)]
Map.toList Map tag (Name, q Exp)
bindings
]
q Exp
expr0
where
loop :: tag -> StateT (Map.Map tag (Name, q Exp)) q (q Exp)
loop :: tag -> StateT (Map tag (Name, q Exp)) q (q Exp)
loop tag
tag = do
Map tag (Name, q Exp)
m <- forall (m :: * -> *) s. Monad m => StateT s m s
get
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup tag
tag Map tag (Name, q Exp)
m of
Just (Name
name, q Exp
_exp) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name)
Maybe (Name, q Exp)
Nothing -> mdo
Name
name <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *). Quote m => String -> m Name
newName (tag -> String
nameOf tag
tag))
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert tag
tag (Name
name, q Exp
expr))
q Exp
expr <- forall (m :: * -> *).
Monad m =>
(tag -> m (q Exp)) -> tag -> m (q Exp)
recf tag -> StateT (Map tag (Name, q Exp)) q (q Exp)
loop tag
tag
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name)