{-|
  Copyright  :  (C) 2026, QBayLogic B.V.
  License    :  BSD2 (see the file LICENSE)
  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>

  Compile a "Clash.Rewrite.StrategyDSL" strategy into executable dispatch
  code. 'compileStrategy' produces the fused fast path: one constructor match
  per node drives both the dispatch of the node program and the descent into
  the node's children.
-}

{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

module Clash.Rewrite.StrategyDSL.TH
  ( compileStrategy
  , compileStrategyReference
  , dispatchQ
  , asRewriteQ
  ) where

import Data.Char (isAlphaNum)
import Data.Foldable (traverse_)
import Data.List (tails)
import Language.Haskell.TH hiding (Prim)

import Clash.Core.Term
  (Bind (..), CoreContext (..), Term (..), bindToList, patIds, primArg)
import Clash.Core.VarEnv (extendInScopeSet, extendInScopeSetList)
import Clash.Rewrite.StrategyDSL
  ( Constructor (..), Step (..), Strat (..), Transformation (..)
  , TransformationWorker (..)
  )
import Clash.Rewrite.Types (TransformContext (..))
import Clash.Rewrite.Util (apply, applyWith)

import qualified Clash.Rewrite.Combinators as Comb
import qualified Control.Monad as Monad
import qualified Control.Monad.Writer as Writer
import qualified Data.Monoid as Monoid

-- | The term constructor belonging to a 'Constructor'.
constructorName :: Constructor -> Name
constructorName :: Constructor -> Name
constructorName Constructor
con = case Constructor
con of
  Constructor
CVar -> 'Var
  Constructor
CData -> 'Data
  Constructor
CLiteral -> 'Literal
  Constructor
CPrim -> 'Prim
  Constructor
CLam -> 'Lam
  Constructor
CTyLam -> 'TyLam
  Constructor
CApp -> 'App
  Constructor
CTyApp -> 'TyApp
  Constructor
CLet -> 'Let
  Constructor
CCase -> 'Case
  Constructor
CCast -> 'Cast
  Constructor
CTick -> 'Tick

-- | Binder hints for a constructor's fields. Underscore-prefixed because not
-- every generated arm uses every field.
constructorFieldHints :: Constructor -> [String]
constructorFieldHints :: Constructor -> [String]
constructorFieldHints Constructor
con = case Constructor
con of
  Constructor
CVar -> [String
"_i"]
  Constructor
CData -> [String
"_dc"]
  Constructor
CLiteral -> [String
"_lit"]
  Constructor
CPrim -> [String
"_p"]
  Constructor
CLam -> [String
"_v", String
"_e"]
  Constructor
CTyLam -> [String
"_tv", String
"_e"]
  Constructor
CApp -> [String
"_fun", String
"_arg"]
  Constructor
CTyApp -> [String
"_fun", String
"_argTy"]
  Constructor
CLet -> [String
"_bnd", String
"_body"]
  Constructor
CCase -> [String
"_subj", String
"_altsTy", String
"_alts"]
  Constructor
CCast -> [String
"_e", String
"_fromTy", String
"_toTy"]
  Constructor
CTick -> [String
"_tick", String
"_e"]

constructorFieldNames :: Constructor -> Q [Name]
constructorFieldNames :: Constructor -> Q [Name]
constructorFieldNames = (String -> Q Name) -> [String] -> Q [Name]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName ([String] -> Q [Name])
-> (Constructor -> [String]) -> Constructor -> Q [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constructor -> [String]
constructorFieldHints

allConstructors :: [Constructor]
allConstructors :: [Constructor]
allConstructors = [Constructor
forall a. Bounded a => a
minBound .. Constructor
forall a. Bounded a => a
maxBound]

-- | Constructors whose nodes have no subterms to descend into.
isLeafConstructor :: Constructor -> Bool
isLeafConstructor :: Constructor -> Bool
isLeafConstructor Constructor
con = Constructor
con Constructor -> [Constructor] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Constructor
CVar, Constructor
CData, Constructor
CLiteral, Constructor
CPrim]

-- | How a bucket member is invoked once the constructor has matched.
data Invoke
  = InvokeFields Name -- ^ worker applied to ctx, node, and the node's fields
  | InvokeNode Name   -- ^ worker applied to ctx and the node only

-- | The member's invocation at this constructor, if it is in the
-- constructor's bucket.
invokeAt :: Constructor -> Transformation -> Maybe Invoke
invokeAt :: Constructor -> Transformation -> Maybe Invoke
invokeAt Constructor
con Transformation
transformation = [TransformationWorker] -> Maybe Invoke
go Transformation
transformation.workers
 where
  go :: [TransformationWorker] -> Maybe Invoke
go [] = Maybe Invoke
forall a. Maybe a
Nothing
  go (FieldWorker Constructor
con' Name
worker : [TransformationWorker]
rest)
    | Constructor
con' Constructor -> Constructor -> Bool
forall a. Eq a => a -> a -> Bool
== Constructor
con = Invoke -> Maybe Invoke
forall a. a -> Maybe a
Just (Name -> Invoke
InvokeFields Name
worker)
    | Bool
otherwise = [TransformationWorker] -> Maybe Invoke
go [TransformationWorker]
rest
  go (Worker Constructor
con' Name
worker : [TransformationWorker]
rest)
    | Constructor
con' Constructor -> Constructor -> Bool
forall a. Eq a => a -> a -> Bool
== Constructor
con = Invoke -> Maybe Invoke
forall a. a -> Maybe a
Just (Name -> Invoke
InvokeNode Name
worker)
    | Bool
otherwise = [TransformationWorker] -> Maybe Invoke
go [TransformationWorker]
rest
  go (AnyWorker Name
worker : [TransformationWorker]
_) = Invoke -> Maybe Invoke
forall a. a -> Maybe a
Just (Name -> Invoke
InvokeNode Name
worker)

invokeE :: Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp
invokeE :: Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp
invokeE (InvokeFields Name
worker) Q Exp
ctxE Q Exp
nodeE [Q Exp]
fieldEs =
  (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: Type -> Type). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
worker) (Q Exp
ctxE Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: Q Exp
nodeE Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [Q Exp]
fieldEs)
invokeE (InvokeNode Name
worker) Q Exp
ctxE Q Exp
nodeE [Q Exp]
_fieldEs =
  [| $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
worker) $Q Exp
ctxE $Q Exp
nodeE |]

validateChain :: [Transformation] -> Q ()
validateChain :: [Transformation] -> Q ()
validateChain [Transformation]
members = do
  Bool -> Q () -> Q ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
Monad.when ([Transformation] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Transformation]
members) (String -> Q ()
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"compileStrategy: empty chain")
  case [String
name | String
name : [String]
rest <- [String] -> [[String]]
forall a. [a] -> [[a]]
tails ((Transformation -> String) -> [Transformation] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (.name) [Transformation]
members), String
name String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [String]
rest] of
    String
name : [String]
_ ->
      String -> Q ()
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"compileStrategy: duplicate transformation name in one chain: "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (alias one occurrence with 'named')")
    [] -> () -> Q ()
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
  (Transformation -> Q ()) -> [Transformation] -> Q ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Transformation -> Q ()
validateTransformation [Transformation]
members

-- | A transformation's worker table must be non-empty, register at most one
-- worker per constructor, and not mix 'AnyWorker' with per-constructor
-- workers: a transformation either fires at any constructor or at specific
-- ones, never both.
validateTransformation :: Transformation -> Q ()
validateTransformation :: Transformation -> Q ()
validateTransformation Transformation
transformation
  | [TransformationWorker] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [TransformationWorker]
workers = String -> Q ()
forall {m :: Type -> Type} {a}. MonadFail m => String -> m a
failWith String
"declares no workers"
  | (TransformationWorker -> Bool) -> [TransformationWorker] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any TransformationWorker -> Bool
