From 46ae60eaca841b554ba20c6a2b7a15b43c12b4df Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 18 Dec 2018 13:51:16 +0100 Subject: Much ado about nothing --- interactive-edit-lens/src/Interact.hs | 271 ++++++++++++++++++++++++++++ interactive-edit-lens/src/Interact/Types.hs | 120 ++++++++++++ interactive-edit-lens/src/Main.hs | 94 ++++++++++ 3 files changed, 485 insertions(+) create mode 100644 interactive-edit-lens/src/Interact.hs create mode 100644 interactive-edit-lens/src/Interact/Types.hs create mode 100644 interactive-edit-lens/src/Main.hs (limited to 'interactive-edit-lens/src') 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 @@ +{-# LANGUAGE ScopedTypeVariables + , OverloadedStrings + #-} + +module Interact + ( interactiveEditLens + , module Interact.Types + , module Config.Dyre + ) where + +import Prelude hiding (init) + +import Interact.Types + +import Data.Text (Text) +import qualified Data.Text as Text + +import Data.Text.Zipper + +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq + +import Control.Lens +import Numeric.Lens +import System.IO +import Control.Monad +import Control.Monad.RWS hiding (Last(..), (<>)) +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader (runReaderT) + +import Data.Bool (bool) +import Data.Tuple (swap) +import Data.Maybe (fromMaybe) +import Data.List (groupBy) +import Data.Function (on) +import Data.Char (isSpace) + +import Data.Foldable (Foldable(toList)) + +import Brick hiding (on) +import Brick.Focus +import Brick.Widgets.Center +import Brick.Widgets.Border +import Graphics.Vty hiding (showCursor) + +import Config.Dyre + +import System.IO.Unsafe +import Debug.Trace + +interactiveEditLens :: (Params (InteractConfig c) -> Params (InteractConfig c)) -> InteractConfig c -> IO () +interactiveEditLens f = wrapMain . f $ defaultParams + { projectName = "interact-edit-lens" + , showError = \s err -> s & compileError .~ Just err + , realMain = interactiveEditLens' + } + +interactiveEditLens' :: forall c. InteractConfig c -> IO () +interactiveEditLens' cfg@InteractConfig{..} + | Just err <- icfgCompileError + = hPutStrLn stderr err + | otherwise + = void . defaultMain app $! initialState &?~ do + let + a :: Lens' (InteractState c) (Last Validity, Last (Seq Char, Int), StringEdits Natural Char) + a = case icfgInitial of + InitialRight _ -> right + _other -> left + b :: Lens' (InteractState c) (Last Validity, Last (Seq Char, Int), StringEdits Natural Char) + b = case icfgInitial of + InitialRight _ -> left + _other -> right + dir :: InteractDirection + dir = case icfgInitial of + InitialRight _ -> PropagateLeft + _other -> PropagateRight + aDom :: Seq Char + (view charseq -> aDom) = case icfgInitial of + InitialRight t -> t + InitialLeft t -> t + InitialEmpty -> "" + doEdit $ divInit aDom & stringEdits . sePos %~ (fromIntegral :: Natural -> Integer) + -- a .= (Last Valid, Last (aDom, 0)) + -- bEdit <- prop dir $ divInit aDom + -- (b %=) . maybe id (<>) <=< runMaybeT $ do + -- bDom <- use $ b . _2 . _Wrapped . _1 + -- bDom' <- MaybeT . return $ bDom `apply` bEdit + -- return $ (Last Valid, Last (bDom', 0)) + where + infix 1 &?~ + + (&?~) :: a -> RWS (InteractConfig c) () a b -> a + st &?~ act = (\(s, ()) -> s) $ execRWS act cfg st + + actOn = (&?~) + + initialState :: InteractState c + initialState = InteractState + { istComplement = ground icfgLens + , istLeft = (Last Valid, Last (init @(StringEdits Natural Char), 0), mempty) + , istRight = (Last Valid, Last (init @(StringEdits Natural Char), 0), mempty) + , istFocus = focusRing [LeftEditor, RightEditor] & + focusSetCurrent (case icfgInitial of InitialRight _ -> RightEditor; _other -> LeftEditor) + } + + app :: InteractApp c + app = App{..} + + appDraw :: InteractState c -> [Widget InteractName] + appDraw InteractState{..} = [ editors ] + where + editors = hBox + [ mbInvalid (withFocusRing istFocus renderEditor') (istLeft `WithName` LeftEditor) + , vBorder + , mbInvalid (withFocusRing istFocus renderEditor') (istRight `WithName` RightEditor) + ] + renderEditor' :: Bool -> (Seq Char, Int) `WithName` InteractName -> Widget InteractName + renderEditor' foc ((content, cPos) `WithName` n) + = txt (review charseq content) + & bool id (showCursor n cPos') foc + & visibleRegion cPos' (1, 1) + & viewport n Both + where + (cPrefix, _) = Seq.splitAt cPos content + newls = Seq.findIndicesR (== '\n') cPrefix + cPos' = case newls of + (p:_) -> Location (pred $ cPos - p, length newls) + [] -> Location (cPos, 0) + mbInvalid _ ((Last Invalid, _ , _) `WithName` _) + = txt "Invalid" + & border + & center + mbInvalid f ((Last Valid , Last x, _) `WithName` n) = f $ x `WithName` n + + appHandleEvent :: InteractState c -> BrickEvent InteractName InteractEvent -> EventM InteractName (Next (InteractState c)) + appHandleEvent st@InteractState{..} (VtyEvent ev) = case ev of + EvKey KEsc [] -> halt st + EvKey (KChar 'c') [MCtrl] -> halt st + EvKey (KChar '\t') [] -> continue $ st & focus %~ focusNext + EvKey KBackTab [] -> continue $ st & focus %~ focusPrev + EvKey (KChar 'a') [MCtrl] -> continue $ st &?~ doMove + (moveSplit (== '\n') $ \(c, (l, p)) -> if any (== '\n') (c l) || Seq.null (c l) then (pred l, 0) else (l, 0)) + EvKey (KChar 'e') [MCtrl] -> continue $ st &?~ doMove + (moveSplit (== '\n') $ \(c, (l, p)) -> if any (== '\n') $ c l then (pred l, Seq.length . c $ pred l) else (l, Seq.length $ c l)) + EvKey KLeft [MCtrl] -> continue $ st &?~ doMove + (moveSplit isSpace $ \(c, (l, _)) -> if any isSpace (c l) || Seq.null (c l) then (pred l, 0) else (l - 2, 0)) + EvKey KRight [MCtrl] -> continue $ st &?~ doMove + (moveSplit isSpace $ \(c, (l, _)) -> if any isSpace $ c l then (succ l, 0) else (l + 2, 0)) + EvKey KUp [MCtrl] -> continue $ st &?~ doMove + (moveSplit (== '\n') $ \(c, (l, p)) -> if any (== '\n') (c l) || Seq.null (c l) then (pred l, p) else (l - 2, p)) + EvKey KDown [MCtrl] -> continue $ st &?~ doMove + (moveSplit (== '\n') $ \(c, (l, p)) -> if any (== '\n') (c l) then (succ l, p) else (l + 2, p)) + EvKey KLeft [] -> continue $ st &?~ doMove moveLeft + EvKey KRight [] -> continue $ st &?~ doMove moveRight + EvKey KDel [] -> continue $ st &?~ doEdit (delete 0) + EvKey KBS [] -> continue . actOn st $ do + focused' <- preuse $ focused . _2 . _Wrapped + doEdit . delete $ -1 + unless (maybe False ((==) <$> view _2 <*> view (_1 . to Seq.length)) focused') $ + doMove moveLeft + EvKey (KChar c) [] -> continue . actOn st $ do + doEdit $ insert 0 c + doMove moveRight + EvKey KEnter [] -> continue . actOn st $ do + doEdit $ insert 0 '\n' + doMove moveRight + other -> suspendAndResume $ do + traceIO $ "Unhandled event:\n\t" ++ show other + return st + -- where + -- editorMovement f = continue $ st & focused . _Just . editContentsL %~ f + appHandleEvent st _ = continue st + + doMove = zoom $ focused . _2 . _Wrapped + + moveLeft, moveRight :: MonadState (Seq Char, Int) m => m () + moveLeft = modify $ \now@(_, nowP) -> if + | nowP > 0 -> now & _2 %~ pred + | otherwise -> now + moveRight = modify $ \now@(contents, nowP) -> if + | nowP < length contents -> now & _2 %~ succ + | otherwise -> now + + moveSplit :: MonadState (Seq Char, Int) m + => (Char -> Bool) -- ^ Separator predicate + -> (((Int -> Seq Char), (Int, Int)) -> (Int, Int)) -- ^ Move in split coordinates (e.g. @(line, charInLine)@) with access to the focused fragment + -> m () + moveSplit splitPred relMove = modify $ \now@(toList -> contentsStr, nowP) + -> let splitContents = groupBy ((==) `on` splitPred) contentsStr + traceShow x y = flip seq y . unsafePerformIO . appendFile "interact.log" . (<> "\n\n") $ show x + (before, mCurrent, after) = snd . (\x -> traceShow (nowP, x) x) $ foldl go (0, ([], Nothing, [])) splitContents + go acc@(i, st) cGroup + | i <= nowP, nowP < i + length cGroup = (i + length cGroup, st & _2 .~ Just cGroup) + | i + length cGroup <= nowP = (i + length cGroup, st & _1 %~ (flip snoc cGroup)) + | otherwise = (i + length cGroup, st & _3 %~ (flip snoc cGroup)) + relPos = (length before, nowP - sum (map length before)) + (newL, newS) = relMove (\i -> if 0 <= i && i < length splitContents then Seq.fromList $ splitContents !! i else Seq.empty, relPos) + newPos + | null splitContents + , newL /= 0 || newS /= 0 = (0, 0) + | newL >= length splitContents = (pred $ length splitContents, length $ last splitContents) + | newL < 0 = (0, 0) + | newS < 0 = (newL, 0) + | newS > length (splitContents !! newL) = (newL, length $ splitContents !! newL) + | otherwise = (newL, newS) + in now & _2 .~ sum (map length $ take (fst newPos) splitContents) + snd newPos + + appStartEvent :: InteractState c -> EventM InteractName (InteractState c) + appStartEvent = return + + appAttrMap :: InteractState c -> AttrMap + appAttrMap = const $ attrMap defAttr [] + + appChooseCursor :: InteractState c -> [CursorLocation InteractName] -> Maybe (CursorLocation InteractName) + appChooseCursor = focusRingCursor istFocus + +prop :: forall st cfg m. + ( MonadState st m + , MonadReader cfg m + , HasComplement st (Complement cfg) + , HasEditLens cfg (StringEdits Natural Char) (StringEdits Natural Char) + ) + => InteractDirection -> StringEdits Natural Char -> m (StringEdits Natural Char) +prop dir edits = do + propD <- case dir of + PropagateRight -> asks propR + PropagateLeft -> asks propL + (c, res) <- propD . (, edits) <$> use complement + unsafePerformIO . fmap return . appendFile "interact.log" . (<> "\n\n") $ show (edits, dir, res) + res <$ assign complement c + +doEdit :: forall m c. + ( MonadState (InteractState c) m + , MonadReader (InteractConfig c) m + ) + => StringEdits Integer Char -> m () +doEdit relativeEdit = void . runMaybeT $ do + currentFocus <- MaybeT $ uses focus focusGetCurrent + let direction + | RightEditor <- currentFocus = PropagateLeft + | otherwise = PropagateRight + aL :: Lens' (InteractState c) (Last Validity, Last (Seq Char, Int), StringEdits Natural Char) + aL | PropagateRight <- direction = left + | PropagateLeft <- direction = right + bL :: Lens' (InteractState c) (Last Validity, Last (Seq Char, Int), StringEdits Natural Char) + bL | PropagateRight <- direction = right + | PropagateLeft <- direction = left + (aN, bN) = bool swap id (direction == PropagateRight) (LeftEditor, RightEditor) + currentZipper <- use $ aL . _2 . _Wrapped + let currentPos = currentZipper ^. _2 + absoluteEdit <- MaybeT . return $ do + let minOffset = minimumOf (stringEdits . sePos) relativeEdit + guard $ maybe True (\o -> 0 <= currentPos + fromIntegral o) minOffset + return $ relativeEdit & stringEdits . sePos %~ (\n -> fromIntegral $ currentPos + fromIntegral n) + newContent <- MaybeT . return $ view _1 currentZipper `apply` absoluteEdit + let currentPos' + | currentPos < 0 = 0 + | currentPos > length newContent = length newContent + | otherwise = currentPos + aL . _2 %= (<> Last (newContent, currentPos')) + absoluteEdit' <- uses (aL . _3) (absoluteEdit `mappend`) + bEdits <- prop direction absoluteEdit' + bDom <- use $ bL . _2 . _Wrapped . _1 + case bDom `apply` bEdits of + Nothing -> do + bL . _1 %= (<> Last Invalid) + aL . _3 .= absoluteEdit' + Just bDom' -> do + bL . _1 %= (<> Last Valid) + bL . _2 . _Wrapped . _1 .= bDom' + 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 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Interact.Types + ( InteractName(..) + , _LeftEditor, _RightEditor, _PrimitiveName + , Validity, pattern Valid, pattern Invalid + , InteractState(..) + , HasLeft(..), HasRight(..), HasComplement(..), HasFocus(..), HasFocused(..) + , InteractInitial(..) + , _InitialLeft, _InitialRight, _InitialEmpty + , InteractConfig(..) + , HasInitial(..), HasLens(..), HasCompileError(..) + , InteractEvent + , InteractApp + , InteractDirection(..) + , charseq + , WithName(..) + , module Control.Edit + , module Control.Lens.Edit + , module Control.DFST.Lens + , module Data.Semigroup + , module Numeric.Natural + ) where + +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Lens + +import Data.Sequence (Seq(..)) +import qualified Data.Sequence as Seq + +import qualified Data.Foldable as Foldable + +import Data.Semigroup (Semigroup(..), Last(..)) +import Numeric.Natural + +import Brick +import Brick.Focus +import Brick.Widgets.Edit + +import Control.Lens +import Control.Lens.TH +import Control.Edit +import Control.Lens.Edit +import Control.DFST.Lens + +import Data.Text.Zipper.Generic + + +data InteractName + = LeftEditor + | RightEditor + | PrimitiveName !Text + deriving (Eq, Ord, Show, Read) + +makePrisms ''InteractName + +type Validity = Bool +pattern Valid = True +pattern Invalid = False + +data InteractState c = InteractState + { istLeft, istRight :: (Last Validity, Last (Seq Char, Int), StringEdits Natural Char) + , istComplement :: c + , istFocus :: FocusRing InteractName + } + +makeLensesWith abbreviatedFields ''InteractState + +class HasFocused s a | s -> a where + focused :: Traversal' s a + +instance HasFocused (InteractState c) (Last Validity, Last (Seq Char, Int), StringEdits Natural Char) where + focused f st@InteractState{..} = case focusGetCurrent istFocus of + Just LeftEditor -> left f st + Just RightEditor -> right f st + _other -> pure st + +data InteractInitial + = InitialLeft Text + | InitialRight Text + | InitialEmpty + deriving (Eq, Ord, Show, Read) + +makePrisms ''InteractInitial + +data InteractConfig c = InteractConfig + { icfgInitial :: InteractInitial + , icfgLens :: EditLens c (StringEdits Natural Char) (StringEdits Natural Char) + , icfgCompileError :: Maybe String + } + +instance HasEditLens (InteractConfig c) (StringEdits Natural Char) (StringEdits Natural Char) where + type Complement (InteractConfig c) = c + ground = ground . icfgLens + propR = propR . icfgLens + propL = propL . icfgLens + +makeLensesWith abbreviatedFields ''InteractConfig + +charseq :: Iso' Text (Seq Char) +charseq = iso Text.unpack Text.pack . iso Seq.fromList Foldable.toList + +type InteractEvent = () + +type InteractApp c = App (InteractState c) InteractEvent InteractName + +data InteractDirection = PropagateLeft | PropagateRight + deriving (Eq, Ord, Enum, Bounded, Show, Read) + +makePrisms ''InteractDirection + + +infixr 1 `WithName` +data WithName x n = WithName x n + deriving (Eq, Ord, Show, Read) + +instance Named (x `WithName` n) n where + 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 @@ +{-# LANGUAGE OverloadedStrings + , ExistentialQuantification + #-} + +module Main where + +import Interact +import Control.DFST.Lens +import Control.DFST + +import Data.Map (Map) +import qualified Data.Map as Map + +import Data.Set (Set) +import qualified Data.Set as Set + +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq + +import Data.Char + +import System.Environment +import System.Exit + +import Debug.Trace + +data SomeDFST = forall state. (Ord state, Show state) => SomeDFST { someDFST :: DFST state Char Char } + +data JsonNewlState = JNUndeterminedStructure | JNOutsideStructure | JNInsideStructure | JNInsideString | JNEscape + deriving (Eq, Ord, Show, Read) + +dfstMap :: String -> Maybe SomeDFST +dfstMap "double" = Just . SomeDFST $ DFST + { stInitial = () + , stTransition = mconcat + [ Map.fromList + [(((), sym), ((), Seq.fromList [sym, sym])) | sym <- ['a'..'z'] ++ ['A'..'Z'] ++ ['!', ' ']] -- sym <- [minBound..maxBound], isPrint sym] + , Map.singleton ((), '\n') ((), Seq.singleton '\n') + ] + , stAccept = Set.singleton () + } +dfstMap "id" = Just . SomeDFST $ DFST + { stInitial = () + , stTransition = Map.fromList + [(((), sym), ((), Seq.singleton sym)) | sym <- ['a'..'z'] ++ ['A'..'Z'] ++ ['!', ' ']] -- sym <- [minBound..maxBound], isPrint sym] + , stAccept = Set.singleton () + } +dfstMap "alternate" = Just . SomeDFST $ DFST + { stInitial = 0 :: Int + , stTransition = mconcat + [ Map.fromList [((0, sym), (1, Seq.singleton sym)) | sym <- ['a'..'z'] ++ ['A'..'Z'] ++ ['!', ' ']] -- sym <- [minBound..maxBound], isPrint sym] + , Map.fromList [((1, sym), (0, Seq.fromList [toUpper sym, toUpper sym])) | sym <- ['a'..'z'] ++ ['A'..'Z'] ++ ['!', ' ']] -- sym <- [minBound..maxBound], isPrint sym] + ] + , stAccept = Set.fromList [0] + } +dfstMap "json-newl" = Just . SomeDFST $ DFST + { stInitial = JNOutsideStructure + , stTransition = mconcat + [ Map.fromList [((jnOutside, sym), (jnOutside, Seq.empty)) | sym <- whitespace, jnOutside <- [JNOutsideStructure, JNUndeterminedStructure]] + , Map.fromList [((jnOutside, sym), (JNInsideStructure, Seq.fromList [sym, ' '])) | sym <- "[{", jnOutside <- [JNOutsideStructure, JNInsideStructure, JNUndeterminedStructure]] + , Map.fromList [((JNInsideStructure, sym), (JNInsideStructure, Seq.empty)) | sym <- whitespace] + , Map.fromList [((jnInside, sym), (JNUndeterminedStructure, Seq.fromList ['\n', sym])) | sym <- "]}", jnInside <- [JNInsideStructure, JNUndeterminedStructure]] + , Map.fromList [((jnInside, ','), (JNInsideStructure, Seq.fromList "\n, ")) | jnInside <- [JNInsideStructure, JNUndeterminedStructure] ] + , Map.fromList [((jnInside, ':'), (JNInsideStructure, Seq.fromList " : ")) | jnInside <- [JNInsideStructure, JNUndeterminedStructure] ] + , Map.fromList [((jn, '"'), (JNInsideString, Seq.singleton '"')) | jn <- [JNUndeterminedStructure, JNInsideStructure]] + , Map.fromList [((JNInsideString, sym), (JNInsideString, Seq.singleton sym)) | sym <- ['a'..'z'] ++ ['A'..'Z'] ++ ",.!?: "] + , Map.singleton (JNInsideString, '"') (JNUndeterminedStructure, Seq.singleton '"') + , Map.singleton (JNInsideString, '\\') (JNEscape, Seq.singleton '\\') + , Map.singleton (JNEscape, '"') (JNInsideString, Seq.singleton '"') + ] + , stAccept = Set.fromList [JNOutsideStructure, JNUndeterminedStructure] + } + where + whitespace = toEnum <$> [0x0020, 0x0009, 0x000a, 0x000d] +dfstMap _ = Nothing + +main :: IO () +main = do + args <- getArgs + + dfst <- case args of + [name] | Just dfst <- dfstMap name + -> return dfst + _ -> exitWith $ ExitFailure 2 + + interactiveEditLens' dfst + +interactiveEditLens' :: SomeDFST -> IO () +interactiveEditLens' (SomeDFST dfst) + = interactiveEditLens id $ InteractConfig + { icfgInitial = InitialEmpty + , icfgLens = dfstLens dfst + , icfgCompileError = Nothing + } -- cgit v1.2.3