{-# 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.State       (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 => {-bindings-}   DMap key (LetBinding o a)
                       -> {-nameof-}     (forall x. key x -> String)
                       -> {-genBinding-} (forall x rs. Binding o a x -> Regs rs -> DMap key (QSubRoutine s o a) -> Code (Func rs s o a x))
                       -> {-expr-}       (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]).
    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]).
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 -- Make a bunch of names
     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
. (, Regs rs -> Some Regs
forall k (tag :: k -> Type) (a :: k). tag a -> Some tag
Some Regs rs
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
     -- Wrap them up so that they are valid typed template haskell names
     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
     -- Generate each binding providing them with the names
     let makeDecl :: DSum key (LetBinding o a) -> Q Dec
makeDecl (key a
k :=> LetBinding body 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 rs s o a a) -> Q Exp
forall a. Code a -> Q Exp
unTypeCode (Binding o a a
-> Regs rs
-> DMap key (QSubRoutine s o a)
-> Code (Func rs s o a a)
forall x (rs :: [Type]).
Binding o a x
-> Regs rs
-> DMap key (QSubRoutine s o a)
-> Code (Func rs s o a x)
genBinding Binding o a a
body Regs rs
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)
     -- Generate the main expression using the same names
     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)
     -- Construct the let expression
     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)) = Code (Func a s o a x) -> Regs a -> QSubRoutine s o a x
forall s o a x (rs :: [Type]).
Code (Func rs s o a x) -> Regs rs -> QSubRoutine s o a x
QSubRoutine (Q Exp -> Code (Func 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