isAnyWorker [TransformationWorker]
workers, (TransformationWorker -> Bool) -> [TransformationWorker] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool)
-> (TransformationWorker -> Bool) -> TransformationWorker -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransformationWorker -> Bool
isAnyWorker) [TransformationWorker]
workers
  = String -> Q ()
forall {m :: Type -> Type} {a}. MonadFail m => String -> m a
failWith String
"mixes AnyWorker with per-constructor workers"
  | [TransformationWorker] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length ((TransformationWorker -> Bool)
-> [TransformationWorker] -> [TransformationWorker]
forall a. (a -> Bool) -> [a] -> [a]
filter TransformationWorker -> Bool
isAnyWorker [TransformationWorker]
workers) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = String -> Q ()
forall {m :: Type -> Type} {a}. MonadFail m => String -> m a
failWith String
"has a duplicate AnyWorker"
  | Constructor
con : [Constructor]
_ <- [Constructor]
duplicateConstructors = String -> Q ()
forall {m :: Type -> Type} {a}. MonadFail m => String -> m a
failWith (String
"has two workers for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Constructor -> String
forall a. Show a => a -> String
show Constructor
con)
  | Bool
otherwise = () -> Q ()
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
 where
  workers :: [TransformationWorker]
workers = Transformation
transformation.workers

  failWith :: String -> m a
failWith String
reason =
    String -> m a
forall a. String -> m a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"compileStrategy: transformation " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show Transformation
transformation.name
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
reason)

  isAnyWorker :: TransformationWorker -> Bool
isAnyWorker AnyWorker{} = Bool
True
  isAnyWorker TransformationWorker
_ = Bool
False

  duplicateConstructors :: [Constructor]
duplicateConstructors =
    [ Constructor
con
    | Constructor
con : [Constructor]
rest <- [Constructor] -> [[Constructor]]
forall a. [a] -> [[a]]
tails [Constructor
c | Just Constructor
c <- (TransformationWorker -> Maybe Constructor)
-> [TransformationWorker] -> [Maybe Constructor]
forall a b. (a -> b) -> [a] -> [b]
map TransformationWorker -> Maybe Constructor
workerConstructor [TransformationWorker]
workers]
    , Constructor
con Constructor -> [Constructor] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Constructor]
rest
    ]

  workerConstructor :: TransformationWorker -> Maybe Constructor
workerConstructor (FieldWorker Constructor
con Name
_) = Constructor -> Maybe Constructor
forall a. a -> Maybe a
Just Constructor
con
  workerConstructor (Worker Constructor
con Name
_) = Constructor -> Maybe Constructor
forall a. a -> Maybe a
Just Constructor
con
  workerConstructor (AnyWorker Name
_) = Maybe Constructor
forall a. Maybe a
Nothing

-- | Bind the result and change flag of an action:
-- @do { (t, w) <- Writer.listen action; \<continue t (getAny w)\> }@
withListen :: Q Exp -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
withListen :: Q Exp -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
withListen Q Exp
action Q Exp -> Q Exp -> Q Exp
continue = do
  Name
t <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"t"
  Name
w <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"w"
  [Q Stmt] -> Q Exp
forall (m :: Type -> Type). Quote m => [m Stmt] -> m Exp
doE
    [ Q Pat -> Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Pat -> m Exp -> m Stmt
bindS ([Q Pat] -> Q Pat
forall (m :: Type -> Type). Quote m => [m Pat] -> m Pat
tupP [Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
t, Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
w]) [| Writer.listen $Q Exp
action |]
    , Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Exp -> m Stmt
noBindS (Q Exp -> Q Exp -> Q Exp
continue (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
t) [| Monoid.getAny $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
w) |])
    ]

-- | Bind an expression so a continuation can use it more than once.
bindTo :: String -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
bindTo :: String -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
bindTo String
hint Q Exp
bound Q Exp -> Q Exp
continue = do
  Name
x <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
hint
  [Q Dec] -> Q Exp -> Q Exp
forall (m :: Type -> Type). Quote m => [m Dec] -> m Exp -> m Exp
letE [Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: Type -> Type).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
x) (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB Q Exp
bound) []] (Q Exp -> Q Exp
continue (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
x))

-- | A fresh name for a generated let-binding, derived from a transformation
-- name. Underscore-prefixed: not every generated binding ends up used.
freshBinding :: String -> Q Name
freshBinding :: String -> Q Name
freshBinding String
hint = String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName (Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
sanitize String
hint)
 where
  sanitize :: Char -> Char
sanitize Char
c = if Char -> Bool
isAlphaNum Char
c then Char
c else Char
'_'

-- | @\\ctx tm -> case tm of { \<arm per constructor with a program\>;
-- _ -> pure tm }@
-- The wildcard is omitted when every constructor has an arm.
nodeCaseExp
  :: (Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)) -> Q Exp
nodeCaseExp :: (Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp))
-> Q Exp
nodeCaseExp Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
armFor = do
  Name
ctx <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"ctx"
  Name
tm <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"tm"
  let arms :: [Q Match]
arms =
        [ do [Name]
fieldNames <- Constructor -> Q [Name]
constructorFieldNames Constructor
con
             Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: Type -> Type).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> [m Pat] -> m Pat
conP (Constructor -> Name
constructorName Constructor
con) ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP [Name]
fieldNames))
                   (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Exp -> [Q Exp] -> Q Exp
armBody (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
ctx) (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
tm) ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE [Name]
fieldNames)))
                   []
        | Constructor
con <- [Constructor]
allConstructors
        , Just Q Exp -> Q Exp -> [Q Exp] -> Q Exp
armBody <- [Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
armFor Constructor
con]
        ]
      fallthrough :: [Q Match]
fallthrough
        | [Q Match] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Q Match]
arms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Constructor] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Constructor]
allConstructors = []
        | Bool
otherwise = [Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: Type -> Type).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
forall (m :: Type -> Type). Quote m => m Pat
wildP (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB [| pure $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
tm) |]) []]
  [Q Pat] -> Q Exp -> Q Exp
forall (m :: Type -> Type). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
ctx, Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
tm] (Q Exp -> [Q Match] -> Q Exp
forall (m :: Type -> Type). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
tm) ([Q Match]
arms [Q Match] -> [Q Match] -> [Q Match]
forall a. Semigroup a => a -> a -> a
<> [Q Match]
fallthrough))

-- | A compiled node program. 'known' is the program entered with the
-- node's constructor statically known and its fields in scope; 'Nothing'
-- means the program is the identity at that constructor. 'dispatch'
-- references a generated binding running the program on a term of unknown
-- constructor.
data CompiledStep = CompiledStep
  { CompiledStep -> [Q Dec]
decs :: [Q Dec]
  , CompiledStep
-> Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
known :: Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
  , CompiledStep -> Q Exp
dispatch :: Q Exp
  }

compileStep :: Step -> Q CompiledStep
compileStep :: Step -> Q CompiledStep
compileStep Step
step = case Step
step of
  Chain [Transformation]
members -> [Transformation] -> Q CompiledStep
compileChain [Transformation]
members
  SeqS Step
a Step
b -> Step
-> Step
-> (CompiledStep
    -> CompiledStep
    -> Constructor
    -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp))
-> (CompiledStep -> CompiledStep -> Q Exp)
-> Q CompiledStep
compileStep2 Step
a Step
b CompiledStep
-> CompiledStep
-> Constructor
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
seqKnown CompiledStep -> CompiledStep -> Q Exp
seqDispatch
  OnChangeS Step
a Step
b -> Step
-> Step
-> (CompiledStep
    -> CompiledStep
    -> Constructor
    -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp))
