{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeSynonymInstances       #-}
{-# LANGUAGE UndecidableInstances       #-}

module Cubix.Language.Parametric.Semantics.CfgInserter (
    EmptyInsertOkay(..)
  , MonadCfgInsertion(..)
  , CfgInserterT
  , performCfgInsertions
  ) where

import Control.Monad ( liftM )
import Control.Monad.Reader ( ReaderT )
import Control.Monad.State ( MonadState, StateT, execStateT )
import Control.Monad.Trans ( lift )
import Control.Monad.Trans.Maybe ( MaybeT )
import Control.Monad.Writer ( MonadWriter(..), WriterT(..) )

import Data.Foldable ( for_ )
import Data.Function ( on )
import Data.List ( sortOn, minimumBy )
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Proxy ( Proxy(..) )

import Control.Lens ( makeLenses, use, (%=), (%%~), (^.) )

import Data.Comp.Multi ( E(..), runE, HFunctor, HTraversable, HFoldable, All )
import Data.Comp.Multi.Strategic ( GRewriteM, RewriteM, allbuR )

import Cubix.Language.Info
import Cubix.Language.Parametric.Path
import Cubix.Language.Parametric.ProgInfo
import Cubix.Language.Parametric.Semantics.Cfg
import Cubix.Language.Parametric.Semantics.SemanticProperties

import Cubix.Sin.Compdata.Annotation ( MonadAnnotater, getAnn )

-- |
-- I initially wrote this module to use MonadState, but it conflicted with the already present MonadState instances
--
-- With little time left for coding, instead of figuring this out, I just went with a log construction and
-- switched to MonadWriter

-- Nothing to control what order these are applied in. Ideally, want operational transform maybe?
data InsertionOp fs l = InsertionOp { InsertionOp fs l -> NodeEvaluationPoint
_insert_op_eval_point :: NodeEvaluationPoint
                                    , InsertionOp fs l -> TermLab fs l
_insert_op_node       :: TermLab fs l
                                    }
makeLenses ''InsertionOp

data CfgInsertState fs l = CfgInsertState {
                            CfgInsertState fs l -> Map Label [InsertionOp fs l]
_pendingInsertions :: Map Label [InsertionOp fs l]
                          , CfgInsertState fs l -> ProgInfo fs
_cis_proginf       :: ProgInfo fs
                          }

makeLenses ''CfgInsertState

instance HasProgInfo (CfgInsertState fs l) fs where progInfo :: (ProgInfo fs -> f (ProgInfo fs))
-> CfgInsertState fs l -> f (CfgInsertState fs l)
progInfo = (ProgInfo fs -> f (ProgInfo fs))
-> CfgInsertState fs l -> f (CfgInsertState fs l)
forall (fs :: [(* -> *) -> * -> *]) l.
Lens' (CfgInsertState fs l) (ProgInfo fs)
cis_proginf
instance HasCurCfg (CfgInsertState fs l) fs where cur_cfg :: (Cfg fs -> f (Cfg fs))
-> CfgInsertState fs l -> f (CfgInsertState fs l)
cur_cfg = (ProgInfo fs -> f (ProgInfo fs))
-> CfgInsertState fs l -> f (CfgInsertState fs l)
forall (fs :: [(* -> *) -> * -> *]) l.
Lens' (CfgInsertState fs l) (ProgInfo fs)
cis_proginf((ProgInfo fs -> f (ProgInfo fs))
 -> CfgInsertState fs l -> f (CfgInsertState fs l))
-> ((Cfg fs -> f (Cfg fs)) -> ProgInfo fs -> f (ProgInfo fs))
-> (Cfg fs -> f (Cfg fs))
-> CfgInsertState fs l
-> f (CfgInsertState fs l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Cfg fs -> f (Cfg fs)) -> ProgInfo fs -> f (ProgInfo fs)
forall c (fs :: [(* -> *) -> * -> *]).
HasProgInfo c fs =>
Lens' c (Cfg fs)
proginf_cfg

type CfgInserterT fs l m = WriterT [Action fs l] m

data EmptyInsertOkay = EmptyInsertOkay | EmptyInsertNotOkay

data Action fs l = DominatingPrependFirst (E (TermLab fs)) (TermLab fs l) EmptyInsertOkay
                 | DominatingPrependLast  (E (TermLab fs)) (TermLab fs l) EmptyInsertOkay
                 | DominatingAppendFirst  (E (TermLab fs)) (TermLab fs l) EmptyInsertOkay
                 | DominatingAppendLast   (E (TermLab fs)) (TermLab fs l) EmptyInsertOkay
                 | FirstPredPrependLast   (E (TermLab fs)) (TermLab fs l) EmptyInsertOkay
                 | RestPredPrependLast    (E (TermLab fs)) (TermLab fs l) EmptyInsertOkay


collapseMaybeList :: Maybe [a] -> [a]
collapseMaybeList :: Maybe [a] -> [a]
collapseMaybeList = Maybe [a] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat

dominatingInsert ::
  forall fs l m.
  ( Monad m
  , All HFunctor fs
  , InsertAt fs l
  ) => Bool
  -> (forall a. a -> [a] -> [a])
  -> ([CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs])
  -> E (TermLab fs)
  -> TermLab fs l
  -> EmptyInsertOkay
  -> StateT (CfgInsertState fs l) m ()
dominatingInsert :: Bool
-> (forall a. a -> [a] -> [a])
-> ([CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs])
-> E (TermLab fs)
-> TermLab fs l
-> EmptyInsertOkay
-> StateT (CfgInsertState fs l) m ()
dominatingInsert isPrepend :: Bool
isPrepend op :: forall a. a -> [a] -> [a]
op filt :: [CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs]
filt t :: E (TermLab fs)
t toInsert :: TermLab fs l
toInsert empOk :: EmptyInsertOkay
empOk = do
    Cfg fs
cfg <- Getting (Cfg fs) (CfgInsertState fs l) (Cfg fs)
-> StateT (CfgInsertState fs l) m (Cfg fs)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Cfg fs) (CfgInsertState fs l) (Cfg fs)
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg
    let (Just tNode :: CfgNode fs
tNode) = (TermLab fs :=> Maybe (CfgNode fs))
-> E (TermLab fs) -> Maybe (CfgNode fs)
forall (f :: * -> *) b. (f :=> b) -> E f -> b
runE (Cfg fs -> CfgNodeType -> TermLab fs i -> Maybe (CfgNode fs)
forall (fs :: [(* -> *) -> * -> *]) l.
Cfg fs -> CfgNodeType -> TermLab fs l -> Maybe (CfgNode fs)
cfgNodeForTerm Cfg fs
cfg CfgNodeType
EnterNode) E (TermLab fs)
t
    let boundaryFunc :: (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
boundaryFunc = if Bool
isPrepend then (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
forall (fs :: [(* -> *) -> * -> *]).
(CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingPredBoundary else (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
forall (fs :: [(* -> *) -> * -> *]).
(CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
satisfyingSuccBoundary
    case (CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
forall (fs :: [(* -> *) -> * -> *]).
(CfgNode fs -> Bool) -> Cfg fs -> CfgNode fs -> Maybe [CfgNode fs]
boundaryFunc CfgNode fs -> Bool
canInsert Cfg fs
cfg CfgNode fs
tNode of
      Nothing    -> case EmptyInsertOkay
empOk of
                      EmptyInsertOkay   -> () -> StateT (CfgInsertState fs l) m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                      EmptyInsertNotOkay -> [Char] -> StateT (CfgInsertState fs l) m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> StateT (CfgInsertState fs l) m ())
-> [Char] -> StateT (CfgInsertState fs l) m ()
forall a b. (a -> b) -> a -> b
$ "Cannot insert at node " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Label -> [Char]
forall a. Show a => a -> [Char]
show ((TermLab fs :=> Label) -> E (TermLab fs) -> Label
forall (f :: * -> *) b. (f :=> b) -> E f -> b
runE TermLab fs :=> Label
forall (f :: (* -> *) -> * -> *) a. Annotated f a => HFix f :=> a
getAnn E (TermLab fs)
t) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ " when asked to insert before " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Label -> [Char]
forall a. Show a => a -> [Char]
show (CfgNode fs
tNode CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c Label
cfg_node_lab))
      Just prevs :: [CfgNode fs]
prevs -> do
        [CfgNode fs]
prevsFilt <- [CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs]
filt [CfgNode fs]
prevs
        [CfgNode fs]
-> (CfgNode fs -> StateT (CfgInsertState fs l) m ())
-> StateT (CfgInsertState fs l) m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [CfgNode fs]
prevsFilt ((CfgNode fs -> StateT (CfgInsertState fs l) m ())
 -> StateT (CfgInsertState fs l) m ())
-> (CfgNode fs -> StateT (CfgInsertState fs l) m ())
-> StateT (CfgInsertState fs l) m ()
forall a b. (a -> b) -> a -> b
$ \p :: CfgNode fs
p -> do
          let lab :: Label
lab = (TermLab fs :=> Label) -> E (TermLab fs) -> Label
forall (f :: * -> *) b. (f :=> b) -> E f -> b
runE TermLab fs :=> Label
forall (f :: (* -> *) -> * -> *) a. Annotated f a => HFix f :=> a
getAnn (CfgNode fs
p CfgNode fs
-> Getting (E (TermLab fs)) (CfgNode fs) (E (TermLab fs))
-> E (TermLab fs)
forall s a. s -> Getting a s a -> a
^. Getting (E (TermLab fs)) (CfgNode fs) (E (TermLab fs))
forall c (fs :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (E (TermLab fs))
cfg_node_term)
          Maybe [InsertionOp fs l]
insertions <- (Map Label [InsertionOp fs l] -> Maybe [InsertionOp fs l])
-> StateT (CfgInsertState fs l) m (Map Label [InsertionOp fs l])
-> StateT (CfgInsertState fs l) m (Maybe [InsertionOp fs l])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Label -> Map Label [InsertionOp fs l] -> Maybe [InsertionOp fs l]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Label
lab) (Getting
  (Map Label [InsertionOp fs l])
  (CfgInsertState fs l)
  (Map Label [InsertionOp fs l])
-> StateT (CfgInsertState fs l) m (Map Label [InsertionOp fs l])
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Map Label [InsertionOp fs l])
  (CfgInsertState fs l)
  (Map Label [InsertionOp fs l])
forall (fs :: [(* -> *) -> * -> *]) l l.
Lens
  (CfgInsertState fs l)
  (CfgInsertState fs l)
  (Map Label [InsertionOp fs l])
  (Map Label [InsertionOp fs l])
pendingInsertions)
          let insertions' :: [InsertionOp fs l]
insertions' = InsertionOp fs l -> [InsertionOp fs l] -> [InsertionOp fs l]
forall a. a -> [a] -> [a]
op (NodeEvaluationPoint -> TermLab fs l -> InsertionOp fs l
forall (fs :: [(* -> *) -> * -> *]) l.
NodeEvaluationPoint -> TermLab fs l -> InsertionOp fs l
InsertionOp (CfgNodeType -> NodeEvaluationPoint
nodeTypeToEvalPoint (CfgNode fs
p CfgNode fs
-> Getting CfgNodeType (CfgNode fs) CfgNodeType -> CfgNodeType
forall s a. s -> Getting a s a -> a
^. Getting CfgNodeType (CfgNode fs) CfgNodeType
forall c (fs :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c CfgNodeType
cfg_node_type)) TermLab fs l
toInsert) (Maybe [InsertionOp fs l] -> [InsertionOp fs l]
forall a. Maybe [a] -> [a]
collapseMaybeList Maybe [InsertionOp fs l]
insertions)
          (Map Label [InsertionOp fs l]
 -> Identity (Map Label [InsertionOp fs l]))
-> CfgInsertState fs l -> Identity (CfgInsertState fs l)
forall (fs :: [(* -> *) -> * -> *]) l l.
Lens
  (CfgInsertState fs l)
  (CfgInsertState fs l)
  (Map Label [InsertionOp fs l])
  (Map Label [InsertionOp fs l])
pendingInsertions ((Map Label [InsertionOp fs l]
  -> Identity (Map Label [InsertionOp fs l]))
 -> CfgInsertState fs l -> Identity (CfgInsertState fs l))
-> (Map Label [InsertionOp fs l] -> Map Label [InsertionOp fs l])
-> StateT (CfgInsertState fs l) m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Label
-> [InsertionOp fs l]
-> Map Label [InsertionOp fs l]
-> Map Label [InsertionOp fs l]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Label
lab [InsertionOp fs l]
insertions'
  where
    canInsert :: CfgNode fs -> Bool
    canInsert :: CfgNode fs -> Bool
canInsert n :: CfgNode fs
n =  ((TermLab fs :=> Bool) -> E (TermLab fs) -> Bool
forall (f :: * -> *) b. (f :=> b) -> E f -> b
runE (NodeEvaluationPoint -> Proxy l -> AnnTerm Label fs i -> Bool
forall (gs :: [(* -> *) -> * -> *]) l a i.
InsertAt gs l =>
NodeEvaluationPoint -> Proxy l -> AnnTerm a gs i -> Bool
canInsertAt (CfgNodeType -> NodeEvaluationPoint
nodeTypeToEvalPoint (CfgNode fs
n CfgNode fs
-> Getting CfgNodeType (CfgNode fs) CfgNodeType -> CfgNodeType
forall s a. s -> Getting a s a -> a
^. Getting CfgNodeType (CfgNode fs) CfgNodeType
forall c (fs :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c CfgNodeType
cfg_node_type)) (Proxy l
forall k (t :: k). Proxy t
Proxy :: Proxy l)) (CfgNode fs
n CfgNode fs
-> Getting (E (TermLab fs)) (CfgNode fs) (E (TermLab fs))
-> E (TermLab fs)
forall s a. s -> Getting a s a -> a
^. Getting (E (TermLab fs)) (CfgNode fs) (E (TermLab fs))
forall c (fs :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (E (TermLab fs))
cfg_node_term))


append :: a -> [a] -> [a]
append :: a -> [a] -> [a]
append x :: a
x l :: [a]
l = [a]
l [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x]

trivFilt :: (Monad m) => [a] -> m [a]
trivFilt :: [a] -> m [a]
trivFilt = [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return

firstNode :: (MonadState (CfgInsertState fs l) m) => [CfgNode fs] -> m [CfgNode fs]
firstNode :: [CfgNode fs] -> m [CfgNode fs]
firstNode nodes :: [CfgNode fs]
nodes = do
    ProgInfo fs
progInfo <- Getting (ProgInfo fs) (CfgInsertState fs l) (ProgInfo fs)
-> m (ProgInfo fs)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (ProgInfo fs) (CfgInsertState fs l) (ProgInfo fs)
forall c (fs :: [(* -> *) -> * -> *]).
HasProgInfo c fs =>
Lens' c (ProgInfo fs)
progInfo
    [CfgNode fs] -> m [CfgNode fs]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CfgNode fs] -> m [CfgNode fs]) -> [CfgNode fs] -> m [CfgNode fs]
forall a b. (a -> b) -> a -> b
$ [(CfgNode fs -> CfgNode fs -> Ordering)
-> [CfgNode fs] -> CfgNode fs
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (Path -> Path -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Path -> Path -> Ordering)
-> (CfgNode fs -> Path) -> CfgNode fs -> CfgNode fs -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ProgInfo fs -> CfgNode fs -> Path
forall (fs :: [(* -> *) -> * -> *]).
ProgInfo fs -> CfgNode fs -> Path
getPath ProgInfo fs
progInfo)) [CfgNode fs]
nodes]

butFirstNode :: (MonadState (CfgInsertState fs l) m) => [CfgNode fs] -> m [CfgNode fs]
butFirstNode :: [CfgNode fs] -> m [CfgNode fs]
butFirstNode nodes :: [CfgNode fs]
nodes = do
    ProgInfo fs
progInfo <- Getting (ProgInfo fs) (CfgInsertState fs l) (ProgInfo fs)
-> m (ProgInfo fs)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (ProgInfo fs) (CfgInsertState fs l) (ProgInfo fs)
forall c (fs :: [(* -> *) -> * -> *]).
HasProgInfo c fs =>
Lens' c (ProgInfo fs)
progInfo
    [CfgNode fs] -> m [CfgNode fs]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CfgNode fs] -> m [CfgNode fs]) -> [CfgNode fs] -> m [CfgNode fs]
forall a b. (a -> b) -> a -> b
$ [CfgNode fs] -> [CfgNode fs]
forall a. [a] -> [a]
tail ([CfgNode fs] -> [CfgNode fs]) -> [CfgNode fs] -> [CfgNode fs]
forall a b. (a -> b) -> a -> b
$ (CfgNode fs -> Path) -> [CfgNode fs] -> [CfgNode fs]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (ProgInfo fs -> CfgNode fs -> Path
forall (fs :: [(* -> *) -> * -> *]).
ProgInfo fs -> CfgNode fs -> Path
getPath ProgInfo fs
progInfo) [CfgNode fs]
nodes

getPath :: ProgInfo fs -> CfgNode fs -> Path
getPath :: ProgInfo fs -> CfgNode fs -> Path
getPath inf :: ProgInfo fs
inf node :: CfgNode fs
node = case ProgInfo fs -> CfgNode fs -> Maybe Path
forall (fs :: [(* -> *) -> * -> *]).
ProgInfo fs -> CfgNode fs -> Maybe Path
cfgNodePath ProgInfo fs
inf CfgNode fs
node of
  Just p :: Path
p  -> Path
p
  Nothing -> Path
emptyPath

runAction :: (Monad m, InsertAt fs l, All HFunctor fs) => Action fs l -> StateT (CfgInsertState fs l) m ()
runAction :: Action fs l -> StateT (CfgInsertState fs l) m ()
runAction (DominatingPrependFirst l :: E (TermLab fs)
l t :: TermLab fs l
t emp :: EmptyInsertOkay
emp) = Bool
-> (forall a. a -> [a] -> [a])
-> ([CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs])
-> E (TermLab fs)
-> TermLab fs l
-> EmptyInsertOkay
-> StateT (CfgInsertState fs l) m ()
forall (fs :: [(* -> *) -> * -> *]) l (m :: * -> *).
(Monad m, All HFunctor fs, InsertAt fs l) =>
Bool
-> (forall a. a -> [a] -> [a])
-> ([CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs])
-> E (TermLab fs)
-> TermLab fs l
-> EmptyInsertOkay
-> StateT (CfgInsertState fs l) m ()
dominatingInsert Bool
True  (:)    [CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs]
forall (m :: * -> *) a. Monad m => [a] -> m [a]
trivFilt     E (TermLab fs)
l TermLab fs l
t EmptyInsertOkay
emp
runAction (DominatingPrependLast  l :: E (TermLab fs)
l t :: TermLab fs l
t emp :: EmptyInsertOkay
emp) = Bool
-> (forall a. a -> [a] -> [a])
-> ([CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs])
-> E (TermLab fs)
-> TermLab fs l
-> EmptyInsertOkay
-> StateT (CfgInsertState fs l) m ()
forall (fs :: [(* -> *) -> * -> *]) l (m :: * -> *).
(Monad m, All HFunctor fs, InsertAt fs l) =>
Bool
-> (forall a. a -> [a] -> [a])
-> ([CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs])
-> E (TermLab fs)
-> TermLab fs l
-> EmptyInsertOkay
-> StateT (CfgInsertState fs l) m ()
dominatingInsert Bool
True  forall a. a -> [a] -> [a]
append [CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs]
forall (m :: * -> *) a. Monad m => [a] -> m [a]
trivFilt     E (TermLab fs)
l TermLab fs l
t EmptyInsertOkay
emp
runAction (DominatingAppendFirst  l :: E (TermLab fs)
l t :: TermLab fs l
t emp :: EmptyInsertOkay
emp) = Bool
-> (forall a. a -> [a] -> [a])
-> ([CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs])
-> E (TermLab fs)
-> TermLab fs l
-> EmptyInsertOkay
-> StateT (CfgInsertState fs l) m ()
forall (fs :: [(* -> *) -> * -> *]) l (m :: * -> *).
(Monad m, All HFunctor fs, InsertAt fs l) =>
Bool
-> (forall a. a -> [a] -> [a])
-> ([CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs])
-> E (TermLab fs)
-> TermLab fs l
-> EmptyInsertOkay
-> StateT (CfgInsertState fs l) m ()
dominatingInsert Bool
False (:)    [CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs]
forall (m :: * -> *) a. Monad m => [a] -> m [a]
trivFilt     E (TermLab fs)
l TermLab fs l
t EmptyInsertOkay
emp
runAction (DominatingAppendLast   l :: E (TermLab fs)
l t :: TermLab fs l
t emp :: EmptyInsertOkay
emp) = Bool
-> (forall a. a -> [a] -> [a])
-> ([CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs])
-> E (TermLab fs)
-> TermLab fs l
-> EmptyInsertOkay
-> StateT (CfgInsertState fs l) m ()
forall (fs :: [(* -> *) -> * -> *]) l (m :: * -> *).
(Monad m, All HFunctor fs, InsertAt fs l) =>
Bool
-> (forall a. a -> [a] -> [a])
-> ([CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs])
-> E (TermLab fs)
-> TermLab fs l
-> EmptyInsertOkay
-> StateT (CfgInsertState fs l) m ()
dominatingInsert Bool
False forall a. a -> [a] -> [a]
append [CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs]
forall (m :: * -> *) a. Monad m => [a] -> m [a]
trivFilt     E (TermLab fs)
l TermLab fs l
t EmptyInsertOkay
emp
runAction (FirstPredPrependLast   l :: E (TermLab fs)
l t :: TermLab fs l
t emp :: EmptyInsertOkay
emp) = Bool
-> (forall a. a -> [a] -> [a])
-> ([CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs])
-> E (TermLab fs)
-> TermLab fs l
-> EmptyInsertOkay
-> StateT (CfgInsertState fs l) m ()
forall (fs :: [(* -> *) -> * -> *]) l (m :: * -> *).
(Monad m, All HFunctor fs, InsertAt fs l) =>
Bool
-> (forall a. a -> [a] -> [a])
-> ([CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs])
-> E (TermLab fs)
-> TermLab fs l
-> EmptyInsertOkay
-> StateT (CfgInsertState fs l) m ()
dominatingInsert Bool
True  forall a. a -> [a] -> [a]
append [CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs]
forall (fs :: [(* -> *) -> * -> *]) l (m :: * -> *).
MonadState (CfgInsertState fs l) m =>
[CfgNode fs] -> m [CfgNode fs]
firstNode    E (TermLab fs)
l TermLab fs l
t EmptyInsertOkay
emp
runAction (RestPredPrependLast    l :: E (TermLab fs)
l t :: TermLab fs l
t emp :: EmptyInsertOkay
emp) = Bool
-> (forall a. a -> [a] -> [a])
-> ([CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs])
-> E (TermLab fs)
-> TermLab fs l
-> EmptyInsertOkay
-> StateT (CfgInsertState fs l) m ()
forall (fs :: [(* -> *) -> * -> *]) l (m :: * -> *).
(Monad m, All HFunctor fs, InsertAt fs l) =>
Bool
-> (forall a. a -> [a] -> [a])
-> ([CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs])
-> E (TermLab fs)
-> TermLab fs l
-> EmptyInsertOkay
-> StateT (CfgInsertState fs l) m ()
dominatingInsert Bool
True  forall a. a -> [a] -> [a]
append [CfgNode fs] -> StateT (CfgInsertState fs l) m [CfgNode fs]
forall (fs :: [(* -> *) -> * -> *]) l (m :: * -> *).
MonadState (CfgInsertState fs l) m =>
[CfgNode fs] -> m [CfgNode fs]
butFirstNode E (TermLab fs)
l TermLab fs l
t EmptyInsertOkay
emp


-- NOTE: I think this should be refactored so that there's just one kind of
-- append/prepend action, with many options
class (Monad m) => MonadCfgInsertion m fs l where
  dominatingPrependFirstOpts :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
  dominatingPrependLastOpts  :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
  dominatingAppendFirstOpts  :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
  dominatingAppendLastOpts   :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
  firstPredPrependLastOpts   :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
  restPredPrependLastOpts    :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()

  dominatingPrependFirst :: TermLab fs i -> TermLab fs l -> m ()
  dominatingPrependFirst t :: TermLab fs i
t x :: TermLab fs l
x = TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
dominatingPrependFirstOpts TermLab fs i
t TermLab fs l
x EmptyInsertOkay
EmptyInsertNotOkay

  dominatingPrependLast :: TermLab fs i -> TermLab fs l -> m ()
  dominatingPrependLast t :: TermLab fs i
t x :: TermLab fs l
x = TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
dominatingPrependLastOpts TermLab fs i
t TermLab fs l
x EmptyInsertOkay
EmptyInsertNotOkay

  dominatingAppendFirst :: TermLab fs i -> TermLab fs l -> m ()
  dominatingAppendFirst t :: TermLab fs i
t x :: TermLab fs l
x = TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
dominatingAppendFirstOpts TermLab fs i
t TermLab fs l
x EmptyInsertOkay
EmptyInsertNotOkay

  dominatingAppendLast :: TermLab fs i -> TermLab fs l -> m ()
  dominatingAppendLast t :: TermLab fs i
t x :: TermLab fs l
x = TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
dominatingAppendLastOpts TermLab fs i
t TermLab fs l
x EmptyInsertOkay
EmptyInsertNotOkay

  firstPredPrependLast :: TermLab fs i -> TermLab fs l -> m ()
  firstPredPrependLast t :: TermLab fs i
t x :: TermLab fs l
x = TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
firstPredPrependLastOpts TermLab fs i
t TermLab fs l
x EmptyInsertOkay
EmptyInsertNotOkay

  restPredPrependLast :: TermLab fs i -> TermLab fs l -> m ()
  restPredPrependLast t :: TermLab fs i
t x :: TermLab fs l
x = TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
restPredPrependLastOpts TermLab fs i
t TermLab fs l
x EmptyInsertOkay
EmptyInsertNotOkay


instance (Monad m) => MonadCfgInsertion (CfgInserterT fs l m) fs l where
  dominatingPrependFirstOpts :: TermLab fs i
-> TermLab fs l -> EmptyInsertOkay -> CfgInserterT fs l m ()
dominatingPrependFirstOpts t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = [Action fs l] -> CfgInserterT fs l m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [E (TermLab fs) -> TermLab fs l -> EmptyInsertOkay -> Action fs l
forall (fs :: [(* -> *) -> * -> *]) l.
E (TermLab fs) -> TermLab fs l -> EmptyInsertOkay -> Action fs l
DominatingPrependFirst (TermLab fs i -> E (TermLab fs)
forall (f :: * -> *) i. f i -> E f
E TermLab fs i
t) TermLab fs l
x EmptyInsertOkay
emp]
  dominatingPrependLastOpts :: TermLab fs i
-> TermLab fs l -> EmptyInsertOkay -> CfgInserterT fs l m ()
dominatingPrependLastOpts  t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = [Action fs l] -> CfgInserterT fs l m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [E (TermLab fs) -> TermLab fs l -> EmptyInsertOkay -> Action fs l
forall (fs :: [(* -> *) -> * -> *]) l.
E (TermLab fs) -> TermLab fs l -> EmptyInsertOkay -> Action fs l
DominatingPrependLast  (TermLab fs i -> E (TermLab fs)
forall (f :: * -> *) i. f i -> E f
E TermLab fs i
t) TermLab fs l
x EmptyInsertOkay
emp]
  dominatingAppendFirstOpts :: TermLab fs i
-> TermLab fs l -> EmptyInsertOkay -> CfgInserterT fs l m ()
dominatingAppendFirstOpts  t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = [Action fs l] -> CfgInserterT fs l m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [E (TermLab fs) -> TermLab fs l -> EmptyInsertOkay -> Action fs l
forall (fs :: [(* -> *) -> * -> *]) l.
E (TermLab fs) -> TermLab fs l -> EmptyInsertOkay -> Action fs l
DominatingAppendFirst  (TermLab fs i -> E (TermLab fs)
forall (f :: * -> *) i. f i -> E f
E TermLab fs i
t) TermLab fs l
x EmptyInsertOkay
emp]
  dominatingAppendLastOpts :: TermLab fs i
-> TermLab fs l -> EmptyInsertOkay -> CfgInserterT fs l m ()
dominatingAppendLastOpts   t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = [Action fs l] -> CfgInserterT fs l m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [E (TermLab fs) -> TermLab fs l -> EmptyInsertOkay -> Action fs l
forall (fs :: [(* -> *) -> * -> *]) l.
E (TermLab fs) -> TermLab fs l -> EmptyInsertOkay -> Action fs l
DominatingAppendLast   (TermLab fs i -> E (TermLab fs)
forall (f :: * -> *) i. f i -> E f
E TermLab fs i
t) TermLab fs l
x EmptyInsertOkay
emp]
  firstPredPrependLastOpts :: TermLab fs i
-> TermLab fs l -> EmptyInsertOkay -> CfgInserterT fs l m ()
firstPredPrependLastOpts   t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = [Action fs l] -> CfgInserterT fs l m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [E (TermLab fs) -> TermLab fs l -> EmptyInsertOkay -> Action fs l
forall (fs :: [(* -> *) -> * -> *]) l.
E (TermLab fs) -> TermLab fs l -> EmptyInsertOkay -> Action fs l
FirstPredPrependLast   (TermLab fs i -> E (TermLab fs)
forall (f :: * -> *) i. f i -> E f
E TermLab fs i
t) TermLab fs l
x EmptyInsertOkay
emp]
  restPredPrependLastOpts :: TermLab fs i
-> TermLab fs l -> EmptyInsertOkay -> CfgInserterT fs l m ()
restPredPrependLastOpts    t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = [Action fs l] -> CfgInserterT fs l m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [E (TermLab fs) -> TermLab fs l -> EmptyInsertOkay -> Action fs l
forall (fs :: [(* -> *) -> * -> *]) l.
E (TermLab fs) -> TermLab fs l -> EmptyInsertOkay -> Action fs l
RestPredPrependLast    (TermLab fs i -> E (TermLab fs)
forall (f :: * -> *) i. f i -> E f
E TermLab fs i
t) TermLab fs l
x EmptyInsertOkay
emp]

instance (MonadCfgInsertion m fs l) => MonadCfgInsertion (MaybeT m) fs l where
  dominatingPrependFirstOpts :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> MaybeT m ()
dominatingPrependFirstOpts t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = m () -> MaybeT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> MaybeT m ()) -> m () -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
dominatingPrependFirstOpts TermLab fs i
t TermLab fs l
x EmptyInsertOkay
emp
  dominatingPrependLastOpts :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> MaybeT m ()
dominatingPrependLastOpts  t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = m () -> MaybeT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> MaybeT m ()) -> m () -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
dominatingPrependLastOpts  TermLab fs i
t TermLab fs l
x EmptyInsertOkay
emp
  dominatingAppendFirstOpts :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> MaybeT m ()
