module Michelson.Printer.Util
( RenderDoc(..)
, Prettier(..)
, printDoc
, printDocB
, renderOps
, renderOpsList
, spaces
, wrapInParens
, buildRenderDoc
, RenderContext
, needsParens
, doesntNeedParens
, addParens
, assertParensNotNeeded
) where
import Control.Exception (assert)
import qualified Data.Text.Lazy as LT
import Data.Text.Lazy.Builder (Builder)
import Text.PrettyPrint.Leijen.Text
(Doc, SimpleDoc, align, braces, displayB, displayT, enclose, hcat, isEmpty, parens, punctuate,
renderOneLine, renderPretty, semi, space, vcat, (<+>))
newtype RenderContext = RenderContext
{ _rcWillNeedParens :: Bool
}
class RenderDoc a where
renderDoc :: RenderContext -> a -> Doc
isRenderable :: a -> Bool
isRenderable _ = True
newtype Prettier a = Prettier a
printDoc :: Bool -> Doc -> LT.Text
printDoc oneLine = displayT . doRender oneLine
printDocB :: Bool -> Doc -> Builder
printDocB oneLine = displayB . doRender oneLine
renderOps :: (RenderDoc op) => Bool -> NonEmpty op -> Doc
renderOps oneLine = renderOpsList oneLine . toList
spacecat :: NonEmpty Doc -> Doc
spacecat = foldr (<+>) mempty
renderOpsList :: (RenderDoc op) => Bool -> [op] -> Doc
renderOpsList oneLine ops =
braces $
enclose space space $
cat' $ punctuate semi $
renderDoc doesntNeedParens <$> filter isRenderable ops
where
cat' = if oneLine then maybe "" spacecat . nonEmpty else align . vcat
spaces :: Int -> Doc
spaces x = hcat $ replicate x space
wrapInParens :: RenderContext -> NonEmpty Doc -> Doc
wrapInParens (RenderContext pn) ds =
let moreThanOne = length (filter (not . isEmpty) (toList ds)) > 1
in addParens (RenderContext (pn && moreThanOne)) $
foldr (<+>) mempty ds
buildRenderDoc :: RenderDoc a => a -> Builder
buildRenderDoc = printDocB True . renderDoc doesntNeedParens
doRender :: Bool -> Doc -> SimpleDoc
doRender oneLine = if oneLine then renderOneLine else renderPretty 1.0 80
needsParens, doesntNeedParens :: RenderContext
needsParens = RenderContext True
doesntNeedParens = RenderContext False
addParens :: RenderContext -> Doc -> Doc
addParens = \case
RenderContext True -> parens
RenderContext False -> id
assertParensNotNeeded :: HasCallStack => RenderContext -> a -> a
assertParensNotNeeded (RenderContext pn) = assert (not pn)