-> (CompiledStep -> CompiledStep -> Q Exp)
-> Q CompiledStep
compileStep2 Step
a Step
b CompiledStep
-> CompiledStep
-> Constructor
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
onChangeKnown (Q Exp -> CompiledStep -> CompiledStep -> Q Exp
combinatorDispatch [| (Comb.!->) |])
  OnNoChangeS Step
a Step
b -> Step
-> Step
-> (CompiledStep
    -> CompiledStep
    -> Constructor
    -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp))
-> (CompiledStep -> CompiledStep -> Q Exp)
-> Q CompiledStep
compileStep2 Step
a Step
b CompiledStep
-> CompiledStep
-> Constructor
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
onNoChangeKnown (Q Exp -> CompiledStep -> CompiledStep -> Q Exp
combinatorDispatch [| (Comb.>-!) |])

  EmbedS Strat
strat -> do
    Name
embedded <- String -> Q Name
freshBinding String
"embedded"
    let dec :: Q Dec
dec = Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: Type -> Type).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
embedded) (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB (Strat -> Q Exp
compileStrategy Strat
strat)) []
    CompiledStep -> Q CompiledStep
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure CompiledStep
      { $sel:decs:CompiledStep :: [Q Dec]
decs = [Q Dec
dec]
      , $sel:known:CompiledStep :: Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
known = \Constructor
_con ->
          (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall a. a -> Maybe a
Just (\Q Exp
ctxE Q Exp
nodeE [Q Exp]
_fieldEs -> [| $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
embedded) $Q Exp
ctxE $Q Exp
nodeE |])
      , $sel:dispatch:CompiledStep :: Q Exp
dispatch = Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
embedded
      }
 where
  -- These need signatures: without them the record selectors below are
  -- inferred as 'HasField' constraints rather than resolved against
  -- 'CompiledStep'.
  seqKnown, onChangeKnown, onNoChangeKnown
    :: CompiledStep -> CompiledStep -> Constructor
    -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
  seqDispatch :: CompiledStep -> CompiledStep -> Q Exp
  combinatorDispatch :: Q Exp -> CompiledStep -> CompiledStep -> Q Exp
  compileStep2
    :: Step -> Step
    -> (CompiledStep -> CompiledStep -> Constructor
        -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp))
    -> (CompiledStep -> CompiledStep -> Q Exp)
    -> Q CompiledStep

  seqKnown :: CompiledStep
