It is Really Useful in practice.
2. There is a paragraph-fill combinator, fsep, that's much like sep,
- only it keeps fitting things on one line until itc can't fit any more.
+ only it keeps fitting things on one line until it can't fit any more.
3. Some random useful extra combinators are provided.
<+> puts its arguments beside each other with a space between them,
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module Pretty (
Doc, -- Abstract
Mode(..), TextDetails(..),
int, integer, float, double, rational,
parens, brackets, braces, quotes, doubleQuotes,
semi, comma, colon, space, equals,
- lparen, rparen, lbrack, rbrack, lbrace, rbrace,
+ lparen, rparen, lbrack, rbrack, lbrace, rbrace, cparen,
(<>), (<+>), hcat, hsep,
($$), ($+$), vcat,
import BufWrite
import FastString
-
-import GHC.Exts
+import FastTypes
import Numeric (fromRat)
import System.IO
+--import Foreign.Ptr (castPtr)
+#if defined(__GLASGOW_HASKELL__)
+--for a RULES
import GHC.Base ( unpackCString# )
import GHC.Ptr ( Ptr(..) )
+#endif
-- Don't import Util( assertPanic ) because it makes a loop in the module structure
\end{code}
-
-*********************************************************
-* *
-\subsection{CPP magic so that we can compile with both GHC and Hugs}
-* *
-*********************************************************
-
-The library uses unboxed types to get a bit more speed, but these CPP macros
-allow you to use either GHC or Hugs. To get GHC, just set the CPP variable
- __GLASGOW_HASKELL__
-
\begin{code}
-#if defined(__GLASGOW_HASKELL__)
-
--- Glasgow Haskell
-
-- Disable ASSERT checks; they are expensive!
#define LOCAL_ASSERT(x)
-#define ILIT(x) (x#)
-#define IBOX(x) (I# (x))
-#define INT Int#
-#define MINUS -#
-#define NEGATE negateInt#
-#define PLUS +#
-#define GR >#
-#define GREQ >=#
-#define LT <#
-#define DIV `quotInt#`
-
-
-#define SHOW Show
-#define MAXINT maxBound
-
-#else
-
--- Standard Haskell
-
-#define LOCAL_ASSERT(x)
-
-#define INT Int
-#define IBOX(x) x
-#define MINUS -
-#define NEGATE negate
-#define PLUS +
-#define GR >
-#define GREQ >=
-#define LT <
-#define DIV `quot`
-#define ILIT(x) x
-
-#define SHOW Show
-#define MAXINT maxBound
-
-#endif
-
\end{code}
Displaying @Doc@ values.
\begin{code}
-instance SHOW Doc where
+instance Show Doc where
showsPrec prec doc cont = showDoc doc cont
render :: Doc -> String -- Uses default style
integer n = text (show n)
float n = text (show n)
double n = text (show n)
-rational n = text (show (fromRat n))
+rational n = text (show (fromRat n :: Double))
--rational n = text (show (fromRationalX n)) -- _showRational 30 n)
quotes p = char '`' <> p <> char '\''
brackets p = char '[' <> p <> char ']'
braces p = char '{' <> p <> char '}'
+cparen True = parens
+cparen False = id
hcat = foldr (<>) empty
hsep = foldr (<+>) empty
data Doc
= Empty -- empty
| NilAbove Doc -- text "" $$ x
- | TextBeside !TextDetails INT Doc -- text s <> x
- | Nest INT Doc -- nest k x
+ | TextBeside !TextDetails FastInt Doc -- text s <> x
+ | Nest FastInt Doc -- nest k x
| Union Doc Doc -- ul `union` ur
| NoDoc -- The empty set of documents
| Beside Doc Bool Doc -- True <=> space between
data TextDetails = Chr {-#UNPACK#-}!Char
| Str String
| PStr FastString -- a hashed string
- | LStr Addr# Int# -- a '\0'-terminated array of bytes
+ | LStr {-#UNPACK#-}!LitString FastInt -- a '\0'-terminated array of bytes
space_text = Chr ' '
nl_text = Chr '\n'
isEmpty Empty = True
isEmpty _ = False
-char c = textBeside_ (Chr c) 1# Empty
-text s = case length s of {IBOX(sl) -> textBeside_ (Str s) sl Empty}
-ftext s = case lengthFS s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty}
-ptext (Ptr s) = case strLength (Ptr s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
+char c = textBeside_ (Chr c) (_ILIT(1)) Empty
+text s = case iUnbox (length s) of {sl -> textBeside_ (Str s) sl Empty}
+ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty}
+ptext s_= case iUnbox (strLength s) of {sl -> textBeside_ (LStr s sl) sl Empty}
+ where s = {-castPtr-} s_
+#if defined(__GLASGOW_HASKELL__)
-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
-- intermediate packing/unpacking of the string.
{-# RULES
"text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
#-}
+#endif
-nest IBOX(k) p = mkNest k (reduceDoc p) -- Externally callable version
+nest k p = mkNest (iUnbox k) (reduceDoc p) -- Externally callable version
-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
-mkNest k (Nest k1 p) = mkNest (k PLUS k1) p
+mkNest k (Nest k1 p) = mkNest (k +# k1) p
mkNest k NoDoc = NoDoc
mkNest k Empty = Empty
-mkNest ILIT(0) p = p -- Worth a try!
+mkNest k p | k ==# _ILIT(0) = p -- Worth a try!
mkNest k p = nest_ k p
-- mkUnion checks for an empty document
above :: Doc -> Bool -> RDoc -> RDoc
above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
-above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g ILIT(0) (reduceDoc q)
-above p g q = aboveNest p g ILIT(0) (reduceDoc q)
+above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g (_ILIT(0)) (reduceDoc q)
+above p g q = aboveNest p g (_ILIT(0)) (reduceDoc q)
-aboveNest :: RDoc -> Bool -> INT -> RDoc -> RDoc
+aboveNest :: RDoc -> Bool -> FastInt -> RDoc -> RDoc
-- Specfication: aboveNest p g k q = p $g$ (nest k q)
aboveNest NoDoc g k q = NoDoc
aboveNest p2 g k q
aboveNest Empty g k q = mkNest k q
-aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k MINUS k1) 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
where
- k1 = k MINUS sl
+ k1 = k -# sl
rest = case p of
Empty -> nilAboveNest g k1 q
other -> aboveNest p g k1 q
\end{code}
\begin{code}
-nilAboveNest :: Bool -> INT -> RDoc -> RDoc
+nilAboveNest :: Bool -> FastInt -> RDoc -> RDoc
-- Specification: text s <> nilaboveNest g k q
-- = text s <> (text "" $g$ nest k q)
nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!
-nilAboveNest g k (Nest k1 q) = nilAboveNest g (k PLUS k1) q
+nilAboveNest g k (Nest k1 q) = nilAboveNest g (k +# k1) q
-nilAboveNest g k q | (not g) && (k GR ILIT(0)) -- No newline if no overlap
+nilAboveNest g k q | (not g) && (k ># _ILIT(0)) -- No newline if no overlap
= textBeside_ (Str (spaces k)) k q
| otherwise -- Put them really above
= nilAbove_ (mkNest k q)
nilBeside g Empty = Empty -- Hence the text "" in the spec
nilBeside g (Nest _ p) = nilBeside g p
-nilBeside g p | g = textBeside_ space_text ILIT(1) p
+nilBeside g p | g = textBeside_ space_text (_ILIT(1)) p
| otherwise = p
\end{code}
cat = sepX False -- Don't
sepX x [] = empty
-sepX x (p:ps) = sep1 x (reduceDoc p) ILIT(0) ps
+sepX x (p:ps) = sep1 x (reduceDoc p) (_ILIT(0)) ps
-- Specification: sep1 g k ys = sep (x : map (nest k) ys)
-- = oneLiner (x <g> nest k (hsep ys))
-- `union` x $$ nest k (vcat ys)
-sep1 :: Bool -> RDoc -> INT -> [Doc] -> RDoc
+sep1 :: Bool -> RDoc -> FastInt -> [Doc] -> RDoc
sep1 g NoDoc k ys = 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 MINUS n) ys)
+sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k -# n) ys)
sep1 g (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 MINUS sl) ys)
+sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k -# sl) ys)
-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
-- Called when we have already found some text in the first item
-- p1 $$ fill ps
fill g [] = empty
-fill g (p:ps) = fill1 g (reduceDoc p) ILIT(0) ps
+fill g (p:ps) = fill1 g (reduceDoc p) (_ILIT(0)) ps
-fill1 :: Bool -> RDoc -> INT -> [Doc] -> Doc
+fill1 :: Bool -> RDoc -> FastInt -> [Doc] -> Doc
fill1 g NoDoc k ys = 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 MINUS n) 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 MINUS sl) ys)
+fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k -# sl) ys)
fillNB g (Nest _ p) k ys = fillNB g p k ys
fillNB g Empty k [] = Empty
`mkUnion`
nilAboveNest False k (fill g (y:ys))
where
- k1 | g = k MINUS ILIT(1)
+ k1 | g = k -# _ILIT(1)
| otherwise = k
fillNB g p k ys = fill1 g p k ys
-> RDoc
-> RDoc -- No unions in here!
-best IBOX(w) IBOX(r) p
- = get w p
+best w_ r_ p
+ = get (iUnbox w_) p
where
- get :: INT -- (Remaining) width of line
+ r = iUnbox r_
+ get :: FastInt -- (Remaining) width of line
-> Doc -> Doc
get w Empty = Empty
get w 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 MINUS k) 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)
- get1 :: INT -- (Remaining) width of line
- -> INT -- Amount of first line already eaten up
+ get1 :: FastInt -- (Remaining) width of line
+ -> FastInt -- Amount of first line already eaten up
-> Doc -- This is an argument to TextBeside => eat Nests
-> Doc -- No unions in here!
get1 w sl Empty = Empty
get1 w sl NoDoc = NoDoc
- get1 w sl (NilAbove p) = nilAbove_ (get (w MINUS sl) p)
- get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl PLUS tl) 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 k p) = get1 w sl p
get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
(get1 w sl q)
-nicest w r p q = nicest1 w r ILIT(0) p q
-nicest1 w r sl p q | fits ((w `minn` r) MINUS sl) p = p
+nicest w r p q = nicest1 w r (_ILIT(0)) p q
+nicest1 w r sl p q | fits ((w `minFastInt` r) -# sl) p = p
| otherwise = q
-fits :: INT -- Space available
+fits :: FastInt -- Space available
-> Doc
-> Bool -- True if *first line* of Doc fits in space available
-fits n p | n LT ILIT(0) = False
+fits n p | n <# _ILIT(0) = False
fits n NoDoc = False
fits n Empty = True
fits n (NilAbove _) = True
-fits n (TextBeside _ sl p) = fits (n MINUS sl) p
-
-minn x y | x LT y = x
- | otherwise = y
+fits n (TextBeside _ sl p) = fits (n -# sl) p
\end{code}
@first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
string_txt (Str s1) s2 = s1 ++ s2
string_txt (PStr s1) s2 = unpackFS s1 ++ s2
string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
-
-unpackLitString addr =
- unpack 0#
- where
- unpack nh
- | ch `eqChar#` '\0'# = []
- | otherwise = C# ch : unpack (nh +# 1#)
- where
- ch = indexCharOffAddr# addr nh
\end{code}
\begin{code}
hacked_line_length, ribbon_length :: Int
ribbon_length = round (fromIntegral line_length / ribbons_per_line)
- hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length }
+ hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }
-display mode IBOX(page_width) IBOX(ribbon_width) txt end doc
- = case page_width MINUS ribbon_width of { gap_width ->
- case gap_width DIV ILIT(2) of { shift ->
+display mode page_width ribbon_width txt end doc
+ = case (iUnbox page_width) -# (iUnbox ribbon_width) of { gap_width ->
+ case gap_width `quotFastInt` _ILIT(2) of { shift ->
let
- lay k (Nest k1 p) = lay (k PLUS k1) p
+ lay k (Nest k1 p) = lay (k +# k1) p
lay k Empty = end
lay k (NilAbove p) = nl_text `txt` lay k p
lay k (TextBeside s sl p)
= case mode of
- ZigZagMode | k GREQ gap_width
+ ZigZagMode | k >=# gap_width
-> nl_text `txt` (
Str (multi_ch shift '/') `txt` (
nl_text `txt` (
- lay1 (k MINUS shift) s sl p)))
+ lay1 (k -# shift) s sl p)))
- | k LT ILIT(0)
+ | k <# _ILIT(0)
-> nl_text `txt` (
Str (multi_ch shift '\\') `txt` (
nl_text `txt` (
- lay1 (k PLUS shift) s sl p )))
+ lay1 (k +# shift) s sl p )))
other -> lay1 k s sl p
- lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k PLUS sl) p)
+ lay1 k s sl p = indent k (s `txt` lay2 (k +# sl) p)
lay2 k (NilAbove p) = nl_text `txt` lay k p
- lay2 k (TextBeside s sl p) = s `txt` (lay2 (k PLUS sl) p)
+ lay2 k (TextBeside s sl p) = s `txt` (lay2 (k +# sl) p)
lay2 k (Nest _ p) = lay2 k p
lay2 k Empty = end
+
+ -- optimise long indentations using LitString chunks of 8 spaces
+ indent n r | n >=# _ILIT(8) = LStr SLIT(" ") (_ILIT(8)) `txt`
+ indent (n -# _ILIT(8)) r
+ | otherwise = Str (spaces n) `txt` r
in
- lay ILIT(0) doc
+ lay (_ILIT(0)) doc
}}
cant_fail = error "easy_display: NoDoc"
-indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8))
- | otherwise = spaces n
+multi_ch n ch | n <=# _ILIT(0) = ""
+ | otherwise = ch : multi_ch (n -# _ILIT(1)) ch
-multi_ch ILIT(0) ch = ""
-multi_ch n ch = ch : multi_ch (n MINUS ILIT(1)) ch
+spaces n | n <=# _ILIT(0) = ""
+ | otherwise = ' ' : spaces (n -# _ILIT(1))
-spaces ILIT(0) = ""
-spaces n = ' ' : spaces (n MINUS ILIT(1))
\end{code}
\begin{code}
done = hPutChar hdl '\n'
-- some versions of hPutBuf will barf if the length is zero
-hPutLitString handle a# 0# = return ()
-hPutLitString handle a# l#
-#if __GLASGOW_HASKELL__ < 411
- = hPutBuf handle (A# a#) (I# l#)
-#else
- = hPutBuf handle (Ptr a#) (I# l#)
-#endif
+hPutLitString handle a l = if l ==# _ILIT(0)
+ then return ()
+ else hPutBuf handle a (iBox l)
-- Printing output in LeftMode is performance critical: it's used when
-- dumping C and assembly output, so we allow ourselves a few dirty
put b (Str s) = bPutStr b s
put b (PStr s) = bPutFS b s
put b (LStr s l) = bPutLitString b s l
-
-#if __GLASGOW_HASKELL__ < 503
-hPutBuf = hPutBufFull
-#endif
-
\end{code}