1 files changed, 271 insertions, 0 deletions

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