-> CompiledStep
-> Constructor
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
seqKnown CompiledStep
ca CompiledStep
cb Constructor
con = case (CompiledStep
ca.known Constructor
con, CompiledStep
cb.known Constructor
con) of
    (Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
Nothing, Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
Nothing) -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall a. Maybe a
Nothing
    (Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
Nothing, Just Q Exp -> Q Exp -> [Q Exp] -> Q Exp
kb) -> (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall a. a -> Maybe a
Just Q Exp -> Q Exp -> [Q Exp] -> Q Exp
kb
    (Just Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka, Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
Nothing) -> (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall a. a -> Maybe a
Just ((Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
 -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp))
-> (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall a b. (a -> b) -> a -> b
$ \Q Exp
ctxE Q Exp
nodeE [Q Exp]
fieldEs ->
      Q Exp -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
withListen (Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka Q Exp
ctxE Q Exp
nodeE [Q Exp]
fieldEs) ((Q Exp -> Q Exp -> Q Exp) -> Q Exp)
-> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
tE Q Exp
changedE ->
        Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: Type -> Type).
Quote m =>
m Exp -> m Exp -> m Exp -> m Exp
condE Q Exp
changedE [| $(CompiledStep
cb.dispatch) $Q Exp
ctxE $Q Exp
tE |] [| pure $Q Exp
tE |]
    (Just Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka, Just Q Exp -> Q Exp -> [Q Exp] -> Q Exp
kb) -> (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall a. a -> Maybe a
Just ((Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
 -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp))
-> (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall a b. (a -> b) -> a -> b
$ \Q Exp
ctxE Q Exp
nodeE [Q Exp]
fieldEs ->
      Q Exp -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
withListen (Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka Q Exp
ctxE Q Exp
nodeE [Q Exp]
fieldEs) ((Q Exp -> Q Exp -> Q Exp) -> Q Exp)
-> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
tE Q Exp
changedE ->
        -- When the left side did not signal change the term is untouched,
        -- so the right side can still run on the statically matched fields.
        Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: Type -> Type).
Quote m =>
m Exp -> m Exp -> m Exp -> m Exp
condE Q Exp
changedE [| $(CompiledStep
cb.dispatch) $Q Exp
ctxE $Q Exp
tE |] (Q Exp -> Q Exp -> [Q Exp] -> Q Exp
kb Q Exp
ctxE Q Exp
tE [Q Exp]
fieldEs)

  seqDispatch :: CompiledStep -> CompiledStep -> Q Exp
seqDispatch CompiledStep
ca CompiledStep
cb =
    [| \ctx tm -> $(CompiledStep
ca.dispatch) ctx tm >>= $(CompiledStep
cb.dispatch) ctx |]

  onChangeKnown :: CompiledStep
-> CompiledStep
-> Constructor
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
onChangeKnown CompiledStep
ca CompiledStep
cb Constructor
con = case CompiledStep
ca.known Constructor
con of
    Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
Nothing -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall a. Maybe a
Nothing
    Just Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka -> (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall a. a -> Maybe a
Just ((Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
 -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp))
-> (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall a b. (a -> b) -> a -> b
$ \Q Exp
ctxE Q Exp
nodeE [Q Exp]
fieldEs ->
      Q Exp -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
withListen (Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka Q Exp
ctxE Q Exp
nodeE [Q Exp]
fieldEs) ((Q Exp -> Q Exp -> Q Exp) -> Q Exp)
-> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
tE Q Exp
changedE ->
        Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: Type -> Type).
Quote m =>
m Exp -> m Exp -> m Exp -> m Exp
condE Q Exp
changedE [| $(CompiledStep
cb.dispatch) $Q Exp
ctxE $Q Exp
tE |] [| pure $Q Exp
tE |]

  onNoChangeKnown :: CompiledStep
-> CompiledStep
-> Constructor
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
onNoChangeKnown CompiledStep
ca CompiledStep
cb Constructor
con = case (CompiledStep
ca.known Constructor
con, CompiledStep
cb.known Constructor
con) of
    (Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
Nothing, Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
kb) -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
kb
    (Just Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka, Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
Nothing) -> (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall a. a -> Maybe a
Just Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka
    (Just Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka, Just Q Exp -> Q Exp -> [Q Exp] -> Q Exp
kb) -> (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall a. a -> Maybe a
Just ((Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
 -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp))
-> (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall a b. (a -> b) -> a -> b
$ \Q Exp
ctxE Q Exp
nodeE [Q Exp]
fieldEs ->
      Q Exp -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
withListen (Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka Q Exp
ctxE Q Exp
nodeE [Q Exp]
fieldEs) ((Q Exp -> Q Exp -> Q Exp) -> Q Exp)
-> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
tE Q Exp
changedE ->
        Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: Type -> Type).
Quote m =>
m Exp -> m Exp -> m Exp -> m Exp
condE Q Exp
changedE [| pure $Q Exp
tE |] (Q Exp -> Q Exp -> [Q Exp] -> Q Exp
kb Q Exp
ctxE Q Exp
tE [Q Exp]
fieldEs)

  combinatorDispatch :: Q Exp -> CompiledStep -> CompiledStep -> Q Exp
combinatorDispatch Q Exp
op CompiledStep
ca CompiledStep
cb = [| $Q Exp
op $(CompiledStep
ca.dispatch) $(CompiledStep
cb.dispatch) |]

  compileStep2 :: Step
-> Step
-> (CompiledStep
    -> CompiledStep
    -> Constructor
    -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp))
-> (CompiledStep -> CompiledStep -> Q Exp)
-> Q CompiledStep
compileStep2 Step
a Step
b CompiledStep
-> CompiledStep
-> Constructor
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
mkKnown CompiledStep -> CompiledStep -> Q Exp
mkDispatch = do
    CompiledStep
ca <- Step -> Q CompiledStep
compileStep Step
a
    CompiledStep
cb <- Step -> Q CompiledStep
compileStep Step
b
    Name
dispatch <- String -> Q Name
freshBinding String
"dispatch"
    let dispatchDec :: Q Dec
dispatchDec = Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: Type -> Type).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
dispatch) (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB (CompiledStep -> CompiledStep -> Q Exp
mkDispatch CompiledStep
ca CompiledStep
cb)) []
    CompiledStep -> Q CompiledStep
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure CompiledStep
      { $sel:decs:CompiledStep :: [Q Dec]
decs = CompiledStep
ca.decs [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. Semigroup a => a -> a -> a
<> CompiledStep
cb.decs [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. Semigroup a => a -> a -> a
<> [Q Dec
dispatchDec]
      , $sel:known:CompiledStep :: Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
known = CompiledStep
-> CompiledStep
-> Constructor
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
mkKnown CompiledStep
ca CompiledStep
cb
      , $sel:dispatch:CompiledStep :: Q Exp
dispatch = Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
dispatch
      }

compileChain :: [Transformation] -> Q CompiledStep
compileChain :: [Transformation] -> Q CompiledStep
compileChain [Transformation]
members = do
  [Transformation] -> Q ()
validateChain [Transformation]
members
  [Name]
guardNames <- (Transformation -> Q Name) -> [Transformation] -> Q [Name]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\Transformation
member -> String -> Q Name
freshBinding (String
"g_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Transformation
member.name)) [Transformation]
members
  let guardDecs :: [Q Dec]
guardDecs = (Name -> Transformation -> Q Dec)
-> [Name] -> [Transformation] -> [Q Dec]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Transformation -> Q Dec
memberGuardDec [Name]
guardNames [Transformation]
members
  Name
dispatch <- String -> Q Name
freshBinding String
"dispatch"
  let -- The constructor's bucket, each member paired with the guards of all
      -- members after it in the chain (the member's guarded suffix).
      bucketAt :: Constructor -> [(Transformation, Invoke, [Name])]
bucketAt Constructor
con =
        [ (Transformation
member, Invoke
invoke, ((Transformation, Name) -> Name)
-> [(Transformation, Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Transformation, Name) -> Name
forall a b. (a, b) -> b
snd [(Transformation, Name)]
rest)
        | (Transformation
member, Name
_guardName) : [(Transformation, Name)]
rest <- [(Transformation, Name)] -> [[(Transformation, Name)]]
forall a. [a] -> [[a]]
tails ([Transformation] -> [Name] -> [(Transformation, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Transformation]
members [Name]
guardNames)
        , Just Invoke
invoke <- [Constructor -> Transformation -> Maybe Invoke
invokeAt Constructor
con Transformation
member]
        ]
      known :: Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
known Constructor
con = case Constructor -> [(Transformation, Invoke, [Name])]
bucketAt Constructor
con of
        [] -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall a. Maybe a
Nothing
        [(Transformation, Invoke, [Name])]
bucket -> (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall a. a -> Maybe a
Just ([(Transformation, Invoke, [Name])]
-> Q Exp -> Q Exp -> [Q Exp] -> Q Exp
chainArm [(Transformation, Invoke, [Name])]
bucket)
      dispatchDec :: Q Dec
dispatchDec = Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: Type -> Type).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
dispatch) (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB ((Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp))
-> Q Exp
nodeCaseExp Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
known)) []
  CompiledStep -> Q CompiledStep
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure CompiledStep
    { $sel:decs:CompiledStep :: [Q Dec]
decs = [Q Dec]
guardDecs [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. Semigroup a => a -> a -> a
<> [Q Dec
dispatchDec]
    , Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
$sel:known:CompiledStep :: Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
known :: Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
known
    , $sel:dispatch:CompiledStep :: Q Exp
dispatch = Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
dispatch
    }

-- | A bucket entered with the constructor statically known: run the members
-- in order on the original fields; after the first change, hand the term to
-- the remaining chain members' guards.
chainArm
  :: [(Transformation, Invoke, [Name])]
  -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp
chainArm :: [(Transformation, Invoke, [Name])]
-> Q Exp -> Q Exp -> [Q Exp] -> Q Exp
chainArm [(Transformation, Invoke, [Name])]
bucket0 Q Exp
ctxE Q Exp
nodeE0 [Q Exp]
fieldEs = Q Exp -> [(Transformation, Invoke, [Name])] -> Q Exp
go Q Exp
nodeE0 [(Transformation, Invoke, [Name])]
bucket0
 where
  go :: Q Exp -> [(Transformation, Invoke, [Name])] -> Q Exp
  go :: Q Exp -> [(Transformation, Invoke, [Name])] -> Q Exp
go Q Exp
nodeE [] = [| pure $Q Exp
nodeE |]
  go Q Exp
nodeE ((Transformation
member, Invoke
invoke, [Name]
suffixGuards) : [(Transformation, Invoke, [Name])]
rest) = do
    Name
t <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"t"
    Name
changed <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"changed"
    [Q Stmt] -> Q Exp
forall (m :: Type -> Type). Quote m => [m Stmt] -> m Exp
doE
      [ Q Pat -> Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Pat -> m Exp -> m Stmt
bindS ([Q Pat] -> Q Pat
forall (m :: Type -> Type). Quote m => [m Pat] -> m Pat
tupP [Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
t, Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
changed])
          [| applyWith $(String -> Q Exp
forall (m :: Type -> Type). Quote m => String -> m Exp
stringE Transformation
member.name) $Q Exp
ctxE $Q Exp
nodeE
               $(Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp
invokeE Invoke
invoke Q Exp
ctxE Q Exp
nodeE [Q Exp]
fieldEs) |]
      , Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Exp -> m Stmt
noBindS (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: Type -> Type).
Quote m =>
m Exp -> m Exp -> m Exp -> m Exp
condE (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
changed)
          ([Name] -> Q Exp -> Q Exp -> Q Exp
guardedSuffix [Name]
suffixGuards Q Exp
ctxE (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
t))
          (Q Exp -> [(Transformation, Invoke, [Name])] -> Q Exp
go (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
t) [(Transformation, Invoke, [Name])]
rest)
      ]

-- | @g1 ctx t >>= g2 ctx >>= …@: offer the term to each remaining chain
-- member through its full worker table.
guardedSuffix :: [Name] -> Q Exp -> Q Exp -> Q Exp
guardedSuffix :: [Name] -> Q Exp -> Q Exp -> Q Exp
guardedSuffix [] Q Exp
_ctxE Q Exp
nodeE = [| pure $Q Exp
nodeE |]
guardedSuffix (Name
g : [Name]
gs) Q Exp
ctxE Q Exp
nodeE =
  (Q Exp -> Name -> Q Exp) -> Q Exp -> [Name] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
acc Name
g' -> [| $Q Exp
acc >>= $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
g') $Q Exp
ctxE |])
        [| $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
g) $Q Exp
ctxE $Q Exp
nodeE |]
        [Name]
gs

-- | One member's guard: match the term against the member's full worker
-- table; run the member instrumented on a match, return the term untouched
-- (without instrumentation) otherwise.
memberGuardDec :: Name -> Transformation -> Q Dec
memberGuardDec :: Name -> Transformation -> Q Dec
memberGuardDec Name
guardName Transformation
transformation =
  Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: Type -> Type).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
guardName) (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB ((Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Transformation -> Q Exp
guardExp Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp
instrumented Transformation
transformation)) []
 where
  instrumented :: Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp
instrumented Invoke
invoke Q Exp
ctxE Q Exp
nodeE [Q Exp]
fieldEs =
    [| fmap fst (applyWith $(String -> Q Exp
forall (m :: Type -> Type). Quote m => String -> m Exp
stringE Transformation
transformation.name) $Q Exp
ctxE $Q Exp
nodeE
                   $(Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp
invokeE Invoke
invoke Q Exp
ctxE Q Exp
nodeE [Q Exp]
fieldEs)) |]

-- | @\\ctx tm -> case tm of …@ over a transformation's worker table, with the
-- given wrapper around each invocation.
guardExp
  :: (Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
  -> Transformation
  -> Q Exp
guardExp :: (Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Transformation -> Q Exp
guardExp Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp
wrap Transformation
transformation =
  (Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp))
-> Q Exp
nodeCaseExp ((Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp))
 -> Q Exp)
-> (Constructor -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp))
-> Q Exp
forall a b. (a -> b) -> a -> b
$ \Constructor
con -> Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp
wrap (Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Maybe Invoke -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Constructor -> Transformation -> Maybe Invoke
invokeAt Constructor
con Transformation
transformation

{-
Note [NonRec erasure during descent]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Clash.Rewrite.Combinators.allR' matches let-expressions through the 'Letrec'
pattern synonym and rebuilds them with 'Rec' bindings, so any 'NonRec' let a
traversal descends into comes back as a 'Rec' let. The generated descent
replicates that behavior deliberately: preserving 'NonRec' is a real behavior
change (downstream code branches on 'Rec'/'NonRec', and netlist rendering
order can shift) that must be validated on its own, separately from this
dispatch machinery.
-}

-- | The one-level descent for one constructor, replicating
-- 'Clash.Rewrite.Combinators.allR' exactly: same 'CoreContext' pushes, same
-- 'InScopeSet' extensions, and the argument's context computed from the
-- already-rewritten function. The continuation receives the rebuilt node's
-- fields and the rebuilt node itself; descent preserves the constructor, so
-- the continuation may run a statically matched program on the result.
genDescend
  :: Constructor
  -> Q Exp            -- ^ recursion function @:: TransformContext -> Term -> m Term@
  -> (Q Exp, Q Exp)   -- ^ the context's InScopeSet and CoreContext stack
  -> Q Exp            -- ^ the node
  -> [Q Exp]          -- ^ the node's fields
  -> ([Q Exp] -> Q Exp -> Q Exp)  -- ^ continuation: rebuilt fields, rebuilt node
  -> Q Exp
genDescend :: Constructor
-> Q Exp
-> (Q Exp, Q Exp)
-> Q Exp
-> [Q Exp]
-> ([Q Exp] -> Q Exp -> Q Exp)
-> Q Exp
genDescend Constructor
con Q Exp
go (Q Exp
isE, Q Exp
cE) Q Exp
nodeE [Q Exp]
fieldEs [Q Exp] -> Q Exp -> Q Exp
continue = case (Constructor
con, [Q Exp]
fieldEs) of
  (Constructor
CVar, [Q Exp]
_) -> Q Exp
leaf
  (Constructor
CData, [Q Exp]
_) -> Q Exp
leaf
  (Constructor
CLiteral, [Q Exp]
_) -> Q Exp
leaf
  (Constructor
CPrim, [Q Exp]
_) -> Q Exp
leaf

  (Constructor
CLam, [Q Exp
v, Q Exp
e]) -> do
    Name
e' <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"e'"
    [Q Stmt] -> Q Exp
forall (m :: Type -> Type). Quote m => [m Stmt] -> m Exp
doE
      [ Q Pat -> Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
e')
          [| $Q Exp
go (TransformContext (extendInScopeSet $Q Exp
isE $Q Exp
v) (LamBody $Q Exp
v : $Q Exp
cE)) $Q Exp
e |]
      , [Q Exp] -> Q Exp -> Q Stmt
continueWith [Q Exp
v, Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
e'] [| Lam $Q Exp
v $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
e') |]
      ]

  (Constructor
CTyLam, [Q Exp
tv, Q Exp
e]) -> do
    Name
e' <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"e'"
    [Q Stmt] -> Q Exp
forall (m :: Type -> Type). Quote m => [m Stmt] -> m Exp
doE
      [ Q Pat -> Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
e')
          [| $Q Exp
go (TransformContext (extendInScopeSet $Q Exp
isE $Q Exp
tv) (TyLamBody $Q Exp
tv : $Q Exp
cE)) $Q Exp
e |]
      , [Q Exp] -> Q Exp -> Q Stmt
continueWith [Q Exp
tv, Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
e'] [| TyLam $Q Exp
tv $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
e') |]
      ]

  (Constructor
CApp, [Q Exp
fun, Q Exp
arg]) -> do
    Name
fun' <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"fun'"
    Name
arg' <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"arg'"
    [Q Stmt] -> Q Exp
forall (m :: Type -> Type). Quote m => [m Stmt] -> m Exp
doE
      [ Q Pat -> Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
fun') [| $Q Exp
go (TransformContext $Q Exp
isE (AppFun : $Q Exp
cE)) $Q Exp
fun |]
        -- The argument's context is computed from the already rewritten
        -- function, so the function has to be rewritten first.
      , Q Pat -> Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
arg')
          [| $Q Exp
go (TransformContext $Q Exp
isE (AppArg (primArg $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
fun')) : $Q Exp
cE)) $Q Exp
arg |]
      , [Q Exp] -> Q Exp -> Q Stmt
continueWith [Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
fun', Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
arg'] [| App $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
fun') $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
arg') |]
      ]

  (Constructor
CTyApp, [Q Exp
fun, Q Exp
argTy]) -> do
    Name
fun' <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"fun'"
    [Q Stmt] -> Q Exp
forall (m :: Type -> Type). Quote m => [m Stmt] -> m Exp
doE
      [ Q Pat -> Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
fun') [| $Q Exp
go (TransformContext $Q Exp
isE (TyAppC : $Q Exp
cE)) $Q Exp
fun |]
      , [Q Exp] -> Q Exp -> Q Stmt
continueWith [Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
fun', Q Exp
argTy] [| TyApp $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
fun') $Q Exp
argTy |]
      ]

  (Constructor
CLet, [Q Exp
bnd, Q Exp
body]) -> do
    -- See Note [NonRec erasure during descent]
    Name
bs <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"bs"
    Name
bndrs <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"bndrs"
    Name
is' <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"is'"
    Name
bs' <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"bs'"
    Name
body' <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"body'"
    [Q Stmt] -> Q Exp
forall (m :: Type -> Type). Quote m => [m Stmt] -> m Exp
doE
      [ [Q Dec] -> Q Stmt
forall (m :: Type -> Type). Quote m => [m Dec] -> m Stmt
letS
          [ Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: Type -> Type).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
bs) (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB [| bindToList $Q Exp
bnd |]) []
          , Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: Type -> Type).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
bndrs) (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB [| map fst $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
bs) |]) []
          , Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: Type -> Type).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
