{-# LANGUAGE TupleSections,
             CPP #-}
{-|
Module      : Parsley.Internal.Backend.Machine.LetRecBuilder
Description : Function for building recursive groups.
License     : BSD-3-Clause
Maintainer  : Jamie Willis
Stability   : experimental

Exposes the `letRec` function, used to provide a recursive /group/ of bindings
for the top level of a parser.

@since 1.0.0.0
-}
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

{-|
Given a collection of bindings, generates a recursive binding group where each is allowed to
refer to every other. These are then in scope for the top-level parser.

@since 1.0.0.0
-}
letRec :: GCompare key 
       => {-bindings-}  DMap key (LetBinding o a)   -- ^ The bindings that should form part of the recursive group
      -> {-nameof-}     (forall x. key x -> String) -- ^ A function which can give a name to a key in the map
      -> {-genBinding-} (forall x rs. key x -> Binding o a x -> Regs rs -> DMap key (QSubroutine s o a) -> Code (Func rs s o a x)) 
      -- ^ How a binding - and their free registers - should be converted into code
      -> {-expr-}       (DMap key (QSubroutine s o a) -> Code b) 
      -- ^ How to produce the top-level binding given the compiled bindings, i.e. the @in@ for the @let@
      -> 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 -- 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
. (, 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
     -- 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 (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)
     -- 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)) = 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