{-# LANGUAGE TupleSections #-}
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)
import Language.Haskell.TH.Syntax (Exp(VarE, LetE), Dec(FunD), Clause(Clause), Body(NormalB))
import Parsley.Internal.Backend.Machine.LetBindings (LetBinding(..), Metadata, Binding, Regs)
import Parsley.Internal.Backend.Machine.THUtils (unsafeCodeCoerce, unTypeCode)
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)
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) -> Metadata -> 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)
-> Metadata
-> 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)
-> Metadata
-> 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, Metadata))
names <- (forall v.
key v
-> LetBinding o a v -> Q (Const (Name, Some Regs, Metadata) v))
-> DMap key (LetBinding o a)
-> Q (DMap key (Const (Name, Some Regs, Metadata)))
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 meta) -> (Name, Some Regs, Metadata) -> Const (Name, Some Regs, Metadata) v
forall k a (b :: k). a -> Const a b
Const ((Name, Some Regs, Metadata)
-> Const (Name, Some Regs, Metadata) v)
-> (Name -> (Name, Some Regs, Metadata))
-> Name
-> Const (Name, Some Regs, Metadata) v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Some Regs
rs, Metadata
meta) (Name -> Const (Name, Some Regs, Metadata) v)
-> Q Name -> Q (Const (Name, Some Regs, Metadata) 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, Metadata) v -> QSubroutine s o a v)
-> DMap key (Const (Name, Some Regs, Metadata))
-> 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, Metadata) v -> QSubroutine s o a v
forall x s o a.
Const (Name, Some Regs, Metadata) x -> QSubroutine s o a x
makeTypedName DMap key (Const (Name, Some Regs, Metadata))
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
_, Metadata
meta) = DMap key (Const (Name, Some Regs, Metadata))
names DMap key (Const (Name, Some Regs, Metadata))
-> key a -> Const (Name, Some Regs, Metadata) 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)
-> Metadata
-> 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)
-> Metadata
-> 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 Metadata
meta)
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, Metadata) x -> QSubroutine s o a x
makeTypedName :: Const (Name, Some Regs, Metadata) x -> QSubroutine s o a x
makeTypedName (Const (Name
name, Some Regs a
frees, Metadata
meta)) = DynFunc a s o a x -> Regs a -> Metadata -> QSubroutine s o a x
forall s o a x (rs :: [Type]).
DynFunc rs s o a x -> Regs rs -> Metadata -> 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 Metadata
meta