\begin{comment}
\begin{code}
{-# LANGUAGE ScopedTypeVariables
           , TypeApplications
           , TypeFamilyDependencies
  #-}

module Control.Lens.Edit.ActionTree
  ( Action(..)
  , treeLens
  ) where

import Control.Edit
import Control.Edit.String
import Control.Edit.String.Affected
import Control.Lens.Edit

import Control.Lens

import Numeric.Natural
import Numeric.Interval (Interval, (...))
import qualified Numeric.Interval as Int

import Data.Compositions (Compositions)
import qualified Data.Compositions as Comp

import Data.Algorithm.Diff (Diff, getDiff)
import qualified Data.Algorithm.Diff as Diff

import Data.Sequence (Seq((:<|), (:|>)))
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set

import Data.Monoid
import Data.Function (on)
import Data.Foldable (toList)
import Data.Maybe (fromMaybe)

import System.IO (Handle, hPutStrLn, IOMode(AppendMode), withFile)
import System.IO.Unsafe
\end{code}
\end{comment}

Das beschrieben Verfahren wurde prinzipiell agnostisch in Bezug auf die konkret gewählte Parser-Konstruktion gewählt.

Hierfür wurden die benötigten Operationen auf der DFST-Wirkung und das in $\Lleftarrow$ verwendete Suchschema abstrakt als Typklasse angegeben:

\begin{code}
class Monoid action => Action action input output | action -> input, action -> output where
\end{code}
\begin{comment}
\begin{code}
  -- | Most operations of `Action` permit access to some underlying description of the parser (i.e. an automaton)
  type ActionParam action = param | param -> action

  -- | A full capture of the Parser-State (i.e. a state for a given automaton)
  type ActionState action :: *

  -- | `mempty` should be neutral under `(<>)`, `actionFail` should be absorptive
  actionFail :: action

  -- | Construct an @action@ from a single character of input
  actionSingleInput :: ActionParam action -> input -> action
  -- | Initial state of the parser
  actionGroundState :: ActionParam action -> ActionState action
  -- | Is a certain state acceptable as final?
  actionStateFinal :: ActionParam action -> ActionState action -> Bool
  -- | Run an @action@ (actually a binary tree thereof, use `Comp.composed` to extract the root) on a given state
  actionState :: ActionParam action -> Compositions action -> ActionState action -> Maybe (ActionState action)
  -- | What @output@ does running an @action@ on a given state produce?
  actionProduces :: ActionParam action -> Compositions action -> ActionState action -> Seq output
  -- | What @input@ does running an @action@ on a given state consume?
  actionConsumes :: ActionParam action -> Compositions action -> Seq input

  -- | Find a new string of @input@-symbols to travel between the given states while producing exactly the given @output@
  --
  -- @actionFindPath@ also has access to the remaining action to be run after it's new @input@ has been consumed.
  -- This is necessary to further restrict the considered paths in such a way that the resulting run as a whole is acceptable in the sense of `actionStateFinal`.
  actionFindPath :: ActionParam action
                 -> ActionState action -- ^ From
                 -> Seq output -- ^ New output to be produced
                 -> ActionState action -- ^ To
                 -> Compositions action -- ^ Suffix
                 -> Maybe (Seq input)
\end{code}
\end{comment}

Das Verfahren kann nun auf andere Sorten von Parser angewendet werden, indem nur die oben aufgeführte \texttt{Action}-Typklasse implementiert wird:

\begin{code}
treeLens :: forall action input output.
            ( Ord input, Ord output
            , Show input, Show output
            , Action action input output
            , Show (ActionState action)
            ) => ActionParam action -> EditLens (Compositions action) (StringEdits Natural input) (StringEdits Natural output)
\end{code}
\begin{comment}
\begin{code}
treeLens param = EditLens ground propR propL
  where
    ground :: Compositions action
    ground = mempty

    propR :: (Compositions action, StringEdits Natural input)
          -> (Compositions action, StringEdits Natural output)
    propR (c, SEFail) = (c, SEFail)
    propR (c, StringEdits Seq.Empty) = (c, mempty)
    propR (c, lEs@(StringEdits (es :> e)))
      | Just final <- actionState param c' $ actionGroundState @action param
      , actionStateFinal param final
      = (c', rEs)
      | otherwise
      = (c, SEFail)
      where
        Just int = affected lEs
        (cAffSuffix, cAffPrefix) = Comp.splitAt (Comp.length c - fromIntegral (Int.inf int)) c
        (cSuffix, cPrefix) = Comp.splitAt (Comp.length c - (e ^. sePos . from enum)) c
        cSuffix'
          | Delete _       <- e
          , Comp.length cSuffix > 0 = Comp.take (pred $ Comp.length cSuffix) cSuffix
          | Insert _ nChar <- e = cSuffix <> Comp.singleton (actionSingleInput param nChar)
          | otherwise = Comp.singleton actionFail
        (c', _) = propR (cSuffix' <> cPrefix, StringEdits es)
        (cAffSuffix', _) = Comp.splitAt (Comp.length c' - Comp.length cAffPrefix) c'
        Just pFinal = actionState param cAffPrefix $ actionGroundState @action param
        rEs = strDiff (actionProduces param cAffSuffix pFinal) (actionProduces param cAffSuffix' pFinal) & stringEdits . sePos . from enum +~ length (actionProduces param cAffPrefix $ actionGroundState @action param)

    propL :: (Compositions action, StringEdits Natural output)
          -> (Compositions action, StringEdits Natural input)
    propL (c, StringEdits Seq.Empty) = (c, mempty)
    propL (c, es) = fromMaybe (c, SEFail) $ do
      -- Determine states @(iState, fState)@ at the boundary of the region affected by @es@
      ((,) <$> Int.inf <*> Int.sup -> (minAff, maxAff)) <- affected es
      trace (show (minAff, maxAff)) $ Just ()
      let
        prevTrans :: Natural -> Maybe ( Compositions action {- Run after chosen transition to accepting state -}
                                      , (ActionState action, input, Seq output, ActionState action)
                                      , Compositions action {- Run from `stInitial` up to chosen transition -}
                                      )
        -- ^ Given an index in the output, find the associated transition in @c@
        prevTrans needle = do
          let (after, before) = prevTrans' (c, mempty)
          transSt <- actionState param before $ actionGroundState @action param
          trace ("transSt = " ++ show transSt) $ Just ()
          let (after', trans) = Comp.splitAt (pred $ Comp.length after) after
          [inS] <- return . toList $ actionConsumes param trans
          Just postTransSt <- return $ actionState param trans transSt
          outSs <- return $ actionProduces param trans transSt
          return (after', (transSt, inS, outSs, postTransSt), before)
          where
            -- | Move monoid summands from @after@ to @before@ until first transition of @after@ produces @needle@ or @after@ is a singleton
            prevTrans' :: (Compositions action, Compositions action)
                       -> (Compositions action, Compositions action)
            prevTrans' (after, before)
              | producedNext > needle = (after, before)
              | Comp.length after == 1 = (after, before)
              | otherwise = prevTrans' (after', before')
              where
                producedNext = fromIntegral . Seq.length . traceShowId . actionProduces param before' $ actionGroundState @action param
                (after', nextTrans) = Comp.splitAt (pred $ Comp.length after) after
                before' = nextTrans `mappend` before
      (_, (iState, _, _, _), prefix) <- prevTrans minAff 
      trace (show (iState, Comp.length prefix)) $ Just ()
      (suffix, (pfState, _, _, fState), _) <- prevTrans maxAff
      trace (show (pfState, fState, Comp.length suffix)) $ Just ()

      newOut <- actionProduces param c (actionGroundState @action param) `apply` es
      let affNewOut = (\s -> Seq.take (Seq.length s - Seq.length (actionProduces param suffix fState)) s) $ Seq.drop (Seq.length . actionProduces param prefix $ actionGroundState @action param) newOut
      trace (show (iState, fState, affNewOut)) $ Just ()

      newIn <- actionFindPath param iState affNewOut fState suffix 

      let oldIn = actionConsumes param . Comp.drop (Comp.length suffix) $ Comp.take (Comp.length c - Comp.length prefix) c
          inDiff = oldIn `strDiff` newIn
          diffOffset = fromIntegral . Seq.length $ actionConsumes param prefix
          inDiff' = inDiff & stringEdits . sePos +~ diffOffset

      trace (show (oldIn, newIn, inDiff')) $ Just ()

      let affComp = Comp.fromList $ actionSingleInput param <$> toList newIn
  
      return (suffix <> affComp <> prefix, inDiff')


strDiff :: forall sym pos. (Eq sym, Integral pos) => Seq sym -> Seq sym -> StringEdits pos sym
-- ^ @strDiff a b@ calculates a set of edits, which, when applied to @a@, produce @b@
strDiff a b = snd . foldl toEdit (0, mempty) $ (getDiff `on` toList) a b
  where
    toEdit :: (pos, StringEdits pos sym) -> Diff sym -> (pos, StringEdits pos sym)
    toEdit (n, es) (Diff.Both _ _) = (succ n, es)
    toEdit (n, es) (Diff.First _ ) = (n, delete n <> es)
    toEdit (n, es) (Diff.Second c) = (succ n, insert n c <> es)

trace :: String -> a -> a
{-# NOINLINE trace #-}
trace str y = flip seq y . unsafePerformIO . withFile "lens.log" AppendMode $ \h ->
  hPutStrLn h str

traceShowId :: Show a => a -> a
traceShowId x = trace (show x) x
\end{code}
\end{comment}