-- | Generic traversals of 'AST' terms

module Language.Syntactic.Traversal
    ( gmapQ
    , gmapT
    , everywhereUp
    , everywhereDown
    , universe
    , Args (..)
    , listArgs
    , mapArgs
    , mapArgsA
    , mapArgsM
    , foldrArgs
    , appArgs
    , listFold
    , match
    , simpleMatch
    , fold
    , simpleFold
    , matchTrans
    , mapAST
    , WrapFull (..)
    , toTree
    ) where



import Control.Applicative
import Data.Tree

import Language.Syntactic.Syntax



-- | Map a function over all immediate sub-terms (corresponds to the function
-- with the same name in Scrap Your Boilerplate)
gmapT :: forall sym
      .  (forall a . ASTF sym a -> ASTF sym a)
      -> (forall a . ASTF sym a -> ASTF sym a)
gmapT :: (forall a. ASTF sym a -> ASTF sym a)
-> forall a. ASTF sym a -> ASTF sym a
gmapT forall a. ASTF sym a -> ASTF sym a
f ASTF sym a
a = ASTF sym a -> ASTF sym a
forall a. AST sym a -> AST sym a
go ASTF sym a
a
  where
    go :: AST sym a -> AST sym a
    go :: AST sym a -> AST sym a
go (AST sym (a :-> a)
s :$ AST sym (Full a)
a) = AST sym (a :-> a) -> AST sym (a :-> a)
forall a. AST sym a -> AST sym a
go AST sym (a :-> a)
s AST sym (a :-> a) -> AST sym (Full a) -> AST sym a
forall (sym :: * -> *) a sig.
AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig
:$ AST sym (Full a) -> AST sym (Full a)
forall a. ASTF sym a -> ASTF sym a
f AST sym (Full a)
a
    go AST sym a
s        = AST sym a
s

-- | Map a function over all immediate sub-terms, collecting the results in a
-- list (corresponds to the function with the same name in Scrap Your
-- Boilerplate)
gmapQ :: forall sym b
      .  (forall a . ASTF sym a -> b)
      -> (forall a . ASTF sym a -> [b])
gmapQ :: (forall a. ASTF sym a -> b) -> forall a. ASTF sym a -> [b]
gmapQ forall a. ASTF sym a -> b
f ASTF sym a
a = ASTF sym a -> [b]
forall a. AST sym a -> [b]
go ASTF sym a
a
  where
    go :: AST sym a -> [b]
    go :: AST sym a -> [b]
go (AST sym (a :-> a)
s :$ AST sym (Full a)
a) = AST sym (Full a) -> b
forall a. ASTF sym a -> b
f AST sym (Full a)
a b -> [b] -> [b]
forall a. a -> [a] -> [a]
: AST sym (a :-> a) -> [b]
forall a. AST sym a -> [b]
go AST sym (a :-> a)
s
    go AST sym a
_        = []

-- | Apply a transformation bottom-up over an 'AST' (corresponds to @everywhere@ in Scrap Your
-- Boilerplate)
everywhereUp
    :: (forall a . ASTF sym a -> ASTF sym a)
    -> (forall a . ASTF sym a -> ASTF sym a)
everywhereUp :: (forall a. ASTF sym a -> ASTF sym a)
-> forall a. ASTF sym a -> ASTF sym a
everywhereUp forall a. ASTF sym a -> ASTF sym a
f = ASTF sym a -> ASTF sym a
forall a. ASTF sym a -> ASTF sym a
f (ASTF sym a -> ASTF sym a)
-> (ASTF sym a -> ASTF sym a) -> ASTF sym a -> ASTF sym a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. ASTF sym a -> ASTF sym a)
-> forall a. ASTF sym a -> ASTF sym a
forall (sym :: * -> *).
(forall a. ASTF sym a -> ASTF sym a)
-> forall a. ASTF sym a -> ASTF sym a
gmapT ((forall a. ASTF sym a -> ASTF sym a)
-> forall a. ASTF sym a -> ASTF sym a
forall (sym :: * -> *).
(forall a. ASTF sym a -> ASTF sym a)
-> forall a. ASTF sym a -> ASTF sym a
everywhereUp forall a. ASTF sym a -> ASTF sym a
f)

