From f4c419b9ddec15bad267a4463f0720d6e28042d2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 30 May 2019 12:18:08 +0200 Subject: Further work --- interactive-edit-lens/package.yaml | 1 + interactive-edit-lens/src/Interact.hs | 142 +++++++++++++++++++--------- interactive-edit-lens/src/Interact/Types.hs | 26 ++++- interactive-edit-lens/src/Main.hs | 17 +++- 4 files changed, 132 insertions(+), 54 deletions(-) (limited to 'interactive-edit-lens') 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 -- cgit v1.2.3