{-# 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.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)

{-|
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 :: forall key binding s o a b. 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 (binding s o a) -> Metadata -> Code (Func rs s o a x))
      -> {-wrapBinding-} (forall x rs. Code (Func rs s o a x) -> Regs rs -> Metadata -> binding s o a x)
      -- ^ How a binding - and their free registers - should be converted into code
      -> {-expr-}        (DMap key (binding 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 :: 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 -- Make a bunch of names
     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
     -- Wrap them up so that they are valid typed template haskell names
     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
     -- Generate each binding providing them with the 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)
     -- Generate the main expression using the same names
     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)
     -- Construct the let expression
     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