\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(..),
import BufWrite
import FastString
import FastTypes
+import Panic
import Numeric (fromRat)
import System.IO
#if defined(__GLASGOW_HASKELL__)
--for a RULES
import GHC.Base ( unpackCString# )
+import GHC.Exts ( Int# )
import GHC.Ptr ( Ptr(..) )
#endif
\begin{code}
instance Show Doc where
- showsPrec prec doc cont = showDoc doc cont
+ showsPrec _ doc cont = showDoc doc cont
render :: Doc -> String -- Uses default style
fullRender :: Mode
brackets p = char '[' <> p <> char ']'
braces p = char '{' <> p <> char '}'
+cparen :: Bool -> Doc -> Doc
cparen True = parens
cparen False = id
hang d1 n d2 = sep [d1, nest n d2]
-punctuate p [] = []
+punctuate _ [] = []
punctuate p (d:ds) = go d ds
where
go d [] = [d]
| LStr {-#UNPACK#-}!LitString FastInt -- a '\0'-terminated
-- array of bytes
+space_text :: TextDetails
space_text = Chr ' '
+nl_text :: TextDetails
nl_text = Chr '\n'
\end{code}
\end{itemize}
\begin{code}
- -- Arg of a NilAbove is always an RDoc
-nilAbove_ p = LOCAL_ASSERT( ok p ) NilAbove p
+-- Arg of a NilAbove is always an RDoc
+nilAbove_ :: Doc -> Doc
+nilAbove_ p = LOCAL_ASSERT( _ok p ) NilAbove p
where
- ok Empty = False
- ok other = True
+ _ok Empty = False
+ _ok _ = True
- -- Arg of a TextBeside is always an RDoc
-textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( ok p ) p)
+-- Arg of a TextBeside is always an RDoc
+textBeside_ :: TextDetails -> FastInt -> Doc -> Doc
+textBeside_ s sl p = TextBeside s sl (LOCAL_ASSERT( _ok p ) p)
where
- ok (Nest _ _) = False
- ok other = True
+ _ok (Nest _ _) = False
+ _ok _ = True
- -- Arg of Nest is always an RDoc
-nest_ k p = Nest k (LOCAL_ASSERT( ok p ) p)
+-- Arg of Nest is always an RDoc
+nest_ :: FastInt -> Doc -> Doc
+nest_ k p = Nest k (LOCAL_ASSERT( _ok p ) p)
where
- ok Empty = False
- ok other = True
+ _ok Empty = False
+ _ok _ = True
- -- Args of union are always RDocs
-union_ p q = Union (LOCAL_ASSERT( ok p ) p) (LOCAL_ASSERT( ok q ) q)
+-- Args of union are always RDocs
+union_ :: Doc -> Doc -> Doc
+union_ p q = Union (LOCAL_ASSERT( _ok p ) p) (LOCAL_ASSERT( _ok q ) q)
where
- ok (TextBeside _ _ _) = True
- ok (NilAbove _) = True
- ok (Union _ _) = True
- ok other = False
+ _ok (TextBeside _ _ _) = True
+ _ok (NilAbove _) = True
+ _ok (Union _ _) = True
+ _ok _ = False
\end{code}
char c = textBeside_ (Chr c) (_ILIT(1)) Empty
text s = case iUnbox (length s) of {sl -> textBeside_ (Str s) sl Empty}
+ftext :: FastString -> Doc
ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty}
+ptext :: LitString -> Doc
ptext s_= case iUnbox (strLength s) of {sl -> textBeside_ (LStr s sl) sl Empty}
where s = {-castPtr-} s_
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 :: Int# -> Doc -> Doc
mkNest k (Nest k1 p) = mkNest (k +# k1) p
-mkNest k NoDoc = NoDoc
-mkNest k Empty = Empty
+mkNest _ NoDoc = NoDoc
+mkNest _ Empty = Empty
mkNest k p | k ==# _ILIT(0) = p -- Worth a try!
mkNest k p = nest_ k p
-- mkUnion checks for an empty document
-mkUnion Empty q = Empty
+mkUnion :: Doc -> Doc -> Doc
+mkUnion Empty _ = Empty
mkUnion p q = p `union_` q
\end{code}
\begin{code}
p $$ q = Above p False q
+($+$) :: Doc -> Doc -> Doc
p $+$ q = Above p True q
above :: Doc -> Bool -> 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 NoDoc _ _ _ = NoDoc
aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
aboveNest p2 g k q
-aboveNest Empty g k q = mkNest k 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
k1 = k -# sl
rest = case p of
Empty -> nilAboveNest g k1 q
- other -> aboveNest p g k1 q
+ _ -> aboveNest p g k1 q
+aboveNest _ _ _ _ = panic "aboveNest: Unhandled case"
\end{code}
\begin{code}
-- 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 _ _ 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 ># _ILIT(0)) -- No newline if no overlap
beside :: Doc -> Bool -> RDoc -> RDoc
-- Specification: beside g p q = p <g> q
-beside NoDoc g q = NoDoc
+beside NoDoc _ _ = NoDoc
beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)
-beside Empty g q = q
+beside Empty _ q = q
beside (Nest k p) g q = nest_ k $! beside p g q -- p non-empty
beside p@(Beside p1 g1 q1) g2 q2
{- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2
where
rest = case p of
Empty -> nilBeside g q
- other -> beside p g q
+ _ -> beside p g q
\end{code}
\begin{code}
-- Specification: text "" <> nilBeside g p
-- = text "" <g> p
-nilBeside g Empty = Empty -- Hence the text "" in the spec
+nilBeside _ 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
| otherwise = p
sep = sepX True -- Separate with spaces
cat = sepX False -- Don't
-sepX x [] = empty
+sepX :: Bool -> [Doc] -> Doc
+sepX _ [] = empty
sepX x (p:ps) = sep1 x (reduceDoc p) (_ILIT(0)) ps
-- `union` x $$ nest k (vcat ys)
sep1 :: Bool -> RDoc -> FastInt -> [Doc] -> RDoc
-sep1 g NoDoc k ys = NoDoc
+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 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat 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 _ _ _ _ = panic "sep1: Unhandled case"
-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
-- Called when we have already found some text in the first item
-- We have to eat up nests
+sepNB :: Bool -> Doc -> FastInt -> [Doc] -> Doc
sepNB g (Nest _ p) k ys = sepNB g p k ys
sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
-- `union`
-- p1 $$ fill ps
-fill g [] = empty
+fill :: Bool -> [Doc] -> Doc
+fill _ [] = empty
fill g (p:ps) = fill1 g (reduceDoc p) (_ILIT(0)) ps
fill1 :: Bool -> RDoc -> FastInt -> [Doc] -> Doc
-fill1 g NoDoc k ys = NoDoc
+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 (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 _ _ _ _ = panic "fill1: Unhandled case"
+fillNB :: Bool -> Doc -> Int# -> [Doc] -> Doc
fillNB g (Nest _ p) k ys = fillNB g p k ys
-fillNB g Empty k [] = Empty
+fillNB _ Empty _ [] = Empty
fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
`mkUnion`
nilAboveNest False k (fill g (y:ys))
r = iUnbox r_
get :: FastInt -- (Remaining) width of line
-> Doc -> Doc
- get w Empty = Empty
- get w NoDoc = NoDoc
+ 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 _ _ = panic "best/get: Unhandled case"
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 _ _ 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 k p) = get1 w sl 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 _ _ _ = panic "best/get1: Unhandled case"
+nicest :: FastInt -> FastInt -> Doc -> Doc -> Doc
nicest w r p q = nicest1 w r (_ILIT(0)) p q
+nicest1 :: FastInt -> FastInt -> Int# -> Doc -> Doc -> Doc
nicest1 w r sl p q | fits ((w `minFastInt` r) -# sl) p = p
| otherwise = q
-> Doc
-> Bool -- True if *first line* of Doc fits in space available
-fits n p | n <# _ILIT(0) = False
-fits n NoDoc = False
-fits n Empty = True
-fits n (NilAbove _) = True
+fits n _ | n <# _ILIT(0) = False
+fits _ NoDoc = False
+fits _ Empty = True
+fits _ (NilAbove _) = True
fits n (TextBeside _ sl p) = fits (n -# sl) p
+fits _ _ = panic "fits: Unhandled case"
\end{code}
@first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
@first@ returns its first argument if it is non-empty, otherwise its second.
\begin{code}
+first :: Doc -> Doc -> Doc
first p q | nonEmptySet p = p
| otherwise = q
+nonEmptySet :: Doc -> Bool
nonEmptySet NoDoc = False
-nonEmptySet (p `Union` q) = True
+nonEmptySet (_ `Union` _) = True
nonEmptySet Empty = True
-nonEmptySet (NilAbove p) = True -- NoDoc always in first line
+nonEmptySet (NilAbove _) = True -- NoDoc always in first line
nonEmptySet (TextBeside _ _ p) = nonEmptySet p
nonEmptySet (Nest _ p) = nonEmptySet p
+nonEmptySet _ = panic "nonEmptySet: Unhandled case"
\end{code}
@oneLiner@ returns the one-line members of the given set of @Doc@s.
oneLiner :: Doc -> Doc
oneLiner NoDoc = NoDoc
oneLiner Empty = Empty
-oneLiner (NilAbove p) = NoDoc
+oneLiner (NilAbove _) = NoDoc
oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
oneLiner (Nest k p) = nest_ k (oneLiner p)
-oneLiner (p `Union` q) = oneLiner p
+oneLiner (p `Union` _) = oneLiner p
+oneLiner _ = panic "oneLiner: Unhandled case"
\end{code}
-}
render doc = showDocWith PageMode doc
+
+showDoc :: Doc -> String -> String
showDoc doc rest = showDocWithAppend PageMode doc rest
showDocWithAppend :: Mode -> Doc -> String -> String
showDocWith :: Mode -> Doc -> String
showDocWith mode doc = showDocWithAppend mode doc ""
+string_txt :: TextDetails -> String -> String
string_txt (Chr c) s = c:s
string_txt (Str s1) s2 = s1 ++ s2
string_txt (PStr s1) s2 = unpackFS s1 ++ s2
fullRender OneLineMode _ _ txt end doc
= lay (reduceDoc doc)
where
- lay NoDoc = cant_fail
- lay (Union p q) = (lay q) -- Second arg can't be NoDoc
- lay (Nest k p) = lay p
- lay Empty = end
- lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on
- -- first line
- lay (TextBeside s sl p) = s `txt` lay p
+ lay NoDoc = cant_fail
+ lay (Union _ q) = lay q -- Second arg can't be NoDoc
+ lay (Nest _ p) = lay p
+ lay Empty = end
+ lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on
+ -- first line
+ lay (TextBeside s _ p) = s `txt` lay p
+ lay _ = panic "fullRender/OneLineMode/lay: Unhandled case"
fullRender LeftMode _ _ txt end doc
= lay (reduceDoc doc)
where
- lay NoDoc = cant_fail
- lay (Union p q) = lay (first p q)
- lay (Nest k p) = lay p
- lay Empty = end
- lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line
- lay (TextBeside s sl p) = s `txt` lay p
+ lay NoDoc = cant_fail
+ lay (Union p q) = lay (first p q)
+ lay (Nest _ p) = lay p
+ lay Empty = end
+ lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line
+ lay (TextBeside s _ p) = s `txt` lay p
+ lay _ = panic "fullRender/LeftMode/lay: Unhandled case"
fullRender mode line_length ribbons_per_line txt end doc
= display mode line_length ribbon_length txt end best_doc
hacked_line_length, ribbon_length :: Int
ribbon_length = round (fromIntegral line_length / ribbons_per_line)
- hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }
+ hacked_line_length = case mode of
+ ZigZagMode -> maxBound
+ _ -> line_length
+display :: Mode -> Int -> Int -> (TextDetails -> t -> t) -> t -> Doc -> t
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 +# k1) p
- lay k Empty = end
+ lay _ Empty = end
lay k (NilAbove p) = nl_text `txt` lay k p
nl_text `txt` (
lay1 (k +# shift) s sl p )))
- other -> lay1 k s sl p
+ _ -> lay1 k s sl p
+ lay _ _ = panic "display/lay: Unhandled case"
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 +# sl) p)
lay2 k (Nest _ p) = lay2 k p
- lay2 k Empty = end
+ lay2 _ Empty = end
+ lay2 _ _ = panic "display/lay2: Unhandled case"
-- optimise long indentations using LitString chunks of 8 spaces
indent n r | n >=# _ILIT(8) = LStr SLIT(" ") (_ILIT(8)) `txt`
lay (_ILIT(0)) doc
}}
+cant_fail :: a
cant_fail = error "easy_display: NoDoc"
+multi_ch :: Int# -> Char -> String
multi_ch n ch | n <=# _ILIT(0) = ""
| otherwise = ch : multi_ch (n -# _ILIT(1)) ch
+spaces :: Int# -> String
spaces n | n <=# _ILIT(0) = ""
| otherwise = ' ' : spaces (n -# _ILIT(1))
\end{code}
\begin{code}
-pprCols = (120 :: Int) -- could make configurable
+pprCols :: Int
+pprCols = 120 -- could make configurable
printDoc :: Mode -> Handle -> Doc -> IO ()
printDoc LeftMode hdl doc
done = hPutChar hdl '\n'
-- some versions of hPutBuf will barf if the length is zero
+hPutLitString :: Handle -> Ptr a -> Int# -> IO ()
hPutLitString handle a l = if l ==# _ILIT(0)
then return ()
else hPutBuf handle a (iBox l)
-- HACK ALERT! the "return () >>" below convinces GHC to eta-expand
-- this function with the IO state lambda. Otherwise we end up with
-- closures in all the case branches.
-layLeft b _ | b `seq` False = undefined -- make it strict in b
-layLeft b NoDoc = cant_fail
-layLeft b (Union p q) = return () >> layLeft b (first p q)
-layLeft b (Nest k p) = return () >> layLeft b p
-layLeft b Empty = bPutChar b '\n'
-layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p
-layLeft b (TextBeside s sl p) = put b s >> layLeft b p
+layLeft :: BufHandle -> Doc -> IO ()
+layLeft b _ | b `seq` False = undefined -- make it strict in b
+layLeft _ NoDoc = cant_fail
+layLeft b (Union p q) = return () >> layLeft b (first p q)
+layLeft b (Nest _ p) = return () >> layLeft b p
+layLeft b Empty = bPutChar b '\n'
+layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p
+layLeft b (TextBeside s _ p) = 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 (LStr s l) = bPutLitString b s l
+layLeft _ _ = panic "layLeft: Unhandled case"
\end{code}
projects / ghc-hetmet.git / commitdiff