dominatingAppendFirstOpts  t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = m () -> MaybeT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> MaybeT m ()) -> m () -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
dominatingAppendFirstOpts  TermLab fs i
t TermLab fs l
x EmptyInsertOkay
emp
  dominatingAppendLastOpts :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> MaybeT m ()
dominatingAppendLastOpts   t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = m () -> MaybeT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> MaybeT m ()) -> m () -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
dominatingAppendLastOpts   TermLab fs i
t TermLab fs l
x EmptyInsertOkay
emp
  firstPredPrependLastOpts :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> MaybeT m ()
firstPredPrependLastOpts   t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = m () -> MaybeT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> MaybeT m ()) -> m () -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
firstPredPrependLastOpts   TermLab fs i
t TermLab fs l
x EmptyInsertOkay
emp
  restPredPrependLastOpts :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> MaybeT m ()
restPredPrependLastOpts    t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = m () -> MaybeT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> MaybeT m ()) -> m () -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
restPredPrependLastOpts    TermLab fs i
t TermLab fs l
x EmptyInsertOkay
emp

instance (MonadCfgInsertion m fs l) => MonadCfgInsertion (ReaderT s m) fs l where
  dominatingPrependFirstOpts :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> ReaderT s m ()
dominatingPrependFirstOpts t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = m () -> ReaderT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT s m ()) -> m () -> ReaderT s m ()
forall a b. (a -> b) -> a -> b
$ TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
dominatingPrependFirstOpts TermLab fs i
t TermLab fs l
x EmptyInsertOkay
emp
  dominatingPrependLastOpts :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> ReaderT s m ()
