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 qualified Data.Text.IO 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 Brick.Widgets.FileBrowser
import Graphics.Vty hiding (showCursor)

import Config.Dyre

import System.IO.Unsafe
import Debug.Trace

import System.CPUTime
import Text.Printf

import Control.Exception (evaluate)
import Control.DeepSeq

interactiveEditLens :: forall c. NFData c => (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. NFData 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 &?~
    
    (&?~), actOn :: 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)
      , istActive = True
      , istLoadBrowser = Nothing
      }

    app :: InteractApp c
    app = App{..}

    appDraw :: InteractState c -> [Widget InteractName]
    appDraw InteractState{..} = [ editors ]
      where
        editors = vBox
          [ case istLoadBrowser of
              Nothing -> hBox
                [ mbInvalid (withFocusRing istFocus renderEditor') (istLeft `WithName` LeftEditor)
                , vBorder
                , mbInvalid (withFocusRing istFocus renderEditor') (istRight `WithName` RightEditor)
                ]
              Just lBrowser -> renderFileBrowser True lBrowser
          , hCenter . str $ bool "Inactive" "" istActive
          ]
        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)
      | Nothing <- istLoadBrowser = case ev of
          EvKey  KEsc        []      -> halt st
          EvKey (KChar 'c')  [MCtrl] -> halt st
          EvKey (KChar '\t') []      -> continue . actOn st . runMaybeT $ do
            guard =<< use active
            focus %= focusNext
          EvKey  KBackTab    []      -> continue . actOn st . runMaybeT $ do
            guard =<< use active
            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
          EvKey (KChar 'p')  [MCtrl]
            | istActive -> do
                void . liftIO . evaluate . force . ($ st) $ (,,) <$> view left <*> view right <*> view complement
                continue $ st & active .~ False
            | otherwise -> do
                let st' = actOn st $ do
                      active .= True
                      doEdit mempty
                before <- liftIO getCPUTime
                void . liftIO . evaluate . force . ($ st') $ (,,) <$> view left <*> view right <*> view complement
                after <- liftIO getCPUTime
                suspendAndResume $ do
                  printf "Resume took %.12fs\n" (fromInteger (after - before) * 1e-12 :: Double)
                  return st'
          EvKey (KChar 'o')  [MCtrl] -> do
            lBrowser <- liftIO $ newFileBrowser selectNonDirectories LoadBrowser Nothing
            continue $ st & loadBrowser .~ Just lBrowser
          other                      -> suspendAndResume $ do
            traceIO $ "Unhandled event:\n\t" ++ show other
            return st
          -- where
          --   editorMovement f = continue $ st & focused . _Just . editContentsL %~ f
      | Just lBrowser <- istLoadBrowser = do
          lBrowser' <- handleFileBrowserEvent ev lBrowser
          case fileBrowserSelection lBrowser' of
            [] -> continue $ st &?~ loadBrowser .= Just lBrowser'
            (FileInfo{..} : _) -> do
              insEdit <- divInit . view charseq <$> liftIO (Text.readFile fileInfoFilePath)
              let st' = actOn st $ do
                    doEdit $ (insEdit :: StringEdits Natural Char) & stringEdits . sePos %~ fromIntegral
                    loadBrowser .= Nothing
              continue st'
              
    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`)
  bRes <- runMaybeT $ do
    guard =<< use active
    (,) <$> use (bL . _2 . _Wrapped . _1) <*> prop direction absoluteEdit'
  case uncurry apply =<< bRes 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