summaryrefslogtreecommitdiff
path: root/interactive-edit-lens
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2018-12-18 13:51:16 +0100
committerGregor Kleen <gkleen@yggdrasil.li>2018-12-18 13:51:16 +0100
commit46ae60eaca841b554ba20c6a2b7a15b43c12b4df (patch)
tree0bb06127a0e08e75f8be755f5a5dfb1702b627b6 /interactive-edit-lens
parentb0b18979d5ccd109d5a56937396acdeb85c857aa (diff)
downloadincremental-dfsts-46ae60eaca841b554ba20c6a2b7a15b43c12b4df.tar
incremental-dfsts-46ae60eaca841b554ba20c6a2b7a15b43c12b4df.tar.gz
incremental-dfsts-46ae60eaca841b554ba20c6a2b7a15b43c12b4df.tar.bz2
incremental-dfsts-46ae60eaca841b554ba20c6a2b7a15b43c12b4df.tar.xz
incremental-dfsts-46ae60eaca841b554ba20c6a2b7a15b43c12b4df.zip
Much ado about nothing
Diffstat (limited to 'interactive-edit-lens')
-rw-r--r--interactive-edit-lens/ChangeLog.md5
-rw-r--r--interactive-edit-lens/LICENSE30
-rw-r--r--interactive-edit-lens/Setup.hs2
-rw-r--r--interactive-edit-lens/package.yaml53
-rw-r--r--interactive-edit-lens/src/Interact.hs271
-rw-r--r--interactive-edit-lens/src/Interact/Types.hs120
-rw-r--r--interactive-edit-lens/src/Main.hs94
7 files changed, 575 insertions, 0 deletions
diff --git a/interactive-edit-lens/ChangeLog.md b/interactive-edit-lens/ChangeLog.md
new file mode 100644
index 0000000..8bae309
--- /dev/null
+++ b/interactive-edit-lens/ChangeLog.md
@@ -0,0 +1,5 @@
1# Revision history for edit-lens
2
3## 0.0.0.0
4
5* First version.
diff --git a/interactive-edit-lens/LICENSE b/interactive-edit-lens/LICENSE
new file mode 100644
index 0000000..4522849
--- /dev/null
+++ b/interactive-edit-lens/LICENSE
@@ -0,0 +1,30 @@
1Copyright (c) 2017, Gregor Kleen
2
3All rights reserved.
4
5Redistribution and use in source and binary forms, with or without
6modification, are permitted provided that the following conditions are met:
7
8 * Redistributions of source code must retain the above copyright
9 notice, this list of conditions and the following disclaimer.
10
11 * Redistributions in binary form must reproduce the above
12 copyright notice, this list of conditions and the following
13 disclaimer in the documentation and/or other materials provided
14 with the distribution.
15
16 * Neither the name of Gregor Kleen nor the names of other
17 contributors may be used to endorse or promote products derived
18 from this software without specific prior written permission.
19
20THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/interactive-edit-lens/Setup.hs b/interactive-edit-lens/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/interactive-edit-lens/Setup.hs
@@ -0,0 +1,2 @@
1import Distribution.Simple
2main = defaultMain
diff --git a/interactive-edit-lens/package.yaml b/interactive-edit-lens/package.yaml
new file mode 100644
index 0000000..9bc3ead
--- /dev/null
+++ b/interactive-edit-lens/package.yaml
@@ -0,0 +1,53 @@
1name: interactive-edit-lens
2version: 0.0.0.0
3license: BSD3
4license-file: LICENSE
5author: Gregor Kleen <aethoago@141.li>
6build-type: Simple
7extra-source-files:
8 - ChangeLog.md
9git: https://git.yggdrasil.li/gkleen/pub/bachelor-thesis
10
11default-extensions:
12 - RecordWildCards
13 - MultiParamTypeClasses
14 - FlexibleInstances
15 - FlexibleContexts
16 - FunctionalDependencies
17 - TupleSections
18 - TypeApplications
19 - ViewPatterns
20 - PatternSynonyms
21 - TypeFamilies
22 - TypeOperators
23 - MultiWayIf
24
25other-extensions:
26 - TemplateHaskell
27
28dependencies:
29 - base
30 - lens
31 - containers
32 - edit-lens
33 - brick
34 - vty
35 - text
36 - text-zipper
37 - dyre
38 - mtl
39 - transformers
40
41# ghc-options: [ -O2 ]
42
43library:
44 source-dirs: src
45 exposed-modules:
46 - Interact
47 - Interact.Types
48
49executables:
50 interact:
51 ghc-options: [ -threaded ]
52 source-dirs: src
53 main: Main.hs
diff --git a/interactive-edit-lens/src/Interact.hs b/interactive-edit-lens/src/Interact.hs
new file mode 100644
index 0000000..3aab5c2
--- /dev/null
+++ b/interactive-edit-lens/src/Interact.hs
@@ -0,0 +1,271 @@
1{-# LANGUAGE ScopedTypeVariables
2 , OverloadedStrings
3 #-}
4
5module Interact
6 ( interactiveEditLens
7 , module Interact.Types
8 , module Config.Dyre
9 ) where
10
11import Prelude hiding (init)
12
13import Interact.Types
14
15import Data.Text (Text)
16import qualified Data.Text as Text
17
18import Data.Text.Zipper
19
20import Data.Sequence (Seq)
21import qualified Data.Sequence as Seq
22
23import Control.Lens
24import Numeric.Lens
25import System.IO
26import Control.Monad
27import Control.Monad.RWS hiding (Last(..), (<>))
28import Control.Monad.Trans.Maybe
29import Control.Monad.Trans.Reader (runReaderT)
30
31import Data.Bool (bool)
32import Data.Tuple (swap)
33import Data.Maybe (fromMaybe)
34import Data.List (groupBy)
35import Data.Function (on)
36import Data.Char (isSpace)
37
38import Data.Foldable (Foldable(toList))
39
40import Brick hiding (on)
41import Brick.Focus
42import Brick.Widgets.Center
43import Brick.Widgets.Border
44import Graphics.Vty hiding (showCursor)
45
46import Config.Dyre
47
48import System.IO.Unsafe
49import Debug.Trace
50
51interactiveEditLens :: (Params (InteractConfig c) -> Params (InteractConfig c)) -> InteractConfig c -> IO ()
52interactiveEditLens f = wrapMain . f $ defaultParams
53 { projectName = "interact-edit-lens"
54 , showError = \s err -> s & compileError .~ Just err
55 , realMain = interactiveEditLens'
56 }
57
58interactiveEditLens' :: forall c. InteractConfig c -> IO ()
59interactiveEditLens' cfg@InteractConfig{..}
60 | Just err <- icfgCompileError
61 = hPutStrLn stderr err
62 | otherwise
63 = void . defaultMain app $! initialState &?~ do
64 let
65 a :: Lens' (InteractState c) (Last Validity, Last (Seq Char, Int), StringEdits Natural Char)
66 a = case icfgInitial of
67 InitialRight _ -> right
68 _other -> left
69 b :: Lens' (InteractState c) (Last Validity, Last (Seq Char, Int), StringEdits Natural Char)
70 b = case icfgInitial of
71 InitialRight _ -> left
72 _other -> right
73 dir :: InteractDirection
74 dir = case icfgInitial of
75 InitialRight _ -> PropagateLeft
76 _other -> PropagateRight
77 aDom :: Seq Char
78 (view charseq -> aDom) = case icfgInitial of
79 InitialRight t -> t
80 InitialLeft t -> t
81 InitialEmpty -> ""
82 doEdit $ divInit aDom & stringEdits . sePos %~ (fromIntegral :: Natural -> Integer)
83 -- a .= (Last Valid, Last (aDom, 0))
84 -- bEdit <- prop dir $ divInit aDom
85 -- (b %=) . maybe id (<>) <=< runMaybeT $ do
86 -- bDom <- use $ b . _2 . _Wrapped . _1
87 -- bDom' <- MaybeT . return $ bDom `apply` bEdit
88 -- return $ (Last Valid, Last (bDom', 0))
89 where
90 infix 1 &?~
91
92 (&?~) :: a -> RWS (InteractConfig c) () a b -> a
93 st &?~ act = (\(s, ()) -> s) $ execRWS act cfg st
94
95 actOn = (&?~)
96
97 initialState :: InteractState c
98 initialState = InteractState
99 { istComplement = ground icfgLens
100 , istLeft = (Last Valid, Last (init @(StringEdits Natural Char), 0), mempty)
101 , istRight = (Last Valid, Last (init @(StringEdits Natural Char), 0), mempty)
102 , istFocus = focusRing [LeftEditor, RightEditor] &
103 focusSetCurrent (case icfgInitial of InitialRight _ -> RightEditor; _other -> LeftEditor)
104 }
105
106 app :: InteractApp c
107 app = App{..}
108
109 appDraw :: InteractState c -> [Widget InteractName]
110 appDraw InteractState{..} = [ editors ]
111 where
112 editors = hBox
113 [ mbInvalid (withFocusRing istFocus renderEditor') (istLeft `WithName` LeftEditor)
114 , vBorder
115 , mbInvalid (withFocusRing istFocus renderEditor') (istRight `WithName` RightEditor)
116 ]
117 renderEditor' :: Bool -> (Seq Char, Int) `WithName` InteractName -> Widget InteractName
118 renderEditor' foc ((content, cPos) `WithName` n)
119 = txt (review charseq content)
120 & bool id (showCursor n cPos') foc
121 & visibleRegion cPos' (1, 1)
122 & viewport n Both
123 where
124 (cPrefix, _) = Seq.splitAt cPos content
125 newls = Seq.findIndicesR (== '\n') cPrefix
126 cPos' = case newls of
127 (p:_) -> Location (pred $ cPos - p, length newls)
128 [] -> Location (cPos, 0)
129 mbInvalid _ ((Last Invalid, _ , _) `WithName` _)
130 = txt "Invalid"
131 & border
132 & center
133 mbInvalid f ((Last Valid , Last x, _) `WithName` n) = f $ x `WithName` n
134
135 appHandleEvent :: InteractState c -> BrickEvent InteractName InteractEvent -> EventM InteractName (Next (InteractState c))
136 appHandleEvent st@InteractState{..} (VtyEvent ev) = case ev of
137 EvKey KEsc [] -> halt st
138 EvKey (KChar 'c') [MCtrl] -> halt st
139 EvKey (KChar '\t') [] -> continue $ st & focus %~ focusNext
140 EvKey KBackTab [] -> continue $ st & focus %~ focusPrev
141 EvKey (KChar 'a') [MCtrl] -> continue $ st &?~ doMove
142 (moveSplit (== '\n') $ \(c, (l, p)) -> if any (== '\n') (c l) || Seq.null (c l) then (pred l, 0) else (l, 0))
143 EvKey (KChar 'e') [MCtrl] -> continue $ st &?~ doMove
144 (moveSplit (== '\n') $ \(c, (l, p)) -> if any (== '\n') $ c l then (pred l, Seq.length . c $ pred l) else (l, Seq.length $ c l))
145 EvKey KLeft [MCtrl] -> continue $ st &?~ doMove
146 (moveSplit isSpace $ \(c, (l, _)) -> if any isSpace (c l) || Seq.null (c l) then (pred l, 0) else (l - 2, 0))
147 EvKey KRight [MCtrl] -> continue $ st &?~ doMove
148 (moveSplit isSpace $ \(c, (l, _)) -> if any isSpace $ c l then (succ l, 0) else (l + 2, 0))
149 EvKey KUp [MCtrl] -> continue $ st &?~ doMove
150 (moveSplit (== '\n') $ \(c, (l, p)) -> if any (== '\n') (c l) || Seq.null (c l) then (pred l, p) else (l - 2, p))
151 EvKey KDown [MCtrl] -> continue $ st &?~ doMove
152 (moveSplit (== '\n') $ \(c, (l, p)) -> if any (== '\n') (c l) then (succ l, p) else (l + 2, p))
153 EvKey KLeft [] -> continue $ st &?~ doMove moveLeft
154 EvKey KRight [] -> continue $ st &?~ doMove moveRight
155 EvKey KDel [] -> continue $ st &?~ doEdit (delete 0)
156 EvKey KBS [] -> continue . actOn st $ do
157 focused' <- preuse $ focused . _2 . _Wrapped
158 doEdit . delete $ -1
159 unless (maybe False ((==) <$> view _2 <*> view (_1 . to Seq.length)) focused') $
160 doMove moveLeft
161 EvKey (KChar c) [] -> continue . actOn st $ do
162 doEdit $ insert 0 c
163 doMove moveRight
164 EvKey KEnter [] -> continue . actOn st $ do
165 doEdit $ insert 0 '\n'
166 doMove moveRight
167 other -> suspendAndResume $ do
168 traceIO $ "Unhandled event:\n\t" ++ show other
169 return st
170 -- where
171 -- editorMovement f = continue $ st & focused . _Just . editContentsL %~ f
172 appHandleEvent st _ = continue st
173
174 doMove = zoom $ focused . _2 . _Wrapped
175
176 moveLeft, moveRight :: MonadState (Seq Char, Int) m => m ()
177 moveLeft = modify $ \now@(_, nowP) -> if
178 | nowP > 0 -> now & _2 %~ pred
179 | otherwise -> now
180 moveRight = modify $ \now@(contents, nowP) -> if
181 | nowP < length contents -> now & _2 %~ succ
182 | otherwise -> now
183
184 moveSplit :: MonadState (Seq Char, Int) m
185 => (Char -> Bool) -- ^ Separator predicate
186 -> (((Int -> Seq Char), (Int, Int)) -> (Int, Int)) -- ^ Move in split coordinates (e.g. @(line, charInLine)@) with access to the focused fragment
187 -> m ()
188 moveSplit splitPred relMove = modify $ \now@(toList -> contentsStr, nowP)
189 -> let splitContents = groupBy ((==) `on` splitPred) contentsStr
190 traceShow x y = flip seq y . unsafePerformIO . appendFile "interact.log" . (<> "\n\n") $ show x
191 (before, mCurrent, after) = snd . (\x -> traceShow (nowP, x) x) $ foldl go (0, ([], Nothing, [])) splitContents
192 go acc@(i, st) cGroup
193 | i <= nowP, nowP < i + length cGroup = (i + length cGroup, st & _2 .~ Just cGroup)
194 | i + length cGroup <= nowP = (i + length cGroup, st & _1 %~ (flip snoc cGroup))
195 | otherwise = (i + length cGroup, st & _3 %~ (flip snoc cGroup))
196 relPos = (length before, nowP - sum (map length before))
197 (newL, newS) = relMove (\i -> if 0 <= i && i < length splitContents then Seq.fromList $ splitContents !! i else Seq.empty, relPos)
198 newPos
199 | null splitContents
200 , newL /= 0 || newS /= 0 = (0, 0)
201 | newL >= length splitContents = (pred $ length splitContents, length $ last splitContents)
202 | newL < 0 = (0, 0)
203 | newS < 0 = (newL, 0)
204 | newS > length (splitContents !! newL) = (newL, length $ splitContents !! newL)
205 | otherwise = (newL, newS)
206 in now & _2 .~ sum (map length $ take (fst newPos) splitContents) + snd newPos
207
208 appStartEvent :: InteractState c -> EventM InteractName (InteractState c)
209 appStartEvent = return
210
211 appAttrMap :: InteractState c -> AttrMap
212 appAttrMap = const $ attrMap defAttr []
213
214 appChooseCursor :: InteractState c -> [CursorLocation InteractName] -> Maybe (CursorLocation InteractName)
215 appChooseCursor = focusRingCursor istFocus
216
217prop :: forall st cfg m.
218 ( MonadState st m
219 , MonadReader cfg m
220 , HasComplement st (Complement cfg)
221 , HasEditLens cfg (StringEdits Natural Char) (StringEdits Natural Char)
222 )
223 => InteractDirection -> StringEdits Natural Char -> m (StringEdits Natural Char)
224prop dir edits = do
225 propD <- case dir of
226 PropagateRight -> asks propR
227 PropagateLeft -> asks propL
228 (c, res) <- propD . (, edits) <$> use complement
229 unsafePerformIO . fmap return . appendFile "interact.log" . (<> "\n\n") $ show (edits, dir, res)
230 res <$ assign complement c
231
232doEdit :: forall m c.
233 ( MonadState (InteractState c) m
234 , MonadReader (InteractConfig c) m
235 )
236 => StringEdits Integer Char -> m ()
237doEdit relativeEdit = void . runMaybeT $ do
238 currentFocus <- MaybeT $ uses focus focusGetCurrent
239 let direction
240 | RightEditor <- currentFocus = PropagateLeft
241 | otherwise = PropagateRight
242 aL :: Lens' (InteractState c) (Last Validity, Last (Seq Char, Int), StringEdits Natural Char)
243 aL | PropagateRight <- direction = left
244 | PropagateLeft <- direction = right
245 bL :: Lens' (InteractState c) (Last Validity, Last (Seq Char, Int), StringEdits Natural Char)
246 bL | PropagateRight <- direction = right
247 | PropagateLeft <- direction = left
248 (aN, bN) = bool swap id (direction == PropagateRight) (LeftEditor, RightEditor)
249 currentZipper <- use $ aL . _2 . _Wrapped
250 let currentPos = currentZipper ^. _2
251 absoluteEdit <- MaybeT . return $ do
252 let minOffset = minimumOf (stringEdits . sePos) relativeEdit
253 guard $ maybe True (\o -> 0 <= currentPos + fromIntegral o) minOffset
254 return $ relativeEdit & stringEdits . sePos %~ (\n -> fromIntegral $ currentPos + fromIntegral n)
255 newContent <- MaybeT . return $ view _1 currentZipper `apply` absoluteEdit
256 let currentPos'
257 | currentPos < 0 = 0
258 | currentPos > length newContent = length newContent
259 | otherwise = currentPos
260 aL . _2 %= (<> Last (newContent, currentPos'))
261 absoluteEdit' <- uses (aL . _3) (absoluteEdit `mappend`)
262 bEdits <- prop direction absoluteEdit'
263 bDom <- use $ bL . _2 . _Wrapped . _1
264 case bDom `apply` bEdits of
265 Nothing -> do
266 bL . _1 %= (<> Last Invalid)
267 aL . _3 .= absoluteEdit'
268 Just bDom' -> do
269 bL . _1 %= (<> Last Valid)
270 bL . _2 . _Wrapped . _1 .= bDom'
271 aL . _3 .= mempty
diff --git a/interactive-edit-lens/src/Interact/Types.hs b/interactive-edit-lens/src/Interact/Types.hs
new file mode 100644
index 0000000..a4d08ac
--- /dev/null
+++ b/interactive-edit-lens/src/Interact/Types.hs
@@ -0,0 +1,120 @@
1{-# LANGUAGE TemplateHaskell #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3
4module Interact.Types
5 ( InteractName(..)
6 , _LeftEditor, _RightEditor, _PrimitiveName
7 , Validity, pattern Valid, pattern Invalid
8 , InteractState(..)
9 , HasLeft(..), HasRight(..), HasComplement(..), HasFocus(..), HasFocused(..)
10 , InteractInitial(..)
11 , _InitialLeft, _InitialRight, _InitialEmpty
12 , InteractConfig(..)
13 , HasInitial(..), HasLens(..), HasCompileError(..)
14 , InteractEvent
15 , InteractApp
16 , InteractDirection(..)
17 , charseq
18 , WithName(..)
19 , module Control.Edit
20 , module Control.Lens.Edit
21 , module Control.DFST.Lens
22 , module Data.Semigroup
23 , module Numeric.Natural
24 ) where
25
26import Data.Text (Text)
27import qualified Data.Text as Text
28import Data.Text.Lens
29
30import Data.Sequence (Seq(..))
31import qualified Data.Sequence as Seq
32
33import qualified Data.Foldable as Foldable
34
35import Data.Semigroup (Semigroup(..), Last(..))
36import Numeric.Natural
37
38import Brick
39import Brick.Focus
40import Brick.Widgets.Edit
41
42import Control.Lens
43import Control.Lens.TH
44import Control.Edit
45import Control.Lens.Edit
46import Control.DFST.Lens
47
48import Data.Text.Zipper.Generic
49
50
51data InteractName
52 = LeftEditor
53 | RightEditor
54 | PrimitiveName !Text
55 deriving (Eq, Ord, Show, Read)
56
57makePrisms ''InteractName
58
59type Validity = Bool
60pattern Valid = True
61pattern Invalid = False
62
63data InteractState c = InteractState
64 { istLeft, istRight :: (Last Validity, Last (Seq Char, Int), StringEdits Natural Char)
65 , istComplement :: c
66 , istFocus :: FocusRing InteractName
67 }
68
69makeLensesWith abbreviatedFields ''InteractState
70
71class HasFocused s a | s -> a where
72 focused :: Traversal' s a
73
74instance HasFocused (InteractState c) (Last Validity, Last (Seq Char, Int), StringEdits Natural Char) where
75 focused f st@InteractState{..} = case focusGetCurrent istFocus of
76 Just LeftEditor -> left f st
77 Just RightEditor -> right f st
78 _other -> pure st
79
80data InteractInitial
81 = InitialLeft Text
82 | InitialRight Text
83 | InitialEmpty
84 deriving (Eq, Ord, Show, Read)
85
86makePrisms ''InteractInitial
87
88data InteractConfig c = InteractConfig
89 { icfgInitial :: InteractInitial
90 , icfgLens :: EditLens c (StringEdits Natural Char) (StringEdits Natural Char)
91 , icfgCompileError :: Maybe String
92 }
93
94instance HasEditLens (InteractConfig c) (StringEdits Natural Char) (StringEdits Natural Char) where
95 type Complement (InteractConfig c) = c
96 ground = ground . icfgLens
97 propR = propR . icfgLens
98 propL = propL . icfgLens
99
100makeLensesWith abbreviatedFields ''InteractConfig
101
102charseq :: Iso' Text (Seq Char)
103charseq = iso Text.unpack Text.pack . iso Seq.fromList Foldable.toList
104
105type InteractEvent = ()
106
107type InteractApp c = App (InteractState c) InteractEvent InteractName
108
109data InteractDirection = PropagateLeft | PropagateRight
110 deriving (Eq, Ord, Enum, Bounded, Show, Read)
111
112makePrisms ''InteractDirection
113
114
115infixr 1 `WithName`
116data WithName x n = WithName x n
117 deriving (Eq, Ord, Show, Read)
118
119instance Named (x `WithName` n) n where
120 getName (_ `WithName` n) = n
diff --git a/interactive-edit-lens/src/Main.hs b/interactive-edit-lens/src/Main.hs
new file mode 100644
index 0000000..f7bc806
--- /dev/null
+++ b/interactive-edit-lens/src/Main.hs
@@ -0,0 +1,94 @@
1{-# LANGUAGE OverloadedStrings
2 , ExistentialQuantification
3 #-}
4
5module Main where
6
7import Interact
8import Control.DFST.Lens
9import Control.DFST
10
11import Data.Map (Map)
12import qualified Data.Map as Map
13
14import Data.Set (Set)
15import qualified Data.Set as Set
16
17import Data.Sequence (Seq)
18import qualified Data.Sequence as Seq
19
20import Data.Char
21
22import System.Environment
23import System.Exit
24
25import Debug.Trace
26
27data SomeDFST = forall state. (Ord state, Show state) => SomeDFST { someDFST :: DFST state Char Char }
28
29data JsonNewlState = JNUndeterminedStructure | JNOutsideStructure | JNInsideStructure | JNInsideString | JNEscape
30 deriving (Eq, Ord, Show, Read)
31
32dfstMap :: String -> Maybe SomeDFST
33dfstMap "double" = Just . SomeDFST $ DFST
34 { stInitial = ()
35 , stTransition = mconcat
36 [ Map.fromList
37 [(((), sym), ((), Seq.fromList [sym, sym])) | sym <- ['a'..'z'] ++ ['A'..'Z'] ++ ['!', ' ']] -- sym <- [minBound..maxBound], isPrint sym]
38 , Map.singleton ((), '\n') ((), Seq.singleton '\n')
39 ]
40 , stAccept = Set.singleton ()
41 }
42dfstMap "id" = Just . SomeDFST $ DFST
43 { stInitial = ()
44 , stTransition = Map.fromList
45 [(((), sym), ((), Seq.singleton sym)) | sym <- ['a'..'z'] ++ ['A'..'Z'] ++ ['!', ' ']] -- sym <- [minBound..maxBound], isPrint sym]
46 , stAccept = Set.singleton ()
47 }
48dfstMap "alternate" = Just . SomeDFST $ DFST
49 { stInitial = 0 :: Int
50 , stTransition = mconcat
51 [ Map.fromList [((0, sym), (1, Seq.singleton sym)) | sym <- ['a'..'z'] ++ ['A'..'Z'] ++ ['!', ' ']] -- sym <- [minBound..maxBound], isPrint sym]
52 , Map.fromList [((1, sym), (0, Seq.fromList [toUpper sym, toUpper sym])) | sym <- ['a'..'z'] ++ ['A'..'Z'] ++ ['!', ' ']] -- sym <- [minBound..maxBound], isPrint sym]
53 ]
54 , stAccept = Set.fromList [0]
55 }
56dfstMap "json-newl" = Just . SomeDFST $ DFST
57 { stInitial = JNOutsideStructure
58 , stTransition = mconcat
59 [ Map.fromList [((jnOutside, sym), (jnOutside, Seq.empty)) | sym <- whitespace, jnOutside <- [JNOutsideStructure, JNUndeterminedStructure]]
60 , Map.fromList [((jnOutside, sym), (JNInsideStructure, Seq.fromList [sym, ' '])) | sym <- "[{", jnOutside <- [JNOutsideStructure, JNInsideStructure, JNUndeterminedStructure]]
61 , Map.fromList [((JNInsideStructure, sym), (JNInsideStructure, Seq.empty)) | sym <- whitespace]
62 , Map.fromList [((jnInside, sym), (JNUndeterminedStructure, Seq.fromList ['\n', sym])) | sym <- "]}", jnInside <- [JNInsideStructure, JNUndeterminedStructure]]
63 , Map.fromList [((jnInside, ','), (JNInsideStructure, Seq.fromList "\n, ")) | jnInside <- [JNInsideStructure, JNUndeterminedStructure] ]
64 , Map.fromList [((jnInside, ':'), (JNInsideStructure, Seq.fromList " : ")) | jnInside <- [JNInsideStructure, JNUndeterminedStructure] ]
65 , Map.fromList [((jn, '"'), (JNInsideString, Seq.singleton '"')) | jn <- [JNUndeterminedStructure, JNInsideStructure]]
66 , Map.fromList [((JNInsideString, sym), (JNInsideString, Seq.singleton sym)) | sym <- ['a'..'z'] ++ ['A'..'Z'] ++ ",.!?: "]
67 , Map.singleton (JNInsideString, '"') (JNUndeterminedStructure, Seq.singleton '"')
68 , Map.singleton (JNInsideString, '\\') (JNEscape, Seq.singleton '\\')
69 , Map.singleton (JNEscape, '"') (JNInsideString, Seq.singleton '"')
70 ]
71 , stAccept = Set.fromList [JNOutsideStructure, JNUndeterminedStructure]
72 }
73 where
74 whitespace = toEnum <$> [0x0020, 0x0009, 0x000a, 0x000d]
75dfstMap _ = Nothing
76
77main :: IO ()
78main = do
79 args <- getArgs
80
81 dfst <- case args of
82 [name] | Just dfst <- dfstMap name
83 -> return dfst
84 _ -> exitWith $ ExitFailure 2
85
86 interactiveEditLens' dfst
87
88interactiveEditLens' :: SomeDFST -> IO ()
89interactiveEditLens' (SomeDFST dfst)
90 = interactiveEditLens id $ InteractConfig
91 { icfgInitial = InitialEmpty
92 , icfgLens = dfstLens dfst
93 , icfgCompileError = Nothing
94 }