Much ado about nothing

3 files changed, 485 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
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
+      }