dominatingPrependLastOpts  t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = m () -> ReaderT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT s m ()) -> m () -> ReaderT s m ()
forall a b. (a -> b) -> a -> b
$ TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
dominatingPrependLastOpts  TermLab fs i
t TermLab fs l
x EmptyInsertOkay
emp
  dominatingAppendFirstOpts :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> ReaderT s m ()
dominatingAppendFirstOpts  t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = m () -> ReaderT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT s m ()) -> m () -> ReaderT s m ()
forall a b. (a -> b) -> a -> b
$ TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
dominatingAppendFirstOpts  TermLab fs i
t TermLab fs l
x EmptyInsertOkay
emp
  dominatingAppendLastOpts :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> ReaderT s m ()
dominatingAppendLastOpts   t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = m () -> ReaderT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT s m ()) -> m () -> ReaderT s m ()
forall a b. (a -> b) -> a -> b
$ TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
dominatingAppendLastOpts   TermLab fs i
t TermLab fs l
x EmptyInsertOkay
emp
  firstPredPrependLastOpts :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> ReaderT s m ()
firstPredPrependLastOpts   t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = m () -> ReaderT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT s m ()) -> m () -> ReaderT s m ()
forall a b. (a -> b) -> a -> b
$ TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
firstPredPrependLastOpts   TermLab fs i
t TermLab fs l
x EmptyInsertOkay
emp
  restPredPrependLastOpts :: TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> ReaderT s m ()
