Commit 659db2e3 authored by doyougnu's avatar doyougnu
Browse files

use bang patterns in Ppr

parent a74cd1fb
......@@ -119,6 +119,8 @@ import GHC.Utils.Panic.Plain
import System.IO
import Numeric (showHex)
import Data.Foldable (foldr')
--for a RULES
import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) )
import GHC.Ptr ( Ptr(..) )
......@@ -214,13 +216,13 @@ infixl 5 $$, $+$
-- no occurrences of Union or NoDoc represents just one layout.
data Doc
= Empty -- empty
| NilAbove Doc -- text "" $$ x
| TextBeside !TextDetails {-# UNPACK #-} !Int Doc -- text s <> x
| Nest {-# UNPACK #-} !Int Doc -- nest k x
| Union Doc Doc -- ul `union` ur
| NilAbove !Doc -- text "" $$ x
| TextBeside !TextDetails {-# UNPACK #-} !Int !Doc -- text s <> x
| Nest {-# UNPACK #-} !Int !Doc -- nest k x
| Union !Doc !Doc -- ul `union` ur
| NoDoc -- The empty set of documents
| Beside Doc Bool Doc -- True <=> space between
| Above Doc Bool Doc -- True <=> never overlap
| Beside !Doc Bool !Doc -- True <=> space between
| Above !Doc Bool !Doc -- True <=> never overlap
{-
Here are the invariants:
......@@ -506,15 +508,15 @@ reduceDoc p = p
-- | List version of '<>'.
hcat :: [Doc] -> Doc
hcat = reduceAB . foldr (beside_' False) empty
hcat = reduceAB . foldr' (beside_' False) empty
-- | List version of '<+>'.
hsep :: [Doc] -> Doc
hsep = reduceAB . foldr (beside_' True) empty
hsep = reduceAB . foldr' (beside_' True) empty
-- | List version of '$$'.
vcat :: [Doc] -> Doc
vcat = reduceAB . foldr (above_' False) empty
vcat = reduceAB . foldr' (above_' False) empty
-- | Nest (or indent) a document by a given number of positions
-- (which may also be negative). 'nest' satisfies the laws:
......@@ -550,17 +552,17 @@ hangNotEmpty d1 n d2 = if isEmpty d1
punctuate :: Doc -> [Doc] -> [Doc]
punctuate _ [] = []
punctuate p (x:xs) = go x xs
where go y [] = [y]
go y (z:zs) = (y <> p) : go z zs
where go !y [] = [y]
go !y (z:zs) = (y <> p) : go z zs
-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
mkNest :: Int -> Doc -> Doc
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
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 checks for an empty document
mkUnion :: Doc -> Doc -> Doc
......@@ -617,11 +619,13 @@ union_ = Union
-- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty.
--
($$) :: Doc -> Doc -> Doc
{-# INLINE ($$) #-}
p $$ q = above_ p False q
-- | Above, with no overlapping.
-- '$+$' is associative, with identity 'empty'.
($+$) :: Doc -> Doc -> Doc
{-# INLINE ($+$) #-}
p $+$ q = above_ p True q
above_ :: Doc -> Bool -> Doc -> Doc
......@@ -636,17 +640,16 @@ above p g q = aboveNest p g 0 (reduceDoc q)
-- Specification: aboveNest p g k q = p $g$ (nest k q)
aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
aboveNest _ _ k _ | k `seq` False = undefined
aboveNest NoDoc _ _ _ = NoDoc
aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
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 Empty _ !k q = mkNest k q
aboveNest (Nest k1 p) g !k q = nest_ k1 (aboveNest p g (k - k1) q)
-- p can't be Empty, so no need for mkNest
aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
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
......@@ -658,11 +661,10 @@ aboveNest (Beside {}) _ _ _ = error "aboveNest Beside"
-- Specification: text s <> nilaboveNest g k q
-- = text s <> (text "" $g$ nest k q)
nilAboveNest :: Bool -> Int -> RDoc -> RDoc
nilAboveNest _ k _ | k `seq` False = undefined
nilAboveNest _ _ Empty = Empty
-- Here's why the "text s <>" is in the spec!
nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
nilAboveNest g k q | not g && k > 0 -- No newline if no overlap
nilAboveNest g !k (Nest k1 q) = nilAboveNest g (k + k1) q
nilAboveNest g !k q | not g && k > 0 -- No newline if no overlap
= textBeside_ (RStr k ' ') k q
| otherwise -- Put them really above
= nilAbove_ (mkNest k q)
......@@ -678,11 +680,13 @@ nilAboveNest g k q | not g && k > 0 -- No newline if no overlap
-- | Beside.
-- '<>' is associative, with identity 'empty'.
(<>) :: Doc -> Doc -> Doc
{-# INLINE (<>) #-}
p <> q = beside_ p False q
-- | Beside, separated by space, unless one of the arguments is 'empty'.
-- '<+>' is associative, with identity 'empty'.
(<+>) :: Doc -> Doc -> Doc
{-# INLINE (<+>) #-}
p <+> q = beside_ p True q
beside_ :: Doc -> Bool -> Doc -> Doc
......@@ -740,17 +744,16 @@ sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
-- = oneLiner (x <g> nest k (hsep ys))
-- `union` x $$ nest k (vcat ys)
sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
sep1 _ _ k _ | k `seq` False = undefined
sep1 _ NoDoc _ _ = NoDoc
sep1 g (p `Union` q) k ys = sep1 g p k ys `union_`
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 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_
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 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"
......@@ -803,24 +806,22 @@ fill _ [] = empty
fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
fill1 _ _ k _ | k `seq` False = undefined
fill1 _ NoDoc _ _ = NoDoc
fill1 g (p `Union` q) k ys = fill1 g p k ys `union_`
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 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 -> Doc -> Int -> [Doc] -> Doc
fillNB _ _ k _ | k `seq` False = undefined
fillNB g (Nest _ p) k ys = fillNB g p k ys
fillNB g (Nest _ p) !k ys = fillNB g p k ys
-- Never triggered, because of invariant (2)
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 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
......@@ -829,7 +830,7 @@ fillNBE g k y ys
= nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys)
-- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)
`mkUnion` nilAboveNest False k (fill g (y:ys))
where k' = if g then k - 1 else k
where !k' = if g then k - 1 else k
elideNest :: Doc -> Doc
elideNest (Nest _ d) = d
......@@ -846,13 +847,12 @@ best w0 r = get w0
where
get :: Int -- (Remaining) width of line
-> Doc -> Doc
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 !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"
......@@ -861,13 +861,12 @@ best w0 r = get w0
-> Doc -- This is an argument to TextBeside => eat Nests
-> Doc -- No unions in here!
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 (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"
......@@ -1010,11 +1009,10 @@ 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 !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)
lay !k (NilAbove p) = nlText `txt` lay k p
lay !k (TextBeside s sl p)
= case m of
ZigZagMode | k >= gap_width
-> nlText `txt` (
......@@ -1037,10 +1035,9 @@ display m !page_width !ribbon_width txt end doc
lay1 !k s !sl p = let !r = k + sl
in indent k (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 !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"
......@@ -1137,21 +1134,19 @@ bufLeftRender :: BufHandle -> Doc -> IO ()
bufLeftRender b doc = layLeft b (reduceDoc doc)
layLeft :: BufHandle -> Doc -> IO ()
layLeft b _ | b `seq` False = undefined -- make it strict in b
layLeft _ NoDoc = error "layLeft: NoDoc"
layLeft b (Union p q) = layLeft b $! first p q
layLeft b (Nest _ p) = layLeft b $! p
layLeft b Empty = bPutChar b '\n'
layLeft b (NilAbove p) = p `seq` (bPutChar b '\n' >> layLeft b p)
layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p)
layLeft !b (Union p q) = layLeft b $! first p q
layLeft !b (Nest _ p) = layLeft b $! p
layLeft !b Empty = bPutChar b '\n'
layLeft !b (NilAbove p) = p `seq` (bPutChar b '\n' >> layLeft b p)
layLeft !b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p)
where
put b _ | b `seq` False = undefined
put b (Chr c) = bPutChar b c
put b (Str s) = bPutStr b s
put b (PStr s) = bPutFS b s
put b (ZStr s) = bPutFZS b s
put b (LStr s) = bPutPtrString b s
put b (RStr n c) = bPutReplicate b n c
put !b (Chr c) = bPutChar b c
put !b (Str s) = bPutStr b s
put !b (PStr s) = bPutFS b s
put !b (ZStr s) = bPutFZS b s
put !b (LStr s) = bPutPtrString b s
put !b (RStr n c) = bPutReplicate b n c
layLeft _ _ = panic "layLeft: Unhandled case"
-- Define error=panic, for easier comparison with libraries/pretty.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment