pretty-ghci (empty) → 0.1.0.0
raw patch · 16 files changed
+1133/−0 lines, 16 filesdep +arraydep +basedep +directorysetup-changed
Dependencies added: array, base, directory, filepath, haddock-library, pretty-ghci, prettyprinter, prettyprinter-ansi-terminal, process, text
Files
- .gitignore +13/−0
- .travis.yml +34/−0
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +52/−0
- Setup.hs +2/−0
- driver/Main.hs +73/−0
- haddock-test/Main.hs +64/−0
- pretty-ghci.cabal +92/−0
- show-test/Main.hs +63/−0
- src/System/Terminal/Utils.hsc +50/−0
- src/Text/PrettyPrint/GHCi.hs +24/−0
- src/Text/PrettyPrint/GHCi/Haddock.hs +219/−0
- src/Text/PrettyPrint/GHCi/Value.hs +168/−0
- src/Text/PrettyPrint/GHCi/Value/Lexer.x +128/−0
- src/Text/PrettyPrint/GHCi/Value/Parser.y +116/−0
+ .gitignore view
@@ -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/
+ .travis.yml view
@@ -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
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for `pretty-ghci`++## 0.1.0.0 -- 2019-03-07++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ driver/Main.hs view
@@ -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+
+ haddock-test/Main.hs view
@@ -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."+
+ pretty-ghci.cabal view
@@ -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+
+ show-test/Main.hs view
@@ -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."+
+ src/System/Terminal/Utils.hsc view
@@ -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 <sys/ioctl.h>+#include <unistd.h>++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
+ src/Text/PrettyPrint/GHCi.hs view
@@ -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+
+ src/Text/PrettyPrint/GHCi/Haddock.hs view
@@ -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 "<table could not be rendered>")++ , 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)+
+ src/Text/PrettyPrint/GHCi/Value.hs view
@@ -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)+
+ src/Text/PrettyPrint/GHCi/Value/Lexer.x view
@@ -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 ]++}
+ src/Text/PrettyPrint/GHCi/Value/Parser.y view
@@ -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+}