restPredPrependLastOpts    t :: TermLab fs i
t x :: TermLab fs l
x emp :: EmptyInsertOkay
emp = m () -> ReaderT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT s m ()) -> m () -> ReaderT s m ()
forall a b. (a -> b) -> a -> b
$ TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l i.
MonadCfgInsertion m fs l =>
TermLab fs i -> TermLab fs l -> EmptyInsertOkay -> m ()
restPredPrependLastOpts    TermLab fs i
t TermLab fs l
x EmptyInsertOkay
emp

finalizeInsertions ::
  forall fs m l.
  ( InsertAt fs l
  , MonadAnnotater Label m
  , All HTraversable fs
  , All HFoldable fs
  , All HFunctor fs
  ) => Map Label [InsertionOp fs l] -> GRewriteM m (TermLab fs)
finalizeInsertions :: Map Label [InsertionOp fs l] -> GRewriteM m (TermLab fs)
finalizeInsertions insertMap :: Map Label [InsertionOp fs l]
insertMap t :: TermLab fs l
t = (InsertionOp fs l -> m (TermLab fs l) -> m (TermLab fs l))
-> m (TermLab fs l) -> [InsertionOp fs l] -> m (TermLab fs l)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(InsertionOp p :: NodeEvaluationPoint
p x :: TermLab fs l
x) r :: m (TermLab fs l)
r -> m (TermLab fs l)
r m (TermLab fs l)
-> (TermLab fs l -> m (TermLab fs l)) -> m (TermLab fs l)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeEvaluationPoint
-> TermLab fs l -> TermLab fs l -> m (TermLab fs l)
forall (gs :: [(* -> *) -> * -> *]) l a (m :: * -> *) i.
(InsertAt gs l, MonadAnnotater a m) =>
NodeEvaluationPoint
-> AnnTerm a gs l -> AnnTerm a gs i -> m (AnnTerm a gs i)
insertAt NodeEvaluationPoint
p TermLab fs l
x) (TermLab fs l -> m (TermLab fs l)
forall (m :: * -> *) a. Monad m => a -> m a
return TermLab fs l
t) ([InsertionOp fs l] -> m (TermLab fs l))
-> m [InsertionOp fs l] -> m (TermLab fs l)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m [InsertionOp fs l]
insertions
  where
    insertions :: m [InsertionOp fs l]
    insertions :: m [InsertionOp fs l]
