diff --git a/app/Main.hs b/app/Main.hs index 0517ac6..df6bed7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,16 +4,19 @@ module Main where import Brick import Control.Monad -import qualified Graphics.Vty as Vty +import qualified Data.Text.IO as T +import qualified Graphics.Vty as Vty +import Options.Applicative -import Profold.LineNode +import Profold.Options +import Profold.ParseProfFile import Profold.UiState data UiName = UiViewport deriving (Show, Eq, Ord) myAppDraw :: UiState -> [Widget UiName] -myAppDraw s = [viewport UiViewport Vertical $ renderUiState s] +myAppDraw s = [renderUiState UiViewport s] myHandleEvent :: UiState -> BrickEvent n e -> EventM n (Next UiState) myHandleEvent s (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt s @@ -32,7 +35,7 @@ myAttrMap = attrMap Vty.defAttr myApp :: App UiState () UiName myApp = App - { appDraw = \s -> [renderUiState s] + { appDraw = myAppDraw , appChooseCursor = neverShowCursor , appHandleEvent = myHandleEvent , appStartEvent = pure @@ -40,7 +43,12 @@ myApp = App } main :: IO () -main = void $ defaultMain myApp $ newUiState $ newLineNode "Hello world" - [ newLineNode " Child" [] - , newLineNode " More children" [] - ] +main = do + opts <- execParser options + let filename = optFileName opts + text <- T.readFile filename + case parseProfFile filename text of + Left e -> putStrLn e + Right f -> do + print f + void $ defaultMain myApp $ newUiState (profInfoLines f) (profNode f) diff --git a/package.yaml b/package.yaml index f4bcf91..f11bcaf 100644 --- a/package.yaml +++ b/package.yaml @@ -15,8 +15,8 @@ extra-source-files: dependencies: - base >= 4.7 && < 5 - brick -- containers - megaparsec +- optparse-applicative - text - vector - vty diff --git a/src/Profold/Options.hs b/src/Profold/Options.hs new file mode 100644 index 0000000..9d3b10e --- /dev/null +++ b/src/Profold/Options.hs @@ -0,0 +1,17 @@ +module Profold.Options + ( Options(..) + , options + ) where + +import Options.Applicative + +newtype Options = Options + { optFileName :: String + } deriving (Show) + +parser :: Parser Options +parser = Options + <$> strArgument (help "Path to the .prof file" <> metavar "FILE") + +options :: ParserInfo Options +options = info (helper <*> parser) fullDesc diff --git a/src/Profold/ParseProfFile.hs b/src/Profold/ParseProfFile.hs new file mode 100644 index 0000000..bf3809d --- /dev/null +++ b/src/Profold/ParseProfFile.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Profold.ParseProfFile + ( ProfFile(..) + , parseProfFile + ) where + +import Control.Monad +import qualified Data.Text as T +import Data.Void +import Text.Megaparsec +import Text.Megaparsec.Char + +import Profold.LineNode + +data ProfFile = ProfFile + { profInfoLines :: [T.Text] + , profNode :: LineNode + } deriving (Show) + +type Parser = Parsec Void T.Text + +line :: Parser T.Text +line = label "line" $ takeWhileP Nothing (/= '\n') <* newline + +skipUntilTheInterestingStuff :: Parser () +skipUntilTheInterestingStuff = void $ skipManyTill line newLines + where + newLines = try $ newline >> newline + +lineWithIndentation :: T.Text -> Parser T.Text +lineWithIndentation indentation = do + void $ string indentation + l <- line + pure $ indentation <> l + +lineNode :: T.Text -> Parser LineNode +lineNode indentation = do + text <- lineWithIndentation indentation + children <- many $ lineNode $ indentation <> " " + pure $ newLineNode text children + +profFile :: Parser ProfFile +profFile = do + skipUntilTheInterestingStuff + info <- count 2 line + void newline + node <- lineNode "" + pure $ ProfFile info node + +parseProfFile :: String -> T.Text -> Either String ProfFile +parseProfFile filename text = case parse profFile filename text of + Left e -> Left $ errorBundlePretty e + Right f -> Right f diff --git a/src/Profold/UiState.hs b/src/Profold/UiState.hs index 162d195..cc634d4 100644 --- a/src/Profold/UiState.hs +++ b/src/Profold/UiState.hs @@ -13,18 +13,20 @@ module Profold.UiState import Brick import Data.Maybe +import qualified Data.Text as T import qualified Data.Vector as V import Profold.LineNode import Profold.Util data UiState = UiState - { uiTree :: LineNode + { uiInfo :: [T.Text] + , uiTree :: LineNode , uiFocused :: Path } deriving (Show) -newUiState :: LineNode -> UiState -newUiState ln = UiState ln [] +newUiState :: [T.Text] -> LineNode -> UiState +newUiState info ln = UiState info ln [] moveFocusUp :: UiState -> UiState moveFocusUp s = @@ -50,24 +52,22 @@ toggleFold s = | V.null $ lineChildren ln = ln | otherwise = ln {lineFolded = not $ lineFolded ln} -wrapFolded :: Bool -> Widget n -> Widget n -wrapFolded False widget = withDefAttr "unfolded" $ str " " <+> widget -wrapFolded True widget = withDefAttr "folded" $ str "+" <+> widget - wrapFocused :: Bool -> Widget n -> Widget n wrapFocused False = withDefAttr "unfocused" wrapFocused True = visible . withDefAttr "focused" renderLine :: Bool -> LineNode -> Widget n renderLine focused ln = - wrapFocused focused $ - wrapFolded foldedWithChildren $ padRight Max $ txt $ lineText ln - where - foldedWithChildren = lineFolded ln && not (V.null $ lineChildren ln) + let prefix + | V.null $ lineChildren ln = " " + | lineFolded ln = "+" + | otherwise = "-" + in wrapFocused focused $ padRight Max $ str prefix <+> txt (lineText ln) -renderUiState :: UiState -> Widget n -renderUiState s = - let flat = V.toList $ flatten $ uiTree s +renderUiState :: (Show n, Ord n) => n -> UiState -> Widget n +renderUiState n s = + let info = vBox $ map txt $ uiInfo s + flat = V.toList $ flatten $ uiTree s focused = uiFocused s rendered = map (\(p, ln) -> renderLine (p == focused) ln) flat - in vBox rendered + in info <=> viewport n Vertical (vBox rendered)