{-# LANGUAGE TupleSections #-}
{-|
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)
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)

{-|
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.5.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) -> Metadata -> 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)
    -> 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 -- Make a bunch of names
     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
     -- 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, 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
     -- 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
_, 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)
     -- 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, 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