insertions = do
      let raw_list :: [InsertionOp fs l]
raw_list = Maybe [InsertionOp fs l] -> [InsertionOp fs l]
forall a. Maybe [a] -> [a]
collapseMaybeList (Maybe [InsertionOp fs l] -> [InsertionOp fs l])
-> Maybe [InsertionOp fs l] -> [InsertionOp fs l]
forall a b. (a -> b) -> a -> b
$ Label -> Map Label [InsertionOp fs l] -> Maybe [InsertionOp fs l]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (TermLab fs l -> Label
forall (f :: (* -> *) -> * -> *) a. Annotated f a => HFix f :=> a
getAnn TermLab fs l
t) Map Label [InsertionOp fs l]
insertMap

      -- Some things to be inserted will have their own insertions
      [InsertionOp fs l]
normalized <- (InsertionOp fs l -> m (InsertionOp fs l))
-> [InsertionOp fs l] -> m [InsertionOp fs l]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TermLab fs l -> m (TermLab fs l))
-> InsertionOp fs l -> m (InsertionOp fs l)
forall (fs :: [(* -> *) -> * -> *]) l (fs :: [(* -> *) -> * -> *])
       l.
Lens
  (InsertionOp fs l) (InsertionOp fs l) (TermLab fs l) (TermLab fs l)
