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 ++++++++++++++++++++++++++++++++++ 1 file changed, 271 insertions(+) create mode 100644 interactive-edit-lens/src/Interact.hs (limited to 'interactive-edit-lens/src/Interact.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 @@ +{-# 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 -- cgit v1.2.3