rewrite-inspector 0.1.0.4 → 0.1.0.5
raw patch · 9 files changed
+392/−148 lines, 9 filesdep +hashabledep ~basenew-component:exe:str-example
Dependencies added: hashable
Dependency ranges changed: base
Files
- README.md +1/−2
- app/Main.hs +0/−68
- examples/expr/Main.hs +66/−0
- examples/str/Main.hs +67/−0
- rewrite-inspector.cabal +32/−6
- src/BrickUI.hs +104/−28
- src/Gen.hs +1/−0
- src/Pretty.hs +78/−29
- src/Types.hs +43/−15
README.md view
@@ -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 [](http://hackage.haskell.org/package/rewrite-inspector)+Available on [](http://hackage.haskell.org/package/rewrite-inspector)
− app/Main.hs
@@ -1,68 +0,0 @@-{-|- Copyright : (C) 2019, QBayLogic- License : BSD2 (see the file LICENSE)- Maintainer : Orestis Melkonian <melkon.or@gmail.com>-- 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"
+ examples/expr/Main.hs view
@@ -0,0 +1,66 @@+{-|+ Copyright : (C) 2019, QBayLogic+ License : BSD2 (see the file LICENSE)+ Maintainer : Orestis Melkonian <melkon.or@gmail.com>+-}+{-# 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"
+ examples/str/Main.hs view
@@ -0,0 +1,67 @@+{-|+ Copyright : (C) 2019, QBayLogic+ License : BSD2 (see the file LICENSE)+ Maintainer : Orestis Melkonian <melkon.or@gmail.com>+-}+{-# 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"
rewrite-inspector.cabal view
@@ -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
src/BrickUI.hs view
@@ -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 .~ []
src/Gen.hs view
@@ -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 :: *
src/Pretty.hs view
@@ -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]
src/Types.hs view
@@ -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