insert_op_node ((TermLab fs l -> m (TermLab fs l))
 -> InsertionOp fs l -> m (InsertionOp fs l))
-> (TermLab fs l -> m (TermLab fs l))
-> InsertionOp fs l
-> m (InsertionOp fs l)
forall k (f :: k -> *) s (t :: k) a (b :: k).
LensLike f s t a b -> LensLike f s t a b
%%~ (GRewriteM m (TermLab fs) -> GRewriteM m (TermLab fs)
forall (m :: * -> *) (f :: (* -> *) -> * -> *) h (a :: * -> *).
(Monad m, HTraversable f) =>
GRewriteM m (Cxt h f a) -> GRewriteM m (Cxt h f a)
allbuR (Map Label [InsertionOp fs l] -> GRewriteM m (TermLab fs)
forall (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(InsertAt fs l, MonadAnnotater Label m, All HTraversable fs,
 All HFoldable fs, All HFunctor fs) =>
Map Label [InsertionOp fs l] -> GRewriteM m (TermLab fs)
finalizeInsertions Map Label [InsertionOp fs l]
insertMap))) [InsertionOp fs l]
raw_list

      -- For each eval point, do insertions in the order given. But, do the later eval points first.
      --
      -- We assume sortOn is a stable sort. The documentation is kinda weird on this point: it promises that sort
      -- is stable, and that sortOn is closely related to sort, but doesn't explicitly say that sortBy is stable,
      -- though it is today.
      -- I'll rely on the fact that there are many, many users of sortBy to constrain them to keep it stable.
      --
      -- This code makes a small sin: it assumes that repeated InsertAt's work better when applied back-to-front,
      -- which is not in the interface. But, maybe it should be: both current uses of inserting into the middle of
      -- a statement have this property for the same reason: inserting into point p preserves everything that happens
      -- before p.
      let sorted :: [InsertionOp fs l]
