module Michelson.Printer.Util
( RenderDoc(..)
, Prettier(..)
, printDoc
, printDocB
, printDocS
, renderOps
, renderOpsList
, renderOpsListNoBraces
, renderAnyBuildable
, spaces
, wrapInParens
, buildRenderDoc
, buildRenderDocExtended
, renderDocList
, RenderContext
, needsParens
, doesntNeedParens
, addParens
, assertParensNotNeeded
) where
import Fmt (Buildable, pretty)
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, text, vcat, (<+>), lbracket, rbracket, encloseSep)
newtype RenderContext = RenderContext
{ RenderContext -> Bool
_rcWillNeedParens :: Bool
}
class RenderDoc a where
renderDoc :: RenderContext -> a -> Doc
isRenderable :: a -> Bool
isRenderable a
_ = Bool
True
renderDocList :: RenderDoc a => RenderContext -> [a] -> Doc
renderDocList :: RenderContext -> [a] -> Doc
renderDocList RenderContext
context = Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep Doc
lbracket Doc
rbracket Doc
", " ([Doc] -> Doc) -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RenderContext -> a -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
context)
renderAnyBuildable :: Buildable a => a -> Doc
renderAnyBuildable :: a -> Doc
renderAnyBuildable = Text -> Doc
text (Text -> Doc) -> (a -> Text) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty
newtype Prettier a = Prettier a
printDoc :: Bool -> Doc -> LT.Text
printDoc :: Bool -> Doc -> Text
printDoc Bool
oneLine = SimpleDoc -> Text
displayT (SimpleDoc -> Text) -> (Doc -> SimpleDoc) -> Doc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Doc -> SimpleDoc
doRender Bool
oneLine
printDocB :: Bool -> Doc -> Builder
printDocB :: Bool -> Doc -> Builder
printDocB Bool
oneLine = SimpleDoc -> Builder
displayB (SimpleDoc -> Builder) -> (Doc -> SimpleDoc) -> Doc -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Doc -> SimpleDoc
doRender Bool
oneLine
printDocS :: Bool -> Doc -> String
printDocS :: Bool -> Doc -> String
printDocS Bool
oneLine = Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> (Doc -> Text) -> Doc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Doc -> Text
printDoc Bool
oneLine
renderOps :: (RenderDoc op) => Bool -> NonEmpty op -> Doc
renderOps :: Bool -> NonEmpty op -> Doc
renderOps Bool
oneLine = Bool -> [op] -> Doc
forall op. RenderDoc op => Bool -> [op] -> Doc
renderOpsList Bool
oneLine ([op] -> Doc) -> (NonEmpty op -> [op]) -> NonEmpty op -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty op -> [op]
forall t. Container t => t -> [Element t]
toList
spacecat :: NonEmpty Doc -> Doc
spacecat :: NonEmpty Doc -> Doc
spacecat = (Element (NonEmpty Doc) -> Doc -> Doc)
-> Doc -> NonEmpty Doc -> Doc
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
foldr Element (NonEmpty Doc) -> Doc -> Doc
Doc -> Doc -> Doc
(<+>) Doc
forall a. Monoid a => a
mempty
renderOpsList :: (RenderDoc op) => Bool -> [op] -> Doc
renderOpsList :: Bool -> [op] -> Doc
renderOpsList Bool
oneLine [op]
ops =
Doc -> Doc
braces (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc -> Doc
enclose Doc
space Doc
space (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> [op] -> Doc
forall op. RenderDoc op => Bool -> [op] -> Doc
renderOpsListNoBraces Bool
oneLine [op]
ops
renderOpsListNoBraces :: RenderDoc op => Bool -> [op] -> Doc
renderOpsListNoBraces :: Bool -> [op] -> Doc
renderOpsListNoBraces Bool
oneLine [op]
ops =
[Doc] -> Doc
cat' ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
semi ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$
RenderContext -> op -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
doesntNeedParens (op -> Doc) -> [op] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (op -> Bool) -> [op] -> [op]
forall a. (a -> Bool) -> [a] -> [a]
filter op -> Bool
forall a. RenderDoc a => a -> Bool
isRenderable [op]
ops
where
cat' :: [Doc] -> Doc
cat' = if Bool
oneLine then Doc -> (NonEmpty Doc -> Doc) -> Maybe (NonEmpty Doc) -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
"" NonEmpty Doc -> Doc
spacecat (Maybe (NonEmpty Doc) -> Doc)
-> ([Doc] -> Maybe (NonEmpty Doc)) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Maybe (NonEmpty Doc)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty else Doc -> Doc
align (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vcat
spaces :: Int -> Doc
spaces :: Int -> Doc
spaces Int
x = [Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> [Doc]
forall a. Int -> a -> [a]
replicate Int
x Doc
space
wrapInParens :: RenderContext -> NonEmpty Doc -> Doc
wrapInParens :: RenderContext -> NonEmpty Doc -> Doc
wrapInParens (RenderContext Bool
pn) NonEmpty Doc
ds =
let moreThanOne :: Bool
moreThanOne = [Doc] -> Int
forall t. Container t => t -> Int
length ((Doc -> Bool) -> [Doc] -> [Doc]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Doc -> Bool) -> Doc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Bool
isEmpty) (NonEmpty Doc -> [Element (NonEmpty Doc)]
forall t. Container t => t -> [Element t]
toList NonEmpty Doc
ds)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
in RenderContext -> Doc -> Doc
addParens (Bool -> RenderContext
RenderContext (Bool
pn Bool -> Bool -> Bool
&& Bool
moreThanOne)) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
(Element (NonEmpty Doc) -> Doc -> Doc)
-> Doc -> NonEmpty Doc -> Doc
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
foldr Element (NonEmpty Doc) -> Doc -> Doc
Doc -> Doc -> Doc
(<+>) Doc
forall a. Monoid a => a
mempty NonEmpty Doc
ds
buildRenderDoc :: RenderDoc a => a -> Builder
buildRenderDoc :: a -> Builder
buildRenderDoc = Bool -> Doc -> Builder
printDocB Bool
True (Doc -> Builder) -> (a -> Doc) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderContext -> a -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
doesntNeedParens
buildRenderDocExtended :: RenderDoc a => a -> Builder
buildRenderDocExtended :: a -> Builder
buildRenderDocExtended = Bool -> Doc -> Builder
printDocB Bool
False (Doc -> Builder) -> (a -> Doc) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderContext -> a -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
doesntNeedParens
doRender :: Bool -> Doc -> SimpleDoc
doRender :: Bool -> Doc -> SimpleDoc
doRender Bool
oneLine = if Bool
oneLine then Doc -> SimpleDoc
renderOneLine else Float -> Int -> Doc -> SimpleDoc
renderPretty Float
1.0 Int
80
needsParens, doesntNeedParens :: RenderContext
needsParens :: RenderContext
needsParens = Bool -> RenderContext
RenderContext Bool
True
doesntNeedParens :: RenderContext
doesntNeedParens = Bool -> RenderContext
RenderContext Bool
False
addParens :: RenderContext -> Doc -> Doc
addParens :: RenderContext -> Doc -> Doc
addParens = \case
RenderContext Bool
True -> Doc -> Doc
parens
RenderContext Bool
False -> Doc -> Doc
forall a. a -> a
id
assertParensNotNeeded :: RenderContext -> a -> a
assertParensNotNeeded :: RenderContext -> a -> a
assertParensNotNeeded (RenderContext Bool
pn) = Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not Bool
pn)