rewrite-inspector 0.1.0.6 → 0.1.0.7

raw patch · 6 files changed

+312/−132 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +108/−5
• rewrite-inspector.cabal +1/−1
• src/BrickUI.hs +43/−33
• src/Gen.hs +49/−22
• src/Pretty.hs +53/−41
• src/Types.hs +58/−30

@@ -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)

@@ -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

@@ -3,11 +3,11 @@   License     :  BSD2 (see the file LICENSE)   Maintainer  :  Orestis Melkonian <melkon.or@gmail.com> -  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

@@ -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

@@ -3,7 +3,7 @@   License     :  BSD2 (see the file LICENSE)   Maintainer  :  Orestis Melkonian <melkon.or@gmail.com> -  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)

@@ -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.