diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,10 +1,113 @@ # Rewrite Inspector -A terminal UI for inspecting steps taken by a rewriting process. -Useful for the optimization phase of a compiler, -or even evaluators of small languages. +A terminal user-interface (TUI) for inspecting steps taken by a rewriting process. +Useful for the optimization phase of a compiler, or even evaluators of small languages. +Available on [![Hackage](https://img.shields.io/hackage/v/rewrite-inspector.svg)](http://hackage.haskell.org/package/rewrite-inspector) + +## Usage Instructions 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). +must be an instance of the `Diff` typeclass. -Available on [![Hackage](https://img.shields.io/hackage/v/rewrite-inspector.svg)](http://hackage.haskell.org/package/rewrite-inspector) +Let's see an example for a simple language for arithmetic expressions. +```haskell +data Expr = N Int | Expr :+: Expr deriving (Eq, Show) +``` + +We first need to give the type of contexts, which navigate to a certain sub-term: +```haskell +data ExprContext = L | R deriving (Eq, Show) +``` + +We can then give the instance for the `Diff` typeclass, by providing the following: +1. `readHistory`: A way to read the rewrite history from file (for this example, always return a constant history). +2. `ppr'`: A pretty-printing for (for this example, the type of annotations is just the type of contexts) +3. `patch`: A way to patch a given expression at some context. + +Below is the complete definition of our instance: +```haskell +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" +``` + +Finally, we are ready to run our TUI to inspect the rewriting steps with proper +highlighting (`.ini` files are used to provide styling directives): +```haskell +main :: IO () +main = runTerminal @Expr "examples/expr/theme.ini" +``` + +For more examples, check the ![examples](https://github.com/omelkonian/rewrite-inspector/raw/master/examples/) folder. + +## Features +The features depicted below have been recorded on the optimizing phase of the +![Cλash compiler](https://github.com/clash-lang/clash-compiler/). + +1. Use `Ctrl-p` to show/hide keyboard controls: +![](https://github.com/omelkonian/rewrite-inspector/raw/master/gifs/controls.gif) + +2. Syntax highlighting: +![](https://github.com/omelkonian/rewrite-inspector/raw/master/gifs/syntax.gif) + +3. Navigate through the rewriting steps with highlighted diffs: +![](https://github.com/omelkonian/rewrite-inspector/raw/master/gifs/steps.gif) + +4. Also navigate through all top-level binders: +![](https://github.com/omelkonian/rewrite-inspector/raw/master/gifs/binders.gif) + +5. Hide extraneous code output, suc as uniques/types/qualifiers: +![](https://github.com/omelkonian/rewrite-inspector/raw/master/gifs/hiding.gif) + +6. Individual and grouped scrolling for code panes, both vertically and horizontally: +![](https://github.com/omelkonian/rewrite-inspector/raw/master/gifs/scrolling.gif) + +7. Move to next transformation with the given step number: +![](https://github.com/omelkonian/rewrite-inspector/raw/master/gifs/stepno.gif) + +8. Move to next transformation with the given name: +![](https://github.com/omelkonian/rewrite-inspector/raw/master/gifs/trans.gif) + +9. Search for string occurrences within source code: +![](https://github.com/omelkonian/rewrite-inspector/raw/master/gifs/search.gif) + +10. Inside code panes, the line width is dynamically adjusted depending on available space: +![](https://github.com/omelkonian/rewrite-inspector/raw/master/gifs/dynamic.gif) + +11. User-configurable colour theme: +![](https://github.com/omelkonian/rewrite-inspector/raw/master/gifs/theme.gif) 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.6 +version: 0.1.0.7 cabal-version: >=1.10 build-type: Simple license: BSD3 diff --git a/src/BrickUI.hs b/src/BrickUI.hs --- a/src/BrickUI.hs +++ b/src/BrickUI.hs @@ -3,11 +3,11 @@ License : BSD2 (see the file LICENSE) Maintainer : Orestis Melkonian - Basic functionality for the terminal UI. + Basic functionality for the terminal user-inteface (TUI). -} {-# LANGUAGE OverloadedStrings #-} -module BrickUI (runTerminal) where +module BrickUI where import System.Environment (getArgs) import Control.Applicative ((<|>)) @@ -35,7 +35,7 @@ import Types import Pretty --- | Entry point. +-- | Entry point for the TUI. runTerminal :: forall term. Diff term => FilePath -> IO () runTerminal ftheme = do res <- loadCustomizations ftheme (defaultTheme $ userStyles @term) @@ -52,15 +52,15 @@ (app @term (themeToAttrMap theme)) -- the Brick application (createVizStates @term hist) -- initial state --- | The Brick App. -app :: forall term. Diff term - => B.AttrMap -> App (VizStates term) NoCustomEvent Name -app attrMap = App { appDraw = drawUI - , appChooseCursor = chooseCursor - , appHandleEvent = handleStart - , appStartEvent = (lookupSize <*>) . return - , appAttrMap = const attrMap - } +-- | The 'Brick.App' configuration. +app :: Diff term => B.AttrMap -> App (VizStates term) NoCustomEvent Name +app attrMap = App + { appDraw = drawUI + , 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 @@ -70,11 +70,12 @@ where isSearch :: Cursor -> Bool isSearch = \case - CursorLocation {cursorLocationName = Just (SearchResult _ _)} -> True - _ -> False + CursorLocation {cursorLocationName = Just (SearchResult _)} -> True + _ -> False --- | Top-level: Draw all top-level binders and their current step. --- NB: delegates bottom-level to `drawUI` +-- * Display. + +-- Draw all top-level binders and their current step. drawUI :: forall term. Diff term => VizStates term -> [Widget Name] drawUI vs = @@ -110,8 +111,7 @@ diff | v@(VizState (st:_) _ curE _ curO _ _) <- getCurrentState vs = let - showE vn = showCode vn - (vs^.scroll) + showE vn = showCode (vs^.scroll) (min 80 $ getCodeWidth vs) (vs^.formData^.opts) (st^.ctx) @@ -178,6 +178,8 @@ where button .- desc = hBox [emph button, str $ " : " ++ desc] +-- * Event handling. + -- | Lookup terminal size and store in the current state. lookupSize :: EventM Name (VizStates term -> VizStates term) lookupSize = do @@ -219,7 +221,7 @@ -- some controls are disabled when the user is writing in the input form | [] <- mods - , focusGetCurrent (Bf.formFocus (vs^.form)) /= Just (FormField "Trans") + , focusGetCurrent (Bf.formFocus (vs^.form)) /= Just (FormField "Command") = sometimes -- the rest of the controls are active all the time @@ -248,9 +250,9 @@ contF = (>> continue (vs & scroll .~ False)) bottom fg = continue $ updateState vs (fg $ getCurrentState vs) & scroll .~ True - action dir = case vs^.formData.trans of + action dir = case vs^.formData.com of Step n -> bottom $ moveTo n - Name s -> bottom $ nextTrans dir s + Trans s -> bottom $ nextTrans dir s Search _ -> bottom $ nextOccur dir sometimes = case key of @@ -301,23 +303,25 @@ -- form-handler formHandler = do fm' <- Bf.handleFormEvent ev (vs^.form) - let tr = (Bf.formState fm')^.trans + let cm = (Bf.formState fm')^.com (_, tot, _) = getStep vs (vs^.curBinder) - valid = case tr of Step n -> n > 0 && n <= tot + valid = case cm of Step n -> n > 0 && n <= tot _ -> True - continue $ vs & form .~ Bf.setFieldValid valid (FormField "Trans") fm' + continue $ vs & form .~ Bf.setFieldValid valid (FormField "Command") fm' -- no-op event handleEvent vs _ = continue vs --- Scrolling, viewports. -l, r :: B.ViewportScroll Name -l = B.viewportScroll LeftViewport -r = B.viewportScroll RightViewport +-- * Scrolling. +-- | The amount of scrolling with each request (in pixels). scrollStep :: Int scrollStep = 5 +l, r :: B.ViewportScroll Name +l = B.viewportScroll LeftViewport +r = B.viewportScroll RightViewport + vScrollL, vScrollR, hScrollL, hScrollR, vScrollL', vScrollR', hScrollL', hScrollR', vScrollHomeL, vScrollHomeR, vScrollEndL, vScrollEndR :: EventM Name () vScrollL = B.vScrollBy l scrollStep @@ -333,26 +337,32 @@ vScrollEndL = B.vScrollToEnd l vScrollEndR = B.vScrollToEnd r +-- | Gather all cursor placement requests coming from within the given 'Widget', +-- filter out only those that are the result of a /search/ command, +-- and convert the current one (based on the current occurrence number) +-- to a visibility request. +-- NB: Only to be used within a 'viewport'. 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) + $ sortOn ((\case (SearchResult i) -> i) . snd) $ catMaybes $ map (\c -> case cursorLocationName c of - Just s@(SearchResult n _) -> Just (c, s) - _ -> Nothing) + Just s@(SearchResult _) -> 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 + , vrSize = (1, 1) }] & cursorsL .~ [c] +-- | Remove all cursor placement requests coming from within the given 'Widget'. +-- NB: Only to be used within a 'viewport'. invisibleCursors :: Widget n -> Widget n invisibleCursors p = Widget (hSize p) (vSize p) $ do res <- B.render p diff --git a/src/Gen.hs b/src/Gen.hs --- a/src/Gen.hs +++ b/src/Gen.hs @@ -18,16 +18,22 @@ import qualified Graphics.Vty as V --------------------------------------------------- --- Syntactic annotations used for highlighting. - +-- | Syntactic annotations used for highlighting. +-- This should be stored in the pretty-printed code output, +-- in addition to term contexts. data Syntax - = Type -- ^ type information - | Keyword -- ^ standard keywords of the language - | Literal -- ^ literal values (e.g. strings, numbers) - | Unique -- ^ unique identifiers - | Qualifier -- ^ qualifiers for modules - | Custom String -- ^ used for user-supplied styling + = Type + -- ^ type information + | Keyword + -- ^ standard keywords of the language + | Literal + -- ^ literal values (e.g. strings, numbers) + | Unique + -- ^ unique identifiers + | Qualifier + -- ^ qualifiers for modules + | Custom String + -- ^ used for user-supplied styling instance Show Syntax where show = \case @@ -38,59 +44,80 @@ Qualifier -> "qualifier" Custom s -> s --------------------------------------------------- --- Generic interface. - +-- | This is the typeclass that the user-supplied @term@ type should implement. +-- It requires all operations, which are necessary for our TUI to runn. class Eq (Ctx term) => Diff term where - -- T0D0 type family deps + -- | The type of annotations associated to the given @term@ type. type Ann term :: * + -- | The type of options for the associated pretty-printer for @term@. type Options term :: * + -- | The type of navigation contexts for values of type @term@. type Ctx term :: * + -- | Read a rewrite history from a binBooary file on disk. readHistory :: FilePath -> IO (History term (Ctx term)) default readHistory :: (Binary term, Binary (Ctx term)) => FilePath -> IO (History term (Ctx term)) readHistory = decodeFile + -- | Given a rewrite history, extract the top-level initial expression. initialExpr :: History term (Ctx term) -> term initialExpr = _before . last + -- | If a binder containing this name exists, display first in the list of binders. topEntity :: String topEntity = "top" + -- | Handle annotations of the pretty-printed code, + -- emitting either syntax elements or navigation contexts. handleAnn :: Ann term -> Either Syntax (Ctx term) default handleAnn :: Ann term ~ Ctx term => Ann term -> Either Syntax (Ctx term) handleAnn = Right + -- | User-supplied styling for the TUI. userStyles :: [(String, V.Attr)] userStyles = [] + -- | Initial options for the pretty-printer. initOptions :: Options term default initOptions :: Default (Options term) => Options term initOptions = def + -- | Provide the boolean flags of the pretty-printing options. + -- NB: Lenses are not used here, due to impredicativity... flagFields :: [( Options term -> Bool -- getter , Options term -> Bool -> Options term -- setter , String -- text to display )] flagFields = [] + -- | Pretty-print a given expression, given some options. + -- The resulting document format should contain syntax/context annotations. ppr' :: Options term -> term -> Doc (Ann term) + -- | Patch a given expression, given a navigation context to a sub-expression + -- and a new sub-expression to replace it. patch :: term -> [Ctx term] -> term -> term --------------------------------------------------- --- History datatype. +-- * Rewrite history. +-- | The rewrite history consists of multiple single steps of rewriting. type History term ctx = [HStep term ctx] -data HStep term ctx - = HStep { _ctx :: [ctx] - , _bndrS :: String - , _name :: String - , _before :: term - , _after :: term } - deriving (Generic, Show, Binary) + +-- | Each step of the rewrite history contains information about a single rewrite. +data HStep term ctx = HStep + { _ctx :: [ctx] + -- ^ the current context of the sub-expression being rewritten + , _bndrS :: String + -- ^ the name of the current binder + , _name :: String + -- ^ the name of the applied transformation + , _before :: term + -- ^ the sub-expression __before__ rewriting + , _after :: term + -- ^ the sub-expression __after__ rewriting + } deriving (Generic, Show, Binary) makeLenses ''HStep diff --git a/src/Pretty.hs b/src/Pretty.hs --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -3,7 +3,7 @@ License : BSD2 (see the file LICENSE) Maintainer : Orestis Melkonian - Pretty-printing utilities and styling for the UI. + Pretty-printing utilities and styling for the TUI. -} {-# LANGUAGE OverloadedStrings #-} @@ -29,13 +29,12 @@ import qualified Brick.Widgets.Border.Style as BrS import qualified Graphics.Vty as V - import Gen import Types ----------------------------------------------------------------------------- --- Pretty-printing Cλash Core. +-- * Rendering. +-- | Count number of occurrences of a given search string in a given expression. countOcc :: forall term . Diff term @@ -45,70 +44,76 @@ -> Int -- ^ total number of occurrences countOcc opts searchString = foldl (\cur d -> cur + countDoc d) 0 - . myForm @term [] [] [] [] + . myForm @term [] . layoutCompact . ppr' @term opts where countDoc :: MyDoc -> Int countDoc = \case - MString s -> snd (highlightSearch undefined 0 s searchString) + MString s -> snd (highlightSearch 0 s searchString) MMod _ d -> countDoc d MLine _ -> 0 +-- | Render the given expression as a 'Brick.Widget'. showCode :: forall n term . Diff term - => Name -- ^ viewport name - -> Bool -- ^ whether to scroll to focused region + => 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 +showCode scroll w opts ctx0 searchString = vBox - . fmap (render vn scroll searchString 0) . split . (MLine 0 :) - . myForm @term ctx0 [] [] [] + . fmap (render 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. +-- | A simpler document type, specific to our use-case. data MyDoc = MString String | MLine Int | MMod [String] MyDoc data Item = Stx | Ctx +-- | Convert a document stream into our simpler data type. myForm :: forall term. Diff term - => [Ctx term] -> [Ctx term] -> [Item] -> [String] + => [Ctx term] -> SimpleDocStream (Ann term) -> [MyDoc] +myForm ctx0 = go [] [] [] + where + go :: [Ctx term] -> [Item] -> [String] -> SimpleDocStream (Ann term) -> [MyDoc] -myForm ctx0 ctx' stack attrs = \case - SFail -> error "split.SFail" - SEmpty -> [mark (MString "")] - SChar c rest -> mark (MString [c]) : continueWith rest - SText _ s rest -> mark (MString (unpack s)) : continueWith rest - SLine i rest -> MLine i : continueWith rest - SAnnPush a rest -> case handleAnn @term a of - Left s -> myForm @term ctx0 ctx' (Stx:stack) (show s:attrs) rest - Right c -> myForm @term ctx0 (ctx' ++ [c]) (Ctx:stack) attrs rest - SAnnPop rest -> case top of - Stx -> myForm @term ctx0 ctx' stack' (tail attrs) rest - Ctx -> myForm @term ctx0 (init ctx') stack' attrs rest - where (top:stack') = stack - where continueWith = myForm @term ctx0 ctx' stack attrs - mark = MMod $ ["focus" | ctx0 `isPrefixOf` ctx'] ++ attrs + go ctx' stack attrs = + let + continueWith = go ctx' stack attrs + mark = MMod $ ["focus" | ctx0 `isPrefixOf` ctx'] ++ attrs + in \case + SFail -> error "split.SFail" + SEmpty -> [mark (MString "")] + SChar c rest -> mark (MString [c]) : continueWith rest + SText _ s rest -> mark (MString (unpack s)) : continueWith rest + SLine i rest -> MLine i : continueWith rest + SAnnPush a rest -> case handleAnn @term a of + Left s -> go ctx' (Stx:stack) (show s:attrs) rest + Right c -> go (ctx' ++ [c]) (Ctx:stack) attrs rest + SAnnPop rest -> case top of + Stx -> go ctx' stack' (tail attrs) rest + Ctx -> go (init ctx') stack' attrs rest + where (top:stack') = stack --- Split into individual lines (of some indendation). +-- | Split into individual lines (of some indendation). split :: [MyDoc] -> [(Int, [MyDoc])] split [] = [] split (MLine i : ys) = (i, ysL) : split ysR where (ysL, ysR) = break (\case (MLine _) -> True ; _ -> False) ys split _ = error "split: does not start with STLine" --- Render a single line in Brick (highlighting when marked). -render :: Name -> Bool -> String -> Int -> (Int, [MyDoc]) -> Widget Name -render vn scroll searchString n0 (i, xs) = B.padLeft (B.Pad i) +-- | Render a single line in Brick (highlighting when marked). +render :: Bool -> String -> Int -> (Int, [MyDoc]) -> Widget Name +render scroll searchString n0 (i, xs) = B.padLeft (B.Pad i) $ hBox $ render1 n0 xs where @@ -120,14 +125,12 @@ 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 + MString s -> highlightSearch n s searchString _ -> error "render1" - - ----------------------------------------------------------------------------- --- UI Styling. +-- * Styling. +-- | The default theme. defaultTheme :: [(String, V.Attr)] -> Bt.Theme defaultTheme extraAttrs = Bt.newTheme V.defAttr $ [ ("focus", B.bg $ V.rgbColor 47 79 79) @@ -147,21 +150,22 @@ , ("qualifier", V.defAttr `V.withStyle` V.italic) ] ++ map (\(s, a) -> (B.attrName s, a)) extraAttrs +-- | Add a list of stylistic modifications to a 'Widget'. modify :: Bool -> [String] -> Widget n -> Widget n modify scroll = foldr (.) id . fmap mod1 . sortOn (\case "Type" -> 1; _ -> 0) where mod1 "focus" = (if scroll then B.visible else id) . B.withDefAttr "focus" mod1 attr = B.withDefAttr (B.attrName attr) +-- | Highlight searched occurrences inside the given 'Widget'. highlightSearch - :: Name -- ^ viewport name - -> Int -- ^ occurrences so far + :: 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 = +highlightSearch n0 s0 toS = case toS of [] -> (str s0, n0) (c:_) -> first hBox $ go n0 (find s0 (findIndices (== c) s0)) @@ -171,7 +175,7 @@ where (x', n') = case x of Left s -> (str s, n) - Right s -> ( ( B.showCursor (SearchResult vn n) (B.Location (1,0)) + Right s -> ( ( B.showCursor (SearchResult n) (B.Location (0,0)) $ B.forceAttr "search" $ str s ) , n + 1 ) @@ -192,16 +196,21 @@ getPrefix (c:s) (c':s') | c == c' = getPrefix s s' | otherwise = Nothing +-- | Styling for emphasized strings. emph :: String -> Widget n emph = B.withAttr "emph" . str +-- | Styling for titles. title :: String -> Widget n title = B.withAttr "title" . str . (" " ++) . (++ " ") withBorder, withBorderSelected :: String -> Widget n -> Widget n +-- | Render a given widget inside a box with /unicode/ border. withBorder = withBorderStyle BrS.unicode +-- | Render a given widget inside a box with /unicode/ and /bold/ border. withBorderSelected = withBorderStyle BrS.unicodeBold +-- | Render given 'Widget' inside a box with the given title and border style. withBorderStyle :: BrS.BorderStyle -> String -> Widget n -> Widget n withBorderStyle style s w = B.withBorderStyle style @@ -209,14 +218,17 @@ $ B.padAll 1 $ w +-- | Fill requested word size with spaces (if necessary). fillSize :: Int -> String -> String fillSize n s = replicate l ' ' ++ s ++ replicate (l + r) ' ' where (l, r) = (n - length s) `quotRem` 2 +-- | A variant of 'vBox' that adds spaces in-between. vBoxSpaced :: [Widget n] -> Widget n vBoxSpaced [] = B.emptyWidget vBoxSpaced (w:ws) = vBox $ w : (B.padTop (B.Pad 1) <$> ws) +-- | A variant of 'hBox' that adds spaces in-between. hBoxSpaced :: Int -> [Widget n] -> Widget n hBoxSpaced _ [] = B.emptyWidget hBoxSpaced n (w:ws) = hBox $ w : (B.padLeft (B.Pad n) <$> ws) diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -24,36 +24,44 @@ import Gen +-- * Basic types. + +-- | Program binders (i.e. top-level identifiers) are identified by their name. type Binder = String +-- | Our @Brick@ TUI does not use any custom events. data NoCustomEvent +-- | The type of resource names, used throughout the TUI. data Name = LeftViewport | RightViewport -- ^ viewports | FormField String -- ^ form fields - | SearchResult - Name {- viewport name -} - Int {- occurrence -} + | SearchResult Int -- ^ search results with numbered occurrences | Other deriving (Eq, Ord, Show) +-- | Type of cursors in our TUI. type Cursor = CursorLocation Name -data Trans +-- | Commands that the user can issue through the input form. +data Command = Step Int -- ^ move to given step in the current binder - | Name String + | Trans String -- ^ move to the next/previous transformation with the given name | Search String -- ^ move to the next/previous occurrence of the searched string deriving (Eq, Ord, Show) +-- | Options kept and changed throught the TUI's input form. data OptionsUI term = OptionsUI - { _opts :: Options term - , _trans :: Trans + { _opts :: Options term + -- ^ options for the pretty-printer + , _com :: Command + -- ^ command to issue (search string, etc...) } makeLenses ''OptionsUI @@ -68,8 +76,11 @@ , _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 + -- ^ current occurrence we are highlighting + , _leftN :: Int + -- ^ # of occurrences in the left viewport + , _rightN :: Int + -- ^ # of occurrences in the right viewport } makeLenses ''VizState @@ -94,6 +105,9 @@ } makeLenses ''VizStates +-- * Getters and setters. + +-- | Create the input form. mkForm :: forall term. Diff term => OptionsUI term -> Form (OptionsUI term) NoCustomEvent Name @@ -102,19 +116,19 @@ (flagFields @term) ++ [ (str "move to " <+>) @@= - editField trans -- lens - (FormField "Trans") -- resource name + editField com -- lens + (FormField "Command") -- resource name (Just 1) -- line limit (pack . concat . tail . words . show) -- display - (readTrans . unpack . head) -- validate + (readCom . unpack . head) -- validate (txt . head) -- render id -- rendering augmentation ] where - readTrans x | Just n <- readMaybe x :: Maybe Int = Just $ Step n - | '%':'s':' ':s <- x = Just $ Search s - | '%':'t':' ':s <- x = Just $ Name s - | otherwise = Nothing + readCom x | Just n <- readMaybe x :: Maybe Int = Just $ Step n + | '%':'s':' ':s <- x = Just $ Search s + | '%':'t':' ':s <- x = Just $ Trans s + | otherwise = Nothing -- | Group the rewrite history by the different top-level binders. createVizStates :: forall term. Diff term @@ -127,8 +141,8 @@ $ map (\h -> (head h ^. bndrS, initialState h)) $ groupBy (\ x y -> x^.bndrS == y^.bndrS) $ sortOn _bndrS hist - , _form = mkForm @term (OptionsUI { _opts = initOptions @term - , _trans = Step 1 }) + , _form = mkForm @term (OptionsUI { _opts = initOptions @term + , _com = Step 1 }) , _showBot = False , _width = 0 , _height = 0 @@ -137,9 +151,8 @@ where bndrs = _bndrS <$> hist top = fromJust $ find (topEntity @term `isInfixOf`) bndrs -initialState :: Diff term - => History term (Ctx term) - -> VizState term +-- | State initialization for the bottom layer. +initialState :: Diff term => History term (Ctx term) -> VizState term initialState hist = VizState { _steps = hist , _prevState = Nothing , _curExpr = initialExpr hist @@ -148,12 +161,14 @@ , _leftN = 0 , _rightN = 0 } +-- | Get the name of the current transformation. currentStepName :: VizState term -> String currentStepName v = case v^.steps of [] -> "THE END" (st:_) -> st^.name +-- | Get information about the current step. getStep :: VizStates term -> Binder -> (Int {-current-}, Int {-total-}, String {-transformation-}) @@ -161,23 +176,34 @@ where v = (vs^.states) ! bndr cur = v^.curStep +-- | Get the current state of the bottom layer. getCurrentState :: VizStates term -> VizState term getCurrentState vs = (vs^.states) ! (vs^.curBinder) +-- | Get the current string we are searching for. +-- NB: Returns the empty string of no search command has been issued. getSearchString :: Diff term => VizStates term -> String -getSearchString vs = case vs^.formData.trans of { Search s -> s; _ -> "" } +getSearchString vs = case vs^.formData.com of { Search s -> s; _ -> "" } +-- | Lens from the /global/ state to the input form's data. formData :: forall term . Diff term => Lens' (VizStates term) (OptionsUI term) formData f vs = (\fm' -> vs {_form = mkForm @term fm'}) <$> f (formState $ _form vs) +-- | Update the /local/ state of the current binder. updateState :: VizStates term -> VizState term -> VizStates term updateState vs v = vs & states .~ insert (vs^.curBinder) v (vs^.states) +-- | Get the available code width for one of the two code panes. getCodeWidth :: VizStates term -> Int getCodeWidth vs = vs^.width `div` 2 +-- | Cycle through top-level binders in the /global/ state. +-- +-- [@stepBinder@] Proceed forward. +-- +-- [@unstepBinder@] Proceed backward. stepBinder, unstepBinder :: VizStates term -> VizStates term stepBinder vs = vs & curBinder .~ findNext (vs^.curBinder) (vs^.binders) where findNext :: Eq a => a -> [a] -> a @@ -190,10 +216,14 @@ | Just i <- x `elemIndex` xs, i > 0 = xs !! (i - 1) | otherwise = x - -step, unstep, reset :: Diff term - => VizState term -> VizState term --- | Proceed to the next state. +-- | Cycle through transformations of the current binder in the /local/ state. +-- +-- [@step@] Proceed forward. +-- +-- [@unstep@] Proceed backward. +-- +-- [@reset@] Reset to the initial state. +step, unstep, reset :: Diff term => VizState term -> VizState term step prev@(VizState [] _ _ _ _ _ _) = prev step prev@(VizState (t:ts) _ curE curS _ _ _) = VizState { _steps = ts @@ -203,17 +233,15 @@ , _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 ---------------------------------------------------------- --- Actions. +-- * User-issued commands. +-- | Some user commands have a notion of direction; either going forth or back. data Direction = Forward | Backward -- | Move to a specified step of the transformations of the current binder.