-- | Apply a transformation top-down over an 'AST' (corresponds to @everywhere'@ in Scrap Your
-- Boilerplate)
everywhereDown
    :: (forall a . ASTF sym a -> ASTF sym a)
    -> (forall a . ASTF sym a -> ASTF sym a)
everywhereDown :: (forall a. ASTF sym a -> ASTF sym a)
-> forall a. ASTF sym a -> ASTF sym a
everywhereDown forall a. ASTF sym a -> ASTF sym a
f = (forall a. ASTF sym a -> ASTF sym a)
-> forall a. ASTF sym a -> ASTF sym a
forall (sym :: * -> *).
(forall a. ASTF sym a -> ASTF sym a)
-> forall a. ASTF sym a -> ASTF sym a
gmapT ((forall a. ASTF sym a -> ASTF sym a)
-> forall a. ASTF sym a -> ASTF sym a
forall (sym :: * -> *).
(forall a. ASTF sym a -> ASTF sym a)
-> forall a. ASTF sym a -> ASTF sym a
everywhereDown forall a. ASTF sym a -> ASTF sym a
f) (ASTF sym a -> ASTF sym a)
-> (ASTF sym a -> ASTF sym a) -> ASTF sym a -> ASTF sym a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASTF sym a -> ASTF sym a
forall a. ASTF sym a -> ASTF sym a
f

-- | List all sub-terms (corresponds to @universe@ in Uniplate)
universe :: ASTF sym a -> [EF (AST sym)]
universe :: ASTF sym a -> [EF (AST sym)]
universe ASTF sym a
a = ASTF sym a -> EF (AST sym)
forall (e :: * -> *) a. e (Full a) -> EF e
EF ASTF sym a
a EF (AST sym) -> [EF (AST sym)] -> [EF (AST sym)]
forall a. a -> [a] -> [a]
: ASTF sym a -> [EF (AST sym)]
forall (sym :: * -> *) a. AST sym a -> [EF (AST sym)]
go ASTF sym a
a
  where
    go :: AST sym a -> [EF (AST sym)]
    go :: AST sym a -> [EF (AST sym)]
go (Sym sym a
s)  = []
    go (AST sym (a :-> a)
s :$ AST sym (Full a)
a) = AST sym (a :-> a) -> [EF (AST sym)]
forall (sym :: * -> *) a. AST sym a -> [EF (AST sym)]
go AST sym (a :-> a)
s [EF (AST sym)] -> [EF (AST sym)] -> [EF (AST sym)]
forall a. [a] -> [a] -> [a]
++ AST sym (Full a) -> [EF (AST sym)]
forall (sym :: * -> *) a. ASTF sym a -> [EF (AST sym)]
universe AST sym (Full a)
a

-- | List of symbol arguments
data Args c sig
  where
    Nil  :: Args c (Full a)
    (:*) :: c (Full a) -> Args c sig -> Args c (a :-> sig)

infixr :*

-- | Map a function over an 'Args' list and collect the results in an ordinary list
listArgs :: (forall a . c (Full a) -> b) -> Args c sig -> [b]
listArgs :: (forall a. c (Full a) -> b) -> Args c sig -> [b]
listArgs forall a. c (Full a) -> b
f Args c sig
Nil       = []
listArgs forall a. c (Full a) -> b
f (c (Full a)
a :* Args c sig
as) = c (Full a) -> b
forall a. c (Full a) -> b
f c (Full a)
a b -> [b] -> [b]
forall a. a -> [a] -> [a]
: (forall a. c (Full a) -> b) -> Args c sig -> [b]
forall (c :: * -> *) b sig.
(forall a. c (Full a) -> b) -> Args c sig -> [b]
listArgs forall a. c (Full a) -> b
f Args c sig
as

-- | Map a function over an 'Args' list
mapArgs
    :: (forall a   . c1 (Full a) -> c2 (Full a))
    -> (forall sig . Args c1 sig -> Args c2 sig)