is') (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB [| extendInScopeSetList $Q Exp
isE $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
bndrs) |]) []
          ]
      , Q Pat -> Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
bs')
          [| traverse
               (\(b, rhs) ->
                  fmap ((,) b)
                    ($Q Exp
go (TransformContext $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
is')
                            (LetBinding b $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
bndrs) : $Q Exp
cE))
                         rhs))
               $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
bs) |]
      , Q Pat -> Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
body')
          [| $Q Exp
go (TransformContext $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
is') (LetBody $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
bs) : $Q Exp
cE)) $Q Exp
body |]
      , [Q Exp] -> Q Exp -> Q Stmt
continueWith [[| Rec $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
bs') |], Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
body']
          [| Let (Rec $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
bs')) $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
body') |]
      ]

  (Constructor
CCase, [Q Exp
subj, Q Exp
altsTy, Q Exp
alts]) -> do
    Name
subj' <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"subj'"
    Name
alts' <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"alts'"
    [Q Stmt] -> Q Exp
forall (m :: Type -> Type). Quote m => [m Stmt] -> m Exp
doE
      [ Q Pat -> Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
subj') [| $Q Exp
go (TransformContext $Q Exp
isE (CaseScrut : $Q Exp
cE)) $Q Exp
subj |]
      , Q Pat -> Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
alts')
          [| traverse
               (\(p, e) ->
                  let (tvs, ids) = patIds p
                      isAlt = extendInScopeSetList (extendInScopeSetList $Q Exp
isE tvs) ids
                  in fmap ((,) p) ($Q Exp
go (TransformContext isAlt (CaseAlt p : $Q Exp
cE)) e))
               $Q Exp
alts |]
      , [Q Exp] -> Q Exp -> Q Stmt
continueWith [Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
subj', Q Exp
altsTy, Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
alts']
          [| Case $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
subj') $Q Exp
altsTy $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
alts') |]
      ]

  (Constructor
CCast, [Q Exp
e, Q Exp
fromTy, Q Exp
toTy]) -> do
    Name
e' <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"e'"
    [Q Stmt] -> Q Exp
forall (m :: Type -> Type). Quote m => [m Stmt] -> m Exp
doE
      [ Q Pat -> Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
e') [| $Q Exp
go (TransformContext $Q Exp
isE (CastBody : $Q Exp
cE)) $Q Exp
e |]
      , [Q Exp] -> Q Exp -> Q Stmt
continueWith [Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
e', Q Exp
fromTy, Q Exp
toTy] [| Cast $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
e') $Q Exp
fromTy $Q Exp
toTy |]
      ]

  (Constructor
CTick, [Q Exp
tick, Q Exp
e]) -> do
    Name
e' <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"e'"
    [Q Stmt] -> Q Exp
forall (m :: Type -> Type). Quote m => [m Stmt] -> m Exp
doE
      [ Q Pat -> Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
e') [| $Q Exp
go (TransformContext $Q Exp
isE (TickC $Q Exp
tick : $Q Exp
cE)) $Q Exp
e |]
      , [Q Exp] -> Q Exp -> Q Stmt
continueWith [Q Exp
tick, Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
e'] [| Tick $Q Exp
tick $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
e') |]
      ]

  (Constructor, [Q Exp])
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"genDescend: field count mismatch for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Constructor -> String
forall a. Show a => a -> String
show Constructor
con)
 where
  leaf :: Q Exp
leaf = [Q Exp] -> Q Exp -> Q Exp
continue [Q Exp]
fieldEs Q Exp
nodeE
  continueWith :: [Q Exp] -> Q Exp -> Q Stmt
continueWith [Q Exp]
fieldEs' Q Exp
rebuiltE = Q Exp -> Q Stmt
forall (m :: Type -> Type). Quote m => m Exp -> m Stmt
noBindS ([Q Exp] -> Q Exp -> Q Exp
continue [Q Exp]
fieldEs' Q Exp
rebuiltE)

-- | What a traversal does at one node: given the recursion function, the
-- node program for the matched constructor ('Nothing' when the program is the
-- identity there), the context, the node, its fields, and a descent builder,
-- produce the body of @go@'s clause for that constructor.
type NodeArm
  =  Q Exp                                  -- ^ the traversal's @go@
  -> Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
  -> Q Exp                                  -- ^ ctx
  -> Q Exp                                  -- ^ the node
  -> [Q Exp]                                -- ^ its fields
  -> (([Q Exp] -> Q Exp -> Q Exp) -> Q Exp) -- ^ descend with a continuation
  -> Q Exp

-- | Generate a fused traversal: a recursive @go@ whose single constructor
-- match drives both the node program and the descent. The recursion
-- structure of each traversal is pinned to its "Clash.Rewrite.Combinators"
-- counterpart, with the node program as @r@:
--
-- * 'TopDown': @'Comb.topdownR' r = 'Comb.repeatR' r '>->' 'Comb.allR' …@. On
--   change, re-enter @go@ at this node (which also re-matches the
--   constructor); otherwise descend. See Note [topdown repeatR] in
--   "Clash.Rewrite.Combinators".
-- * 'BottomUp': descend first, run the program once on the rebuilt node,
--   whose constructor is already known, so no re-match.
-- * 'TopDownSuc': run the program once; when it fired, stop, neither
--   repeating nor descending.
-- * 'InnerMost': bottom-up; when the program fires, re-enter @go@ on the
--   result until the innermost fixpoint is reached.
-- * 'TopDownFix': see 'genTopDownFix'.
genTraversal :: Strat -> Q Exp
genTraversal :: Strat -> Q Exp
genTraversal Strat
strat = case Strat
strat of
  TopDown Step
step -> Step -> NodeArm -> Q Exp
fused Step
step (NodeArm -> Q Exp) -> NodeArm -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
goE Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
known Q Exp
ctxE Q Exp
tmE [Q Exp]
fieldEs ([Q Exp] -> Q Exp -> Q Exp) -> Q Exp
descend ->
    case Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
known of
      Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
Nothing -> ([Q Exp] -> Q Exp -> Q Exp) -> Q Exp
descend [Q Exp] -> Q Exp -> Q Exp
rebuildOnly
      Just Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka ->
        Q Exp -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
withListen (Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka Q Exp
ctxE Q Exp
tmE [Q Exp]
fieldEs) ((Q Exp -> Q Exp -> Q Exp) -> Q Exp)
-> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
tE Q Exp
changedE ->
          Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: Type -> Type).
Quote m =>
m Exp -> m Exp -> m Exp -> m Exp
condE Q Exp
changedE [| $Q Exp
goE $Q Exp
ctxE $Q Exp
tE |] (([Q Exp] -> Q Exp -> Q Exp) -> Q Exp
descend [Q Exp] -> Q Exp -> Q Exp
rebuildOnly)

  TopDownSuc Step
step -> Step -> NodeArm -> Q Exp
fused Step
step (NodeArm -> Q Exp) -> NodeArm -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
_goE Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
known Q Exp
ctxE Q Exp
tmE [Q Exp]
fieldEs ([Q Exp] -> Q Exp -> Q Exp) -> Q Exp
descend ->
    case Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
known of
      Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
Nothing -> ([Q Exp] -> Q Exp -> Q Exp) -> Q Exp
descend [Q Exp] -> Q Exp -> Q Exp
rebuildOnly
      Just Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka ->
        Q Exp -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
withListen (Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka Q Exp
ctxE Q Exp
tmE [Q Exp]
fieldEs) ((Q Exp -> Q Exp -> Q Exp) -> Q Exp)
-> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
tE Q Exp
changedE ->
          Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: Type -> Type).