sorted = (InsertionOp fs l -> NodeEvaluationPoint)
-> [InsertionOp fs l] -> [InsertionOp fs l]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (InsertionOp fs l
-> Getting
     NodeEvaluationPoint (InsertionOp fs l) NodeEvaluationPoint
-> NodeEvaluationPoint
forall s a. s -> Getting a s a -> a
^. Getting NodeEvaluationPoint (InsertionOp fs l) NodeEvaluationPoint
forall (fs :: [(* -> *) -> * -> *]) l.
Lens' (InsertionOp fs l) NodeEvaluationPoint
insert_op_eval_point) [InsertionOp fs l]
normalized
      [InsertionOp fs l] -> m [InsertionOp fs l]
forall (m :: * -> *) a. Monad m => a -> m a
return [InsertionOp fs l]
sorted


performCfgInsertions ::
  ( MonadAnnotater Label m
  , InsertAt fs l
  , All HTraversable fs
  , All HFunctor fs
  , All HFoldable fs
  ) => Proxy l -> ProgInfo fs -> RewriteM (CfgInserterT fs l m) (TermLab fs) i -> RewriteM m (TermLab fs) i
performCfgInsertions :: Proxy l
-> ProgInfo fs
-> RewriteM (CfgInserterT fs l m) (TermLab fs) i
-> RewriteM m (TermLab fs) i
performCfgInsertions _ proginf :: ProgInfo fs
proginf f :: RewriteM (CfgInserterT fs l m) (TermLab fs) i
f t :: TermLab fs i
t = do
   (t' :: TermLab fs i
t', actions :: [Action fs l]
actions) <- WriterT [Action fs l] m (TermLab fs i)
-> m (TermLab fs i, [Action fs l])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (RewriteM (CfgInserterT fs l m) (TermLab fs) i
f TermLab fs i
t)
   CfgInsertState fs l
