#if __GLASGOW_HASKELL__ >= 701
#endif
module Text.PrettyPrint.MarkedHughesPJ (
Doc,
MDoc,
TextDetails(..),
char, text, ptext, sizedText, zeroWidthText,
int, integer, float, double, rational,
semi, comma, colon, space, equals,
lparen, rparen, lbrack, rbrack, lbrace, rbrace,
parens, brackets, braces, quotes, doubleQuotes,
maybeParens, maybeBrackets, maybeBraces, maybeQuotes, maybeDoubleQuotes,
empty,
(<>), (<+>), hcat, hsep,
($$), ($+$), vcat,
sep, cat,
fsep, fcat,
nest,
hang, punctuate,
isEmpty,
first, reduceDoc,
render,
Style(..),
style,
renderStyle,
Mode(..),
fullRender,
mark
) where
import Control.DeepSeq ( NFData(rnf) )
import Data.Function ( on )
#if __GLASGOW_HASKELL__ < 709
import Data.Monoid ( Monoid(mempty, mappend) )
#endif
import Data.String ( IsString(fromString) )
import GHC.Generics
infixl 6 <>
infixl 6 <+>
infixl 5 $$, $+$
type Doc = MDoc ()
data MDoc a
= Empty
| NilAbove (MDoc a)
| TextBeside !(TextDetails a) !Int (MDoc a)
| Nest !Int (MDoc a)
| Union (MDoc a) (MDoc a)
| NoDoc
| Beside (MDoc a) Bool (MDoc a)
| Above (MDoc a) Bool (MDoc a)
#if __GLASGOW_HASKELL__ >= 701
deriving (Generic)
#endif
type RDoc a = MDoc a
data TextDetails a = Chr !Char
| Str String
| PStr String
| Mark a
#if __GLASGOW_HASKELL__ >= 701
deriving (Show, Eq, Generic)
#endif
instance Monoid (MDoc a) where
mempty = empty
mappend = (<>)
instance IsString (MDoc a) where
fromString = text
instance Show (MDoc a) where
showsPrec _ doc cont = fullRender (mode style) (lineLength style)
(ribbonsPerLine style)
txtPrinter cont doc
instance Eq (MDoc a) where
(==) = (==) `on` render
instance NFData a => NFData (MDoc a) where
rnf Empty = ()
rnf (NilAbove d) = rnf d
rnf (TextBeside td i d) = rnf td `seq` rnf i `seq` rnf d
rnf (Nest k d) = rnf k `seq` rnf d
rnf (Union ur ul) = rnf ur `seq` rnf ul
rnf NoDoc = ()
rnf (Beside ld s rd) = rnf ld `seq` rnf s `seq` rnf rd
rnf (Above ud s ld) = rnf ud `seq` rnf s `seq` rnf ld
instance NFData a => NFData (TextDetails a) where
rnf (Chr c) = rnf c
rnf (Str str) = rnf str
rnf (PStr str) = rnf str
rnf (Mark a) = rnf a
char :: Char -> MDoc a
char c = textBeside_ (Chr c) 1 Empty
text :: String -> MDoc a
text s = case length s of {sl -> textBeside_ (Str s) sl Empty}
ptext :: String -> MDoc a
ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}
sizedText :: Int -> String -> MDoc a
sizedText l s = textBeside_ (Str s) l Empty
zeroWidthText :: String -> MDoc a
zeroWidthText = sizedText 0
empty :: MDoc a
empty = Empty
isEmpty :: MDoc a -> Bool
isEmpty Empty = True
isEmpty _ = False
indent :: Int -> String
indent !n = replicate n ' '
semi :: MDoc a
comma :: MDoc a
colon :: MDoc a
space :: MDoc a
equals :: MDoc a
lparen :: MDoc a
rparen :: MDoc a
lbrack :: MDoc a
rbrack :: MDoc a
lbrace :: MDoc a
rbrace :: MDoc a
semi = char ';'
comma = char ','
colon = char ':'
space = char ' '
equals = char '='
lparen = char '('
rparen = char ')'
lbrack = char '['
rbrack = char ']'
lbrace = char '{'
rbrace = char '}'
spaceText, nlText :: TextDetails a
spaceText = Chr ' '
nlText = Chr '\n'
int :: Int -> MDoc a
integer :: Integer -> MDoc a
float :: Float -> MDoc a
double :: Double -> MDoc a
rational :: Rational -> MDoc a
int n = text (show n)
integer n = text (show n)
float n = text (show n)
double n = text (show n)
rational n = text (show n)
parens :: MDoc a -> MDoc a
brackets :: MDoc a -> MDoc a
braces :: MDoc a -> MDoc a
quotes :: MDoc a -> MDoc a
doubleQuotes :: MDoc a -> MDoc a
quotes p = char '\'' <> p <> char '\''
doubleQuotes p = char '"' <> p <> char '"'
parens p = char '(' <> p <> char ')'
brackets p = char '[' <> p <> char ']'
braces p = char '{' <> p <> char '}'
maybeParens :: Bool -> MDoc a -> MDoc a
maybeParens False = id
maybeParens True = parens
maybeBrackets :: Bool -> MDoc a -> MDoc a
maybeBrackets False = id
maybeBrackets True = brackets
maybeBraces :: Bool -> MDoc a -> MDoc a
maybeBraces False = id
maybeBraces True = braces
maybeQuotes :: Bool -> MDoc a -> MDoc a
maybeQuotes False = id
maybeQuotes True = quotes
maybeDoubleQuotes :: Bool -> MDoc a -> MDoc a
maybeDoubleQuotes False = id
maybeDoubleQuotes True = doubleQuotes
reduceDoc :: MDoc a -> RDoc a
reduceDoc (Beside p g q) = beside p g (reduceDoc q)
reduceDoc (Above p g q) = above p g (reduceDoc q)
reduceDoc p = p
hcat :: [MDoc a] -> MDoc a
hcat = snd . reduceHoriz . foldr (\p q -> Beside p False q) empty
hsep :: [MDoc a] -> MDoc a
hsep = snd . reduceHoriz . foldr (\p q -> Beside p True q) empty
vcat :: [MDoc a] -> MDoc a
vcat = snd . reduceVert . foldr (\p q -> Above p False q) empty
nest :: Int -> MDoc a -> MDoc a
nest k p = mkNest k (reduceDoc p)
hang :: MDoc a -> Int -> MDoc a -> MDoc a
hang d1 n d2 = sep [d1, nest n d2]
punctuate :: MDoc a -> [MDoc a] -> [MDoc a]
punctuate _ [] = []
punctuate p (x:xs) = go x xs
where go y [] = [y]
go y (z:zs) = (y <> p) : go z zs
mkNest :: Int -> MDoc a -> MDoc a
mkNest k _ | k `seq` False = undefined
mkNest k (Nest k1 p) = mkNest (k + k1) p
mkNest _ NoDoc = NoDoc
mkNest _ Empty = Empty
mkNest 0 p = p
mkNest k p = nest_ k p
mkUnion :: MDoc a -> MDoc a -> MDoc a
mkUnion Empty _ = Empty
mkUnion p q = p `union_` q
data IsEmpty = IsEmpty | NotEmpty
reduceHoriz :: MDoc a -> (IsEmpty, MDoc a)
reduceHoriz (Beside p g q) = eliminateEmpty Beside (snd (reduceHoriz p)) g (reduceHoriz q)
reduceHoriz doc = (NotEmpty, doc)
reduceVert :: MDoc a -> (IsEmpty, MDoc a)
reduceVert (Above p g q) = eliminateEmpty Above (snd (reduceVert p)) g (reduceVert q)
reduceVert doc = (NotEmpty, doc)
eliminateEmpty ::
(MDoc a -> Bool -> MDoc a -> MDoc a) ->
MDoc a -> Bool -> (IsEmpty, MDoc a) -> (IsEmpty, MDoc a)
eliminateEmpty _ Empty _ q = q
eliminateEmpty cons p g q =
(NotEmpty,
case q of
(NotEmpty, q') -> cons p g q'
(IsEmpty, _) -> p)
nilAbove_ :: RDoc a -> RDoc a
nilAbove_ = NilAbove
textBeside_ :: TextDetails a -> Int -> RDoc a -> RDoc a
textBeside_ = TextBeside
nest_ :: Int -> RDoc a -> RDoc a
nest_ = Nest
union_ :: RDoc a -> RDoc a -> RDoc a
union_ = Union
($$) :: MDoc a -> MDoc a -> MDoc a
p $$ q = above_ p False q
($+$) :: MDoc a -> MDoc a -> MDoc a
p $+$ q = above_ p True q
above_ :: MDoc a -> Bool -> MDoc a -> MDoc a
above_ p _ Empty = p
above_ Empty _ q = q
above_ p g q = Above p g q
above :: MDoc a -> Bool -> RDoc a -> RDoc a
above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
above p@(Beside{}) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)
above p g q = aboveNest p g 0 (reduceDoc q)
aboveNest :: RDoc a -> Bool -> Int -> RDoc a -> RDoc a
aboveNest _ _ k _ | k `seq` False = undefined
aboveNest NoDoc _ _ _ = NoDoc
aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
aboveNest p2 g k q
aboveNest Empty _ k q = mkNest k q
aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k k1) q)
aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
where
!k1 = k sl
rest = case p of
Empty -> nilAboveNest g k1 q
_ -> aboveNest p g k1 q
aboveNest (Above {}) _ _ _ = error "aboveNest Above"
aboveNest (Beside {}) _ _ _ = error "aboveNest Beside"
nilAboveNest :: Bool -> Int -> RDoc a -> RDoc a
nilAboveNest _ k _ | k `seq` False = undefined
nilAboveNest _ _ Empty = Empty
nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
nilAboveNest g k q | not g && k > 0
= textBeside_ (Str (indent k)) k q
| otherwise
= nilAbove_ (mkNest k q)
(<>) :: MDoc a -> MDoc a -> MDoc a
p <> q = beside_ p False q
(<+>) :: MDoc a -> MDoc a -> MDoc a
p <+> q = beside_ p True q
beside_ :: MDoc a -> Bool -> MDoc a -> MDoc a
beside_ p _ Empty = p
beside_ Empty _ q = q
beside_ p g q = Beside p g q
beside :: MDoc a -> Bool -> RDoc a -> RDoc a
beside NoDoc _ _ = NoDoc
beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q
beside Empty _ q = q
beside (Nest k p) g q = nest_ k $! beside p g q
beside p@(Beside p1 g1 q1) g2 q2
| g1 == g2 = beside p1 g1 $! beside q1 g2 q2
| otherwise = beside (reduceDoc p) g2 q2
beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q
beside (NilAbove p) g q = nilAbove_ $! beside p g q
beside (TextBeside s sl p) g q = textBeside_ s sl $! rest
where
rest = case p of
Empty -> nilBeside g q
_ -> beside p g q
nilBeside :: Bool -> RDoc a -> RDoc a
nilBeside _ Empty = Empty
nilBeside g (Nest _ p) = nilBeside g p
nilBeside g p | g = textBeside_ spaceText 1 p
| otherwise = p
sep :: [MDoc a] -> MDoc a
sep = sepX True
cat :: [MDoc a] -> MDoc a
cat = sepX False
sepX :: Bool -> [MDoc a] -> MDoc a
sepX _ [] = empty
sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
sep1 :: Bool -> RDoc a -> Int -> [MDoc a] -> RDoc a
sep1 _ _ k _ | k `seq` False = undefined
sep1 _ NoDoc _ _ = NoDoc
sep1 g (p `Union` q) k ys = sep1 g p k ys `union_`
aboveNest q False k (reduceDoc (vcat ys))
sep1 g Empty k ys = mkNest k (sepX g ys)
sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k n) ys)
sep1 _ (NilAbove p) k ys = nilAbove_
(aboveNest p False k (reduceDoc (vcat ys)))
sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k sl) ys)
sep1 _ (Above {}) _ _ = error "sep1 Above"
sep1 _ (Beside {}) _ _ = error "sep1 Beside"
sepNB :: Bool -> MDoc a -> Int -> [MDoc a] -> MDoc a
sepNB g (Nest _ p) k ys
= sepNB g p k ys
sepNB g Empty k ys
= oneLiner (nilBeside g (reduceDoc rest)) `mkUnion`
nilAboveNest False k (reduceDoc (vcat ys))
where
rest | g = hsep ys
| otherwise = hcat ys
sepNB g p k ys
= sep1 g p k ys
fcat :: [MDoc a] -> MDoc a
fcat = fill False
fsep :: [MDoc a] -> MDoc a
fsep = fill True
fill :: Bool -> [MDoc a] -> RDoc a
fill _ [] = empty
fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
fill1 :: Bool -> RDoc a -> Int -> [MDoc a] -> MDoc a
fill1 _ _ k _ | k `seq` False = undefined
fill1 _ NoDoc _ _ = NoDoc
fill1 g (p `Union` q) k ys = fill1 g p k ys `union_`
aboveNest q False k (fill g ys)
fill1 g Empty k ys = mkNest k (fill g ys)
fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k n) ys)
fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k sl) ys)
fill1 _ (Above {}) _ _ = error "fill1 Above"
fill1 _ (Beside {}) _ _ = error "fill1 Beside"
fillNB :: Bool -> MDoc a -> Int -> [MDoc a] -> MDoc a
fillNB _ _ k _ | k `seq` False = undefined
fillNB g (Nest _ p) k ys = fillNB g p k ys
fillNB _ Empty _ [] = Empty
fillNB g Empty k (Empty:ys) = fillNB g Empty k ys
fillNB g Empty k (y:ys) = fillNBE g k y ys
fillNB g p k ys = fill1 g p k ys
fillNBE :: Bool -> Int -> MDoc a -> [MDoc a] -> MDoc a
fillNBE g k y ys
= nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys)
`mkUnion` nilAboveNest False k (fill g (y:ys))
where k' = if g then k 1 else k
elideNest :: MDoc a -> MDoc a
elideNest (Nest _ d) = d
elideNest d = d
best :: Int
-> Int
-> RDoc a
-> RDoc a
best w0 r = get w0
where
get w _ | w == 0 && False = undefined
get _ Empty = Empty
get _ NoDoc = NoDoc
get w (NilAbove p) = nilAbove_ (get w p)
get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
get w (Nest k p) = nest_ k (get (w k) p)
get w (p `Union` q) = nicest w r (get w p) (get w q)
get _ (Above {}) = error "best get Above"
get _ (Beside {}) = error "best get Beside"
get1 w _ _ | w == 0 && False = undefined
get1 _ _ Empty = Empty
get1 _ _ NoDoc = NoDoc
get1 w sl (NilAbove p) = nilAbove_ (get (w sl) p)
get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
get1 w sl (Nest _ p) = get1 w sl p
get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
(get1 w sl q)
get1 _ _ (Above {}) = error "best get1 Above"
get1 _ _ (Beside {}) = error "best get1 Beside"
nicest :: Int -> Int -> MDoc a -> MDoc a -> MDoc a
nicest !w !r = nicest1 w r 0
nicest1 :: Int -> Int -> Int -> MDoc a -> MDoc a -> MDoc a
nicest1 !w !r !sl p q | fits ((w `min` r) sl) p = p
| otherwise = q
fits :: Int
-> MDoc a
-> Bool
fits n _ | n < 0 = False
fits _ NoDoc = False
fits _ Empty = True
fits _ (NilAbove _) = True
fits n (TextBeside _ sl p) = fits (n sl) p
fits _ (Above {}) = error "fits Above"
fits _ (Beside {}) = error "fits Beside"
fits _ (Union {}) = error "fits Union"
fits _ (Nest {}) = error "fits Nest"
first :: MDoc a -> MDoc a -> MDoc a
first p q | nonEmptySet p = p
| otherwise = q
nonEmptySet :: MDoc a -> Bool
nonEmptySet NoDoc = False
nonEmptySet (_ `Union` _) = True
nonEmptySet Empty = True
nonEmptySet (NilAbove _) = True
nonEmptySet (TextBeside _ _ p) = nonEmptySet p
nonEmptySet (Nest _ p) = nonEmptySet p
nonEmptySet (Above {}) = error "nonEmptySet Above"
nonEmptySet (Beside {}) = error "nonEmptySet Beside"
oneLiner :: MDoc a -> MDoc a
oneLiner NoDoc = NoDoc
oneLiner Empty = Empty
oneLiner (NilAbove _) = NoDoc
oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
oneLiner (Nest k p) = nest_ k (oneLiner p)
oneLiner (p `Union` _) = oneLiner p
oneLiner (Above {}) = error "oneLiner Above"
oneLiner (Beside {}) = error "oneLiner Beside"
data Style
= Style { mode :: Mode
, lineLength :: Int
, ribbonsPerLine :: Float
}
#if __GLASGOW_HASKELL__ >= 701
deriving (Show, Eq, Generic)
#endif
style :: Style
style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }
data Mode = PageMode
| ZigZagMode
| LeftMode
| OneLineMode
#if __GLASGOW_HASKELL__ >= 701
deriving (Show, Eq, Generic)
#endif
render :: MDoc a -> String
render = fullRender (mode style) (lineLength style) (ribbonsPerLine style)
txtPrinter ""
renderStyle :: Style -> MDoc a -> String
renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s)
txtPrinter ""
txtPrinter :: TextDetails a -> String -> String
txtPrinter (Chr c) s = c:s
txtPrinter (Str s1) s2 = s1 ++ s2
txtPrinter (PStr s1) s2 = s1 ++ s2
txtPrinter (Mark _) s2 = s2
fullRender :: Mode
-> Int
-> Float
-> (TextDetails b -> a -> a)
-> a
-> MDoc b
-> a
fullRender OneLineMode _ _ txt end doc
= easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc)
fullRender LeftMode _ _ txt end doc
= easyDisplay nlText first txt end (reduceDoc doc)
fullRender m lineLen ribbons txt rest doc
= display m lineLen ribbonLen txt rest doc'
where
doc' = best bestLineLen ribbonLen (reduceDoc doc)
bestLineLen, ribbonLen :: Int
ribbonLen = round (fromIntegral lineLen / ribbons)
bestLineLen = case m of
ZigZagMode -> maxBound
_ -> lineLen
easyDisplay :: TextDetails b
-> (MDoc b -> MDoc b -> MDoc b)
-> (TextDetails b -> a -> a)
-> a
-> MDoc b
-> a
easyDisplay nlSpaceText choose txt end
= lay
where
lay NoDoc = error "easyDisplay: NoDoc"
lay (Union p q) = lay (choose p q)
lay (Nest _ p) = lay p
lay Empty = end
lay (NilAbove p) = nlSpaceText `txt` lay p
lay (TextBeside s _ p) = s `txt` lay p
lay (Above {}) = error "easyDisplay Above"
lay (Beside {}) = error "easyDisplay Beside"
display :: Mode -> Int -> Int -> (TextDetails b -> a -> a) -> a -> MDoc b -> a
display m !page_width !ribbon_width txt end doc
= case page_width ribbon_width of { gap_width ->
case gap_width `quot` 2 of { shift ->
let
lay k _ | k `seq` False = undefined
lay k (Nest k1 p) = lay (k + k1) p
lay _ Empty = end
lay k (NilAbove p) = nlText `txt` lay k p
lay k (TextBeside s sl p)
= case m of
ZigZagMode | k >= gap_width
-> nlText `txt` (
Str (replicate shift '/') `txt` (
nlText `txt`
lay1 (k shift) s sl p ))
| k < 0
-> nlText `txt` (
Str (replicate shift '\\') `txt` (
nlText `txt`
lay1 (k + shift) s sl p ))
_ -> lay1 k s sl p
lay _ (Above {}) = error "display lay Above"
lay _ (Beside {}) = error "display lay Beside"
lay _ NoDoc = error "display lay NoDoc"
lay _ (Union {}) = error "display lay Union"
lay1 !k s !sl p = let !r = k + sl
in Str (indent k) `txt` (s `txt` lay2 r p)
lay2 k _ | k `seq` False = undefined
lay2 k (NilAbove p) = nlText `txt` lay k p
lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p
lay2 k (Nest _ p) = lay2 k p
lay2 _ Empty = end
lay2 _ (Above {}) = error "display lay2 Above"
lay2 _ (Beside {}) = error "display lay2 Beside"
lay2 _ NoDoc = error "display lay2 NoDoc"
lay2 _ (Union {}) = error "display lay2 Union"
in
lay 0 doc
}}
mark :: a -> MDoc a
mark m = textBeside_ (Mark m) 0 Empty