packages feed

rewrite-inspector (empty) → 0.1.0.0

raw patch · 9 files changed

+910/−0 lines, 9 filesdep +basedep +binarydep +bricksetup-changed

Dependencies added: base, binary, brick, containers, data-default, microlens, microlens-th, prettyprinter, rewrite-inspector, text, vty

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2019, QBayLogic+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,3 @@+1. `stack setup`+2. `stack build`+3. `stack exec music-exe` or `stack test`
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,68 @@+{-|+  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"
+ rewrite-inspector.cabal view
@@ -0,0 +1,70 @@+name: rewrite-inspector+version: 0.1.0.0+cabal-version: >=1.10+build-type: Simple+license: BSD3+license-file: LICENSE+maintainer: Orestis Melkonian <melkon.or@gmail.com>+stability: experimental+homepage: http://github.com/omelkonian/rewrite-inspector/+bug-reports: http://github.com/omelkonian/rewrite-inspector/issues+synopsis: Inspection of rewriting steps+description:+    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.+author: Orestis Melkonian+extra-source-files:+    README.md+    LICENSE++source-repository head+    type: git+    location: git://github.com/omelkonian/rewrite-inspector.git++library+    hs-source-dirs:   src+    exposed-modules:  Gen+                      Types+                      Pretty+                      BrickUI+    build-depends:    base          >= 4.7  && < 5,+                      binary        >= 0.8.5    && < 0.11,+                      containers    >= 0.5.0.0  && < 0.7,+                      brick         >= 0.40,+                      vty           >= 5.23.1,+                      prettyprinter >= 1.2.0.1  && < 2.0,+                      text,+                      microlens     >= 0.3.0.0,+                      microlens-th,+                      data-default  >= 0.7.1.1++    ghc-options:      -Wall+    default-language: Haskell2010+    default-extensions: ScopedTypeVariables+                        ViewPatterns+                        LambdaCase+                        MultiParamTypeClasses+                        FunctionalDependencies+                        ConstraintKinds+                        TypeApplications+                        AllowAmbiguousTypes+                        TypeSynonymInstances+                        TypeOperators+                        DeriveGeneric+                        DeriveAnyClass+                        DefaultSignatures+                        TypeFamilies+                        FlexibleContexts+                        StandaloneDeriving++executable expr-example+    hs-source-dirs:   app+    main-is:          Main.hs+    build-depends:    base >=4.7 && <5,+                      rewrite-inspector -any,+                      prettyprinter >= 1.2.0.1  && < 2.0++    ghc-options:      -threaded+    extra-libraries:  pthread+    default-language: Haskell2010
+ src/BrickUI.hs view
@@ -0,0 +1,283 @@+{-|+  Copyright   :  (C) 2019, QBayLogic+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Orestis Melkonian <melkon.or@gmail.com>++  Basic functionality for the terminal UI.+-}+{-# LANGUAGE OverloadedStrings #-}++module BrickUI (runTerminal) where++import System.Environment (getArgs)+import Control.Monad      (void, (>>))+import Lens.Micro++import Brick+  ( App (..), BrickEvent (..), EventM, Next, Widget+  , continue, halt+  , str, vBox, hBox+  )+import Brick.Focus  (focusRingCursor, focusGetCurrent)+import Brick.Themes (loadCustomizations, themeToAttrMap)+import qualified Brick                as B+import qualified Brick.Forms          as Bf+import qualified Brick.Widgets.Center as C+import qualified Graphics.Vty         as V++import Gen+import Types+import Pretty++-- | Entry point.+runTerminal :: forall term. Diff term => FilePath -> IO ()+runTerminal ftheme = do+  res <- loadCustomizations ftheme (defaultTheme $ annStyles @term)+  case res of+    Left err ->+      error $ "[theme.ini] Configuration file is malformed: " ++ err+    Right theme -> do+      [fname] <- getArgs+      hist    <- readHistory @term fname+      void $ B.customMain+        -- Vty configuration+        (V.mkVty $ V.defaultConfig { V.vtime = Just 100, V.vmin  = Just 1 })+        Nothing                             -- event channel+        (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 = focusRingCursor (Bf.formFocus . _form)+                  , appHandleEvent  = handleStart+                  , appStartEvent   = (lookupSize <*>) . return+                  , appAttrMap      = const attrMap+                  }++-- | Top-level: Draw all top-level binders and their current step.+-- NB: delegates bottom-level to `drawUI`+drawUI :: forall term. Diff term+       => VizStates term -> [Widget Name]+drawUI vs =+  [ B.translateBy (B.Location controlsOffset) controls+  | vs^.showBot+  ]+  +++  [ vBox+      [ B.vLimitPercent 20 $+          C.hCenter $+            hBoxSpaced 2 (drawBndr <$> vs^.binders)+      , diff+      , B.vLimitPercent 10 inputForm+      ]+  ]+  where+    -- display the top-level binders+    drawBndr :: Binder -> Widget Name+    drawBndr bndr+      = wb (show curN ++ "/" ++ show totN ++ " (" ++ stepName ++ ")")+      $ str (fillSize 50 bndr)+      where+        (curN, totN, stepName) = getStep vs bndr+        wb | bndr == vs^.curBinder = withBorderSelected+           | otherwise             = withBorder++    -- display the diff of this rewrite step+    diff :: Widget Name+    diff+      | v@(VizState (st:_) _ curE _) <- getCurrentState vs+      = let+          showE = showCode (vs^.scroll)+                           (min 80 $ getCodeWidth vs)+                           (vs^.formData^.opts)+                           (case vs^.formData.trans of {Search s -> s; _ -> ""})+                           (st^.ctx)+          nextE = step v ^. curExpr+        in+          hBoxSpaced 2+            [ B.viewport LeftViewport B.Both $+                withBorder "Before" $ showE curE+            , B.viewport RightViewport B.Both $+                withBorder "After" $ showE nextE+            ]++      | otherwise+      = C.center $ title "THE END"++    -- display the (editable) input form+    inputForm :: Widget Name+    inputForm = withBorder "Input"+              $ Bf.renderForm+              $ Bf.setFormConcat (hBoxSpaced 10)+              $ vs^.form++    -- display the keyboard controls+    controlsOffset :: (Int, Int)+    controlsOffset = ( (vs^.width `div` 2) - 25+                     , (vs^.height `div` 2) - 15+                     )++    controls :: Widget Name+    controls = withBorder "Controls" $ vBoxSpaced+      [ "→ / ← (Ctrl-l / Ctrl-k)" .- "next/previous binder"+      , "↓ / ↑"                   .- "next/previous step"+      , "r"                       .- "reset"+      , "Escape"                  .- "quit"+      , "Shift-<dir>"             .- "scroll left pane"+      , "Ctrl-<dir>"              .- "scroll right pane"+      , "PageUp/Down"             .- "scroll both panes (up/down)"+      , "Home/End"                .- "(vertically) scroll to start/end"+      , "Ins/Del"                 .- "scroll both panes (left/right)"+      , "Ctrl-p"                  .- "show/hide keyboard controls"+      , "(Shift-)Tab"             .- "cycle through input fields"+      , "Enter"                   .- "submit move action"+      , "Space"                   .- "toggle flag"+      ]+      where+        button .- desc = hBox [emph button, str $ " : " ++ desc]++-- 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.+handleStart :: forall term. Diff term+            => VizStates term+            -> BrickEvent Name NoCustomEvent+            -> EventM Name (Next (VizStates term))+handleStart vs ev = do+  pre <- lookupSize+  vs' <- handleEvent (pre vs) ev+  post <- lookupSize+  return (post <$> vs')++-- | Handle keyboard events.+handleEvent :: Diff term+            => VizStates term+            -> BrickEvent Name NoCustomEvent+            -> EventM Name (Next (VizStates term))+handleEvent vs ev@(VtyEvent (V.EvKey key mods))++  -- some controls are disabled when the user is writing in the input form+  | [] <- mods+  , focusGetCurrent (Bf.formFocus (vs^.form)) /= Just (FormField "Trans")+  = sometimes++  -- the rest of the controls are active all the time+  | [] <- mods+  = always++  | [V.MShift] <- mods+  = case key of+      -- search (next)+      V.KEnter -> search unstep+      _        -> shiftScroll++  | [V.MCtrl] <- mods+  = case key of+      -- show/hide bottom pane+      V.KChar 'p' -> continue (vs & showBot %~ not)+      -- search (previous)+      V.KEnter    -> search unstep+      -- change top-level binder+      V.KChar 'l' -> contT (stepBinder vs)+      V.KChar 'k' -> contT (unstepBinder vs)+      _        -> ctrlScroll++  | otherwise+  = continue vs++  where+    contT      = continue . (scroll .~ True)+    contF      = (>> continue (vs & scroll .~ False))+    bottom fg  = continue $ updateState vs (fg $ getCurrentState vs)+                          & scroll .~ True+    search f  = case vs^.formData.trans of+      Step n   -> bottom $ moveTo n+      Name s   -> bottom $ nextTrans f s+      _        -> continue vs++    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+      -- change top-level binder+      V.KRight    -> contT (stepBinder vs)+      V.KLeft     -> contT (unstepBinder vs)+      _           -> always++    always = case key of+      -- basic controls+      V.KEsc      -> halt vs+      -- change step of current binder+      V.KDown     -> bottom step+      V.KUp       -> bottom unstep+      -- vertical scrolling (both)+      V.KPageDown -> contF (vScrollL     >> vScrollR)+      V.KPageUp   -> contF (vScrollL'    >> vScrollR')+      V.KHome     -> contF (vScrollHomeL >> vScrollHomeR)+      V.KEnd      -> contF (vScrollEndL  >> vScrollEndR)+      -- horizontal scrolling (both)+      V.KDel      -> contF (hScrollL  >> hScrollR)+      V.KIns      -> contF (hScrollL' >> hScrollR')+      -- move to next step/transformation+      V.KEnter    -> search step+      -- dispatch to form handler+      _           -> formHandler++    shiftScroll = contF $ case key of+      -- vertical/horizontal scrolling (left side)+      V.KDown  -> vScrollL+      V.KUp    -> vScrollL'+      V.KRight -> hScrollL+      V.KLeft  -> hScrollL'+      _        -> return ()++    ctrlScroll = contF $ case key of+      -- vertical/horizontal scrolling (right side)+      V.KDown  -> vScrollR+      V.KUp    -> vScrollR'+      V.KRight -> hScrollR+      V.KLeft  -> hScrollR'+      _        -> return ()++    -- form-handler+    formHandler = do+      fm' <- Bf.handleFormEvent ev (vs^.form)+      let tr          = (Bf.formState fm')^.trans+          (_, tot, _) = getStep vs (vs^.curBinder)+          valid       = case tr of Step n  -> n > 0 && n <= tot+                                   _       -> True+      continue $ vs & form .~ Bf.setFieldValid valid (FormField "Trans") fm'++-- no-op event+handleEvent vs _ = continue vs++-- Scrolling, viewports.+l, r :: B.ViewportScroll Name+l = B.viewportScroll LeftViewport+r = B.viewportScroll RightViewport++scrollStep :: Int+scrollStep = 5++vScrollL, vScrollR, hScrollL, hScrollR, vScrollL', vScrollR', hScrollL', hScrollR',+  vScrollHomeL, vScrollHomeR, vScrollEndL, vScrollEndR :: EventM Name ()+vScrollL     = B.vScrollBy l scrollStep+vScrollL'    = B.vScrollBy l (-scrollStep)+vScrollR     = B.vScrollBy r scrollStep+vScrollR'    = B.vScrollBy r (-scrollStep)+hScrollL     = B.hScrollBy l scrollStep+hScrollL'    = B.hScrollBy l (-scrollStep)+hScrollR     = B.hScrollBy r scrollStep+hScrollR'    = B.hScrollBy r (-scrollStep)+vScrollHomeL = B.vScrollToBeginning l+vScrollHomeR = B.vScrollToBeginning r+vScrollEndL  = B.vScrollToEnd l+vScrollEndR  = B.vScrollToEnd r
+ src/Gen.hs view
@@ -0,0 +1,76 @@+{-|+  Copyright   :  (C) 2019, QBayLogic+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Orestis Melkonian <melkon.or@gmail.com>++  Generic interface for Term types.+-}+{-# LANGUAGE TemplateHaskell #-}+module Gen where++import GHC.Generics (Generic)++import Data.Binary               (Binary, decodeFile)+import Data.Default              (Default, def)+import Data.Text.Prettyprint.Doc (Doc)++import Lens.Micro.TH (makeLenses)++import qualified Graphics.Vty as V++-------------------------------+-- Generic interface.++class Eq (Ctx term) => Diff term where+  type Ann     term :: *+  type Options term :: *+  type Ctx     term :: *++  readHistory :: FilePath -> IO (History term (Ctx term))++  default readHistory :: (Binary term, Binary (Ctx term))+                      => FilePath -> IO (History term (Ctx term))+  readHistory = decodeFile++  initialExpr :: History term (Ctx term) -> term+  initialExpr = _before . last++  topEntity :: String+  topEntity = "top"++  handleAnn :: Ann term -> Either String (Ctx term)++  default handleAnn :: Ann term ~ Ctx term => Ann term -> Either String (Ctx term)+  handleAnn = Right++  annStyles :: [(String, V.Attr)]+  annStyles = []++  initOptions :: Options term++  default initOptions :: Default (Options term) => Options term+  initOptions = def++  flagFields :: [( Options term -> Bool                  -- getter+                 , Options term -> Bool -> Options term  -- setter+                 , String                                -- text to display+                 )]+  flagFields = []++  ppr' :: Options term -> term -> Doc (Ann term)++  patch :: term -> [Ctx term] -> term -> term+++--------------------------------+-- History datatype.++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)+makeLenses ''HStep
+ src/Pretty.hs view
@@ -0,0 +1,167 @@+{-|+  Copyright   :  (C) 2019, QBayLogic+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Orestis Melkonian <melkon.or@gmail.com>++  Pretty-printing utilities and styling for the UI.+-}++{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Pretty where++import Brick (Widget, str, hBox, vBox)+import qualified Brick                      as B+import qualified Brick.Forms                as Bf+import qualified Brick.Themes               as Bt+import qualified Brick.Widgets.Edit         as E+import qualified Brick.Widgets.Border       as Br+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++----------------------------------------------------------------------------+-- Pretty-printing Cλash Core.+++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 :)+  . myForm @term ctx0 [] [] []+  . layoutPretty (LayoutOptions (AvailablePerLine w 0.8))+  . ppr' @term opts++-- Convert a stream into our simpler data type.+data Item = Stx | Ctx++myForm :: forall term. Diff term+       => [Ctx term] -> [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) (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++data MyDoc = MChar Char+           | MString String+           | MLine Int+           | MMod [String] MyDoc++-- 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 :: Bool -> String -> (Int, [MyDoc]) -> Widget n+render scroll searchString (i, xs) = B.padLeft (B.Pad i) $ hBox $ render1 <$> xs+  where+    render1 :: MyDoc -> Widget n+    render1 = \case+      MMod attrs x -> modify scroll (nub attrs) (render1 x)+      MString s    -> highlightSearch s searchString+      _            -> error "render1"++----------------------------------------------------------------------------+-- UI Styling.++defaultTheme :: [(String, V.Attr)] -> Bt.Theme+defaultTheme userStyles = Bt.newTheme V.defAttr $+  [ ("focus",      B.bg $ V.rgbColor 47 79 79)+  , ("title",      V.defAttr `V.withStyle` V.bold)+  , ("emph",       V.defAttr `V.withStyle` V.bold)+  , ("search",     V.defAttr `V.withStyle` V.underline)+    -- forms+  , (E.editAttr,              V.white `B.on` V.black)+  , (E.editFocusedAttr,       V.black `B.on` V.yellow)+  , (Bf.invalidFormInputAttr, V.white `B.on` V.red)+  , (Bf.focusedFormInputAttr, V.black `B.on` V.yellow)+  ] ++ map (\(s, a) -> (B.attrName s, a)) userStyles++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)++highlightSearch :: String -> String -> Widget n+highlightSearch s0 toS+  | null toS  = str s0+  | otherwise = hBox $ mark <$> find s0 (findIndices (== head toS) s0)+  where+    mark = \case Left s -> str s; Right s -> B.forceAttr "search" $ str s++    find :: String -> [Int] -> [Either String String]+    find s []     = [Left s]+    find s (i:is)+      | i > 0 = Left (take i s) : find (drop i s) ((\j -> j - i) <$> (i:is))++      | Just s' <- toS `getPrefix` s+      = Right toS : find s' ((\j -> j - length toS) <$> is)++      | otherwise+      = find s is++    getPrefix []    s       = Just s+    getPrefix _     []      = Nothing+    getPrefix (c:s) (c':s') | c == c'   = getPrefix s s'+                            | otherwise = Nothing++emph :: String -> Widget n+emph = B.withAttr "emph" . str++title :: String -> Widget n+title = B.withAttr "title"  . str . (" " ++) . (++ " ")++withBorder, withBorderSelected :: String -> Widget n -> Widget n+withBorder           = withBorderStyle BrS.unicode+withBorderSelected   = withBorderStyle BrS.unicodeBold++withBorderStyle :: BrS.BorderStyle -> String -> Widget n -> Widget n+withBorderStyle style s w =+    B.withBorderStyle style+  $ Br.borderWithLabel (title s)+  $ B.padAll 1+  $ w++fillSize :: Int -> String -> String+fillSize n s = replicate l ' ' ++ s ++ replicate (l + r) ' '+  where (l, r) = (n - length s) `quotRem` 2++vBoxSpaced :: [Widget n] -> Widget n+vBoxSpaced []     = B.emptyWidget+vBoxSpaced (w:ws) = vBox $ w : (B.padTop (B.Pad 1) <$> ws)++hBoxSpaced :: Int -> [Widget n] -> Widget n+hBoxSpaced _ []     = B.emptyWidget+hBoxSpaced n (w:ws) = hBox $ w : (B.padLeft (B.Pad n) <$> ws)
+ src/Types.hs view
@@ -0,0 +1,219 @@+{-|+  Copyright   :  (C) 2019, QBayLogic+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Orestis Melkonian <melkon.or@gmail.com>++  Basic datatypes.+-}+{-# LANGUAGE OverloadedStrings, TemplateHaskell, Rank2Types #-}++module Types where++import Data.Char  (toLower)+import Data.List  (delete, elemIndex, find, isInfixOf, groupBy, nub, sortOn)+import Data.Maybe (fromJust)+import Data.Map   ((!), Map, insert, fromList)+import Text.Read  (readMaybe)+import Data.Text  (pack, unpack)++import Lens.Micro    ((^.), (&), (.~), Lens', lens)+import Lens.Micro.TH (makeLenses)++import Brick       ((<+>), str, txt)+import Brick.Forms ((@@=), checkboxField, editField, formState, newForm, Form)++import Gen++type Binder = String++data NoCustomEvent++data Name+  = LeftViewport | RightViewport+  -- ^ viewports+  | FormField String+  -- ^ form fields+  deriving (Eq, Ord, Show)++data Trans+  = Step Int+  -- ^ move to given step in the current binder+  | Name 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)++data OptionsUI term = OptionsUI+  { _opts  :: Options term+  , _trans :: Trans+  }+makeLenses ''OptionsUI++-- | Bottom-level state of the UI (navigate steps of a top-level binder).+data VizState term = VizState+  { _steps     :: History term (Ctx term)+  -- ^ steps of the rewriting process+  , _prevState :: Maybe (VizState term)+  -- ^ previous state (initially Nothing)+  , _curExpr   :: term+  -- ^ current (intermediate) expression+  , _curStep   :: Int+  -- ^ current step in given top-level entity+  }+makeLenses ''VizState++-- | Top-level state of the UI (navigate top-level binders).+data VizStates term = VizStates+  { _binders   :: [Binder]+  -- ^ all top-level binders+  , _curBinder :: Binder+  -- ^ currently selected binder+  , _states    :: Map Binder (VizState term)+  -- ^ state of each binder+  , _form      :: Form (OptionsUI term) NoCustomEvent Name+  -- ^ input form for setting parameters+  , _showBot   :: Bool+  -- ^ whether to hide bottom pane+  , _width     :: Int+  -- ^ current terminal width+  , _height    :: Int+  -- ^ current terminal height+  , _scroll    :: Bool+  -- ^ whether to scroll to focused region+  }+makeLenses ''VizStates++mkForm :: forall term. Diff term+       => OptionsUI term+       -> Form (OptionsUI term) NoCustomEvent Name+mkForm = newForm $+  map (\(f, g, s) -> checkboxField (opts . lens f g) (FormField s) (pack s))+      (flagFields @term)+  +++  [ (str "move to " <+>) @@=+      editField trans -- lens+                (FormField "Trans") -- resource name+                (Just 1) -- line limit+                (pack . concat . tail . words . show) -- display+                (readTrans . 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++-- | Group the rewrite history by the different top-level binders.+createVizStates :: forall term. Diff term+                => History term (Ctx term)+                -> VizStates term+createVizStates hist = VizStates+  { _binders    = top : (delete top $ nub bndrs)+  , _curBinder  = top+  , _states     = fromList+                $ 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 })+  , _showBot    = False+  , _width      = 0+  , _height     = 0+  , _scroll     = True+  }+  where bndrs = _bndrS <$> hist+        top   = fromJust $ find (topEntity @term `isInfixOf`) bndrs++initialState :: Diff term+             => History term (Ctx term)+             -> VizState term+initialState hist = VizState { _steps      = hist+                             , _prevState  = Nothing+                             , _curExpr    = initialExpr hist+                             , _curStep    = 1 }++currentStepName :: VizState term -> String+currentStepName v =+  case v^.steps of+    []     -> "THE END"+    (st:_) -> st^.name++getStep :: VizStates term+        -> Binder+        -> (Int {-current-}, Int {-total-}, String {-transformation-})+getStep vs bndr = (cur, cur + length (v^.steps), currentStepName v)+  where v   = (vs^.states) ! bndr+        cur = v^.curStep++getCurrentState :: VizStates term -> VizState term+getCurrentState vs = (vs^.states) ! (vs^.curBinder)++formData :: forall term+          . Diff term+         => Lens' (VizStates term) (OptionsUI term)+formData f vs = (\fm' -> vs {_form = mkForm @term fm'}) <$> f (formState $ _form vs)++updateState :: VizStates term -> VizState term -> VizStates term+updateState vs v = vs & states .~ insert (vs^.curBinder) v (vs^.states)++getCodeWidth :: VizStates term -> Int+getCodeWidth vs = vs^.width `div` 2++stepBinder, unstepBinder :: VizStates term -> VizStates term+stepBinder vs = vs & curBinder .~ findNext (vs^.curBinder) (vs^.binders)+  where findNext :: Eq a => a -> [a] -> a+        findNext x xs+          | Just i <- x `elemIndex` xs, i < (length xs - 1) = xs !! (i + 1)+          | otherwise                                       = x+unstepBinder vs = vs & curBinder .~ findPrev (vs^.curBinder) (vs^.binders)+  where findPrev :: Eq a => a -> [a] -> a+        findPrev x xs+          | 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.+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+           }+-- | 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++-- | Move to a specified step of the transformations of the current binder.+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)+  where+    startStep = v0^.curStep+    go v -- not found, abort+         | v^.curStep == startStep = v+         -- end of steps, reset+         | [] <- v^.steps = go (reset v)+         -- found, return+         | (st:_) <- v^.steps+         , s `isInfixOf` (toLower <$> st^.name) = v+         -- continue searching..+         | otherwise = go (f v)