mapArgs :: (forall a. c1 (Full a) -> c2 (Full a))
-> forall sig. Args c1 sig -> Args c2 sig
mapArgs forall a. c1 (Full a) -> c2 (Full a)
f Args c1 sig
Nil       = Args c2 sig
forall (c :: * -> *) a. Args c (Full a)
Nil
mapArgs forall a. c1 (Full a) -> c2 (Full a)
f (c1 (Full a)
a :* Args c1 sig
as) = c1 (Full a) -> c2 (Full a)
forall a. c1 (Full a) -> c2 (Full a)
f c1 (Full a)
a c2 (Full a) -> Args c2 sig -> Args c2 (a :-> sig)
forall (c :: * -> *) a sig.
c (Full a) -> Args c sig -> Args c (a :-> sig)
:* (forall a. c1 (Full a) -> c2 (Full a))
-> Args c1 sig -> Args c2 sig
forall (c1 :: * -> *) (c2 :: * -> *).
(forall a. c1 (Full a) -> c2 (Full a))
-> forall sig. Args c1 sig -> Args c2 sig
mapArgs forall a. c1 (Full a) -> c2 (Full a)
f Args c1 sig
as

-- | Map an applicative function over an 'Args' list
mapArgsA :: Applicative f
    => (forall a   . c1 (Full a) -> f (c2 (Full a)))
    -> (forall sig . Args c1 sig -> f (Args c2 sig))
