1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
\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 implementiert.
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
-- | 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}
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}
|
