diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,6 @@ GraphViz pretty-printing =================================== -http://hackage.haskell.org/package/prettyprinter-graphviz - Just some simple utility functions for hooking up the Haskell libraries [graphviz](https://hackage.haskell.org/package/graphviz) and [prettyprinter](https://hackage.haskell.org/package/prettyprinter). Given a [Doc](https://hackage.haskell.org/package/prettyprinter/docs/Data-Text-Prettyprint-Doc.html#t:Doc), you can use [render](https://hackage.haskell.org/package/prettyprinter-graphviz/docs/Data-Text-Prettyprint-Doc-Render-GraphViz.html#v:render) to transform it to a GraphViz [Label](https://hackage.haskell.org/package/graphviz/docs/Data-GraphViz-Attributes-Complete.html#t:Label). If you are using a different annotation type (eg. something more abstract), then you can define a mapping to GraphViz HTML attributes, and `fmap` it over your `Doc`. diff --git a/prettyprinter-graphviz.cabal b/prettyprinter-graphviz.cabal --- a/prettyprinter-graphviz.cabal +++ b/prettyprinter-graphviz.cabal @@ -1,29 +1,34 @@ -cabal-version: 2.4 +cabal-version: 3.0 name: prettyprinter-graphviz -version: 0.1.1.1 -synopsis: a prettyprinter backend for graphviz -description: Contains utility functions for rendering pretty GraphViz labels. +version: 1.0.0.0 +synopsis: A prettyprinter backend for graphviz +description: Provides utility functions for rendering pretty GraphViz labels. homepage: https://github.com/georgefst/prettyprinter-graphviz license: BSD-3-Clause license-file: LICENSE author: George Thomas maintainer: georgefsthomas@gmail.com category: Graphics -extra-source-files: CHANGELOG.md - README.md +extra-doc-files: + CHANGELOG.md + README.md source-repository head - type: git - location: git://github.com/georgefst/prettyprinter-graphviz.git + type: git + location: git://github.com/georgefst/prettyprinter-graphviz.git library - exposed-modules: Data.Text.Prettyprint.Doc.Render.GraphViz - build-depends: base >= 4.11 && < 5 - ,graphviz ^>= 2999.20.0.3 - ,prettyprinter ^>= 1.5.1 - ,text ^>= 1.2.3.1 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall - default-extensions: LambdaCase - OverloadedStrings + exposed-modules: + Data.Text.Prettyprint.Doc.Render.GraphViz + build-depends: + base >= 4.11 && < 5, + graphviz ^>= 2999.20.0.3, + prettyprinter ^>= { 1.5.1, 1.6 }, + text ^>= 1.2.3.1, + hs-source-dirs: src + ghc-options: + -Wall + default-language: Haskell2010 + default-extensions: + LambdaCase + OverloadedStrings diff --git a/src/Data/Text/Prettyprint/Doc/Render/GraphViz.hs b/src/Data/Text/Prettyprint/Doc/Render/GraphViz.hs --- a/src/Data/Text/Prettyprint/Doc/Render/GraphViz.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/GraphViz.hs @@ -1,94 +1,66 @@ -- | Pretty-print GraphViz labels module Data.Text.Prettyprint.Doc.Render.GraphViz ( - -- * Rendering functions render, render', - - -- * Error handling - -- The functions in this module can throw errors, given a malformed document stream. - -- The average user is very unlikely to run into this, - -- but error handling functionality is provided for completeness. - GraphVizRenderError(..), - renderSafe, - renderSafe', ) where import qualified Data.Text.Lazy as TL import qualified Data.Text as T -import Control.Exception ( - Exception, - displayException, - throw, - ) -import Data.GraphViz.Attributes.Complete ( - Label (HtmlLabel), - ) +import Data.GraphViz.Attributes.Complete (Label(HtmlLabel)) import qualified Data.GraphViz.Attributes.HTML as H +import Data.Text (Text) import Data.Text.Prettyprint.Doc ( - Doc, - SimpleDocStream (..), - defaultLayoutOptions, - layoutPretty, + Doc, + SimpleDocStream( + SFail, + SEmpty, + SChar, + SText, + SLine, + SAnnPush, + SAnnPop), + layoutPretty, defaultLayoutOptions, ) +import Data.Text.Prettyprint.Doc.Internal (textSpaces) +import Data.Text.Prettyprint.Doc.Render.Util.Panic ( + panicUnpairedPop, panicInputNotFullyConsumed, panicUncaughtFail + ) --- | Render a document as a GraphViz label, using 'defaultLayoutOptions'. +-- | Render a document as a GraphViz label, using sensible defaults. render :: Doc H.Attribute -> Label -render = throwLeft . renderSafe +render = HtmlLabel . H.Text . render' . layoutPretty defaultLayoutOptions -- | Render a document stream as HTML text for GraphViz. This provides more fine-grained control than 'render'. render' :: SimpleDocStream H.Attribute -> H.Text -render' = throwLeft . renderSafe' - --- | Errors which indicate a malformed 'SimpleDocStream'. -data GraphVizRenderError - -- | The stream ended with 'SFail'. - = GVDocStreamFail - -- | The stream contained more 'SAnnPop's than 'SAnnPush's. - | GVEmptyStack - deriving (Eq, Ord, Read, Show) -instance Exception GraphVizRenderError where - displayException = \case - GVDocStreamFail -> t ++ "encountered failure in document stream" - GVEmptyStack -> t ++ "attempted to pop empty attribute stack" - where t = "Failed to render HTML for GraphViz: " - --- | A total version of 'render'. -renderSafe :: Doc H.Attribute -> Either GraphVizRenderError Label -renderSafe = fmap (HtmlLabel . H.Text) . renderSafe' . layoutPretty defaultLayoutOptions - --- | A total version of 'render''. --- This can be seen as a generalisation of any of the other functions exported by this module. -renderSafe' :: SimpleDocStream H.Attribute -> Either GraphVizRenderError H.Text -renderSafe' = - let go cs = \case - SFail -> Left GVDocStreamFail - SEmpty -> Right [] - SChar c ds -> renderText cs (T.singleton c) ?: go cs ds - SText _ txt ds -> renderText cs txt ?: go cs ds - SLine n ds -> H.Newline [] ?: renderText cs (T.replicate n " ") ?: go cs ds - SAnnPush col ds -> go (col : cs) ds - SAnnPop ds -> flip go ds =<< maybeToEither GVEmptyStack (tailMay cs) - infixr 0 ?: - (?:) = fmap . (:) - in go [] +render' = renderSimplyDecorated' (pure .: renderText) mempty mempty -{- Internal utilities -} - --- | On encountering a 'Left', throw it as an exception. -throwLeft :: Exception e => Either e a -> a -throwLeft = either throw id +{- Util -} --- | Equal to the function of the same name from [extra](https://hackage.haskell.org/package/extra). -maybeToEither :: a -> Maybe b -> Either a b -maybeToEither x = maybe (Left x) Right +(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d +(.:) = (.) . (.) --- | Equal to the function of the same name from [safe](https://hackage.haskell.org/package/safe). -tailMay :: [a] -> Maybe [a] -tailMay = \case - [] -> Nothing - _ : xs -> Just xs +-- | This is a very minor modification of 'renderSimplyDecorated', where the /text/ function is +-- additionally passed the current stack. Worth suggesting change upstream. +renderSimplyDecorated' + :: Monoid out + => ([ann] -> Text -> out) -- ^ Render plain 'Text' + -> (ann -> out) -- ^ How to render an annotation + -> (ann -> out) -- ^ How to render the removed annotation + -> SimpleDocStream ann + -> out +renderSimplyDecorated' text push pop = go [] + where + go _ SFail = panicUncaughtFail + go [] SEmpty = mempty + go (_:_) SEmpty = panicInputNotFullyConsumed + go stack (SChar c rest) = text stack (T.singleton c) <> go stack rest + go stack (SText _l t rest) = text stack t <> go stack rest + go stack (SLine i rest) = text stack (T.singleton '\n') <> text stack (textSpaces i) <> go stack rest + go stack (SAnnPush ann rest) = push ann <> go (ann : stack) rest + go (ann:stack) (SAnnPop rest) = pop ann <> go stack rest + go [] SAnnPop{} = panicUnpairedPop -- | Helper for rendering an individual 'H.TextItem'. renderText :: H.Attributes -> T.Text -> H.TextItem