Further work

4 files changed, 132 insertions, 54 deletions

diff --git a/interactive-edit-lens/package.yaml b/interactive-edit-lens/package.yaml
index 95e2464..80d2a31 100644
--- a/interactive-edit-lens/package.yaml
+++ b/interactive-edit-lens/package.yaml
@@ -38,6 +38,7 @@ dependencies:
   - mtl
   - transformers
   - universe
+  - deepseq
 
 # ghc-options: [ -O2 ]
 
diff --git a/interactive-edit-lens/src/Interact.hs b/interactive-edit-lens/src/Interact.hs
index 0074e86..662052b 100644
--- a/interactive-edit-lens/src/Interact.hs
+++ b/interactive-edit-lens/src/Interact.hs
@@ -14,6 +14,7 @@ import Interact.Types
 
 import Data.Text (Text)
 import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
 
 import Data.Text.Zipper
 
@@ -41,6 +42,7 @@ 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
@@ -48,14 +50,20 @@ import Config.Dyre
 import System.IO.Unsafe
 import Debug.Trace
 
-interactiveEditLens :: (Params (InteractConfig c) -> Params (InteractConfig c)) -> InteractConfig c -> IO ()
+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. InteractConfig c -> IO ()
+interactiveEditLens' :: forall c. NFData c => InteractConfig c -> IO ()
 interactiveEditLens' cfg@InteractConfig{..}
   | Just err <- icfgCompileError
   = hPutStrLn stderr err
@@ -89,9 +97,8 @@ interactiveEditLens' cfg@InteractConfig{..}
   where
     infix 1 &?~
     
-    (&?~) :: a -> RWS (InteractConfig c) () a b -> a
+    (&?~), actOn :: a -> RWS (InteractConfig c) () a b -> a
     st &?~ act = (\(s, ()) -> s) $ execRWS act cfg st
-
     actOn = (&?~)
 
     initialState :: InteractState c
@@ -101,6 +108,8 @@ interactiveEditLens' cfg@InteractConfig{..}
       , 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
@@ -109,10 +118,15 @@ interactiveEditLens' cfg@InteractConfig{..}
     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)
+        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)
@@ -133,42 +147,75 @@ interactiveEditLens' cfg@InteractConfig{..}
         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@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
@@ -259,9 +306,10 @@ doEdit relativeEdit = void . runMaybeT $ do
         | 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
+  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'
diff --git a/interactive-edit-lens/src/Interact/Types.hs b/interactive-edit-lens/src/Interact/Types.hs
index a4d08ac..67f9ae3 100644
--- a/interactive-edit-lens/src/Interact/Types.hs
+++ b/interactive-edit-lens/src/Interact/Types.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, DeriveGeneric, StandaloneDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Interact.Types
@@ -6,7 +6,7 @@ module Interact.Types
   , _LeftEditor, _RightEditor, _PrimitiveName
   , Validity, pattern Valid, pattern Invalid
   , InteractState(..)
-  , HasLeft(..), HasRight(..), HasComplement(..), HasFocus(..), HasFocused(..)
+  , HasLeft(..), HasRight(..), HasComplement(..), HasFocus(..), HasFocused(..), HasActive(..), HasLoadBrowser(..)
   , InteractInitial(..)
   , _InitialLeft, _InitialRight, _InitialEmpty
   , InteractConfig(..)
@@ -38,6 +38,7 @@ import Numeric.Natural
 import Brick
 import Brick.Focus
 import Brick.Widgets.Edit
+import Brick.Widgets.FileBrowser
 
 import Control.Lens
 import Control.Lens.TH
@@ -47,12 +48,29 @@ import Control.DFST.Lens
 
 import Data.Text.Zipper.Generic
 
