{-# 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.Types (Func)
import Parsley.Internal.Common.Utils (Code)
import Parsley.Internal.Common.THUtils (unsafeCodeCoerce, unTypeCode)
import Data.Dependent.Map as DMap (DMap, (!), map, toList, traverseWithKey)
letRec :: forall key binding s o a b. 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 (binding s o a) -> Metadata -> Code (Func rs s o a x))
-> (forall x rs. Code (Func rs s o a x) -> Regs rs -> Metadata -> binding s o a x)
-> (DMap key (binding s o a) -> Code b)
-> Code b
letRec :: forall (key :: Type -> Type)
(binding :: Type -> Type -> Type -> Type -> Type) s o a b.
GCompare key =>
DMap key (LetBinding o a)
-> (forall x. key x -> String)
-> (forall x (rs :: [Type]).
key x
-> Binding o a x
-> Regs rs
-> DMap key (binding s o a)
-> Metadata
-> Code (Func rs s o a x))
-> (forall x (rs :: [Type]).
Code (Func rs s o a x) -> Regs rs -> Metadata -> binding s o a x)
-> (DMap key (binding 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 (binding s o a)
-> Metadata
-> Code (Func rs s o a x)
genBinding forall x (rs :: [Type]).
Code (Func rs s o a x) -> Regs rs -> Metadata -> binding s o a x
wrapBinding DMap key (binding s o a) -> Code b
expr = forall a (m :: Type -> Type). Quote m => m Exp -> Code m a
unsafeCodeCoerce forall a b. (a -> b) -> a -> b
$
do
DMap key (Const (Name, Some Regs, Metadata))
names <- 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 Binding o a v
_ Some Regs
rs Metadata
meta) -> forall {k} a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Some Regs
rs, Metadata
meta) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: Type -> Type). Quote m => String -> m Name
newName (forall x. key x -> String
nameOf key v
k)) DMap key (LetBinding o a)
bindings
let typedNames :: DMap key (binding s o a)
typedNames = 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 x. Const (Name, Some Regs, Metadata) x -> binding 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 Binding o a a
body (Some Regs a
frees) Metadata
_) =
do let Const (Name
name, Some Regs
_, Metadata
meta) = DMap key (Const (Name, Some Regs, Metadata))
names forall {k1} (k2 :: k1 -> Type) (f :: k1 -> Type) (v :: k1).
GCompare k2 =>
DMap k2 f -> k2 v -> f v
! key a
k
Exp
func <- forall a (m :: Type -> Type). Quote m => Code m a -> m Exp
unTypeCode (forall x (rs :: [Type]).
key x
-> Binding o a x
-> Regs rs
-> DMap key (binding 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 (binding s o a)
typedNames Metadata
meta)
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 <- 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 (forall {k1} (k2 :: k1 -> Type) (f :: k1 -> Type).
DMap k2 f -> [DSum k2 f]
toList DMap key (LetBinding o a)
bindings)
Exp
exp <- forall a (m :: Type -> Type). Quote m => Code m a -> m Exp
unTypeCode (DMap key (binding s o a) -> Code b
expr DMap key (binding s o a)
typedNames)
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 -> binding s o a x
makeTypedName :: forall x. Const (Name, Some Regs, Metadata) x -> binding s o a x
makeTypedName (Const (Name
name, Some Regs a
frees, Metadata
meta)) = forall x (rs :: [Type]).
Code (Func rs s o a x) -> Regs rs -> Metadata -> binding s o a x
wrapBinding (forall a (m :: Type -> Type). Quote m => m Exp -> Code m a
unsafeCodeCoerce (forall (m :: Type -> Type) a. Monad m => a -> m a
return (Name -> Exp
VarE Name
name))) Regs a
frees Metadata
meta