Quote m =>
m Exp -> m Exp -> m Exp -> m Exp
condE Q Exp
changedE [| pure $Q Exp
tE |] (([Q Exp] -> Q Exp -> Q Exp) -> Q Exp
descend [Q Exp] -> Q Exp -> Q Exp
rebuildOnly)

  BottomUp Step
step -> Step -> NodeArm -> Q Exp
fused Step
step (NodeArm -> Q Exp) -> NodeArm -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
_goE Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
known Q Exp
ctxE Q Exp
_tmE [Q Exp]
_fieldEs ([Q Exp] -> Q Exp -> Q Exp) -> Q Exp
descend ->
    ([Q Exp] -> Q Exp -> Q Exp) -> Q Exp
descend (([Q Exp] -> Q Exp -> Q Exp) -> Q Exp)
-> ([Q Exp] -> Q Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \[Q Exp]
fieldEs' Q Exp
rebuiltE ->
      case Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
known of
        Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
Nothing -> [| pure $Q Exp
rebuiltE |]
        Just Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka -> String -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
bindTo String
"tm'" Q Exp
rebuiltE ((Q Exp -> Q Exp) -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
tmE' -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka Q Exp
ctxE Q Exp
tmE' [Q Exp]
fieldEs'

  InnerMost Step
step -> Step -> NodeArm -> Q Exp
fused Step
step (NodeArm -> Q Exp) -> NodeArm -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
goE Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
known Q Exp
ctxE Q Exp
_tmE [Q Exp]
_fieldEs ([Q Exp] -> Q Exp -> Q Exp) -> Q Exp
descend ->
    ([Q Exp] -> Q Exp -> Q Exp) -> Q Exp
descend (([Q Exp] -> Q Exp -> Q Exp) -> Q Exp)
-> ([Q Exp] -> Q Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \[Q Exp]
fieldEs' Q Exp
rebuiltE ->
      case Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
known of
        Maybe (Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
Nothing -> [| pure $Q Exp
rebuiltE |]
        Just Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka -> String -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
bindTo String
"tm'" Q Exp
rebuiltE ((Q Exp -> Q Exp) -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
tmE' ->
          Q Exp -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
withListen (Q Exp -> Q Exp -> [Q Exp] -> Q Exp
ka Q Exp
ctxE Q Exp
tmE' [Q Exp]
fieldEs') ((Q Exp -> Q Exp -> Q Exp) -> Q Exp)
-> (Q Exp -> Q Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Q Exp
tE Q Exp
changedE ->
            Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: Type -> Type).
Quote m =>
m Exp -> m Exp -> m Exp -> m Exp
condE Q Exp
changedE [| $Q Exp
goE $Q Exp
ctxE $Q Exp
tE |] [| pure $Q Exp
tE |]

  TopDownFix Step
step -> do
    CompiledStep
cs <- Step -> Q CompiledStep
compileStep Step
step
    CompiledStep -> Q Exp
genTopDownFix CompiledStep
cs

  Strat
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"genTraversal: not a traversal"
 where
  rebuildOnly :: [Q Exp] -> Q Exp -> Q Exp
  rebuildOnly :: [Q Exp] -> Q Exp -> Q Exp
rebuildOnly [Q Exp]
_fieldEs' Q Exp
rebuiltE = [| pure $Q Exp
rebuiltE |]

  fused :: Step -> NodeArm -> Q Exp
  fused :: Step -> NodeArm -> Q Exp
fused Step
step NodeArm
mkArm = do
    CompiledStep
cs <- Step -> Q CompiledStep
compileStep Step
step
    Name
go <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"go"
    [Clause]
clauses <- (Constructor -> Q Clause) -> [Constructor] -> Q [Clause]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (CompiledStep -> Q Exp -> NodeArm -> Constructor -> Q Clause
goClause CompiledStep
cs (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
go) NodeArm
mkArm) [Constructor]
allConstructors
    [Q Dec] -> Q Exp -> Q Exp
forall (m :: Type -> Type). Quote m => [m Dec] -> m Exp -> m Exp
letE (CompiledStep
cs.decs [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec -> Q Dec
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Name -> [Clause] -> Dec
FunD Name
go [Clause]
clauses)]) (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
go)

  goClause :: CompiledStep -> Q Exp -> NodeArm -> Constructor -> Q Clause
  goClause :: CompiledStep -> Q Exp -> NodeArm -> Constructor -> Q Clause
goClause CompiledStep
cs Q Exp
goE NodeArm
mkArm Constructor
con = do
    Name
ctx <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"_ctx"
    Name
is <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"_is"
    Name
c <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"_c"
    Name
tm <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"_tm"
    [Name]
fieldNames <- Constructor -> Q [Name]
constructorFieldNames Constructor
con
    let fieldEs :: [Q Exp]
fieldEs = (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE [Name]
fieldNames
        descend :: ([Q Exp] -> Q Exp -> Q Exp) -> Q Exp
descend = Constructor
-> Q Exp
-> (Q Exp, Q Exp)
-> Q Exp
-> [Q Exp]
-> ([Q Exp] -> Q Exp -> Q Exp)
-> Q Exp
genDescend Constructor
con Q Exp
goE (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
is, Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
c) (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
tm) [Q Exp]
fieldEs
    Exp
body <- NodeArm
mkArm Q Exp
goE (CompiledStep
cs.known Constructor
con) (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
ctx) (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
tm) [Q Exp]
fieldEs ([Q Exp] -> Q Exp -> Q Exp) -> Q Exp
descend
    [Pat]
pats <- [Q Pat] -> Q [Pat]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: Type -> Type) a. Monad m => [m a] -> m [a]
sequence
      [ Name -> Q Pat -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat -> m Pat
asP Name
ctx (Name -> [Q Pat] -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> [m Pat] -> m Pat
conP 'TransformContext [Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
is, Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
c])
      , Name -> Q Pat -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat -> m Pat
asP Name
tm (Name -> [Q Pat] -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> [m Pat] -> m Pat
conP (Constructor -> Name
constructorName Constructor
con) ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP [Name]
fieldNames))
      ]
    Clause -> Q Clause
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
pats (Exp -> Body
NormalB Exp
body) [])

-- | 'Comb.topdownFixR' with the node program as @r@: a local @settle@
-- (@'Comb.repeatR' r@) plus the tryParent\/childChanged\/parentChanged loop
-- from Note [topdownFixR] in "Clash.Rewrite.Combinators", over a generated
-- 'Comb.allR' replica.
genTopDownFix :: CompiledStep -> Q Exp
genTopDownFix :: CompiledStep -> Q Exp
genTopDownFix CompiledStep
cs = do
  Name
goFix <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"goFix"
  Name
settle <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"settle"
  Name
descendD <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"descendD"
  [Clause]
descendClauses <- (Constructor -> Q Clause) -> [Constructor] -> Q [Clause]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Constructor -> Q Clause
descendClause [Constructor]
allConstructors
  let settleDec :: Q Dec
settleDec = Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: Type -> Type).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
settle) (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB
        [| let loop ctx tm = do
                 (t1, w) <- Writer.listen ($(CompiledStep
cs.dispatch) ctx tm)
                 if Monoid.getAny w then loop ctx t1 else pure t1
           in loop |]) []
      descendDec :: Q Dec
