{-# 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
showCode :: forall n term
. Diff term
=> Bool
-> Int
-> Options term
-> String
-> [Ctx term]
-> term
-> Widget n
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
data MyDoc = MChar Char
| MString String
| MLine Int
| MMod [String] MyDoc
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) (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
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 :: 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"
defaultTheme :: [(String, V.Attr)] -> Bt.Theme
defaultTheme extraAttrs = 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)
, (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)
, ("type", V.defAttr `V.withForeColor` V.brightYellow)
, ("keyword", V.defAttr `V.withForeColor` V.rgbColor 255 165 0)
, ("literal", V.defAttr `V.withForeColor` V.brightCyan)
, ("unique", V.defAttr `V.withStyle` V.dim)
, ("qualifier", V.defAttr `V.withStyle` V.italic)
] ++ map (\(s, a) -> (B.attrName s, a)) extraAttrs
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)