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 | } | ||
