{-# LANGUAGE TupleSections,
CPP #-}
module Parsley.Internal.Backend.Machine.LetRecBuilder (letRec) where
import Data.Dependent.Sum (DSum((:=>)))
import Data.Functor.Const (Const(..))
import Data.GADT.Compare (GCompare)
import Data.Some (Some(Some))
import Language.Haskell.TH (newName, Name)
#if __GLASGOW_HASKELL__ < 900
import Language.Haskell.TH.Syntax (Q, unTypeQ, unsafeTExpCoerce, Exp(VarE, LetE), Dec(FunD), Clause(Clause), Body(NormalB))
#else
import Language.Haskell.TH.Syntax (unTypeCode, unsafeCodeCoerce, Exp(VarE, LetE), Dec(FunD), Clause(Clause), Body(NormalB))
#endif
import Parsley.Internal.Backend.Machine.LetBindings (LetBinding(..), Binding, Regs)
import Parsley.Internal.Backend.Machine.Types (QSubroutine, qSubroutine, Func)
import Parsley.Internal.Common.Utils (Code)
import Data.Dependent.Map as DMap (DMap, (!), map, toList, traverseWithKey)
#if __GLASGOW_HASKELL__ < 900
unsafeCodeCoerce :: Q Exp -> Code a
unsafeCodeCoerce :: Q Exp -> Code a
unsafeCodeCoerce = Q Exp -> Code a
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce
unTypeCode :: Code a -> Q Exp
unTypeCode :: Code a -> Q Exp
unTypeCode = Code a -> Q Exp
forall a. Q (TExp a) -> Q Exp
unTypeQ
#endif
letRec :: GCompare key
=> DMap key (LetBinding o a)
-> (forall x. key x -> String)
-> (forall x rs. key x -> Binding o a x -> Regs rs -> DMap key (QSubroutine s o a) -> Code (Func rs s o a x))
-> (DMap key (QSubroutine s o a) -> Code b)
-> Code b
letRec :: DMap key (LetBinding o a)
-> (forall x. key x -> String)
-> (forall x (rs :: [Type]).
key x
-> Binding o a x
-> Regs rs
-> DMap key (QSubroutine s o a)
-> Code (Func rs s o a x))
-> (DMap key (QSubroutine s o a) -> Code b)
-> Code b
letRec DMap key (LetBinding o a)
bindings forall x. key x -> String
nameOf forall x (rs :: [Type]).
key x
-> Binding o a x
-> Regs rs
-> DMap key (QSubroutine s o a)
-> Code (Func rs s o a x)
genBinding DMap key (QSubroutine s o a) -> Code b
expr = Q Exp -> Code b
forall a. Q Exp -> Code a
unsafeCodeCoerce (Q Exp -> Code b) -> Q Exp -> Code b
forall a b. (a -> b) -> a -> b
$
do
DMap key (Const (Name, Some Regs))
names <- (forall v.
key v -> LetBinding o a v -> Q (Const (Name, Some Regs) v))
-> DMap key (LetBinding o a)
-> Q (DMap key (Const (Name, Some Regs)))
forall k1 (t :: Type -> Type) (k2 :: k1 -> Type) (f :: k1 -> Type)
(g :: k1 -> Type).
Applicative t =>
(forall (v :: k1). k2 v -> f v -> t (g v))
-> DMap k2 f -> t (DMap k2 g)
traverseWithKey (\key v
k (LetBinding _ rs) -> (Name, Some Regs) -> Const (Name, Some Regs) v
forall k a (b :: k). a -> Const a b
Const ((Name, Some Regs) -> Const (Name, Some Regs) v)
-> (Name -> (Name, Some Regs)) -> Name -> Const (Name, Some Regs) v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Some Regs
rs) (Name -> Const (Name, Some Regs) v)
-> Q Name -> Q (Const (Name, Some Regs) v)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName (key v -> String
forall x. key x -> String
nameOf key v
k)) DMap key (LetBinding o a)
bindings
let typedNames :: DMap key (QSubroutine s o a)
typedNames = (forall v. Const (Name, Some Regs) v -> QSubroutine s o a v)
-> DMap key (Const (Name, Some Regs))
-> DMap key (QSubroutine s o a)
forall k1 (f :: k1 -> Type) (g :: k1 -> Type) (k2 :: k1 -> Type).
(forall (v :: k1). f v -> g v) -> DMap k2 f -> DMap k2 g
DMap.map forall v. Const (Name, Some Regs) v -> QSubroutine s o a v
forall x s o a. Const (Name, Some Regs) x -> QSubroutine s o a x
makeTypedName DMap key (Const (Name, Some Regs))
names
let makeDecl :: DSum key (LetBinding o a) -> Q Dec
makeDecl (key a
k :=> LetBinding body (Some frees)) =
do let Const (Name
name, Some Regs
_) = DMap key (Const (Name, Some Regs))
names DMap key (Const (Name, Some Regs))
-> key a -> Const (Name, Some Regs) a
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
DMap k2 f -> k2 v -> f v
! key a
k
Exp
func <- Code (Func a s o a a) -> Q Exp
forall a. Code a -> Q Exp
unTypeCode (key a
-> Binding o a a
-> Regs a
-> DMap key (QSubroutine s o a)
-> Code (Func a s o a a)
forall x (rs :: [Type]).
key x
-> Binding o a x
-> Regs rs
-> DMap key (QSubroutine s o a)
-> Code (Func rs s o a x)
genBinding key a
k Binding o a a
body Regs a
frees DMap key (QSubroutine s o a)
typedNames)
Dec -> Q Dec
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Name -> [Clause] -> Dec
FunD Name
name [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
func) []])
[Dec]
decls <- (DSum key (LetBinding o a) -> Q Dec)
-> [DSum key (LetBinding o a)] -> Q [Dec]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DSum key (LetBinding o a) -> Q Dec
makeDecl (DMap key (LetBinding o a) -> [DSum key (LetBinding o a)]
forall k1 (k2 :: k1 -> Type) (f :: k1 -> Type).
DMap k2 f -> [DSum k2 f]
toList DMap key (LetBinding o a)
bindings)
Exp
exp <- Code b -> Q Exp
forall a. Code a -> Q Exp
unTypeCode (DMap key (QSubroutine s o a) -> Code b
expr DMap key (QSubroutine s o a)
typedNames)
Exp -> Q Exp
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Dec] -> Exp -> Exp
LetE [Dec]
decls Exp
exp)
where
makeTypedName :: Const (Name, Some Regs) x -> QSubroutine s o a x
makeTypedName :: Const (Name, Some Regs) x -> QSubroutine s o a x
makeTypedName (Const (Name
name, Some Regs a
frees)) = DynFunc a s o a x -> Regs a -> QSubroutine s o a x
forall s o a x (rs :: [Type]).
DynFunc rs s o a x -> Regs rs -> QSubroutine s o a x
qSubroutine (Q Exp -> DynFunc a s o a x
forall a. Q Exp -> Code a
unsafeCodeCoerce (Exp -> Q Exp
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Name -> Exp
VarE Name
name))) Regs a
frees