diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,5 +7,4 @@ To use the library, the user's type of language expressions must be an instance of the `Diff` typeclass (see `app/Main.hs` for an example). - -Available on [![Hackage](https://img.shields.io/badge/Hackage-v0.1.0.2-blue.svg)](http://hackage.haskell.org/package/rewrite-inspector) +Available on [![Hackage](https://img.shields.io/hackage/v/rewrite-inspector.svg)](http://hackage.haskell.org/package/rewrite-inspector) diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-| - Copyright : (C) 2019, QBayLogic - License : BSD2 (see the file LICENSE) - Maintainer : Orestis Melkonian - - Entry point for the @clash-term@ executable. --} -{-# LANGUAGE OverloadedStrings, TypeApplications, TypeFamilies #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} - -module Main (main) where - -import GHC.Generics (Generic) -import Data.Text.Prettyprint.Doc (annotate, hsep, pretty) - -import Gen -import BrickUI (runTerminal) - -main :: IO () -main = runTerminal @Expr "app/theme.ini" - -------------------------------- --- Adhoc instance for Diff. - -data Expr = N Int | Expr :+: Expr deriving (Eq, Show) - -data ExprContext = L | R deriving (Eq, Show) - -instance Diff Expr where - type Ann Expr = ExprContext - type Options Expr = () - type Ctx Expr = ExprContext - - readHistory _ = return [ HStep { _ctx = [L] - , _bndrS = "top" - , _name = "adhocI" - , _before = N 1 - , _after = N 11 :+: N 12 - } - , HStep { _ctx = [L, L] - , _bndrS = "top" - , _name = "adhocII" - , _before = N 11 - , _after = N 111 :+: N 112 - } - , HStep { _ctx = [] - , _bndrS = "top" - , _name = "normalization" - , _before = N 1 :+: (N 2 :+: N 3) - , _after = ((N 111 :+: N 112) :+: N 12) - :+: (N 2 :+: N 3) - } - ] - - ppr' _ (N n) = pretty n - ppr' opts (e :+: e') = hsep [ annotate L (ppr' opts e) - , "+" - , annotate R (ppr' opts e') - ] - - patch _ [] e' = e' - patch curE (c:cs) e' = let go e = patch e cs e' in - case (curE, c) of - (l :+: r, L) -> go l :+: r - (l :+: r, R) -> l :+: go r - _ -> error "patch" diff --git a/examples/expr/Main.hs b/examples/expr/Main.hs new file mode 100644 --- /dev/null +++ b/examples/expr/Main.hs @@ -0,0 +1,66 @@ +{-| + Copyright : (C) 2019, QBayLogic + License : BSD2 (see the file LICENSE) + Maintainer : Orestis Melkonian +-} +{-# LANGUAGE OverloadedStrings, TypeApplications, TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Main (main) where + +import GHC.Generics (Generic) +import Data.Text.Prettyprint.Doc (annotate, hsep, pretty) + +import Gen +import BrickUI (runTerminal) + +main :: IO () +main = runTerminal @Expr "examples/expr/theme.ini" + +------------------------------- +-- Adhoc instance for Diff. + +data Expr = N Int | Expr :+: Expr deriving (Eq, Show) + +data ExprContext = L | R deriving (Eq, Show) + +instance Diff Expr where + type Ann Expr = ExprContext + type Options Expr = () + type Ctx Expr = ExprContext + + readHistory _ = return [ HStep { _ctx = [L] + , _bndrS = "top" + , _name = "adhocI" + , _before = N 1 + , _after = N 11 :+: N 12 + } + , HStep { _ctx = [L, L] + , _bndrS = "top" + , _name = "adhocII" + , _before = N 11 + , _after = N 111 :+: N 112 + } + , HStep { _ctx = [] + , _bndrS = "top" + , _name = "normalization" + , _before = N 1 :+: (N 2 :+: N 3) + , _after = ((N 111 :+: N 112) :+: N 12) + :+: (N 2 :+: N 3) + } + ] + + ppr' _ (N n) = pretty n + ppr' opts (e :+: e') = hsep [ annotate L (ppr' opts e) + , "+" + , annotate R (ppr' opts e') + ] + + patch _ [] e' = e' + patch curE (c:cs) e' = let go e = patch e cs e' in + case (curE, c) of + (l :+: r, L) -> go l :+: r + (l :+: r, R) -> l :+: go r + _ -> error "patch" diff --git a/examples/str/Main.hs b/examples/str/Main.hs new file mode 100644 --- /dev/null +++ b/examples/str/Main.hs @@ -0,0 +1,67 @@ +{-| + Copyright : (C) 2019, QBayLogic + License : BSD2 (see the file LICENSE) + Maintainer : Orestis Melkonian +-} +{-# LANGUAGE TypeApplications, TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Main (main) where + +import GHC.Generics (Generic) +import Data.Text.Prettyprint.Doc (annotate, vsep, pretty) + +import Gen +import BrickUI (runTerminal) + +main :: IO () +main = runTerminal @Expr "examples/str/theme.ini" + +------------------------------- +-- Adhoc instance for Diff. + +data Expr = N Int | Expr :+: Expr deriving (Eq, Show) + +data ExprContext = L | R deriving (Eq, Show) + +instance Diff Expr where + type Ann Expr = ExprContext + type Options Expr = () + type Ctx Expr = ExprContext + + readHistory _ = return [ HStep { _ctx = [L] + , _bndrS = "top" + , _name = "adhocI" + , _before = N 1 + , _after = N 11 :+: N 12 + } + , HStep { _ctx = [L, L] + , _bndrS = "top" + , _name = "adhocII" + , _before = N 11 + , _after = N 111 :+: N 112 + } + , HStep { _ctx = [] + , _bndrS = "top" + , _name = "normalization" + , _before = N 1 :+: (N 2 :+: N 3) + , _after = ((N 111 :+: N 112) :+: N 12) + :+: (N 2 :+: N 3) + } + ] + + ppr' _ (N n) = pretty $ case n of {1 -> "one" ; 2 -> "two" ; 3 -> "three" ; _ -> "..."} + ppr' opts (e :+: e') = vsep $ [ annotate L (ppr' opts e) ] + ++ replicate 25 (pretty " ") + ++ [pretty "plus"] + ++ replicate 25 (pretty " ") + ++ [ annotate R (ppr' opts e') ] + + patch _ [] e' = e' + patch curE (c:cs) e' = let go e = patch e cs e' in + case (curE, c) of + (l :+: r, L) -> go l :+: r + (l :+: r, R) -> l :+: go r + _ -> error "patch" diff --git a/rewrite-inspector.cabal b/rewrite-inspector.cabal --- a/rewrite-inspector.cabal +++ b/rewrite-inspector.cabal @@ -1,5 +1,5 @@ name: rewrite-inspector -version: 0.1.0.4 +version: 0.1.0.5 cabal-version: >=1.10 build-type: Simple license: BSD3 @@ -30,8 +30,9 @@ Types Pretty BrickUI - build-depends: base >= 4.7 && < 5, + build-depends: base >= 4.3.1.0 && < 5, binary >= 0.8.5 && < 0.11, + hashable >= 1.2.1.0 && < 1.3, containers >= 0.5.0.0 && < 0.7, brick == 0.46, vty >= 5.23.1, @@ -41,7 +42,7 @@ microlens-th, data-default >= 0.7.1.1 - ghc-options: -Wall + default-language: Haskell2010 default-extensions: ScopedTypeVariables ViewPatterns @@ -61,12 +62,37 @@ StandaloneDeriving executable expr-example - hs-source-dirs: app + hs-source-dirs: examples/expr main-is: Main.hs build-depends: base >=4.7 && <5, - rewrite-inspector -any, - prettyprinter >= 1.2.0.1 && < 2.0 + prettyprinter >= 1.2.0.1 && < 2.0, + rewrite-inspector -any ghc-options: -threaded extra-libraries: pthread default-language: Haskell2010 + +executable str-example + hs-source-dirs: examples/str + main-is: Main.hs + build-depends: base >=4.7 && <5, + prettyprinter >= 1.2.0.1 && < 2.0, + rewrite-inspector -any + + ghc-options: -threaded + extra-libraries: pthread + default-language: Haskell2010 + +-- executable clash-example +-- hs-source-dirs: examples/clash +-- main-is: Main.hs +-- build-depends: base >= 4.3.1.0 && <5, +-- prettyprinter >= 1.2.0.1 && < 2.0, +-- binary >= 0.8.5 && < 0.11, +-- +-- clash-lib >= 0.7.1 && < 1.0, +-- rewrite-inspector -any +-- +-- ghc-options: -threaded +-- extra-libraries: pthread +-- default-language: Haskell2010 diff --git a/src/BrickUI.hs b/src/BrickUI.hs --- a/src/BrickUI.hs +++ b/src/BrickUI.hs @@ -9,12 +9,18 @@ module BrickUI (runTerminal) where -import System.Environment (getArgs) -import Control.Monad (void, (>>)) +import System.Environment (getArgs) +import Control.Applicative ((<|>)) +import Control.Monad (void, (>>)) +import Data.List (sortOn) +import Data.Maybe (isJust, listToMaybe, catMaybes) import Lens.Micro import Brick - ( App (..), BrickEvent (..), EventM, Next, Widget + ( App (..), BrickEvent (..), EventM, Next, Widget (..) + , CursorLocation (..), cursorLocationName, cursorsL + , VisibilityRequest (..), visibilityRequestsL + , hSize, vSize, imageL , continue, halt , str, vBox, hBox ) @@ -50,12 +56,23 @@ app :: forall term. Diff term => B.AttrMap -> App (VizStates term) NoCustomEvent Name app attrMap = App { appDraw = drawUI - , appChooseCursor = focusRingCursor (Bf.formFocus . _form) + , appChooseCursor = chooseCursor , appHandleEvent = handleStart , appStartEvent = (lookupSize <*>) . return , appAttrMap = const attrMap } +-- | Choose a single cursor to display, out of possibly many requests. +chooseCursor :: VizStates term -> [Cursor] -> Maybe Cursor +chooseCursor st ls + = (listToMaybe $ filter isSearch ls) + <|> (focusRingCursor (Bf.formFocus . _form) st ls) + where + isSearch :: Cursor -> Bool + isSearch = \case + CursorLocation {cursorLocationName = Just (SearchResult _ _)} -> True + _ -> False + -- | Top-level: Draw all top-level binders and their current step. -- NB: delegates bottom-level to `drawUI` drawUI :: forall term. Diff term @@ -70,7 +87,11 @@ C.hCenter $ hBoxSpaced 2 (drawBndr <$> vs^.binders) , diff - , B.vLimitPercent 10 inputForm + , B.vLimitPercent 10 $ + hBox + [ inputForm + , searchMatches + ] ] ] where @@ -87,20 +108,27 @@ -- display the diff of this rewrite step diff :: Widget Name diff - | v@(VizState (st:_) _ curE _) <- getCurrentState vs + | v@(VizState (st:_) _ curE _ curO _ _) <- getCurrentState vs = let - showE = showCode (vs^.scroll) - (min 80 $ getCodeWidth vs) - (vs^.formData^.opts) - (case vs^.formData.trans of {Search s -> s; _ -> ""}) - (st^.ctx) + showE vn = showCode vn + (vs^.scroll) + (min 80 $ getCodeWidth vs) + (vs^.formData^.opts) + (st^.ctx) + (getSearchString vs) nextE = step v ^. curExpr + (visL, visR) | v^.curOccur < v^.leftN + = (visibleCursors curO, invisibleCursors) + | otherwise + = (invisibleCursors, visibleCursors (curO - v^.leftN)) in hBoxSpaced 2 [ B.viewport LeftViewport B.Both $ - withBorder "Before" $ showE curE + visL $ + withBorder "Before" $ showE LeftViewport curE , B.viewport RightViewport B.Both $ - withBorder "After" $ showE nextE + visR $ + withBorder "After" $ showE RightViewport nextE ] | otherwise @@ -113,6 +141,17 @@ $ Bf.setFormConcat (hBoxSpaced 10) $ vs^.form + searchMatches :: Widget Name + searchMatches = C.vCenter $ str (n ++ " out of " ++ tot ++ " matches") + where + (n, tot) + | v@(VizState (_:_) _ curE _ _ _ _) <- getCurrentState vs + , let lr = v^.leftN + v^.rightN + , lr > 0 + = (show (v^.curOccur + 1), show lr) + | otherwise + = ("-", "-") + -- display the keyboard controls controlsOffset :: (Int, Int) controlsOffset = ( (vs^.width `div` 2) - 25 @@ -132,20 +171,35 @@ , "Ins/Del" .- "scroll both panes (left/right)" , "Ctrl-p" .- "show/hide keyboard controls" , "(Shift-)Tab" .- "cycle through input fields" - , "Enter" .- "submit move action" + , "Enter" .- "submit move action (forward)" + , "KBS/Ctrl-b" .- "submit move action (backward)" , "Space" .- "toggle flag" ] where button .- desc = hBox [emph button, str $ " : " ++ desc] --- Lookup terminal size and store in the current state. +-- | Lookup terminal size and store in the current state. lookupSize :: EventM Name (VizStates term -> VizStates term) lookupSize = do out <- V.outputIface <$> B.getVtyHandle (w, h) <- V.displayBounds out return $ (width .~ w) . (height .~ h) --- Lookup code sizes and store them in the current state, then handle events. +-- | Update number of occurrences of searched string in both viewports. +updateOcc :: Diff term => VizStates term -> VizStates term +updateOcc vs + | v@(VizState (_:_) _ curE _ _ _ _) <- getCurrentState vs + , let ln = countOcc (vs^.formData^.opts) (getSearchString vs) curE + rn = countOcc (vs^.formData^.opts) (getSearchString vs) (step v ^. curExpr) + , ln + rn > 0 + = updateState vs $ v & leftN .~ ln + & rightN .~ rn + & curOccur .~ ((v^.curOccur) `mod` (ln + rn)) + + | otherwise + = vs + +-- | Lookup code sizes and store them in the current state, then handle events. handleStart :: forall term. Diff term => VizStates term -> BrickEvent Name NoCustomEvent @@ -154,7 +208,7 @@ pre <- lookupSize vs' <- handleEvent (pre vs) ev post <- lookupSize - return (post <$> vs') + return (updateOcc . post <$> vs') -- | Handle keyboard events. handleEvent :: Diff term @@ -173,17 +227,14 @@ = always | [V.MShift] <- mods - = case key of - -- search (next) - V.KEnter -> search unstep - _ -> shiftScroll + = shiftScroll | [V.MCtrl] <- mods = case key of -- show/hide bottom pane V.KChar 'p' -> continue (vs & showBot %~ not) - -- search (previous) - V.KEnter -> search unstep + -- action (forward) + V.KChar 'b' -> action Backward -- change top-level binder V.KChar 'l' -> contT (stepBinder vs) V.KChar 'k' -> contT (unstepBinder vs) @@ -197,16 +248,16 @@ contF = (>> continue (vs & scroll .~ False)) bottom fg = continue $ updateState vs (fg $ getCurrentState vs) & scroll .~ True - search f = case vs^.formData.trans of + action dir = case vs^.formData.trans of Step n -> bottom $ moveTo n - Name s -> bottom $ nextTrans f s - _ -> continue vs + Name s -> bottom $ nextTrans dir s + Search _ -> bottom $ nextOccur dir sometimes = case key of -- reset to initial step (of current binder) V.KChar 'r' -> bottom reset -- move to previous step/transformation - V.KBS -> search unstep + V.KBS -> action Backward -- change top-level binder V.KRight -> contT (stepBinder vs) V.KLeft -> contT (unstepBinder vs) @@ -227,7 +278,7 @@ V.KDel -> contF (hScrollL >> hScrollR) V.KIns -> contF (hScrollL' >> hScrollR') -- move to next step/transformation - V.KEnter -> search step + V.KEnter -> action Forward -- dispatch to form handler _ -> formHandler @@ -281,3 +332,28 @@ vScrollHomeR = B.vScrollToBeginning r vScrollEndL = B.vScrollToEnd l vScrollEndR = B.vScrollToEnd r + +visibleCursors :: Int -> Widget Name -> Widget Name +visibleCursors n p = Widget (hSize p) (vSize p) $ do + res <- B.render p + let size = (res^.imageL.to V.imageWidth, res^.imageL.to V.imageHeight) + let crs = map fst + $ sortOn ((\case (SearchResult _ i) -> i) . snd) + $ catMaybes + $ map (\c -> case cursorLocationName c of + Just s@(SearchResult n _) -> Just (c, s) + _ -> Nothing) + $ (res^.cursorsL) + if null crs then + return res + else do + let c = crs !! (n `mod` length crs) + return $ res & visibilityRequestsL .~ [VR { vrPosition = cursorLocation c + , vrSize = size + }] + & cursorsL .~ [c] + +invisibleCursors :: Widget n -> Widget n +invisibleCursors p = Widget (hSize p) (vSize p) $ do + res <- B.render p + return $ res & cursorsL .~ [] diff --git a/src/Gen.hs b/src/Gen.hs --- a/src/Gen.hs +++ b/src/Gen.hs @@ -42,6 +42,7 @@ -- Generic interface. class Eq (Ctx term) => Diff term where + -- T0D0 type family deps type Ann term :: * type Options term :: * type Ctx term :: * diff --git a/src/Pretty.hs b/src/Pretty.hs --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -12,6 +12,14 @@ module Pretty where +import Control.Arrow (first, second) + +import Data.List (nub, isPrefixOf, findIndices, sortOn) +import Data.Text (unpack) +import Data.Text.Prettyprint.Doc ( layoutPretty, layoutCompact + , LayoutOptions (..) + , PageWidth (..), SimpleDocStream (..) ) + import Brick (Widget, str, hBox, vBox) import qualified Brick as B import qualified Brick.Forms as Bf @@ -21,36 +29,52 @@ import qualified Brick.Widgets.Border.Style as BrS import qualified Graphics.Vty as V -import Data.List (nub, isPrefixOf, findIndices, sortOn) -import Data.Text (unpack) -import Data.Text.Prettyprint.Doc ( layoutPretty, LayoutOptions (..) - , PageWidth (..), SimpleDocStream (..) ) import Gen +import Types ---------------------------------------------------------------------------- -- Pretty-printing Cλash Core. +countOcc + :: forall term + . Diff term + => Options term -- ^ options for Clash's pretty-printer + -> String -- ^ the string to search for + -> term -- ^ code to search in + -> Int -- ^ total number of occurrences +countOcc opts searchString + = foldl (\cur d -> cur + countDoc d) 0 + . myForm @term [] [] [] [] + . layoutCompact + . ppr' @term opts + where + countDoc :: MyDoc -> Int + countDoc = \case + MString s -> snd (highlightSearch undefined 0 s searchString) + MMod _ d -> countDoc d + MLine _ -> 0 -showCode :: forall n term - . Diff term - => Bool -- ^ whether to scroll to focused region - -> Int -- ^ maximum line width - -> Options term -- ^ options for Clash's pretty-printer - -> String -- ^ the string to search for - -> [Ctx term] -- ^ the current context - -> term -- ^ code to display - -> Widget n -- ^ the Brick widget to display -showCode scroll w opts searchString ctx0 = - vBox - . fmap (render scroll searchString) . split . (MLine 0 :) +showCode + :: forall n term + . Diff term + => Name -- ^ viewport name + -> Bool -- ^ whether to scroll to focused region + -> Int -- ^ maximum line width + -> Options term -- ^ options for Clash's pretty-printer + -> [Ctx term] -- ^ the current context + -> String -- ^ the string to search for + -> term -- ^ code to display + -> Widget Name -- ^ the Brick widget to display +showCode vn scroll w opts ctx0 searchString + = vBox + . fmap (render vn scroll searchString 0) . split . (MLine 0 :) . myForm @term ctx0 [] [] [] . layoutPretty (LayoutOptions (AvailablePerLine w 0.8)) . ppr' @term opts -- Convert a stream into our simpler data type. -data MyDoc = MChar Char - | MString String +data MyDoc = MString String | MLine Int | MMod [String] MyDoc @@ -83,15 +107,24 @@ split _ = error "split: does not start with STLine" -- Render a single line in Brick (highlighting when marked). -render :: Bool -> String -> (Int, [MyDoc]) -> Widget n -render scroll searchString (i, xs) = B.padLeft (B.Pad i) $ hBox $ render1 <$> xs +render :: Name -> Bool -> String -> Int -> (Int, [MyDoc]) -> Widget Name +render vn scroll searchString n0 (i, xs) = B.padLeft (B.Pad i) + $ hBox + $ render1 n0 xs where - render1 :: MyDoc -> Widget n - render1 = \case - MMod attrs x -> modify scroll (nub attrs) (render1 x) - MString s -> highlightSearch s searchString + render1 :: Int -> [MyDoc] -> [Widget Name] + render1 _ [] = [] + render1 n (d : ds) = w : render1 n' ds + where (w, n') = f n d + + f :: Int -> MyDoc -> (Widget Name, Int) + f n = \case + MMod attrs w -> first (modify scroll (nub attrs)) (f n w) + MString s -> highlightSearch vn n s searchString _ -> error "render1" + + ---------------------------------------------------------------------------- -- UI Styling. @@ -120,12 +153,28 @@ mod1 "focus" = (if scroll then B.visible else id) . B.withDefAttr "focus" mod1 attr = B.withDefAttr (B.attrName attr) -highlightSearch :: String -> String -> Widget n -highlightSearch s0 toS - | null toS = str s0 - | otherwise = hBox $ mark <$> find s0 (findIndices (== head toS) s0) +highlightSearch + :: Name -- ^ viewport name + -> Int -- ^ occurrences so far + -> String -- ^ the whole string (haystack) + -> String -- ^ the string to search for (needle) + -> ( Widget Name -- ^ resulting widget + , Int -- ^ updated number of occurrences + ) +highlightSearch vn n0 s0 toS = + case toS of + [] -> (str s0, n0) + (c:_) -> first hBox $ go n0 (find s0 (findIndices (== c) s0)) where - mark = \case Left s -> str s; Right s -> B.forceAttr "search" $ str s + go n [] = ([], n) + go n (x : xs) = first (x' :) $ go n' xs + where + (x', n') = case x of + Left s -> (str s, n) + Right s -> ( ( B.showCursor (SearchResult vn n) (B.Location (1,0)) + $ B.forceAttr "search" + $ str s ) + , n + 1 ) find :: String -> [Int] -> [Either String String] find s [] = [Left s] diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -16,10 +16,10 @@ import Text.Read (readMaybe) import Data.Text (pack, unpack) -import Lens.Micro ((^.), (&), (.~), Lens', lens) +import Lens.Micro ((^.), (&), (.~), (%~), Lens', lens) import Lens.Micro.TH (makeLenses) -import Brick ((<+>), str, txt) +import Brick ((<+>), str, txt, CursorLocation) import Brick.Forms ((@@=), checkboxField, editField, formState, newForm, Form) import Gen @@ -33,8 +33,15 @@ -- ^ viewports | FormField String -- ^ form fields + | SearchResult + Name {- viewport name -} + Int {- occurrence -} + -- ^ search results with numbered occurrences + | Other deriving (Eq, Ord, Show) +type Cursor = CursorLocation Name + data Trans = Step Int -- ^ move to given step in the current binder @@ -60,6 +67,9 @@ -- ^ current (intermediate) expression , _curStep :: Int -- ^ current step in given top-level entity + , _curOccur :: Int + , _leftN :: Int -- # of occurrences in the left viewport + , _rightN :: Int -- # of occurrences in the right viewport } makeLenses ''VizState @@ -133,7 +143,10 @@ initialState hist = VizState { _steps = hist , _prevState = Nothing , _curExpr = initialExpr hist - , _curStep = 1 } + , _curStep = 1 + , _curOccur = 0 + , _leftN = 0 + , _rightN = 0 } currentStepName :: VizState term -> String currentStepName v = @@ -151,6 +164,9 @@ getCurrentState :: VizStates term -> VizState term getCurrentState vs = (vs^.states) ! (vs^.curBinder) +getSearchString :: Diff term => VizStates term -> String +getSearchString vs = case vs^.formData.trans of { Search s -> s; _ -> "" } + formData :: forall term . Diff term => Lens' (VizStates term) (OptionsUI term) @@ -178,35 +194,40 @@ step, unstep, reset :: Diff term => VizState term -> VizState term -- | Proceed to the next state. -step prev@(VizState [] _ _ _) = prev -step prev@(VizState (t:ts) _ curE curS) = +step prev@(VizState [] _ _ _ _ _ _) = prev +step prev@(VizState (t:ts) _ curE curS _ _ _) = VizState { _steps = ts , _prevState = Just prev , _curExpr = patch curE (t^.ctx) (t^.after) , _curStep = curS + 1 - } + , _curOccur = 0 + , _leftN = 0 + , _rightN = 0 } -- | Go back to the previous state. unstep st = case st^.prevState of Nothing -> st Just prev -> prev -- | Reset to the initial state. -reset first@(VizState _ Nothing _ _) = first -reset (VizState _ (Just prev) _ _) = reset prev +reset first@(VizState _ Nothing _ _ _ _ _) = first +reset (VizState _ (Just prev) _ _ _ _ _) = reset prev +--------------------------------------------------------- +-- Actions. + +data Direction = Forward | Backward + -- | Move to a specified step of the transformations of the current binder. -moveTo :: Diff term - => Int -> VizState term -> VizState term +moveTo :: Diff term => Int -> VizState term -> VizState term moveTo n v = if (v^.curStep) == (v'^.curStep) then v else moveTo n v' where v' = case n `compare` (v^.curStep) of { EQ -> v ; LT -> unstep v ; GT -> step v } -- | Move to the next/previous step with the given transformation name. -nextTrans :: Diff term - => (VizState term -> VizState term) - -> String -> VizState term -> VizState term -nextTrans f (map toLower -> s) v0 = go (f v0) +nextTrans :: Diff term => Direction -> String -> VizState term -> VizState term +nextTrans dir (map toLower -> s) v0 = go (next v0) where + next = case dir of { Forward -> step ; Backward -> unstep } startStep = v0^.curStep go v -- not found, abort | v^.curStep == startStep = v @@ -216,4 +237,11 @@ | (st:_) <- v^.steps , s `isInfixOf` (toLower <$> st^.name) = v -- continue searching.. - | otherwise = go (f v) + | otherwise = go (next v) + +-- | Cycle through search occurrences. +nextOccur :: Diff term => Direction -> VizState term -> VizState term +nextOccur Forward v = v & curOccur %~ (+ 1) +nextOccur Backward v = v & curOccur %~ back + where back 0 = max 0 (v^.leftN + v^.rightN - 1) + back i = i - 1