mapArgsA :: (forall a. c1 (Full a) -> f (c2 (Full a)))
-> forall sig. Args c1 sig -> f (Args c2 sig)
mapArgsA forall a. c1 (Full a) -> f (c2 (Full a))
f Args c1 sig
Nil       = Args c2 (Full a) -> f (Args c2 (Full a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Args c2 (Full a)
forall (c :: * -> *) a. Args c (Full a)
Nil
mapArgsA forall a. c1 (Full a) -> f (c2 (Full a))
f (c1 (Full a)
a :* Args c1 sig
as) = c2 (Full a) -> Args c2 sig -> Args c2 (a :-> sig)
forall (c :: * -> *) a sig.
c (Full a) -> Args c sig -> Args c (a :-> sig)
(:*) (c2 (Full a) -> Args c2 sig -> Args c2 (a :-> sig))
-> f (c2 (Full a)) -> f (Args c2 sig -> Args c2 (a :-> sig))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c1 (Full a) -> f (c2 (Full a))
forall a. c1 (Full a) -> f (c2 (Full a))
f c1 (Full a)
a f (Args c2 sig -> Args c2 (a :-> sig))
-> f (Args c2 sig) -> f (Args c2 (a :-> sig))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. c1 (Full a) -> f (c2 (Full a)))
-> Args c1 sig -> f (Args c2 sig)
forall (f :: * -> *) (c1 :: * -> *) (c2 :: * -> *).
Applicative f =>
(forall a. c1 (Full a) -> f (c2 (Full a)))
-> forall sig. Args c1 sig -> f (Args c2 sig)
mapArgsA forall a. c1 (Full a) -> f (c2 (Full a))
f Args c1 sig
as

-- | Map a monadic function over an 'Args' list
mapArgsM :: Monad m
    => (forall a   . c1 (Full a) -> m (c2 (Full a)))
    -> (forall sig . Args c1 sig -> m (Args c2 sig))
mapArgsM :: (forall a. c1 (Full a) -> m (c2 (Full a)))
-> forall sig. Args c1 sig -> m (Args c2 sig)
mapArgsM forall a. c1 (Full a) -> m (c2 (Full a))
f = WrappedMonad m (Args c2 sig) -> m (Args c2 sig)
forall (m :: * -> *) a. WrappedMonad m a -> m a
unwrapMonad (WrappedMonad m (Args c2 sig) -> m (Args c2 sig))
-> (Args c1 sig -> WrappedMonad m (Args c2 sig))
-> Args c1 sig
-> m (Args c2 sig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. c1 (Full a) -> WrappedMonad m (c2 (Full a)))
-> forall sig. Args c1 sig -> WrappedMonad m (Args c2 sig)
forall (f :: * -> *) (c1 :: * -> *) (c2 :: * -> *).
Applicative f =>
(forall a. c1 (Full a) -> f (c2 (Full a)))
-> forall sig. Args c1 sig -> f (Args c2 sig)
mapArgsA (m (c2 (Full a)) -> WrappedMonad m (c2 (Full a))
forall (m :: * -> *) a. m a -> WrappedMonad m a
WrapMonad (m (c2 (Full a)) -> WrappedMonad m (c2 (Full a)))
-> (c1 (Full a) -> m (c2 (Full a)))
-> c1 (Full a)
-> WrappedMonad m (c2 (Full a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c1 (Full a) -> m (c2 (Full a))
forall a. c1 (Full a) -> m (c2 (Full a))
f)

-- | Right fold for an 'Args' list
foldrArgs
    :: (forall a . c (Full a) -> b -> b)
    -> b
    -> (forall sig . Args c sig -> b)
foldrArgs :: (forall a. c (Full a) -> b -> b)
-> b -> forall sig. Args c sig -> b
foldrArgs forall a. c (Full a) -> b -> b
f b
b Args c sig
Nil       = b
b
foldrArgs forall a. c (Full a) -> b -> b
f b
b (c (Full a)
a :* Args c sig
as) = c (Full a) -> b -> b
forall a. c (Full a) -> b -> b
f c (Full a)
a ((forall a. c (Full a) -> b -> b) -> b -> Args c sig -> b
forall (c :: * -> *) b.
(forall a. c (Full a) -> b -> b)
-> b -> forall sig. Args c sig -> b
foldrArgs forall a. c (Full a) -> b -> b
f b
b Args c sig
as)

-- | Apply a (partially applied) symbol to a list of argument terms
appArgs :: AST sym sig -> Args (AST sym) sig -> ASTF sym (DenResult sig)
appArgs :: AST sym sig -> Args (AST sym) sig -> ASTF sym (DenResult sig)
appArgs AST sym sig
a Args (AST sym) sig
Nil       = AST sym sig
ASTF sym (DenResult sig)
a
appArgs AST sym sig
s (AST sym (Full a)
a :* Args (AST sym) sig
as) = AST sym sig -> Args (AST sym) sig -> ASTF sym (DenResult sig)
forall (sym :: * -> *) sig.
AST sym sig -> Args (AST sym) sig -> ASTF sym (DenResult sig)
appArgs (AST sym sig
AST sym (a :-> sig)
s AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig
forall (sym :: * -> *) a sig.
AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig
:$ AST sym (Full a)
a) Args (AST sym) sig
as

-- | \"Pattern match\" on an 'AST' using a function that gets direct access to
-- the top-most symbol and its sub-trees
match :: forall sym a c
    .  ( forall sig . (a ~ DenResult sig) =>
           sym sig -> Args (AST sym) sig -> c (Full a)
       )
    -> ASTF sym a
    -> c (Full a)
match :: (forall sig.
 (a ~ DenResult sig) =>
 sym sig -> Args (AST sym) sig -> c (Full a))
-> ASTF sym a -> c (Full a)
match forall sig.
(a ~ DenResult sig) =>
sym sig -> Args (AST sym) sig -> c (Full a)
f ASTF sym a
a = ASTF sym a -> Args (AST sym) (Full a) -> c (Full a)
forall sig.
(a ~ DenResult sig) =>
AST sym sig -> Args (AST sym) sig -> c (Full a)
go ASTF sym a
a Args (AST sym) (Full a)
forall (c :: * -> *) a. Args c (Full a)
Nil
  where
    go :: (a ~ DenResult sig) => AST sym sig -> Args (AST sym) sig -> c (Full a)
    go :: AST sym sig -> Args (AST sym) sig -> c (Full a)
go (Sym sym sig
a)  Args (AST sym) sig
as = sym sig -> Args (AST sym) sig -> c (Full a)
forall sig.
(a ~ DenResult sig) =>
sym sig -> Args (AST sym) sig -> c (Full a)
f sym sig
a Args (AST sym) sig
as
    go (AST sym (a :-> sig)
s :$ AST sym (Full a)
a) Args (AST sym) sig
as = AST sym (a :-> sig) -> Args (AST sym) (a :-> sig) -> c (Full a)
forall sig.
(a ~ DenResult sig) =>
AST sym sig -> Args (AST sym) sig -> c (Full a)
go AST sym (a :-> sig)
s (AST sym (Full a)
a AST sym (Full a)
-> Args (AST sym) sig -> Args (AST sym) (a :-> sig)
forall (c :: * -> *) a sig.
c (Full a) -> Args c sig -> Args c (a :-> sig)
:* Args (AST sym) sig
as)

-- | A version of 'match' with a simpler result type
simpleMatch :: forall sym a b
    .  (forall sig . (a ~ DenResult sig) => sym sig -> Args (AST sym) sig -> b)
    -> ASTF sym a
    -> b
simpleMatch :: (forall sig.
 (a ~ DenResult sig) =>
 sym sig -> Args (AST sym) sig -> b)
-> ASTF sym a -> b
simpleMatch forall sig.
(a ~ DenResult sig) =>
sym sig -> Args (AST sym) sig -> b
f = Const b (Full a) -> b
forall a k (b :: k). Const a b -> a
getConst (Const b (Full a) -> b)
-> (ASTF sym a -> Const b (Full a)) -> ASTF sym a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall sig.
 (a ~ DenResult sig) =>
 sym sig -> Args (AST sym) sig -> Const b (Full a))
-> ASTF sym a -> Const b (Full a)
forall (sym :: * -> *) a (c :: * -> *).
(forall sig.
 (a ~ DenResult sig) =>
 sym sig -> Args (AST sym) sig -> c (Full a))
-> ASTF sym a -> c (Full a)
match (\sym sig
s -> b -> Const b (Full a)
forall k a (b :: k). a -> Const a b
Const (b -> Const b (Full a))
-> (Args (AST sym) sig -> b)
-> Args (AST sym) sig
-> Const b (Full a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sym sig -> Args (AST sym) sig -> b
forall sig.
(a ~ DenResult sig) =>
sym sig -> Args (AST sym) sig -> b
f sym sig
s)

-- | Fold an 'AST' using an 'Args' list to hold the results of sub-terms
fold :: forall sym c
    .  (forall sig . sym sig -> Args c sig -> c (Full (DenResult sig)))
    -> (forall a   . ASTF sym a -> c (Full a))
fold :: (forall sig. sym sig -> Args c sig -> c (Full (DenResult sig)))
-> forall a. ASTF sym a -> c (Full a)
fold forall sig. sym sig -> Args c sig -> c (Full (DenResult sig))
f = (forall sig.
 (a ~ DenResult sig) =>
 sym sig -> Args (AST sym) sig -> c (Full a))
-> ASTF sym a -> c (Full a)
forall (sym :: * -> *) a (c :: * -> *).
(forall sig.
 (a ~ DenResult sig) =>
 sym sig -> Args (AST sym) sig -> c (Full a))
-> ASTF sym a -> c (Full a)
match (\sym sig
s -> sym sig -> Args c sig -> c (Full (DenResult sig))
forall sig. sym sig -> Args c sig -> c (Full (DenResult sig))
f sym sig
s (Args c sig -> c (Full a))
-> (Args (AST sym) sig -> Args c sig)
-> Args (AST sym) sig
-> c (Full a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. ASTF sym a -> c (Full a))
-> forall sig. Args (AST sym) sig -> Args c sig
forall (c1 :: * -> *) (c2 :: * -> *).
(forall a. c1 (Full a) -> c2 (Full a))
-> forall sig. Args c1 sig -> Args c2 sig
mapArgs ((forall sig. sym sig -> Args c sig -> c (Full (DenResult sig)))
-> forall a. ASTF sym a -> c (Full a)
forall (sym :: * -> *) (c :: * -> *).
(forall sig. sym sig -> Args c sig -> c (Full (DenResult sig)))
-> forall a. ASTF sym a -> c (Full a)
fold forall sig. sym sig -> Args c sig -> c (Full (DenResult sig))
f))

-- | Simplified version of 'fold' for situations where all intermediate results
-- have the same type
simpleFold :: forall sym b
    .  (forall sig . sym sig -> Args (Const b) sig -> b)
    -> (forall a   . ASTF sym a                    -> b)
simpleFold :: (forall sig. sym sig -> Args (Const b) sig -> b)
-> forall a. ASTF sym a -> b
simpleFold forall sig. sym sig -> Args (Const b) sig -> b
f = Const b (Full a) -> b
forall a k (b :: k). Const a b -> a
getConst (Const b (Full a) -> b)
-> (ASTF sym a -> Const b (Full a)) -> ASTF sym a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall sig.
 sym sig -> Args (Const b) sig -> Const b (Full (DenResult sig)))
-> forall a. ASTF sym a -> Const b (Full a)
forall (sym :: * -> *) (c :: * -> *).
(forall sig. sym sig -> Args c sig -> c (Full (DenResult sig)))
-> forall a. ASTF sym a -> c (Full a)
fold (\sym sig
s -> b -> Const b (Full (DenResult sig))
forall k a (b :: k). a -> Const a b
Const (b -> Const b (Full (DenResult sig)))
-> (Args (Const b) sig -> b)
-> Args (Const b) sig
-> Const b (Full (DenResult sig))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sym sig -> Args (Const b) sig -> b
forall sig. sym sig -> Args (Const b) sig -> b
f sym sig
s)

-- | Fold an 'AST' using a list to hold the results of sub-terms
listFold :: forall sym b
    .  (forall sig . sym sig -> [b] -> b)
    -> (forall a   . ASTF sym a     -> b)
listFold :: (forall sig. sym sig -> [b] -> b) -> forall a. ASTF sym a -> b
listFold forall sig. sym sig -> [b] -> b
f = (forall sig. sym sig -> Args (Const b) sig -> b)
-> forall a. ASTF sym a -> b
forall (sym :: * -> *) b.
(forall sig. sym sig -> Args (Const b) sig -> b)
-> forall a. ASTF sym a -> b
simpleFold (\sym sig
s -> sym sig -> [b] -> b
forall sig. sym sig -> [b] -> b
f sym sig
s ([b] -> b)
-> (Args (Const b) sig -> [b]) -> Args (Const b) sig -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Const b (Full a) -> b) -> Args (Const b) sig -> [b]
forall (c :: * -> *) b sig.
(forall a. c (Full a) -> b) -> Args c sig -> [b]
listArgs forall a. Const b (Full a) -> b
forall a k (b :: k). Const a b -> a
getConst)

newtype WrapAST c sym sig = WrapAST { WrapAST c sym sig -> c (AST sym sig)
unWrapAST :: c (AST sym sig) }
  -- Only used in the definition of 'matchTrans'

-- | A version of 'match' where the result is a transformed syntax tree,
-- wrapped in a type constructor @c@
matchTrans :: forall sym sym' c a
    .  ( forall sig . (a ~ DenResult sig) =>
           sym sig -> Args (AST sym) sig -> c (ASTF sym' a)
       )
    -> ASTF sym a
    -> c (ASTF sym' a)
matchTrans :: (forall sig.
 (a ~ DenResult sig) =>
 sym sig -> Args (AST sym) sig -> c (ASTF sym' a))
-> ASTF sym a -> c (ASTF sym' a)
matchTrans forall sig.
(a ~ DenResult sig) =>
sym sig -> Args (AST sym) sig -> c (ASTF sym' a)
f = WrapAST c sym' (Full a) -> c (ASTF sym' a)
forall (c :: * -> *) (sym :: * -> *) sig.
WrapAST c sym sig -> c (AST sym sig)
unWrapAST (WrapAST c sym' (Full a) -> c (ASTF sym' a))
-> (ASTF sym a -> WrapAST c sym' (Full a))
-> ASTF sym a
-> c (ASTF sym' a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall sig.
 (a ~ DenResult sig) =>
 sym sig -> Args (AST sym) sig -> WrapAST c sym' (Full a))
-> ASTF sym a -> WrapAST c sym' (Full a)
forall (sym :: * -> *) a (c :: * -> *).
(forall sig.
 (a ~ DenResult sig) =>
 sym sig -> Args (AST sym) sig -> c (Full a))
-> ASTF sym a -> c (Full a)
match (\sym sig
s -> c (ASTF sym' a) -> WrapAST c sym' (Full a)
forall (c :: * -> *) (sym :: * -> *) sig.
c (AST sym sig) -> WrapAST c sym sig
WrapAST (c (ASTF sym' a) -> WrapAST c sym' (Full a))
-> (Args (AST sym) sig -> c (ASTF sym' a))
-> Args (AST sym) sig
-> WrapAST c sym' (Full a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sym sig -> Args (AST sym) sig -> c (ASTF sym' a)
forall sig.
(a ~ DenResult sig) =>
sym sig -> Args (AST sym) sig -> c (ASTF sym' a)
f sym sig
s)

-- | Update the symbols in an AST
mapAST :: (forall sig' . sym1 sig' -> sym2 sig') -> AST sym1 sig -> AST sym2 sig
mapAST :: (forall sig'. sym1 sig' -> sym2 sig')
-> AST sym1 sig -> AST sym2 sig
mapAST forall sig'. sym1 sig' -> sym2 sig'
f (Sym sym1 sig
s)  = sym2 sig -> AST sym2 sig
forall (sym :: * -> *) sig. sym sig -> AST sym sig
Sym (sym1 sig -> sym2 sig
forall sig'. sym1 sig' -> sym2 sig'
f sym1 sig
s)
mapAST forall sig'. sym1 sig' -> sym2 sig'
f (AST sym1 (a :-> sig)
s :$ AST sym1 (Full a)
a) = (forall sig'. sym1 sig' -> sym2 sig')
-> AST sym1 (a :-> sig) -> AST sym2 (a :-> sig)
forall (sym1 :: * -> *) (sym2 :: * -> *) sig.
(forall sig'. sym1 sig' -> sym2 sig')
-> AST sym1 sig -> AST sym2 sig
mapAST forall sig'. sym1 sig' -> sym2 sig'
f AST sym1 (a :-> sig)
s AST sym2 (a :-> sig) -> AST sym2 (Full a) -> AST sym2 sig
forall (sym :: * -> *) a sig.
AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig
:$ (forall sig'. sym1 sig' -> sym2 sig')
-> AST sym1 (Full a) -> AST sym2 (Full a)
forall (sym1 :: * -> *) (sym2 :: * -> *) sig.
(forall sig'. sym1 sig' -> sym2 sig')
-> AST sym1 sig -> AST sym2 sig
mapAST forall sig'. sym1 sig' -> sym2 sig'
f AST sym1 (Full a)
a

-- | Can be used to make an arbitrary type constructor indexed by @(`Full` a)@.
-- This is useful as the type constructor parameter of 'Args'. That is, use
--
-- > Args (WrapFull c) ...
--
-- instead of
--
-- > Args c ...
--
-- if @c@ is not indexed by @(`Full` a)@.
data WrapFull c a
  where
    WrapFull :: { WrapFull c (Full a) -> c a
unwrapFull :: c a } -> WrapFull c (Full a)

-- | Convert an 'AST' to a 'Tree'
toTree :: forall dom a b . (forall sig . dom sig -> b) -> ASTF dom a -> Tree b
toTree :: (forall sig. dom sig -> b) -> ASTF dom a -> Tree b
toTree forall sig. dom sig -> b
f = (forall sig. dom sig -> [Tree b] -> Tree b)
-> forall a. ASTF dom a -> Tree b
forall (sym :: * -> *) b.
(forall sig. sym sig -> [b] -> b) -> forall a. ASTF sym a -> b
listFold (b -> [Tree b] -> Tree b
forall a. a -> Forest a -> Tree a
Node (b -> [Tree b] -> Tree b)
-> (dom sig -> b) -> dom sig -> [Tree b] -> Tree b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. dom sig -> b
forall sig. dom sig -> b
f)