diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,13 @@ +/dist/ +/dist-newstyle/ +/haddock-test/out/ +/show-test/out/ + +.cabal-sandbox +.ghc.environment.* +cabal.sandbox.config +cabal.project.local +cabal.project.local~ + +stack.yaml +.stack-work/ diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,34 @@ +# Sudo used for custom apt setup +sudo: true + +# Add new environments to the build here: +env: + - GHCVER=8.0.2 CABALVER=2.4 + - GHCVER=8.2.2 CABALVER=2.4 + - GHCVER=8.4.4 CABALVER=2.4 + - GHCVER=8.6.4 CABALVER=2.4 + - GHCVER=head CABALVER=head + +# Allow for develop branch to break +matrix: + allow_failures: + - env: GHCVER=head CABALVER=head + +# Manually install ghc and cabal +before_install: + - travis_retry sudo add-apt-repository -y ppa:hvr/ghc + - travis_retry sudo apt-get update + - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER + - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH + - export PATH=$HOME/.cabal/bin:$PATH + - travis_retry cabal v2-update + +# Install Happy and Alex first, before installing +install: + - echo $PATH + - cabal --version + - ghc --version + - cabal v2-configure --enable-tests + +script: + - cabal v2-test diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for `pretty-ghci` + +## 0.1.0.0 -- 2019-03-07 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, Alec Theriault + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Alec Theriault nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +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,52 @@ +### `pretty-ghci` [![Build Status][0]][1] + +This library will make your GHCi experience colourful in 3 steps: + + 1. Install the executable globally with `cabal v2-install pretty-ghci` + + 2. Modify your `~/.ghc/ghci.conf` + + ```haskell + :set prompt "λ> " + :set prompt-cont "|> " + + -- Typing `:pretty` will turn on the pretty-printing + :set -package process + :{ + :def pretty \_ -> pure $ unlines $ + [ ":{" + , "let pprint x = System.Process.withCreateProcess cp' $ \\(Just i) _ _ ph -> do" + , " System.IO.hPutStrLn i (show x)" + , " System.IO.hClose i" + , " _ <- System.Process.waitForProcess ph" + , " pure ()" + , " where cp = System.Process.proc \"pp-ghci\" [\"--value\", \"--smarter-layout\"]" + , " cp' = cp{ System.Process.std_out = System.Process.Inherit" + , " , System.Process.std_err = System.Process.Inherit" + , " , System.Process.std_in = System.Process.CreatePipe }" + , ":}" + , ":set -interactive-print pprint" + ] + :} + + -- Typing `:no-pretty` will turn off the pretty-printing + :def no-pretty \_ -> pure (":set -interactive-print System.IO.print") + + -- Make things pretty by default! + :pretty + ``` + + 3. Enjoy! + +## Advantages over existing alternatives + + * One stop-solution for formatting and coloring with a small dependency graph + * Takes your terminal width into account during the layout step + * Works for values whose `Show` instance don't produce valid Haskell (ex: `Show (->)`) + * Handles unboxed literals (ex: `MyTriple 1# 2.0# "hello"#`) + * Your output will be coloured according to its lexical structure even if parsing fails + * Install one global executable, not one library per GHC version + * Works in `cabal repl` (although you need to call `:pretty` once at the start) + +[0]: https://travis-ci.org/harpocrates/pretty-ghci.svg?branch=master +[1]: https://travis-ci.org/harpocrates/pretty-ghci 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/driver/Main.hs b/driver/Main.hs new file mode 100644 --- /dev/null +++ b/driver/Main.hs @@ -0,0 +1,73 @@ + +import Data.Version ( showVersion ) +import System.Environment ( getArgs, getProgName ) +import System.Exit ( die, exitSuccess ) +import System.Console.GetOpt + +import Text.PrettyPrint.GHCi ( prettyPrintHaddock, prettyPrintValue ) +import Paths_pretty_ghci ( version ) + +main :: IO () +main = do + argv <- getArgs + usage <- getUsage + let exitBad msg = die (msg ++ usage) + exitGood msg = putStr msg >> exitSuccess + + case getOpt Permute options argv of + (_ , _, errs @ (_ : _)) -> exitBad (concat errs) + (_ , args @ (_ : _), _) -> exitBad ("Unexpected arguments: " ++ unwords args) + (opts, [], []) -> do + -- What to do with input? + processInput <- case foldl (flip id) defaultOptions opts of + Options { wantHelp = True } -> exitGood usage + Options { wantVersion = True } -> exitGood versionMsg + Options { inputType = it, smarterLayout = sl } -> case it of + Nothing -> exitBad "Specify either `--doc' or `--value'\n" + Just Doc -> pure (prettyPrintHaddock sl) + Just Value -> pure (prettyPrintValue sl) + + -- Do that to the input + str <- getContents + processInput str + +-- | Type of options to expect +data Options = Options + { inputType :: Maybe InputType -- ^ what input type to use + , smarterLayout :: Bool -- ^ use a smarter layout algorithm? + , wantHelp :: Bool -- ^ show the help + , wantVersion :: Bool -- ^ show the version + } + +defaultOptions :: Options +defaultOptions = Options Nothing False False False + +-- | What sort of input to expect +data InputType = Doc | Value + +options :: [OptDescr (Options -> Options)] +options = + [ Option [] ["doc"] (NoArg (\o -> o{ inputType = Just Doc })) + "pretty print the input assuming it is a docstring" + , Option [] ["value"] (NoArg (\o -> o{ inputType = Just Value })) + "pretty print the input assuming it is a Haskell value" + , Option [] ["smarter-layout"] (NoArg (\o -> o{ smarterLayout = True })) + "use a smarter (but potentially slower) layout algorithm" + , Option ['h'] ["help"] (NoArg (\o -> o{ wantHelp = True })) + "print out this usage info" + , Option ['v'] ["version"] (NoArg (\o -> o{ wantVersion = True })) + "print out the version" + ] + +-- | Return usage information +getUsage :: IO String +getUsage = do + prog <- getProgName + let header = "Usage: " ++ prog ++ " [OPTION...]" + pure (usageInfo header options) + +-- | Message you get with the version +versionMsg :: String +versionMsg = "`ppghci' version " ++ ver ++ ", (c) Alec Theriault 2019\n" + where ver = showVersion version + diff --git a/haddock-test/Main.hs b/haddock-test/Main.hs new file mode 100644 --- /dev/null +++ b/haddock-test/Main.hs @@ -0,0 +1,64 @@ +module Main where + +import Text.PrettyPrint.GHCi.Haddock + +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.String (renderString) + +import Data.Foldable ( for_ ) +import Data.Maybe ( catMaybes ) +import System.Console.GetOpt +import System.Directory ( listDirectory, createDirectoryIfMissing, findExecutable ) +import System.Environment ( getArgs ) +import System.FilePath ( (), takeFileName ) +import System.Process ( callProcess ) + + +-- | Option parser +options :: [OptDescr Opt] +options = [ Option [] ["accept"] (NoArg Accept) "accept the output" + , Option ['h'] ["help"] (NoArg Help) "display usage info" + ] + +-- | Options +data Opt = Accept | Help deriving Eq + +main = do + + -- Command line args: do we want to accept or not? + args <- getArgs + let header = "Usage: haddock-test [OPTION...]" + accept <- case getOpt Permute options args of + (_, _, errs @ (_:_)) -> ioError (userError (concat errs ++ usageInfo header options)) + (_, non @ (_:_), []) -> ioError (userError ("Unexpected options: " ++ concat non ++ usageInfo header options)) + (opts, [], []) + | Help `elem` opts -> ioError (userError ( usageInfo header options)) + | Accept `elem` opts -> pure True + | otherwise -> pure False + + -- Get the test cases + srcs <- listDirectory ("haddock-test" "src") + createDirectoryIfMissing True ("haddock-test" "out") + createDirectoryIfMissing True ("haddock-test" "ref") + + -- Run them in a loop + for_ srcs $ \srcFile -> do + putStrLn $ "Checking " ++ srcFile ++ "..." + + let ref = "haddock-test" "ref" srcFile + out = "haddock-test" "out" srcFile + src = "haddock-test" "src" srcFile + + inp <- readFile src + let output = renderString (layoutPretty defaultLayoutOptions (haddock2Doc inp)) + + -- Accept or test + if accept + then do writeFile ref output + else do writeFile out output + diff : _ <- catMaybes <$> traverse findExecutable ["colordiff", "diff"] + callProcess diff [ref, out] + + -- Report status + putStrLn $ "All " <> show (length srcs) <> " test cases " <> if accept then "accepted." else "passed." + diff --git a/pretty-ghci.cabal b/pretty-ghci.cabal new file mode 100644 --- /dev/null +++ b/pretty-ghci.cabal @@ -0,0 +1,92 @@ +cabal-version: 2.0 + +name: pretty-ghci +version: 0.1.0.0 +synopsis: Functionality for beautifying GHCi +license: BSD3 +license-file: LICENSE +author: Alec Theriault +maintainer: alec.theriault@gmail.com +copyright: (c) Alec Theriault +category: Text +build-type: Simple + +description: + Provides a library and an executable for parsing and pretty-printing the + output of derived @Show@ instances as well as Haddock docstrings. The idea is + to provide functionality that can be easily plugged into GHCi's + @-interactive-print@ option, making for a better REPL experience. + +extra-source-files: + .travis.yml + .gitignore + CHANGELOG.md + README.md + +tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.4 + +executable pp-ghci + main-is: Main.hs + build-depends: base, pretty-ghci + + other-modules: Paths_pretty_ghci + autogen-modules: Paths_pretty_ghci + + ghc-options: -Wall -Wcompat + hs-source-dirs: driver + default-language: Haskell2010 + +library + exposed-modules: Text.PrettyPrint.GHCi + Text.PrettyPrint.GHCi.Haddock + Text.PrettyPrint.GHCi.Value + Text.PrettyPrint.GHCi.Value.Lexer + Text.PrettyPrint.GHCi.Value.Parser + System.Terminal.Utils + + build-tools: alex >=3.1 + , happy >=1.19 + + build-depends: base >=4.9 && <4.13 + , haddock-library ^>=1.7 + , prettyprinter-ansi-terminal ^>=1.1 + , prettyprinter ^>=1.2 + , text ^>=1.2 + , array ^>=0.5 + + ghc-options: -Wall -Wcompat + hs-source-dirs: src + default-language: Haskell2010 + +test-suite haddock-test + type: exitcode-stdio-1.0 + main-is: Main.hs + + build-depends: pretty-ghci + , base + , prettyprinter + , filepath + , directory + , process + + hs-source-dirs: haddock-test + default-language: Haskell2010 + +test-suite show-test + type: exitcode-stdio-1.0 + main-is: Main.hs + + build-depends: pretty-ghci + , base + , prettyprinter + , filepath + , directory + , process + + hs-source-dirs: show-test + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/harpocrates/pretty-ghci.git + diff --git a/show-test/Main.hs b/show-test/Main.hs new file mode 100644 --- /dev/null +++ b/show-test/Main.hs @@ -0,0 +1,63 @@ +module Main where + +import Text.PrettyPrint.GHCi.Value + +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.String (renderString) + +import Data.Foldable ( for_ ) +import Data.Maybe ( catMaybes ) +import System.Console.GetOpt +import System.Directory ( listDirectory, createDirectoryIfMissing, findExecutable ) +import System.Environment ( getArgs ) +import System.FilePath ( (), takeFileName ) +import System.Process ( callProcess ) + +-- | Option parser +options :: [OptDescr Opt] +options = [ Option [] ["accept"] (NoArg Accept) "accept the output" + , Option ['h'] ["help"] (NoArg Help) "display usage info" + ] + +-- | Options +data Opt = Accept | Help deriving Eq + +main = do + + -- Command line args: do we want to accept or not? + args <- getArgs + let header = "Usage: show-test [OPTION...]" + accept <- case getOpt Permute options args of + (_, _, errs @ (_:_)) -> ioError (userError (concat errs ++ usageInfo header options)) + (_, non @ (_:_), []) -> ioError (userError ("Unexpected options: " ++ concat non ++ usageInfo header options)) + (opts, [], []) + | Help `elem` opts -> ioError (userError ( usageInfo header options)) + | Accept `elem` opts -> pure True + | otherwise -> pure False + + -- Get the test cases + srcs <- listDirectory ("show-test" "src") + createDirectoryIfMissing True ("show-test" "out") + createDirectoryIfMissing True ("show-test" "ref") + + -- Run them in a loop + for_ srcs $ \srcFile -> do + putStrLn $ "Checking " ++ srcFile ++ "..." + + let ref = "show-test" "ref" srcFile + out = "show-test" "out" srcFile + src = "show-test" "src" srcFile + + inp <- readFile src + let output = renderString (layoutPretty defaultLayoutOptions (value2Doc inp)) + + -- Accept or test + if accept + then do writeFile ref output + else do writeFile out output + diff : _ <- catMaybes <$> traverse findExecutable ["colordiff", "diff"] + callProcess diff [ref, out] + + -- Report status + putStrLn $ "All " <> show (length srcs) <> " test cases " <> if accept then "accepted." else "passed." + diff --git a/src/System/Terminal/Utils.hsc b/src/System/Terminal/Utils.hsc new file mode 100644 --- /dev/null +++ b/src/System/Terminal/Utils.hsc @@ -0,0 +1,50 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module System.Terminal.Utils ( + getTerminalSize, +) where + +import Foreign +import Foreign.C.Types +import Foreign.Marshal.Alloc ( alloca ) + + +-- | Try to get the number of rows and columns respectively in the terminal +getTerminalSize :: IO (Maybe (Int,Int)) + +#if defined(WINDOWS) + +getTerminalSize = pure Nothing + +#else + +#include +#include + +getTerminalSize = alloca $ \ws -> do + res <- ioctl (#const STDOUT_FILENO) (#const TIOCGWINSZ) ws + if res == -1 + then pure Nothing + else do + WinSize row col <- peek ws + pure (Just (fromIntegral row, fromIntegral col)) + +-- | @ioctl@ fills the struct at the pointer you passed in with the size info +foreign import ccall "sys/ioctl.h ioctl" + ioctl :: CInt -> CInt -> Ptr WinSize -> IO CInt + +-- | Match @struct winsize@ in @sys/ioctl.h@. +data WinSize = WinSize CUShort CUShort + +instance Storable WinSize where + sizeOf _ = (#size struct winsize) + alignment _ = (#alignment struct winsize) + peek ptr = do + row <- (#peek struct winsize, ws_row) ptr + col <- (#peek struct winsize, ws_col) ptr + pure (WinSize row col) + poke ptr (WinSize row col) = do + (#poke struct winsize, ws_row) ptr row + (#poke struct winsize, ws_col) ptr col + +#endif diff --git a/src/Text/PrettyPrint/GHCi.hs b/src/Text/PrettyPrint/GHCi.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/GHCi.hs @@ -0,0 +1,24 @@ +module Text.PrettyPrint.GHCi ( + -- * Interactive expression printing + prettyPrintValue, value2Doc, + ValuePrintConf(..), + defaultValueConf, + + -- * Interactive doc string printing + prettyPrintHaddock, haddock2Doc, + HaddockPrintConf(..), + defaultHaddockConf, + + -- * Formatting options + AnsiStyle, + -- ** Color + color, colorDull, bgColor, bgColorDull, Color(..), + -- ** Style + bold, italicized, underlined, +) where + +import Text.PrettyPrint.GHCi.Value +import Text.PrettyPrint.GHCi.Haddock + +import Data.Text.Prettyprint.Doc.Render.Terminal + diff --git a/src/Text/PrettyPrint/GHCi/Haddock.hs b/src/Text/PrettyPrint/GHCi/Haddock.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/GHCi/Haddock.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE OverloadedStrings #-} +module Text.PrettyPrint.GHCi.Haddock ( + prettyPrintHaddock, haddock2Doc, + HaddockPrintConf(..), + defaultHaddockConf, +) where + +import System.Terminal.Utils + +-- base +import Control.Monad (join) +import Data.String ( fromString ) +import Data.Void ( Void, absurd ) +import Data.Char ( isSpace ) +import Data.List ( dropWhileEnd ) +import System.IO ( stdout ) + +-- haddock-library +import Documentation.Haddock.Markup +import Documentation.Haddock.Parser +import Documentation.Haddock.Types + +-- prettyprinter, prettyprinter-ansi-terminal +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Terminal + +-- | Given a Haddock-formatted docstring, format and print that docstring to +-- the terminal. +-- +-- The 'Bool' is to enable a slower but potentially smarter layout algorithm. +prettyPrintHaddock :: Bool -> String -> IO () +prettyPrintHaddock smarter str = do + termSize <- getTerminalSize + let layoutOpts = LayoutOptions (AvailablePerLine (maybe 80 snd termSize) 1.0) + layoutAlgo = if smarter then layoutSmart else layoutPretty + renderIO stdout (layoutAlgo layoutOpts (haddock2Doc str)) + +-- | Parse a docstring into a pretty 'Doc'. Should never throw an exception +-- (since @haddock-library@ will parse /something/ out of any input). +haddock2Doc :: String -> Doc AnsiStyle +haddock2Doc doc = (blocksToDoc blks <> hardline) + where + MetaDoc { _doc = parsedDoc } = parseParas Nothing doc + blks = getAsBlocks $ markup (terminalMarkup defaultHaddockConf) parsedDoc + + +-- | A Good Enough colour scheme +defaultHaddockConf :: HaddockPrintConf +defaultHaddockConf = HaddockPrintConf + { hpc_default = mempty + , hpc_emphasis = italicized + , hpc_bold = bold + , hpc_monospaced = colorDull Magenta + , hpc_header = bold <> underlined <> color White + , hpc_identifier = underlined <> color Magenta + , hpc_math = italicized <> color Green + , hpc_links = underlined <> color Blue + , hpc_warning = italicized <> color Red + , hpc_control = bold <> colorDull Yellow + } + +-- | Options for how to colour the terminal output +data HaddockPrintConf = HaddockPrintConf + { hpc_default :: AnsiStyle + -- ^ the default background + + , hpc_emphasis :: AnsiStyle + -- ^ emphasized text + + , hpc_bold :: AnsiStyle + -- ^ bold text + + , hpc_monospaced :: AnsiStyle + -- ^ code blocks and inline code + + , hpc_header :: AnsiStyle + -- ^ header bodies + + , hpc_identifier :: AnsiStyle + -- ^ identifiers, module links, anchors + + , hpc_math :: AnsiStyle + -- ^ @\\( ... \\)@ and @\\[ ... \\]@ delimited math + + , hpc_links :: AnsiStyle + -- ^ the link part of hyperlinks or images + + , hpc_warning :: AnsiStyle + -- ^ warning texts + + , hpc_control :: AnsiStyle + -- ^ things like: equals in headers, bullets in lists, etc. + } + + +type ReflowSpaces = Bool + +-- | The main complexity with turning Haddock's 'DocH' into a +-- @'Doc' 'AnsiStyle'@ is that there is often a conflation of +-- inline and block-level elements. +-- +-- We cheat by choosing a worker which tries both at once. +data RenderedDocH = RDH + { getAsBlocks :: [Doc AnsiStyle] -- ^ render as blocks + , getAsInline :: ReflowSpaces -> Doc AnsiStyle -- ^ render as inline + } + +-- | Concatenate a bunch of blocks vertically with empty lines between blocks +blocksToDoc :: [Doc AnsiStyle] -> Doc AnsiStyle +blocksToDoc = align . vcat . punctuate hardline + +-- | Markup for turning a 'DocH' into a 'RenderedDocH' +terminalMarkup :: HaddockPrintConf -> DocMarkupH Void Identifier RenderedDocH +terminalMarkup hpc = Markup + { markupEmpty = RDH { getAsBlocks = [] + , getAsInline = mempty } + + -- This is where reflow spaces matters: we only split the string into words + -- and glue those words back together if we have the go-ahead to reflow. + , markupString = \str -> onlyInline $ \reflowSpaces -> case str of + "" -> mempty + _ | reflowSpaces + -> let headSpace = if isSpace (head str) then space else mempty + lastSpace = if isSpace (last str) then space else mempty + in headSpace <> fillSep (map fromString (words str)) <> lastSpace + | otherwise + -> fromString (dropWhileEnd (== '\n') str) + + , markupParagraph = \doc -> onlyBlock (getAsInline doc True) + + , markupAppend = \(RDH b1 i1) (RDH b2 i2) -> RDH (b1 ++ b2) (i1 <> i2) + + , markupIdentifier = \(_,idnt,_) -> onlyInline $ \_ -> ident (fromString idnt) + , markupModule = \mdl -> onlyInline $ \_ -> ident (fromString mdl) + , markupAName = \anc -> onlyInline $ \_ -> ident (fromString anc) + + , markupIdentifierUnchecked = absurd + + , markupEmphasis = \doc -> onlyInline (emph . getAsInline doc) + , markupBold = \doc -> onlyInline (bolded . getAsInline doc) + , markupMonospaced = \doc -> onlyInline (mono . getAsInline doc) + + , markupWarning = \doc -> + onlyBlock (warn (getAsInline doc True)) + + , markupUnorderedList = \docs -> + onlyBlock (renderListLike (repeat "*") + (map (blocksToDoc . getAsBlocks) docs)) + + , markupOrderedList = \docs -> + onlyBlock (renderListLike [ unsafeViaShow i <> "." | i <- [1 :: Int ..] ] + (map (blocksToDoc . getAsBlocks) docs)) + + , markupDefList = \lblDocs -> let (lbls, docs) = unzip lblDocs in + onlyBlock (renderListLike [ ctrl (getAsInline l True <> ":") <> hardline | l <- lbls ] + (map (\doc -> align (getAsInline doc False)) docs)) + + -- Render markdown-style only when we have a title + , markupHyperlink = \(Hyperlink uri titleOpt) -> onlyInline $ \_ -> case titleOpt of + Nothing -> ctrl "<" <> link (fromString uri) <> ctrl ">" + Just title -> ctrl "[" <> fromString title <> ctrl "](" <> link (fromString uri) <> ctrl ")" + + -- Render markdown-style only when we have a title + , markupPic = \(Picture uri titleOpt) -> onlyInline $ \_ -> case titleOpt of + Nothing -> ctrl "<<" <> link (fromString uri) <> ctrl ">>" + Just title -> ctrl "![" <> fromString title <> ctrl "](" <> link (fromString uri) <> ctrl ")" + + , markupMathInline = \tex -> onlyInline $ \_ -> + math ("\\(" <+> fillSep (map fromString (words tex)) <+> "\\)") + + , markupMathDisplay = \tex -> onlyBlock (math ("\\[" <> fromString tex <> "\\]")) + + , markupProperty = \prop -> onlyBlock (ctrl "prop>" <> fromString prop) + + , markupHeader = \(Header lvl title) -> let leader = ctrl (fromString (replicate lvl '=')) in + onlyBlock (leader <+> header (getAsInline title True)) + + -- TODO: figure out a good way to render this + , markupTable = \_ -> onlyBlock (bad "") + + , markupExample = \examples -> onlyBlock . vcat . join $ + [ (ctrl ">>>" <+> fromString input) : (map (mono . fromString) output) + | Example input output <- examples ] + + -- This is where we ask for an inline block with spaces /not/ reflowed + , markupCodeBlock = \doc -> RDH { getAsBlocks = [mono (getAsInline doc False)] + , getAsInline = \_ -> mono (getAsInline doc True) } + } + where + -- This element is really and inline one, so interpretting it as a block + -- is a best effort. + onlyInline :: (ReflowSpaces -> Doc AnsiStyle) -> RenderedDocH + onlyInline renderInline = RDH { getAsBlocks = [renderInline False] + , getAsInline = renderInline } + + -- This element is really a block one, so interpretting it as inline is a + -- best effort. + onlyBlock :: Doc AnsiStyle -> RenderedDocH + onlyBlock renderBlock = RDH { getAsBlocks = [renderBlock] + , getAsInline = \_ -> align renderBlock } + + -- Given what the bullets look like and elements associated with the + -- bullets, produce the doc. + renderListLike :: [Doc AnsiStyle] -> [Doc AnsiStyle] -> Doc AnsiStyle + renderListLike ixs docs = indent 2 . blocksToDoc $ + [ ctrl ix <+> doc | (ix,doc) <- ixs `zip` docs ] + + -- Useful annotations + header = annotate (hpc_header hpc) + emph = annotate (hpc_emphasis hpc) + bolded = annotate (hpc_bold hpc) + ctrl = annotate (hpc_control hpc) + link = annotate (hpc_links hpc) + math = annotate (hpc_math hpc) + mono = annotate (hpc_monospaced hpc) + ident = annotate (hpc_identifier hpc) + warn = annotate (hpc_warning hpc) + bad = annotate (color Red <> bold <> bgColor White) + diff --git a/src/Text/PrettyPrint/GHCi/Value.hs b/src/Text/PrettyPrint/GHCi/Value.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/GHCi/Value.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Text.PrettyPrint.GHCi.Value ( + prettyPrintValue, value2Doc, + ValuePrintConf(..), + defaultValueConf, +) where + +import Text.PrettyPrint.GHCi.Value.Lexer +import Text.PrettyPrint.GHCi.Value.Parser +import System.Terminal.Utils + +-- base +import Data.String ( fromString ) +import Control.Exception ( catch, ErrorCall ) +import System.IO ( stdout ) +import qualified Data.List.NonEmpty as N + +-- prettyprinter, prettyprinter-ansi-terminal +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Terminal + +-- | Given a 'Show'-ed value, print that value out to the terminal, add helpful +-- indentation and colours whenever possible. If a structured value cannot be +-- parsed out, this falls back on 'print'. +-- +-- The 'Bool' is to enable a slower but potentially smarter layout algorithm. +prettyPrintValue :: Bool -> String -> IO () +prettyPrintValue smarter str = do + termSize <- getTerminalSize + let layoutOpts = LayoutOptions (AvailablePerLine (maybe 80 snd termSize) 1.0) + layoutAlgo = if smarter then layoutSmart else layoutPretty + rendered = layoutAlgo layoutOpts (value2Doc str) + renderIO stdout rendered `catch` \(_ :: ErrorCall) -> putStr str + +-- | Parse a shown value into a pretty 'Doc'. Can throw an error on outputs +-- that could not be parsed properly, but should not throw errors for inputs +-- which are the outputs of 'show' from derived 'Show' instances. +value2Doc :: String -> Doc AnsiStyle +value2Doc shown = case parseValue shown of + Just v -> renderValue defaultValueConf v <> hardline + Nothing -> renderTokens defaultValueConf tokens + where + tokens = lexTokens shown + + +-- | A Good Enough colour scheme +defaultValueConf :: ValuePrintConf +defaultValueConf = ValuePrintConf + { vpc_number = color Cyan + , vpc_character = color Blue + , vpc_string = color Green + , vpc_control = bold <> color Magenta + , vpc_comma = color Yellow + , vpc_operator = color White + , vpc_field = italicized <> colorDull Red + , vpc_indent = 2 + } + +-- | Options for how to colour the terminal output +data ValuePrintConf = ValuePrintConf + { vpc_number :: AnsiStyle -- ^ all sorts of numeric literals + , vpc_character :: AnsiStyle -- ^ character literals + , vpc_string :: AnsiStyle -- ^ string literals + , vpc_control :: AnsiStyle -- ^ various control characters (ex: parens) + , vpc_comma :: AnsiStyle -- ^ commas + , vpc_operator :: AnsiStyle -- ^ general operators + , vpc_field :: AnsiStyle -- ^ field in a record + , vpc_indent :: Int -- ^ how many spaces is one indent? + } + + +-- | Function for turning a 'Value' into a 'Doc' +renderValue :: ValuePrintConf -> Value -> Doc AnsiStyle +renderValue vpc = renderVal + where + renderVal v = case v of + + Num i -> num (fromString i) + Char c -> char (fromString c) + Str s -> string (fromString s) + + List vs -> renderSeq (ctrl "[") (map (align . renderVal) vs) (ctrl "]") + Tuple vs -> renderSeq (ctrl "(") (map (align . renderVal) vs) (ctrl ")") + + -- Either everything goes on one line or the constructor and args each + -- start on a new line (with args indented) + Prefix c [] -> fromString c + Prefix c vs -> + let args = map (align . renderVal) vs + in fromString c <> group (nest n (line <> align (vsep args))) + + -- Either everything goes on one line, or each argument gets its own + -- line with operators at the beginning of the lines + Infix arg0 ops -> + let tails = fmap (\(op,arg) -> optr (fromString op) <+> align (renderVal arg)) ops + in renderVal arg0 <> group (nest n (line <> align (vsep (N.toList tails)))) + + -- Either everything goes on one line or the constructor and fields each + -- start on a new line (with fields indented) + Record c vs -> + let fields = zipWith (\l (f,x) -> hsep [ l, field (fromString f) + , ctrl "=", align (renderVal x) ]) + (ctrl "{" : repeat (coma ",")) (N.toList vs) + in fromString c <> group (nest n (line <> align (vcat fields) <+> ctrl "}")) + + Paren x -> ctrl "(" <> align (renderVal x) <> ctrl ")" + + -- Haskell style formatting of sequence-like things, with the comma at the + -- start of the line + renderSeq :: Doc AnsiStyle -> [Doc AnsiStyle] -> Doc AnsiStyle -> Doc AnsiStyle + renderSeq opn [] cls = opn <> cls + renderSeq opn vs cls = align . group . encloseSep opn' cls' (coma ", ") $ vs + where + opn' = flatAlt (opn <> space) opn + cls' = flatAlt (space <> cls) cls + + n = vpc_indent vpc + + -- Useful annotations + num = annotate (vpc_number vpc) + char = annotate (vpc_character vpc) + string = annotate (vpc_string vpc) + ctrl = annotate (vpc_control vpc) + coma = annotate (vpc_comma vpc) + optr = annotate (vpc_operator vpc) + field = annotate (vpc_field vpc) + + +-- | Function for turning a list of 'Token's into a 'Doc' +renderTokens :: ValuePrintConf -> [Token] -> Doc AnsiStyle +renderTokens vpc = mconcat . map renderTok + where + renderTok tok = case tok of + + WhiteTok w -> renderWhite w + + NumberTok i -> num (fromString i) + CharacterTok c -> char (fromString c) + StringTok s -> string (fromString s) + + OpenBracket -> ctrl "[" + CloseBracket -> ctrl "]" + OpenParen -> ctrl "(" + CloseParen -> ctrl ")" + OpenBrace -> ctrl "{" + CloseBrace -> ctrl "}" + Equal -> ctrl "=" + + OperatorTok op -> optr (fromString op) + IdentifierTok c -> fromString c + + Comma -> coma "," + + -- Render whitespace (which might have newlines) + renderWhite :: String -> Doc AnsiStyle + renderWhite "" = mempty + renderWhite str = let (ln, str') = span (/= '\n') str + in fromString ln <> hardline <> renderWhite (drop 1 str') + + -- Useful annotations + num = annotate (vpc_number vpc) + char = annotate (vpc_character vpc) + string = annotate (vpc_string vpc) + ctrl = annotate (vpc_control vpc) + coma = annotate (vpc_comma vpc) + optr = annotate (vpc_operator vpc) + diff --git a/src/Text/PrettyPrint/GHCi/Value/Lexer.x b/src/Text/PrettyPrint/GHCi/Value/Lexer.x new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/GHCi/Value/Lexer.x @@ -0,0 +1,128 @@ +{ +module Text.PrettyPrint.GHCi.Value.Lexer ( + lexTokens, + Token(..), +) where + +import Data.Char ( generalCategory, GeneralCategory(..) ) +} + +%wrapper "basic" + +$binit = 0-1 +$octit = 0-7 +$decdigit = 0-9 +$hexit = [$decdigit A-F a-f] + +-- Number stuff +@numspc = _* +@decimal = $decdigit(@numspc $decdigit)* +@binary = $binit(@numspc $binit)* +@octal = $octit(@numspc $octit)* +@hexadecimal = $hexit(@numspc $hexit)* +@exponent = @numspc [eE] [\-\+]? @decimal +@bin_exponent = @numspc [pP] [\-\+]? @decimal + +@floating_point = @numspc @decimal \. @decimal @exponent? | @numspc @decimal @exponent +@hex_floating_point = ( @numspc @hexadecimal \. @hexadecimal @bin_exponent? + | @numspc @hexadecimal @bin_exponent + ) + +@magic_hash = ( \# | \#\# )? +@number_prim = ( @decimal + | 0[bB] @numspc @binary + | 0[oO] @numspc @octal + | 0[xX] @numspc @hexadecimal + | @floating_point + | 0[xX] @numspc @hex_floating_point + ) +@number = [\-]? @number_prim @magic_hash + +-- Characters and strings literal +@char_escape = \\ ( [abfnrtv\\"'] + | \^ [@-_] + | x $hexit+ + | o $octit+ + | $decdigit+ + | NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | HT + | LF | VT | FF | CR | SO | SI | DLE | DC1 | DC2 | DC3 + | DC4 | NAK | SYN | ETB | CAN | EM | SUB | ESC | FS | GS + | RS | US | SP | DEL + ) + +@character = \' (~ [\\ \'] | \\ \' | @char_escape) \' +@string = \" (~ [\\ \"] | \\ \" | @char_escape)* \" + +-- Symbol or operator (everything else) + +$sym_op_char = ~[ $white \[ \] \( \) \{ \} \, \" \' \= ] +@sym_op = ($sym_op_char # $decdigit) $sym_op_char* + +tokens :- + + $white+ { WhiteTok } + + "(" { const OpenParen } + ")" { const CloseParen } + + "[" { const OpenBracket } + "]" { const CloseBracket } + + "{" { const OpenBrace } + "}" { const CloseBrace } + + "," { const Comma } + "=" { const Equal } + + @decimal { NumberTok } + @number { NumberTok } + @character { CharacterTok } + @string { StringTok } + + @sym_op { operatorOrSymbol } + +{ + +-- | Turn a 'String' into a list of 'Token'. This may error out for +-- particularly bad inputs (ex: unclosed string). +lexTokens :: String -> [Token] +lexTokens = alexScanTokens + +-- | Our somewhat simplified version of GHC Haskell tokens +data Token + = WhiteTok String + | NumberTok String + | StringTok String + | CharacterTok String + | OperatorTok String + | IdentifierTok String -- ^ we're overly liberal with what can be an + -- identifier (so as to accomodate custom 'Show' + -- instances) + | OpenParen + | CloseParen + | OpenBracket + | CloseBracket + | OpenBrace + | CloseBrace + | Comma + | Equal + deriving (Eq, Show) + +-- | Classify a string as either an operator or an identifier +operatorOrSymbol :: String -> Token +operatorOrSymbol str + | all isOperatorLike str = OperatorTok str + | otherwise = IdentifierTok str + +-- | Characters in these categories can be part of operators +isOperatorLike :: Char -> Bool +isOperatorLike '_' = False +isOperatorLike c = generalCategory c `elem` [ ConnectorPunctuation + , DashPunctuation + , OtherPunctuation + , MathSymbol + , CurrencySymbol + , ModifierSymbol + , OtherSymbol ] + +} diff --git a/src/Text/PrettyPrint/GHCi/Value/Parser.y b/src/Text/PrettyPrint/GHCi/Value/Parser.y new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/GHCi/Value/Parser.y @@ -0,0 +1,116 @@ +{ +module Text.PrettyPrint.GHCi.Value.Parser ( + parseValue, + Id, Op, Value(..), +) where + +import Text.PrettyPrint.GHCi.Value.Lexer + +import qualified Data.List.NonEmpty as N +} + +%name parseTokens value +%monad { Maybe } { (>>=) } { return } +%expect 0 +%tokentype { Token } +%token number { NumberTok $$ } + string { StringTok $$ } + character { CharacterTok $$ } + operator { OperatorTok $$ } + identifier { IdentifierTok $$ } + '(' { OpenParen } + ')' { CloseParen } + '[' { OpenBracket } + ']' { CloseBracket } + '{' { OpenBrace } + '}' { CloseBrace } + ',' { Comma } + '=' { Equal } + +%% + +atom :: { Value } + : number { Num $1 } + | string { Str $1 } + | character { Char $1 } + | '(' ')' { Tuple [] } + | '(' value comma_values ')' { if null $3 + then Paren $2 + else Tuple ($2 : reverse $3) } + | '[' ']' { List [] } + | '[' value comma_values ']' { List ($2 : reverse $3) } + +-- Reversed list of values, each value being preceded by a comma +comma_values :: { [Value] } + : {- empty -} { [] } + | comma_values ',' value { $3 : $1 } + +-- Prefix constructor application +prefix :: { Value } + : identifier prefix_apps { Prefix $1 (reverse $2) } + | identifier '{' fields '}' { Record $1 (N.reverse $3) } + | atom { $1 } + +-- Reversed arguments to a prefix constructor +prefix_apps :: { [Value] } + : {- empty -} { [] } + | prefix_apps atom { $2 : $1 } + | prefix_apps identifier { Prefix $2 [] : $1 } + +-- A record field +field :: { (Id, Value) } + : identifier '=' value { ($1, $3) } + | '(' operator ')' '=' value { ("(" ++ $2 ++ ")", $5) } + +-- Non-empty list of reversed record fields +fields :: { N.NonEmpty (Id, Value) } + : field { $1 N.:| [] } + | fields ',' field { N.cons $3 $1 } + +-- Infix constructor application +infixes :: { Value } + : prefix infixes_sufs { case $2 of + [] -> $1 + x : xs -> Infix $1 (N.reverse (x N.:| xs)) } + +-- Reversed list of operator suffixes +infixes_sufs :: { [(Op, Value)] } + : {- empty -} { [] } + | infixes_sufs operator prefix { ($2, $3) : $1 } + +-- Entry point +value :: { Value } + : infixes { $1 } + +{ +-- | Throws an exception, not particularly helpful +happyError :: [Token] -> Maybe a +happyError _ = Nothing + +-- | A @conid@ or @varid@ (possibly ending in hashes, to account for @MagicHash@) +type Id = String + +-- | A @conop@ or @varop@ +type Op = String + +-- | A very simple representation of the output of 'Show' +data Value + = Prefix Id [Value] + | Infix Value (N.NonEmpty (Op, Value)) + | Record Id (N.NonEmpty (Id, Value)) + | Tuple [Value] + | List [Value] + | Num String -- ^ integer or floating point + | Char String -- ^ character + | Str String -- ^ string + | Paren Value + deriving Show + +-- | Parse a value from a 'String'. Returns 'Nothing' for inputs that +-- could not be parsed. +parseValue :: String -> Maybe Value +parseValue = parseTokens . filter notWhite . lexTokens + where + notWhite (WhiteTok _) = False + notWhite _ = True +}