descendDec = Dec -> Q Dec
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Name -> [Clause] -> Dec
FunD Name
descendD [Clause]
descendClauses)
      goFixDec :: Q Dec
goFixDec = Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: Type -> Type).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
goFix) (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB
        [| let loop tryParent ctx tm = do
                 t1 <- if tryParent then $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
settle) ctx tm else pure tm
                 (t2, w1) <- Writer.listen
                   ($(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
descendD) (loop True) ctx t1)
                 if Monoid.getAny w1
                   then do
                     (t3, w2) <- Writer.listen ($(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
settle) ctx t2)
                     if Monoid.getAny w2
                       then loop False ctx t3
                       else pure t3
                   else pure t2
           in loop |]) []
  [Q Dec] -> Q Exp -> Q Exp
forall (m :: Type -> Type). Quote m => [m Dec] -> m Exp -> m Exp
letE (CompiledStep
cs.decs [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. Semigroup a => a -> a -> a
<> [Q Dec
settleDec, Q Dec
descendDec, Q Dec
goFixDec]) [| $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
goFix) True |]
 where
  descendClause :: Constructor -> Q Clause
descendClause Constructor
con = do
    -- Leaf clauses never call the recursion argument; the underscore hint
    -- keeps -Wunused-matches quiet there.
    Name
rec' <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName (if Constructor -> Bool
isLeafConstructor Constructor
con then String
"_rec" else String
"rec'")
    Name
is <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"_is"
    Name
c <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"_c"
    Name
tm <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"_tm"
    [Name]
fieldNames <- Constructor -> Q [Name]
constructorFieldNames Constructor
con
    Exp