+import Control.DeepSeq
+import GHC.Generics (Generic)
+
+
+deriving instance Generic (StringEdit n c)
+instance (NFData n, NFData c) => NFData (StringEdit n c)
+  
+deriving instance Generic (StringEdits n c)
+instance (NFData n, NFData c) => NFData (StringEdits n c)
+
+deriving instance Generic (DFSTAction s c c')
+instance (NFData s, NFData c, NFData c') => NFData (DFSTAction s c c')
+
+instance (NFData s, NFData c, NFData c') => NFData (DFSTComplement s c c') where
+  rnf = foldr deepseq ()
+
 
 data InteractName
   = LeftEditor
   | RightEditor
+  | LoadBrowser
   | PrimitiveName !Text
-  deriving (Eq, Ord, Show, Read)
+  deriving (Eq, Ord, Show, Read, Generic)
 
 makePrisms ''InteractName
 
@@ -64,6 +82,8 @@ data InteractState c = InteractState
   { istLeft, istRight :: (Last Validity, Last (Seq Char, Int), StringEdits Natural Char)
   , istComplement :: c
   , istFocus :: FocusRing InteractName
+  , istActive :: Bool
+  , istLoadBrowser :: Maybe (FileBrowser InteractName)
   }
 
 makeLensesWith abbreviatedFields ''InteractState
diff --git a/interactive-edit-lens/src/Main.hs b/interactive-edit-lens/src/Main.hs
index 83c9725..c816515 100644
--- a/interactive-edit-lens/src/Main.hs
+++ b/interactive-edit-lens/src/Main.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings
            , ExistentialQuantification
+           , DeriveGeneric
   #-}
 
 module Main where
@@ -30,18 +31,23 @@ import Debug.Trace
 
 import Data.Universe
 
-data SomeDFST = forall state. (Ord state, Show state, Finite state) => SomeDFST { someDFST :: DFST state Char Char }
+import Control.DeepSeq
+import GHC.Generics (Generic)
+
+data SomeDFST = forall state. (Ord state, Show state, Finite state, NFData (DFSTComplement state Char Char)) => SomeDFST { someDFST :: DFST state Char Char }
 
 data JsonContext = JCInDet | JCDict | JCDictKey | JCDictVal | JCArray | JCArrayVal | JCTop
-  deriving (Eq, Ord, Show, Read, Enum, Bounded)
+  deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic)
 instance Universe JsonContext
 instance Finite JsonContext
 
+instance NFData JsonContext
+
 data JsonNewlState = JNElement JsonContext
                    | JNTrue String JsonContext | JNFalse String JsonContext | JNNull String JsonContext | JNLitEnd JsonContext
                    | JNString JsonContext | JNStringEsc Int JsonContext | JNStringEnd JsonContext
                    | JNNumberDigits Bool JsonContext | JNNumberDecimal JsonContext | JNNumberDecimalDigits Bool JsonContext | JNNumberExpSign JsonContext | JNNumberExpDigits Bool JsonContext | JNNumberEnd JsonContext
-  deriving (Eq, Ord, Show, Read)
+  deriving (Eq, Ord, Show, Read, Generic)
 instance Universe JsonNewlState where
   universe = concat
     [ JNElement <$> universeF
@@ -63,6 +69,8 @@ instance Universe JsonNewlState where
       inits' xs = inits xs \\ [""]
 instance Finite JsonNewlState
 
+instance NFData JsonNewlState
+
 jsonStrEscapes :: [(Char, Seq Char)]
 jsonStrEscapes = [ ('"', "\\\"")
                  , ('\\', "\\\\")
@@ -78,10 +86,11 @@ hexDigits :: [Char]
 hexDigits = ['0'..'9'] ++ ['a'..'f']
 
 data LineBreakState = LineBreak Int
-  deriving (Eq, Ord, Show, Read)
+  deriving (Eq, Ord, Show, Read, Generic)
 instance Universe LineBreakState where
   universe = [ LineBreak n | n <- [0..80] ]
 instance Finite LineBreakState
+instance NFData LineBreakState
 
 dfstMap :: String -> Maybe SomeDFST
 dfstMap "double" = Just . SomeDFST $ DFST