path: root/interactive-edit-lens/src/Interact.hs

{-# 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         []      -> 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       []      -> 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