body <- Constructor
-> Q Exp
-> (Q Exp, Q Exp)
-> Q Exp
-> [Q Exp]
-> ([Q Exp] -> Q Exp -> Q Exp)
-> Q Exp
genDescend Constructor
con (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
rec') (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
is, Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
c) (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
tm)
              ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE [Name]
fieldNames) (\[Q Exp]
_fieldEs' Q Exp
rebuiltE -> [| pure $Q Exp
rebuiltE |])
    [Pat]
pats <- [Q Pat] -> Q [Pat]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: Type -> Type) a. Monad m => [m a] -> m [a]
sequence
      [ Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
rec'
      , Name -> [Q Pat] -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> [m Pat] -> m Pat
conP 'TransformContext [Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
is, Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
c]
      , Name -> Q Pat -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat -> m Pat
asP Name
tm (Name -> [Q Pat] -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> [m Pat] -> m Pat
conP (Constructor -> Name
constructorName Constructor
con) ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP [Name]
fieldNames))
      ]
    Clause -> Q Clause
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
pats (Exp -> Body
NormalB Exp
body) [])

-- | Compile a strategy into its fused dispatch code. The result is an
-- expression of type @Rewrite extra@, with @extra@ fixed by the workers the
-- spec references.
compileStrategy :: Strat -> Q Exp
compileStrategy :: Strat -> Q Exp
compileStrategy Strat
strat = case Strat
strat of
  Seq Strat
a Strat
b -> [| $(Strat -> Q Exp
compileStrategy Strat
a) Comb.>-> $(Strat -> Q Exp
compileStrategy Strat
b) |]
  DeepSeqS Strat
a Strat
b -> [| $(Strat -> Q Exp
compileStrategy Strat
a) Comb.>-!-> $(Strat -> Q Exp
compileStrategy Strat
b) |]
  OnChange Strat
a Strat
b -> [| $(Strat -> Q Exp
compileStrategy Strat
a) Comb.!-> $(Strat -> Q Exp
compileStrategy Strat
b) |]
  OnNoChange Strat
a Strat
b -> [| $(Strat -> Q Exp
compileStrategy Strat
a) Comb.>-! $(Strat -> Q Exp
compileStrategy Strat
b) |]
  Repeat Strat
a -> [| Comb.repeatR $(Strat -> Q Exp
compileStrategy Strat
a) |]
  Pass String
name Name
rewriteName -> [| apply $(String -> Q Exp
forall (m :: Type -> Type). Quote m => String -> m Exp
stringE String
name) $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
rewriteName) |]
  CallStrategy Name
name -> Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
name
  TopDown{} -> Strat -> Q Exp
genTraversal Strat
strat
  BottomUp{} -> Strat -> Q Exp
genTraversal Strat
strat
  TopDownFix{} -> Strat -> Q Exp
genTraversal Strat
strat
  TopDownSuc{} -> Strat -> Q Exp
genTraversal Strat
strat
  InnerMost{} -> Strat -> Q Exp
genTraversal Strat
strat

-- | Compile a strategy into its unfused reference: the same transformations,
-- run as a plain @apply@ chain through the "Clash.Rewrite.Combinators"
-- traversals. Agrees with 'compileStrategy' on results, transformation
-- counts, and change flags.
compileStrategyReference :: Strat -> Q Exp
compileStrategyReference :: Strat -> Q Exp
compileStrategyReference = Strat -> Q Exp
goStrat
 where
  goStrat :: Strat -> Q Exp
goStrat Strat
strat = case Strat
strat of
    Seq Strat
a Strat
b -> [| $(Strat -> Q Exp
goStrat Strat
a) Comb.>-> $(Strat -> Q Exp
goStrat Strat
b) |]
    DeepSeqS Strat
a Strat
b -> [| $(Strat -> Q Exp
goStrat Strat
a) Comb.>-!-> $(Strat -> Q Exp
goStrat Strat
b) |]
    OnChange Strat
a Strat
b -> [| $(Strat -> Q Exp
goStrat Strat
a) Comb.!-> $(Strat -> Q Exp
goStrat Strat
b) |]
    OnNoChange Strat
a Strat
b -> [| $(Strat -> Q Exp
goStrat Strat
a) Comb.>-! $(Strat -> Q Exp
goStrat Strat
b) |]
    Repeat Strat
a -> [| Comb.repeatR $(Strat -> Q Exp
goStrat Strat
a) |]
    Pass String
name Name
rewriteName -> [| apply $(String -> Q Exp
forall (m :: Type -> Type). Quote m => String -> m Exp
stringE String
name) $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
rewriteName) |]
    CallStrategy Name
name -> Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
name
    TopDown Step
step -> [| Comb.topdownR $(Step -> Q Exp
goStep Step
step) |]
    BottomUp Step
step -> [| Comb.bottomupR $(Step -> Q Exp
goStep Step
step) |]
    TopDownFix Step
step -> [| Comb.topdownFixR $(Step -> Q Exp
goStep Step
step) |]
    TopDownSuc Step
step -> [| Comb.topdownSucR $(Step -> Q Exp
goStep Step
step) |]
    InnerMost Step
step -> [| Comb.innerMost $(Step -> Q Exp
goStep Step
step) |]

  goStep :: Step -> Q Exp
goStep Step
step = case Step
step of
    SeqS Step
a Step
b -> [| $(Step -> Q Exp
goStep Step
a) Comb.>-> $(Step -> Q Exp
goStep Step
b) |]
    OnChangeS Step
a Step
b -> [| $(Step -> Q Exp
goStep Step
a) Comb.!-> $(Step -> Q Exp
goStep Step
b) |]
    OnNoChangeS Step
a Step
b -> [| $(Step -> Q Exp
goStep Step
a) Comb.>-! $(Step -> Q Exp
goStep Step
b) |]
    EmbedS Strat
strat -> Strat -> Q Exp
goStrat Strat
strat
    Chain [Transformation]
members -> do
      [Transformation] -> Q ()
validateChain [Transformation]
members
      -- The sequential apply chain over all members, each guarded on its full
      -- worker table.
      (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldr1 (\Q Exp
x Q Exp
y -> [| $Q Exp
x Comb.>-> $Q Exp
y |]) ((Transformation -> Q Exp) -> [Transformation] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Transformation -> Q Exp
memberApplyE [Transformation]
members)

  memberApplyE :: Transformation -> Q Exp
memberApplyE Transformation
member =
    [| apply $(String -> Q Exp
forall (m :: Type -> Type). Quote m => String -> m Exp
stringE Transformation
member.name) $(Transformation -> Q Exp
asRewriteQ Transformation
member) |]

-- | A node program as a plain rewrite: match the constructor once and run
-- that constructor's program, without traversing. For composing a 'Step'
-- with plain combinators, and for testing chains in isolation.
dispatchQ :: Step -> Q Exp
dispatchQ :: Step -> Q Exp
dispatchQ Step
step = do
  CompiledStep
cs <- Step -> Q CompiledStep
compileStep Step
step
  [Q Dec] -> Q Exp -> Q Exp
forall (m :: Type -> Type). Quote m => [m Dec] -> m Exp -> m Exp
letE CompiledStep
cs.decs CompiledStep
cs.dispatch

-- | A transformation as a plain uninstrumented rewrite: match the term
-- against the worker table, run the worker on a match, return the term
-- untouched otherwise. Splice this where a transformation is invoked from
-- inside another transformation (any instrumentation is the caller's).
asRewriteQ :: Transformation -> Q Exp
asRewriteQ :: Transformation -> Q Exp
asRewriteQ Transformation
transformation = do
  Transformation -> Q ()
validateTransformation Transformation
transformation
  (Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp)
-> Transformation -> Q Exp
guardExp Invoke -> Q Exp -> Q Exp -> [Q Exp] -> Q Exp
invokeE Transformation
transformation