diff options
Diffstat (limited to 'interactive-edit-lens')
-rw-r--r-- | interactive-edit-lens/ChangeLog.md | 5 | ||||
-rw-r--r-- | interactive-edit-lens/LICENSE | 30 | ||||
-rw-r--r-- | interactive-edit-lens/Setup.hs | 2 | ||||
-rw-r--r-- | interactive-edit-lens/package.yaml | 53 | ||||
-rw-r--r-- | interactive-edit-lens/src/Interact.hs | 271 | ||||
-rw-r--r-- | interactive-edit-lens/src/Interact/Types.hs | 120 | ||||
-rw-r--r-- | interactive-edit-lens/src/Main.hs | 94 |
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 @@ | |||
1 | Copyright (c) 2017, Gregor Kleen | ||
2 | |||
3 | All rights reserved. | ||
4 | |||
5 | Redistribution and use in source and binary forms, with or without | ||
6 | modification, 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 | |||
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | ||
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT | ||
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR | ||
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT | ||
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | ||
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | ||
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, | ||
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY | ||
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT | ||
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE | ||
30 | OF 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 @@ | |||
1 | import Distribution.Simple | ||
2 | main = 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 @@ | |||
1 | name: interactive-edit-lens | ||
2 | version: 0.0.0.0 | ||
3 | license: BSD3 | ||
4 | license-file: LICENSE | ||
5 | author: Gregor Kleen <aethoago@141.li> | ||
6 | build-type: Simple | ||
7 | extra-source-files: | ||
8 | - ChangeLog.md | ||
9 | git: https://git.yggdrasil.li/gkleen/pub/bachelor-thesis | ||
10 | |||
11 | default-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 | |||
25 | other-extensions: | ||
26 | - TemplateHaskell | ||
27 | |||
28 | dependencies: | ||
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 | |||
43 | library: | ||
44 | source-dirs: src | ||
45 | exposed-modules: | ||
46 | - Interact | ||
47 | - Interact.Types | ||
48 | |||
49 | executables: | ||
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 | |||
5 | module Interact | ||
6 | ( interactiveEditLens | ||
7 | , module Interact.Types | ||
8 | , module Config.Dyre | ||
9 | ) where | ||
10 | |||
11 | import Prelude hiding (init) | ||
12 | |||
13 | import Interact.Types | ||
14 | |||
15 | import Data.Text (Text) | ||
16 | import qualified Data.Text as Text | ||
17 | |||
18 | import Data.Text.Zipper | ||
19 | |||
20 | import Data.Sequence (Seq) | ||
21 | import qualified Data.Sequence as Seq | ||
22 | |||
23 | import Control.Lens | ||
24 | import Numeric.Lens | ||
25 | import System.IO | ||
26 | import Control.Monad | ||
27 | import Control.Monad.RWS hiding (Last(..), (<>)) | ||
28 | import Control.Monad.Trans.Maybe | ||
29 | import Control.Monad.Trans.Reader (runReaderT) | ||
30 | |||
31 | import Data.Bool (bool) | ||
32 | import Data.Tuple (swap) | ||
33 | import Data.Maybe (fromMaybe) | ||
34 | import Data.List (groupBy) | ||
35 | import Data.Function (on) | ||
36 | import Data.Char (isSpace) | ||
37 | |||
38 | import Data.Foldable (Foldable(toList)) | ||
39 | |||
40 | import Brick hiding (on) | ||
41 | import Brick.Focus | ||
42 | import Brick.Widgets.Center | ||
43 | import Brick.Widgets.Border | ||
44 | import Graphics.Vty hiding (showCursor) | ||
45 | |||
46 | import Config.Dyre | ||
47 | |||
48 | import System.IO.Unsafe | ||
49 | import Debug.Trace | ||
50 | |||
51 | interactiveEditLens :: (Params (InteractConfig c) -> Params (InteractConfig c)) -> InteractConfig c -> IO () | ||
52 | interactiveEditLens f = wrapMain . f $ defaultParams | ||
53 | { projectName = "interact-edit-lens" | ||
54 | , showError = \s err -> s & compileError .~ Just err | ||
55 | , realMain = interactiveEditLens' | ||
56 | } | ||
57 | |||
58 | interactiveEditLens' :: forall c. InteractConfig c -> IO () | ||
59 | interactiveEditLens' 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 | |||
217 | prop :: 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) | ||
224 | prop 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 | |||
232 | doEdit :: forall m c. | ||
233 | ( MonadState (InteractState c) m | ||
234 | , MonadReader (InteractConfig c) m | ||
235 | ) | ||
236 | => StringEdits Integer Char -> m () | ||
237 | doEdit 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 | |||
4 | module 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 | |||
26 | import Data.Text (Text) | ||
27 | import qualified Data.Text as Text | ||
28 | import Data.Text.Lens | ||
29 | |||
30 | import Data.Sequence (Seq(..)) | ||
31 | import qualified Data.Sequence as Seq | ||
32 | |||
33 | import qualified Data.Foldable as Foldable | ||
34 | |||
35 | import Data.Semigroup (Semigroup(..), Last(..)) | ||
36 | import Numeric.Natural | ||
37 | |||
38 | import Brick | ||
39 | import Brick.Focus | ||
40 | import Brick.Widgets.Edit | ||
41 | |||
42 | import Control.Lens | ||
43 | import Control.Lens.TH | ||
44 | import Control.Edit | ||
45 | import Control.Lens.Edit | ||
46 | import Control.DFST.Lens | ||
47 | |||
48 | import Data.Text.Zipper.Generic | ||
49 | |||
50 | |||
51 | data InteractName | ||
52 | = LeftEditor | ||
53 | | RightEditor | ||
54 | | PrimitiveName !Text | ||
55 | deriving (Eq, Ord, Show, Read) | ||
56 | |||
57 | makePrisms ''InteractName | ||
58 | |||
59 | type Validity = Bool | ||
60 | pattern Valid = True | ||
61 | pattern Invalid = False | ||
62 | |||
63 | data InteractState c = InteractState | ||
64 | { istLeft, istRight :: (Last Validity, Last (Seq Char, Int), StringEdits Natural Char) | ||
65 | , istComplement :: c | ||
66 | , istFocus :: FocusRing InteractName | ||
67 | } | ||
68 | |||
69 | makeLensesWith abbreviatedFields ''InteractState | ||
70 | |||
71 | class HasFocused s a | s -> a where | ||
72 | focused :: Traversal' s a | ||
73 | |||
74 | instance 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 | |||
80 | data InteractInitial | ||
81 | = InitialLeft Text | ||
82 | | InitialRight Text | ||
83 | | InitialEmpty | ||
84 | deriving (Eq, Ord, Show, Read) | ||
85 | |||
86 | makePrisms ''InteractInitial | ||
87 | |||
88 | data InteractConfig c = InteractConfig | ||
89 | { icfgInitial :: InteractInitial | ||
90 | , icfgLens :: EditLens c (StringEdits Natural Char) (StringEdits Natural Char) | ||
91 | , icfgCompileError :: Maybe String | ||
92 | } | ||
93 | |||
94 | instance 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 | |||
100 | makeLensesWith abbreviatedFields ''InteractConfig | ||
101 | |||
102 | charseq :: Iso' Text (Seq Char) | ||
103 | charseq = iso Text.unpack Text.pack . iso Seq.fromList Foldable.toList | ||
104 | |||
105 | type InteractEvent = () | ||
106 | |||
107 | type InteractApp c = App (InteractState c) InteractEvent InteractName | ||
108 | |||
109 | data InteractDirection = PropagateLeft | PropagateRight | ||
110 | deriving (Eq, Ord, Enum, Bounded, Show, Read) | ||
111 | |||
112 | makePrisms ''InteractDirection | ||
113 | |||
114 | |||
115 | infixr 1 `WithName` | ||
116 | data WithName x n = WithName x n | ||
117 | deriving (Eq, Ord, Show, Read) | ||
118 | |||
119 | instance 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 | |||
5 | module Main where | ||
6 | |||
7 | import Interact | ||
8 | import Control.DFST.Lens | ||
9 | import Control.DFST | ||
10 | |||
11 | import Data.Map (Map) | ||
12 | import qualified Data.Map as Map | ||
13 | |||
14 | import Data.Set (Set) | ||
15 | import qualified Data.Set as Set | ||
16 | |||
17 | import Data.Sequence (Seq) | ||
18 | import qualified Data.Sequence as Seq | ||
19 | |||
20 | import Data.Char | ||
21 | |||
22 | import System.Environment | ||
23 | import System.Exit | ||
24 | |||
25 | import Debug.Trace | ||
26 | |||
27 | data SomeDFST = forall state. (Ord state, Show state) => SomeDFST { someDFST :: DFST state Char Char } | ||
28 | |||
29 | data JsonNewlState = JNUndeterminedStructure | JNOutsideStructure | JNInsideStructure | JNInsideString | JNEscape | ||
30 | deriving (Eq, Ord, Show, Read) | ||
31 | |||
32 | dfstMap :: String -> Maybe SomeDFST | ||
33 | dfstMap "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 | } | ||
42 | dfstMap "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 | } | ||
48 | dfstMap "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 | } | ||
56 | dfstMap "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] | ||
75 | dfstMap _ = Nothing | ||
76 | |||
77 | main :: IO () | ||
78 | main = 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 | |||
88 | interactiveEditLens' :: SomeDFST -> IO () | ||
89 | interactiveEditLens' (SomeDFST dfst) | ||
90 | = interactiveEditLens id $ InteractConfig | ||
91 | { icfgInitial = InitialEmpty | ||
92 | , icfgLens = dfstLens dfst | ||
93 | , icfgCompileError = Nothing | ||
94 | } | ||