s <- StateT (CfgInsertState fs l) m ()
-> CfgInsertState fs l -> m (CfgInsertState fs l)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT ((Action fs l -> StateT (CfgInsertState fs l) m ())
-> [Action fs l] -> StateT (CfgInsertState fs l) m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Action fs l -> StateT (CfgInsertState fs l) m ()
forall (m :: * -> *) (fs :: [(* -> *) -> * -> *]) l.
(Monad m, InsertAt fs l, All HFunctor fs) =>
Action fs l -> StateT (CfgInsertState fs l) m ()
runAction [Action fs l]
actions) (Map Label [InsertionOp fs l] -> ProgInfo fs -> CfgInsertState fs l
forall (fs :: [(* -> *) -> * -> *]) l.
Map Label [InsertionOp fs l] -> ProgInfo fs -> CfgInsertState fs l
CfgInsertState Map Label [InsertionOp fs l]
forall k a. Map k a
Map.empty ProgInfo fs
proginf)
   GRewriteM m (TermLab fs) -> RewriteM m (TermLab fs) i
forall (m :: * -> *) (f :: (* -> *) -> * -> *) h (a :: * -> *).
(Monad m, HTraversable f) =>
GRewriteM m (Cxt h f a) -> GRewriteM m (Cxt h f a)
allbuR (Map Label [InsertionOp fs l] -> GRewriteM m (TermLab fs)
forall (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(InsertAt fs l, MonadAnnotater Label m, All HTraversable fs,
 All HFoldable fs, All HFunctor fs) =>
Map Label [InsertionOp fs l] -> GRewriteM m (TermLab fs)
finalizeInsertions (CfgInsertState fs l
s CfgInsertState fs l
-> Getting
     (Map Label [InsertionOp fs l])
     (CfgInsertState fs l)
     (Map Label [InsertionOp fs l])
-> Map Label [InsertionOp fs l]
forall s a. s -> Getting a s a -> a
^. Getting
  (Map Label [InsertionOp fs l])
  (CfgInsertState fs l)
  (Map Label [InsertionOp fs l])
forall (fs :: [(* -> *) -> * -> *]) l l.
Lens
  (CfgInsertState fs l)
  (CfgInsertState fs l)
  (Map Label [InsertionOp fs l])
  (Map Label [InsertionOp fs l])
pendingInsertions)) TermLab fs i
t'