diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +1. `stack setup` +2. `stack build` +3. `stack exec music-exe` or `stack test` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,68 @@ +{-| + Copyright : (C) 2019, QBayLogic + License : BSD2 (see the file LICENSE) + Maintainer : Orestis Melkonian + + Entry point for the @clash-term@ executable. +-} +{-# LANGUAGE OverloadedStrings, TypeApplications, TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Main (main) where + +import GHC.Generics (Generic) +import Data.Text.Prettyprint.Doc (annotate, hsep, pretty) + +import Gen +import BrickUI (runTerminal) + +main :: IO () +main = runTerminal @Expr "app/theme.ini" + +------------------------------- +-- Adhoc instance for Diff. + +data Expr = N Int | Expr :+: Expr deriving (Eq, Show) + +data ExprContext = L | R deriving (Eq, Show) + +instance Diff Expr where + type Ann Expr = ExprContext + type Options Expr = () + type Ctx Expr = ExprContext + + readHistory _ = return [ HStep { _ctx = [L] + , _bndrS = "top" + , _name = "adhocI" + , _before = N 1 + , _after = N 11 :+: N 12 + } + , HStep { _ctx = [L, L] + , _bndrS = "top" + , _name = "adhocII" + , _before = N 11 + , _after = N 111 :+: N 112 + } + , HStep { _ctx = [] + , _bndrS = "top" + , _name = "normalization" + , _before = N 1 :+: (N 2 :+: N 3) + , _after = ((N 111 :+: N 112) :+: N 12) + :+: (N 2 :+: N 3) + } + ] + + ppr' _ (N n) = pretty n + ppr' opts (e :+: e') = hsep [ annotate L (ppr' opts e) + , "+" + , annotate R (ppr' opts e') + ] + + patch _ [] e' = e' + patch curE (c:cs) e' = let go e = patch e cs e' in + case (curE, c) of + (l :+: r, L) -> go l :+: r + (l :+: r, R) -> l :+: go r + _ -> error "patch" diff --git a/rewrite-inspector.cabal b/rewrite-inspector.cabal new file mode 100644 --- /dev/null +++ b/rewrite-inspector.cabal @@ -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 +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 diff --git a/src/BrickUI.hs b/src/BrickUI.hs new file mode 100644 --- /dev/null +++ b/src/BrickUI.hs @@ -0,0 +1,283 @@ +{-| + Copyright : (C) 2019, QBayLogic + License : BSD2 (see the file LICENSE) + Maintainer : Orestis Melkonian + + 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-" .- "scroll left pane" + , "Ctrl-" .- "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 diff --git a/src/Gen.hs b/src/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Gen.hs @@ -0,0 +1,76 @@ +{-| + Copyright : (C) 2019, QBayLogic + License : BSD2 (see the file LICENSE) + Maintainer : Orestis Melkonian + + 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 diff --git a/src/Pretty.hs b/src/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Pretty.hs @@ -0,0 +1,167 @@ +{-| + Copyright : (C) 2019, QBayLogic + License : BSD2 (see the file LICENSE) + Maintainer : Orestis Melkonian + + 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) diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,219 @@ +{-| + Copyright : (C) 2019, QBayLogic + License : BSD2 (see the file LICENSE) + Maintainer : Orestis Melkonian + + 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)