{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
module GHC.Utils.Ppr (
        
        Doc, TextDetails(..),
        
        
        char, text, ftext, ptext, ztext, sizedText, zeroWidthText, emptyText,
        int, integer, float, double, rational, hex,
        
        semi, comma, colon, space, equals,
        lparen, rparen, lbrack, rbrack, lbrace, rbrace,
        
        parens, brackets, braces, quotes, quote, doubleQuotes,
        maybeParens,
        
        empty,
        (<>), (<+>), hcat, hsep,
        ($$), ($+$), vcat,
        sep, cat,
        fsep, fcat,
        nest,
        hang, hangNotEmpty, punctuate,
        
        isEmpty,
        
        
        Style(..),
        style,
        renderStyle,
        Mode(..),
        
        fullRender, txtPrinter,
        
        printDoc, printDoc_,
        bufLeftRender 
  ) where
import GHC.Prelude hiding (error)
import GHC.Utils.BufHandle
import GHC.Data.FastString
import GHC.Utils.Panic.Plain
import System.IO
import Numeric (showHex)
import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) )
import GHC.Ptr  ( Ptr(..) )
infixl 6 <>
infixl 6 <+>
infixl 5 $$, $+$
data Doc
  = Empty                                            
  | NilAbove Doc                                     
  | TextBeside !TextDetails {-# UNPACK #-} !Int Doc  
  | Nest {-# UNPACK #-} !Int Doc                     
  | Union Doc Doc                                    
  | NoDoc                                            
  | Beside Doc Bool Doc                              
  | Above Doc Bool Doc                               
type RDoc = Doc
data TextDetails = Chr  {-# UNPACK #-} !Char 
                 | Str  String 
                 | PStr FastString                      
                 | ZStr FastZString                     
                 | LStr {-# UNPACK #-} !PtrString
                   
                 | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char
                   
instance Show Doc where
  showsPrec :: Int -> Doc -> ShowS
showsPrec Int
_ Doc
doc String
cont = Mode
-> Int
-> Float
-> (TextDetails -> ShowS)
-> String
-> Doc
-> String
forall a.
Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc -> a
fullRender (Style -> Mode
mode Style
style) (Style -> Int
lineLength Style
style)
                                    (Style -> Float
ribbonsPerLine Style
style)
                                    TextDetails -> ShowS
txtPrinter String
cont Doc
doc
char :: Char -> Doc
char :: Char -> Doc
char Char
c = TextDetails -> Int -> Doc -> Doc
textBeside_ (Char -> TextDetails
Chr Char
c) Int
1 Doc
Empty
text :: String -> Doc
text :: String -> Doc
text String
s = TextDetails -> Int -> Doc -> Doc
textBeside_ (String -> TextDetails
Str String
s) (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Doc
Empty
{-# NOINLINE [0] text #-}   
                            
                            
{-# RULES "text/str"
    forall a. text (unpackCString# a)  = ptext (mkPtrString# a)
  #-}
{-# RULES "text/unpackNBytes#"
    forall p n. text (unpackNBytes# p n) = ptext (PtrString (Ptr p) (I# n))
  #-}
{-# RULES "text/[]"
    text [] = emptyText
  #-}
ftext :: FastString -> Doc
ftext :: FastString -> Doc
ftext FastString
s = TextDetails -> Int -> Doc -> Doc
textBeside_ (FastString -> TextDetails
PStr FastString
s) (FastString -> Int
lengthFS FastString
s) Doc
Empty
ptext :: PtrString -> Doc
ptext :: PtrString -> Doc
ptext PtrString
s = TextDetails -> Int -> Doc -> Doc
textBeside_ (PtrString -> TextDetails
LStr PtrString
s) (PtrString -> Int
lengthPS PtrString
s) Doc
Empty
ztext :: FastZString -> Doc
ztext :: FastZString -> Doc
ztext FastZString
s = TextDetails -> Int -> Doc -> Doc
textBeside_ (FastZString -> TextDetails
ZStr FastZString
s) (FastZString -> Int
lengthFZS FastZString
s) Doc
Empty
sizedText :: Int -> String -> Doc
sizedText :: Int -> String -> Doc
sizedText Int
l String
s = TextDetails -> Int -> Doc -> Doc
textBeside_ (String -> TextDetails
Str String
s) Int
l Doc
Empty
zeroWidthText :: String -> Doc
zeroWidthText :: String -> Doc
zeroWidthText = Int -> String -> Doc
sizedText Int
0
emptyText :: Doc
emptyText :: Doc
emptyText = Int -> String -> Doc
sizedText Int
0 []
  
  
empty :: Doc
empty :: Doc
empty = Doc
Empty
isEmpty :: Doc -> Bool
isEmpty :: Doc -> Bool
isEmpty Doc
Empty = Bool
True
isEmpty Doc
_     = Bool
False
semi   :: Doc 
comma  :: Doc 
colon  :: Doc 
space  :: Doc 
equals :: Doc 
lparen :: Doc 
rparen :: Doc 
lbrack :: Doc 
rbrack :: Doc 
lbrace :: Doc 
rbrace :: Doc 
semi :: Doc
semi   = Char -> Doc
char Char
';'
comma :: Doc
comma  = Char -> Doc
char Char
','
colon :: Doc
colon  = Char -> Doc
char Char
':'
space :: Doc
space  = Char -> Doc
char Char
' '
equals :: Doc
equals = Char -> Doc
char Char
'='
lparen :: Doc
lparen = Char -> Doc
char Char
'('
rparen :: Doc
rparen = Char -> Doc
char Char
')'
lbrack :: Doc
lbrack = Char -> Doc
char Char
'['
rbrack :: Doc
rbrack = Char -> Doc
char Char
']'
lbrace :: Doc
lbrace = Char -> Doc
char Char
'{'
rbrace :: Doc
rbrace = Char -> Doc
char Char
'}'
spaceText, nlText :: TextDetails
spaceText :: TextDetails
spaceText = Char -> TextDetails
Chr Char
' '
nlText :: TextDetails
nlText    = Char -> TextDetails
Chr Char
'\n'
int      :: Int      -> Doc 
integer  :: Integer  -> Doc 
float    :: Float    -> Doc 
double   :: Double   -> Doc 
rational :: Rational -> Doc 
hex      :: Integer  -> Doc 
int :: Int -> Doc
int      Int
n = String -> Doc
text (Int -> String
forall a. Show a => a -> String
show Int
n)
integer :: Integer -> Doc
integer  Integer
n = String -> Doc
text (Integer -> String
forall a. Show a => a -> String
show Integer
n)
float :: Float -> Doc
float    Float
n = String -> Doc
text (Float -> String
forall a. Show a => a -> String
show Float
n)
double :: Double -> Doc
double   Double
n = String -> Doc
text (Double -> String
forall a. Show a => a -> String
show Double
n)
rational :: Rational -> Doc
rational Rational
n = String -> Doc
text (Rational -> String
forall a. Show a => a -> String
show Rational
n)
hex :: Integer -> Doc
hex      Integer
n = String -> Doc
text (Char
'0' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'x' Char -> ShowS
forall a. a -> [a] -> [a]
: String
padded)
    where
    str :: String
str = Integer -> ShowS
forall a. Integral a => a -> ShowS
showHex Integer
n String
""
    strLen :: Int
strLen = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str)
    len :: Int
len = Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
2 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
strLen :: Double)) :: Int)
    padded :: String
padded = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
strLen) Char
'0' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str
parens       :: Doc -> Doc 
brackets     :: Doc -> Doc 
braces       :: Doc -> Doc 
quotes       :: Doc -> Doc 
quote        :: Doc -> Doc
doubleQuotes :: Doc -> Doc 
quotes :: Doc -> Doc
quotes Doc
p       = Char -> Doc
char Char
'`' Doc -> Doc -> Doc
<> Doc
p Doc -> Doc -> Doc
<> Char -> Doc
char Char
'\''
quote :: Doc -> Doc
quote Doc
p        = Char -> Doc
char Char
'\'' Doc -> Doc -> Doc
<> Doc
p
doubleQuotes :: Doc -> Doc
doubleQuotes Doc
p = Char -> Doc
char Char
'"' Doc -> Doc -> Doc
<> Doc
p Doc -> Doc -> Doc
<> Char -> Doc
char Char
'"'
parens :: Doc -> Doc
parens Doc
p       = Char -> Doc
char Char
'(' Doc -> Doc -> Doc
<> Doc
p Doc -> Doc -> Doc
<> Char -> Doc
char Char
')'
brackets :: Doc -> Doc
brackets Doc
p     = Char -> Doc
char Char
'[' Doc -> Doc -> Doc
<> Doc
p Doc -> Doc -> Doc
<> Char -> Doc
char Char
']'
braces :: Doc -> Doc
braces Doc
p       = Char -> Doc
char Char
'{' Doc -> Doc -> Doc
<> Doc
p Doc -> Doc -> Doc
<> Char -> Doc
char Char
'}'
maybeParens :: Bool -> Doc -> Doc
maybeParens :: Bool -> Doc -> Doc
maybeParens Bool
False = Doc -> Doc
forall a. a -> a
id
maybeParens Bool
True = Doc -> Doc
parens
reduceDoc :: Doc -> RDoc
reduceDoc :: Doc -> Doc
reduceDoc (Beside Doc
p Bool
g Doc
q) = Doc
p Doc -> Doc -> Doc
forall a b. a -> b -> b
`seq` Bool
g Bool -> Doc -> Doc
forall a b. a -> b -> b
`seq` (Doc -> Bool -> Doc -> Doc
beside Doc
p Bool
g (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$! Doc -> Doc
reduceDoc Doc
q)
reduceDoc (Above  Doc
p Bool
g Doc
q) = Doc
p Doc -> Doc -> Doc
forall a b. a -> b -> b
`seq` Bool
g Bool -> Doc -> Doc
forall a b. a -> b -> b
`seq` (Doc -> Bool -> Doc -> Doc
above  Doc
p Bool
g (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$! Doc -> Doc
reduceDoc Doc
q)
reduceDoc Doc
p              = Doc
p
hcat :: [Doc] -> Doc
hcat :: [Doc] -> Doc
hcat = Doc -> Doc
reduceAB (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bool -> Doc -> Doc -> Doc
beside_' Bool
False) Doc
empty
hsep :: [Doc] -> Doc
hsep :: [Doc] -> Doc
hsep = Doc -> Doc
reduceAB (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bool -> Doc -> Doc -> Doc
beside_' Bool
True)  Doc
empty
vcat :: [Doc] -> Doc
vcat :: [Doc] -> Doc
vcat = Doc -> Doc
reduceAB (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bool -> Doc -> Doc -> Doc
above_' Bool
False) Doc
empty
nest :: Int -> Doc -> Doc
nest :: Int -> Doc -> Doc
nest Int
k Doc
p = Int -> Doc -> Doc
mkNest Int
k (Doc -> Doc
reduceDoc Doc
p)
hang :: Doc -> Int -> Doc -> Doc
hang :: Doc -> Int -> Doc -> Doc
hang Doc
d1 Int
n Doc
d2 = [Doc] -> Doc
sep [Doc
d1, Int -> Doc -> Doc
nest Int
n Doc
d2]
hangNotEmpty :: Doc -> Int -> Doc -> Doc
hangNotEmpty :: Doc -> Int -> Doc -> Doc
hangNotEmpty Doc
d1 Int
n Doc
d2 = if Doc -> Bool
isEmpty Doc
d1
                       then Doc
d2
                       else Doc -> Int -> Doc -> Doc
hang Doc
d1 Int
n Doc
d2
punctuate :: Doc -> [Doc] -> [Doc]
punctuate :: Doc -> [Doc] -> [Doc]
punctuate Doc
_ []     = []
punctuate Doc
p (Doc
x:[Doc]
xs) = Doc -> [Doc] -> [Doc]
go Doc
x [Doc]
xs
                   where go :: Doc -> [Doc] -> [Doc]
go Doc
y []     = [Doc
y]
                         go Doc
y (Doc
z:[Doc]
zs) = (Doc
y Doc -> Doc -> Doc
<> Doc
p) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Doc -> [Doc] -> [Doc]
go Doc
z [Doc]
zs
mkNest :: Int -> Doc -> Doc
mkNest :: Int -> Doc -> Doc
mkNest Int
k Doc
_ | Int
k Int -> Bool -> Bool
forall a b. a -> b -> b
`seq` Bool
False = Doc
forall a. HasCallStack => a
undefined
mkNest Int
k (Nest Int
k1 Doc
p)       = Int -> Doc -> Doc
mkNest (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k1) Doc
p
mkNest Int
_ Doc
NoDoc             = Doc
NoDoc
mkNest Int
_ Doc
Empty             = Doc
Empty
mkNest Int
0 Doc
p                 = Doc
p
mkNest Int
k Doc
p                 = Int -> Doc -> Doc
nest_ Int
k Doc
p
mkUnion :: Doc -> Doc -> Doc
mkUnion :: Doc -> Doc -> Doc
mkUnion Doc
Empty Doc
_ = Doc
Empty
mkUnion Doc
p Doc
q     = Doc
p Doc -> Doc -> Doc
`union_` Doc
q
beside_' :: Bool -> Doc -> Doc -> Doc
beside_' :: Bool -> Doc -> Doc -> Doc
beside_' Bool
_ Doc
p Doc
Empty = Doc
p
beside_' Bool
g Doc
p Doc
q     = Doc -> Bool -> Doc -> Doc
Beside Doc
p Bool
g Doc
q
above_' :: Bool -> Doc -> Doc -> Doc
above_' :: Bool -> Doc -> Doc -> Doc
above_' Bool
_ Doc
p Doc
Empty = Doc
p
above_' Bool
g Doc
p Doc
q     = Doc -> Bool -> Doc -> Doc
Above Doc
p Bool
g Doc
q
reduceAB :: Doc -> Doc
reduceAB :: Doc -> Doc
reduceAB (Above  Doc
Empty Bool
_ Doc
q) = Doc
q
reduceAB (Beside Doc
Empty Bool
_ Doc
q) = Doc
q
reduceAB Doc
doc                = Doc
doc
nilAbove_ :: RDoc -> RDoc
nilAbove_ :: Doc -> Doc
nilAbove_ = Doc -> Doc
NilAbove
textBeside_ :: TextDetails -> Int -> RDoc -> RDoc
textBeside_ :: TextDetails -> Int -> Doc -> Doc
textBeside_ = TextDetails -> Int -> Doc -> Doc
TextBeside
nest_ :: Int -> RDoc -> RDoc
nest_ :: Int -> Doc -> Doc
nest_ = Int -> Doc -> Doc
Nest
union_ :: RDoc -> RDoc -> RDoc
union_ :: Doc -> Doc -> Doc
union_ = Doc -> Doc -> Doc
Union
($$) :: Doc -> Doc -> Doc
Doc
p $$ :: Doc -> Doc -> Doc
$$  Doc
q = Doc -> Bool -> Doc -> Doc
above_ Doc
p Bool
False Doc
q
($+$) :: Doc -> Doc -> Doc
Doc
p $+$ :: Doc -> Doc -> Doc
$+$ Doc
q = Doc -> Bool -> Doc -> Doc
above_ Doc
p Bool
True Doc
q
above_ :: Doc -> Bool -> Doc -> Doc
above_ :: Doc -> Bool -> Doc -> Doc
above_ Doc
p Bool
_ Doc
Empty = Doc
p
above_ Doc
Empty Bool
_ Doc
q = Doc
q
above_ Doc
p Bool
g Doc
q     = Doc -> Bool -> Doc -> Doc
Above Doc
p Bool
g Doc
q
above :: Doc -> Bool -> RDoc -> RDoc
above :: Doc -> Bool -> Doc -> Doc
above (Above Doc
p Bool
g1 Doc
q1)  Bool
g2 Doc
q2 = Doc -> Bool -> Doc -> Doc
above Doc
p Bool
g1 (Doc -> Bool -> Doc -> Doc
above Doc
q1 Bool
g2 Doc
q2)
above p :: Doc
p@(Beside{})     Bool
g  Doc
q  = Doc -> Bool -> Int -> Doc -> Doc
aboveNest (Doc -> Doc
reduceDoc Doc
p) Bool
g Int
0 (Doc -> Doc
reduceDoc Doc
q)
above Doc
p Bool
g Doc
q                  = Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
p             Bool
g Int
0 (Doc -> Doc
reduceDoc Doc
q)
aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
aboveNest :: Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
_                   Bool
_ Int
k Doc
_ | Int
k Int -> Bool -> Bool
forall a b. a -> b -> b
`seq` Bool
False = Doc
forall a. HasCallStack => a
undefined
aboveNest Doc
NoDoc               Bool
_ Int
_ Doc
_ = Doc
NoDoc
aboveNest (Doc
p1 `Union` Doc
p2)     Bool
g Int
k Doc
q = Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
p1 Bool
g Int
k Doc
q Doc -> Doc -> Doc
`union_`
                                      Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
p2 Bool
g Int
k Doc
q
aboveNest Doc
Empty               Bool
_ Int
k Doc
q = Int -> Doc -> Doc
mkNest Int
k Doc
q
aboveNest (Nest Int
k1 Doc
p)         Bool
g Int
k Doc
q = Int -> Doc -> Doc
nest_ Int
k1 (Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
p Bool
g (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k1) Doc
q)
                                  
aboveNest (NilAbove Doc
p)        Bool
g Int
k Doc
q = Doc -> Doc
nilAbove_ (Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
p Bool
g Int
k Doc
q)
aboveNest (TextBeside TextDetails
s Int
sl Doc
p) Bool
g Int
k Doc
q = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
s Int
sl Doc
rest
                                    where
                                      !k1 :: Int
k1  = Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sl
                                      rest :: Doc
rest = case Doc
p of
                                                Doc
Empty -> Bool -> Int -> Doc -> Doc
nilAboveNest Bool
g Int
k1 Doc
q
                                                Doc
_     -> Doc -> Bool -> Int -> Doc -> Doc
aboveNest  Doc
p Bool
g Int
k1 Doc
q
aboveNest (Above {})          Bool
_ Int
_ Doc
_ = String -> Doc
forall a. String -> a
error String
"aboveNest Above"
aboveNest (Beside {})         Bool
_ Int
_ Doc
_ = String -> Doc
forall a. String -> a
error String
"aboveNest Beside"
nilAboveNest :: Bool -> Int -> RDoc -> RDoc
nilAboveNest :: Bool -> Int -> Doc -> Doc
nilAboveNest Bool
_ Int
k Doc
_           | Int
k Int -> Bool -> Bool
forall a b. a -> b -> b
`seq` Bool
False = Doc
forall a. HasCallStack => a
undefined
nilAboveNest Bool
_ Int
_ Doc
Empty       = Doc
Empty
                               
nilAboveNest Bool
g Int
k (Nest Int
k1 Doc
q) = Bool -> Int -> Doc -> Doc
nilAboveNest Bool
g (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k1) Doc
q
nilAboveNest Bool
g Int
k Doc
q           | Bool -> Bool
not Bool
g Bool -> Bool -> Bool
&& Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0      
                             = TextDetails -> Int -> Doc -> Doc
textBeside_ (Int -> Char -> TextDetails
RStr Int
k Char
' ') Int
k Doc
q
                             | Bool
otherwise           
                             = Doc -> Doc
nilAbove_ (Int -> Doc -> Doc
mkNest Int
k Doc
q)
(<>) :: Doc -> Doc -> Doc
Doc
p <> :: Doc -> Doc -> Doc
<>  Doc
q = Doc -> Bool -> Doc -> Doc
beside_ Doc
p Bool
False Doc
q
(<+>) :: Doc -> Doc -> Doc
Doc
p <+> :: Doc -> Doc -> Doc
<+> Doc
q = Doc -> Bool -> Doc -> Doc
beside_ Doc
p Bool
True  Doc
q
beside_ :: Doc -> Bool -> Doc -> Doc
beside_ :: Doc -> Bool -> Doc -> Doc
beside_ Doc
p Bool
_ Doc
Empty = Doc
p
beside_ Doc
Empty Bool
_ Doc
q = Doc
q
beside_ Doc
p Bool
g Doc
q     = Doc -> Bool -> Doc -> Doc
Beside Doc
p Bool
g Doc
q
beside :: Doc -> Bool -> RDoc -> RDoc
beside :: Doc -> Bool -> Doc -> Doc
beside Doc
NoDoc               Bool
_ Doc
_   = Doc
NoDoc
beside (Doc
p1 `Union` Doc
p2)     Bool
g Doc
q   = Doc -> Bool -> Doc -> Doc
beside Doc
p1 Bool
g Doc
q Doc -> Doc -> Doc
`union_` Doc -> Bool -> Doc -> Doc
beside Doc
p2 Bool
g Doc
q
beside Doc
Empty               Bool
_ Doc
q   = Doc
q
beside (Nest Int
k Doc
p)          Bool
g Doc
q   = Int -> Doc -> Doc
nest_ Int
k (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$! Doc -> Bool -> Doc -> Doc
beside Doc
p Bool
g Doc
q
beside p :: Doc
p@(Beside Doc
p1 Bool
g1 Doc
q1) Bool
g2 Doc
q2
         | Bool
g1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
g2              = Doc -> Bool -> Doc -> Doc
beside Doc
p1 Bool
g1 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$! Doc -> Bool -> Doc -> Doc
beside Doc
q1 Bool
g2 Doc
q2
         | Bool
otherwise             = Doc -> Bool -> Doc -> Doc
beside (Doc -> Doc
reduceDoc Doc
p) Bool
g2 Doc
q2
beside p :: Doc
p@(Above{})         Bool
g Doc
q   = let !d :: Doc
d = Doc -> Doc
reduceDoc Doc
p in Doc -> Bool -> Doc -> Doc
beside Doc
d Bool
g Doc
q
beside (NilAbove Doc
p)        Bool
g Doc
q   = Doc -> Doc
nilAbove_ (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$! Doc -> Bool -> Doc -> Doc
beside Doc
p Bool
g Doc
q
beside (TextBeside TextDetails
s Int
sl Doc
p) Bool
g Doc
q   = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
s Int
sl Doc
rest
                               where
                                  rest :: Doc
rest = case Doc
p of
                                           Doc
Empty -> Bool -> Doc -> Doc
nilBeside Bool
g Doc
q
                                           Doc
_     -> Doc -> Bool -> Doc -> Doc
beside Doc
p Bool
g Doc
q
nilBeside :: Bool -> RDoc -> RDoc
nilBeside :: Bool -> Doc -> Doc
nilBeside Bool
_ Doc
Empty         = Doc
Empty 
nilBeside Bool
g (Nest Int
_ Doc
p)    = Bool -> Doc -> Doc
nilBeside Bool
g Doc
p
nilBeside Bool
g Doc
p | Bool
g         = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
spaceText Int
1 Doc
p
              | Bool
otherwise = Doc
p
sep  :: [Doc] -> Doc
sep :: [Doc] -> Doc
sep = Bool -> [Doc] -> Doc
sepX Bool
True   
cat :: [Doc] -> Doc
cat :: [Doc] -> Doc
cat = Bool -> [Doc] -> Doc
sepX Bool
False  
sepX :: Bool -> [Doc] -> Doc
sepX :: Bool -> [Doc] -> Doc
sepX Bool
_ []     = Doc
empty
sepX Bool
x (Doc
p:[Doc]
ps) = Bool -> Doc -> Int -> [Doc] -> Doc
sep1 Bool
x (Doc -> Doc
reduceDoc Doc
p) Int
0 [Doc]
ps
sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
sep1 :: Bool -> Doc -> Int -> [Doc] -> Doc
sep1 Bool
_ Doc
_                   Int
k [Doc]
_  | Int
k Int -> Bool -> Bool
forall a b. a -> b -> b
`seq` Bool
False = Doc
forall a. HasCallStack => a
undefined
sep1 Bool
_ Doc
NoDoc               Int
_ [Doc]
_  = Doc
NoDoc
sep1 Bool
g (Doc
p `Union` Doc
q)       Int
k [Doc]
ys = Bool -> Doc -> Int -> [Doc] -> Doc
sep1 Bool
g Doc
p Int
k [Doc]
ys Doc -> Doc -> Doc
`union_`
                                  Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
q Bool
False Int
k (Doc -> Doc
reduceDoc ([Doc] -> Doc
vcat [Doc]
ys))
sep1 Bool
g Doc
Empty               Int
k [Doc]
ys = Int -> Doc -> Doc
mkNest Int
k (Bool -> [Doc] -> Doc
sepX Bool
g [Doc]
ys)
sep1 Bool
g (Nest Int
n Doc
p)          Int
k [Doc]
ys = Int -> Doc -> Doc
nest_ Int
n (Bool -> Doc -> Int -> [Doc] -> Doc
sep1 Bool
g Doc
p (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) [Doc]
ys)
sep1 Bool
_ (NilAbove Doc
p)        Int
k [Doc]
ys = Doc -> Doc
nilAbove_
                                  (Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
p Bool
False Int
k (Doc -> Doc
reduceDoc ([Doc] -> Doc
vcat [Doc]
ys)))
sep1 Bool
g (TextBeside TextDetails
s Int
sl Doc
p) Int
k [Doc]
ys = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
s Int
sl (Bool -> Doc -> Int -> [Doc] -> Doc
sepNB Bool
g Doc
p (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sl) [Doc]
ys)
sep1 Bool
_ (Above {})          Int
_ [Doc]
_  = String -> Doc
forall a. String -> a
error String
"sep1 Above"
sep1 Bool
_ (Beside {})         Int
_ [Doc]
_  = String -> Doc
forall a. String -> a
error String
"sep1 Beside"
sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc
sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc
sepNB Bool
g (Nest Int
_ Doc
p) Int
k [Doc]
ys
  = Bool -> Doc -> Int -> [Doc] -> Doc
sepNB Bool
g Doc
p Int
k [Doc]
ys 
sepNB Bool
g Doc
Empty Int
k [Doc]
ys
  = Doc -> Doc
oneLiner (Bool -> Doc -> Doc
nilBeside Bool
g (Doc -> Doc
reduceDoc Doc
rest)) Doc -> Doc -> Doc
`mkUnion`
    
    Bool -> Int -> Doc -> Doc
nilAboveNest Bool
False Int
k (Doc -> Doc
reduceDoc ([Doc] -> Doc
vcat [Doc]
ys))
  where
    rest :: Doc
rest | Bool
g         = [Doc] -> Doc
hsep [Doc]
ys
         | Bool
otherwise = [Doc] -> Doc
hcat [Doc]
ys
sepNB Bool
g Doc
p Int
k [Doc]
ys
  = Bool -> Doc -> Int -> [Doc] -> Doc
sep1 Bool
g Doc
p Int
k [Doc]
ys
fcat :: [Doc] -> Doc
fcat :: [Doc] -> Doc
fcat = Bool -> [Doc] -> Doc
fill Bool
False
fsep :: [Doc] -> Doc
fsep :: [Doc] -> Doc
fsep = Bool -> [Doc] -> Doc
fill Bool
True
fill :: Bool -> [Doc] -> RDoc
fill :: Bool -> [Doc] -> Doc
fill Bool
_ []     = Doc
empty
fill Bool
g (Doc
p:[Doc]
ps) = Bool -> Doc -> Int -> [Doc] -> Doc
fill1 Bool
g (Doc -> Doc
reduceDoc Doc
p) Int
0 [Doc]
ps
fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
fill1 :: Bool -> Doc -> Int -> [Doc] -> Doc
fill1 Bool
_ Doc
_                   Int
k [Doc]
_  | Int
k Int -> Bool -> Bool
forall a b. a -> b -> b
`seq` Bool
False = Doc
forall a. HasCallStack => a
undefined
fill1 Bool
_ Doc
NoDoc               Int
_ [Doc]
_  = Doc
NoDoc
fill1 Bool
g (Doc
p `Union` Doc
q)       Int
k [Doc]
ys = Bool -> Doc -> Int -> [Doc] -> Doc
fill1 Bool
g Doc
p Int
k [Doc]
ys Doc -> Doc -> Doc
`union_`
                                   Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
q Bool
False Int
k (Bool -> [Doc] -> Doc
fill Bool
g [Doc]
ys)
fill1 Bool
g Doc
Empty               Int
k [Doc]
ys = Int -> Doc -> Doc
mkNest Int
k (Bool -> [Doc] -> Doc
fill Bool
g [Doc]
ys)
fill1 Bool
g (Nest Int
n Doc
p)          Int
k [Doc]
ys = Int -> Doc -> Doc
nest_ Int
n (Bool -> Doc -> Int -> [Doc] -> Doc
fill1 Bool
g Doc
p (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) [Doc]
ys)
fill1 Bool
g (NilAbove Doc
p)        Int
k [Doc]
ys = Doc -> Doc
nilAbove_ (Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
p Bool
False Int
k (Bool -> [Doc] -> Doc
fill Bool
g [Doc]
ys))
fill1 Bool
g (TextBeside TextDetails
s Int
sl Doc
p) Int
k [Doc]
ys = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
s Int
sl (Bool -> Doc -> Int -> [Doc] -> Doc
fillNB Bool
g Doc
p (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sl) [Doc]
ys)
fill1 Bool
_ (Above {})          Int
_ [Doc]
_  = String -> Doc
forall a. String -> a
error String
"fill1 Above"
fill1 Bool
_ (Beside {})         Int
_ [Doc]
_  = String -> Doc
forall a. String -> a
error String
"fill1 Beside"
fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc
fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc
fillNB Bool
_ Doc
_           Int
k [Doc]
_  | Int
k Int -> Bool -> Bool
forall a b. a -> b -> b
`seq` Bool
False = Doc
forall a. HasCallStack => a
undefined
fillNB Bool
g (Nest Int
_ Doc
p)  Int
k [Doc]
ys   = Bool -> Doc -> Int -> [Doc] -> Doc
fillNB Bool
g Doc
p Int
k [Doc]
ys
                              
fillNB Bool
_ Doc
Empty Int
_ []         = Doc
Empty
fillNB Bool
g Doc
Empty Int
k (Doc
Empty:[Doc]
ys) = Bool -> Doc -> Int -> [Doc] -> Doc
fillNB Bool
g Doc
Empty Int
k [Doc]
ys
fillNB Bool
g Doc
Empty Int
k (Doc
y:[Doc]
ys)     = Bool -> Int -> Doc -> [Doc] -> Doc
fillNBE Bool
g Int
k Doc
y [Doc]
ys
fillNB Bool
g Doc
p Int
k [Doc]
ys             = Bool -> Doc -> Int -> [Doc] -> Doc
fill1 Bool
g Doc
p Int
k [Doc]
ys
fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc
fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc
fillNBE Bool
g Int
k Doc
y [Doc]
ys
  = Bool -> Doc -> Doc
nilBeside Bool
g (Bool -> Doc -> Int -> [Doc] -> Doc
fill1 Bool
g ((Doc -> Doc
elideNest (Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
oneLiner (Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
reduceDoc) Doc
y) Int
k' [Doc]
ys)
    
    Doc -> Doc -> Doc
`mkUnion` Bool -> Int -> Doc -> Doc
nilAboveNest Bool
False Int
k (Bool -> [Doc] -> Doc
fill Bool
g (Doc
yDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:[Doc]
ys))
  where k' :: Int
k' = if Bool
g then Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 else Int
k
elideNest :: Doc -> Doc
elideNest :: Doc -> Doc
elideNest (Nest Int
_ Doc
d) = Doc
d
elideNest Doc
d          = Doc
d
best :: Int   
     -> Int   
     -> RDoc
     -> RDoc  
best :: Int -> Int -> Doc -> Doc
best Int
w0 Int
r = Int -> Doc -> Doc
get Int
w0
  where
    get :: Int          
        -> Doc -> Doc
    get :: Int -> Doc -> Doc
get Int
w Doc
_ | Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Bool
False = Doc
forall a. HasCallStack => a
undefined
    get Int
_ Doc
Empty               = Doc
Empty
    get Int
_ Doc
NoDoc               = Doc
NoDoc
    get Int
w (NilAbove Doc
p)        = Doc -> Doc
nilAbove_ (Int -> Doc -> Doc
get Int
w Doc
p)
    get Int
w (TextBeside TextDetails
s Int
sl Doc
p) = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
s Int
sl (Int -> Int -> Doc -> Doc
get1 Int
w Int
sl Doc
p)
    get Int
w (Nest Int
k Doc
p)          = Int -> Doc -> Doc
nest_ Int
k (Int -> Doc -> Doc
get (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k) Doc
p)
    get Int
w (Doc
p `Union` Doc
q)       = Int -> Int -> Doc -> Doc -> Doc
nicest Int
w Int
r (Int -> Doc -> Doc
get Int
w Doc
p) (Int -> Doc -> Doc
get Int
w Doc
q)
    get Int
_ (Above {})          = String -> Doc
forall a. String -> a
error String
"best get Above"
    get Int
_ (Beside {})         = String -> Doc
forall a. String -> a
error String
"best get Beside"
    get1 :: Int         
         -> Int         
         -> Doc         
         -> Doc         
    get1 :: Int -> Int -> Doc -> Doc
get1 Int
w Int
_ Doc
_ | Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Bool
False  = Doc
forall a. HasCallStack => a
undefined
    get1 Int
_ Int
_  Doc
Empty               = Doc
Empty
    get1 Int
_ Int
_  Doc
NoDoc               = Doc
NoDoc
    get1 Int
w Int
sl (NilAbove Doc
p)        = Doc -> Doc
nilAbove_ (Int -> Doc -> Doc
get (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sl) Doc
p)
    get1 Int
w Int
sl (TextBeside TextDetails
t Int
tl Doc
p) = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
t Int
tl (Int -> Int -> Doc -> Doc
get1 Int
w (Int
sl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tl) Doc
p)
    get1 Int
w Int
sl (Nest Int
_ Doc
p)          = Int -> Int -> Doc -> Doc
get1 Int
w Int
sl Doc
p
    get1 Int
w Int
sl (Doc
p `Union` Doc
q)       = Int -> Int -> Int -> Doc -> Doc -> Doc
nicest1 Int
w Int
r Int
sl (Int -> Int -> Doc -> Doc
get1 Int
w Int
sl Doc
p)
                                                   (Int -> Int -> Doc -> Doc
get1 Int
w Int
sl Doc
q)
    get1 Int
_ Int
_  (Above {})          = String -> Doc
forall a. String -> a
error String
"best get1 Above"
    get1 Int
_ Int
_  (Beside {})         = String -> Doc
forall a. String -> a
error String
"best get1 Beside"
nicest :: Int -> Int -> Doc -> Doc -> Doc
nicest :: Int -> Int -> Doc -> Doc -> Doc
nicest !Int
w !Int
r = Int -> Int -> Int -> Doc -> Doc -> Doc
nicest1 Int
w Int
r Int
0
nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc
nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc
nicest1 !Int
w !Int
r !Int
sl Doc
p Doc
q | Int -> Doc -> Bool
fits ((Int
w Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
r) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sl) Doc
p = Doc
p
                      | Bool
otherwise                 = Doc
q
fits :: Int  
     -> Doc
     -> Bool 
fits :: Int -> Doc -> Bool
fits Int
n Doc
_ | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0           = Bool
False
fits Int
_ Doc
NoDoc               = Bool
False
fits Int
_ Doc
Empty               = Bool
True
fits Int
_ (NilAbove Doc
_)        = Bool
True
fits Int
n (TextBeside TextDetails
_ Int
sl Doc
p) = Int -> Doc -> Bool
fits (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sl) Doc
p
fits Int
_ (Above {})          = String -> Bool
forall a. String -> a
error String
"fits Above"
fits Int
_ (Beside {})         = String -> Bool
forall a. String -> a
error String
"fits Beside"
fits Int
_ (Union {})          = String -> Bool
forall a. String -> a
error String
"fits Union"
fits Int
_ (Nest {})           = String -> Bool
forall a. String -> a
error String
"fits Nest"
first :: Doc -> Doc -> Doc
first :: Doc -> Doc -> Doc
first Doc
p Doc
q | Doc -> Bool
nonEmptySet Doc
p = Doc
p 
          | Bool
otherwise     = Doc
q
nonEmptySet :: Doc -> Bool
nonEmptySet :: Doc -> Bool
nonEmptySet Doc
NoDoc              = Bool
False
nonEmptySet (Doc
_ `Union` Doc
_)      = Bool
True
nonEmptySet Doc
Empty              = Bool
True
nonEmptySet (NilAbove Doc
_)       = Bool
True
nonEmptySet (TextBeside TextDetails
_ Int
_ Doc
p) = Doc -> Bool
nonEmptySet Doc
p
nonEmptySet (Nest Int
_ Doc
p)         = Doc -> Bool
nonEmptySet Doc
p
nonEmptySet (Above {})         = String -> Bool
forall a. String -> a
error String
"nonEmptySet Above"
nonEmptySet (Beside {})        = String -> Bool
forall a. String -> a
error String
"nonEmptySet Beside"
oneLiner :: Doc -> Doc
oneLiner :: Doc -> Doc
oneLiner Doc
NoDoc               = Doc
NoDoc
oneLiner Doc
Empty               = Doc
Empty
oneLiner (NilAbove Doc
_)        = Doc
NoDoc
oneLiner (TextBeside TextDetails
s Int
sl Doc
p) = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
s Int
sl (Doc -> Doc
oneLiner Doc
p)
oneLiner (Nest Int
k Doc
p)          = Int -> Doc -> Doc
nest_ Int
k (Doc -> Doc
oneLiner Doc
p)
oneLiner (Doc
p `Union` Doc
_)       = Doc -> Doc
oneLiner Doc
p
oneLiner (Above {})          = String -> Doc
forall a. String -> a
error String
"oneLiner Above"
oneLiner (Beside {})         = String -> Doc
forall a. String -> a
error String
"oneLiner Beside"
data Style
  = Style { Style -> Mode
mode           :: Mode  
          , Style -> Int
lineLength     :: Int   
          , Style -> Float
ribbonsPerLine :: Float 
          }
style :: Style
style :: Style
style = Style { lineLength :: Int
lineLength = Int
100, ribbonsPerLine :: Float
ribbonsPerLine = Float
1.5, mode :: Mode
mode = Bool -> Mode
PageMode Bool
False }
data Mode = PageMode { Mode -> Bool
asciiSpace :: Bool }    
          | ZigZagMode   
          | LeftMode     
          | OneLineMode  
hasAsciiSpace :: Mode -> Bool
hasAsciiSpace :: Mode -> Bool
hasAsciiSpace Mode
mode =
  case Mode
mode of
    PageMode Bool
asciiSpace -> Bool
asciiSpace
    Mode
_ -> Bool
False
renderStyle :: Style -> Doc -> String
renderStyle :: Style -> Doc -> String
renderStyle Style
s = Mode
-> Int
-> Float
-> (TextDetails -> ShowS)
-> String
-> Doc
-> String
forall a.
Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc -> a
fullRender (Style -> Mode
mode Style
s) (Style -> Int
lineLength Style
s) (Style -> Float
ribbonsPerLine Style
s)
                TextDetails -> ShowS
txtPrinter String
""
txtPrinter :: TextDetails -> String -> String
txtPrinter :: TextDetails -> ShowS
txtPrinter (Chr Char
c)    String
s  = Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
s
txtPrinter (Str String
s1)   String
s2 = String
s1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s2
txtPrinter (PStr FastString
s1)  String
s2 = FastString -> String
unpackFS FastString
s1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s2
txtPrinter (ZStr FastZString
s1)  String
s2 = FastZString -> String
zString FastZString
s1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s2
txtPrinter (LStr PtrString
s1)  String
s2 = PtrString -> String
unpackPtrString PtrString
s1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s2
txtPrinter (RStr Int
n Char
c) String
s2 = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s2
fullRender :: Mode                     
           -> Int                      
           -> Float                    
           -> (TextDetails -> a -> a)  
           -> a                        
           -> Doc                      
           -> a                        
fullRender :: forall a.
Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc -> a
fullRender Mode
OneLineMode Int
_ Float
_ TextDetails -> a -> a
txt a
end Doc
doc
  = TextDetails
-> (Doc -> Doc -> Doc) -> (TextDetails -> a -> a) -> a -> Doc -> a
forall a.
TextDetails
-> (Doc -> Doc -> Doc) -> (TextDetails -> a -> a) -> a -> Doc -> a
easyDisplay TextDetails
spaceText (\Doc
_ Doc
y -> Doc
y) TextDetails -> a -> a
txt a
end (Doc -> Doc
reduceDoc Doc
doc)
fullRender Mode
LeftMode    Int
_ Float
_ TextDetails -> a -> a
txt a
end Doc
doc
  = TextDetails
-> (Doc -> Doc -> Doc) -> (TextDetails -> a -> a) -> a -> Doc -> a
forall a.
TextDetails
-> (Doc -> Doc -> Doc) -> (TextDetails -> a -> a) -> a -> Doc -> a
easyDisplay TextDetails
nlText Doc -> Doc -> Doc
first TextDetails -> a -> a
txt a
end (Doc -> Doc
reduceDoc Doc
doc)
fullRender Mode
m Int
lineLen Float
ribbons TextDetails -> a -> a
txt a
rest Doc
doc
  = Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a
forall a.
Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a
display Mode
m Int
lineLen Int
ribbonLen TextDetails -> a -> a
txt a
rest Doc
doc'
  where
    doc' :: Doc
doc' = Int -> Int -> Doc -> Doc
best Int
bestLineLen Int
ribbonLen (Doc -> Doc
reduceDoc Doc
doc)
    bestLineLen, ribbonLen :: Int
    ribbonLen :: Int
ribbonLen   = Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lineLen Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
ribbons)
    bestLineLen :: Int
bestLineLen = case Mode
m of
                      Mode
ZigZagMode -> Int
forall a. Bounded a => a
maxBound
                      Mode
_          -> Int
lineLen
easyDisplay :: TextDetails
             -> (Doc -> Doc -> Doc)
             -> (TextDetails -> a -> a)
             -> a
             -> Doc
             -> a
easyDisplay :: forall a.
TextDetails
-> (Doc -> Doc -> Doc) -> (TextDetails -> a -> a) -> a -> Doc -> a
easyDisplay TextDetails
nlSpaceText Doc -> Doc -> Doc
choose TextDetails -> a -> a
txt a
end
  = Doc -> a
lay
  where
    lay :: Doc -> a
lay Doc
NoDoc              = String -> a
forall a. String -> a
error String
"easyDisplay: NoDoc"
    lay (Union Doc
p Doc
q)        = Doc -> a
lay (Doc -> Doc -> Doc
choose Doc
p Doc
q)
    lay (Nest Int
_ Doc
p)         = Doc -> a
lay Doc
p
    lay Doc
Empty              = a
end
    lay (NilAbove Doc
p)       = TextDetails
nlSpaceText TextDetails -> a -> a
`txt` Doc -> a
lay Doc
p
    lay (TextBeside TextDetails
s Int
_ Doc
p) = TextDetails
s TextDetails -> a -> a
`txt` Doc -> a
lay Doc
p
    lay (Above {})         = String -> a
forall a. String -> a
error String
"easyDisplay Above"
    lay (Beside {})        = String -> a
forall a. String -> a
error String
"easyDisplay Beside"
display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a
display :: forall a.
Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a
display Mode
m !Int
page_width !Int
ribbon_width TextDetails -> a -> a
txt a
end Doc
doc
  = case Int
page_width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ribbon_width of { Int
gap_width ->
    case Int
gap_width Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
2 of { Int
shift ->
    let
        lay :: Int -> Doc -> a
lay Int
k Doc
_            | Int
k Int -> Bool -> Bool
forall a b. a -> b -> b
`seq` Bool
False = a
forall a. HasCallStack => a
undefined
        lay Int
k (Nest Int
k1 Doc
p)  = Int -> Doc -> a
lay (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k1) Doc
p
        lay Int
_ Doc
Empty        = a
end
        lay Int
k (NilAbove Doc
p) = TextDetails
nlText TextDetails -> a -> a
`txt` Int -> Doc -> a
lay Int
k Doc
p
        lay Int
k (TextBeside TextDetails
s Int
sl Doc
p)
            = case Mode
m of
                    Mode
ZigZagMode |  Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
gap_width
                               -> TextDetails
nlText TextDetails -> a -> a
`txt` (
                                  String -> TextDetails
Str (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
shift Char
'/') TextDetails -> a -> a
`txt` (
                                  TextDetails
nlText TextDetails -> a -> a
`txt`
                                  Int -> TextDetails -> Int -> Doc -> a
lay1 (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
shift) TextDetails
s Int
sl Doc
p ))
                               |  Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
                               -> TextDetails
nlText TextDetails -> a -> a
`txt` (
                                  String -> TextDetails
Str (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
shift Char
'\\') TextDetails -> a -> a
`txt` (
                                  TextDetails
nlText TextDetails -> a -> a
`txt`
                                  Int -> TextDetails -> Int -> Doc -> a
lay1 (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
shift) TextDetails
s Int
sl Doc
p ))
                    Mode
_ -> Int -> TextDetails -> Int -> Doc -> a
lay1 Int
k TextDetails
s Int
sl Doc
p
        lay Int
_ (Above {})   = String -> a
forall a. String -> a
error String
"display lay Above"
        lay Int
_ (Beside {})  = String -> a
forall a. String -> a
error String
"display lay Beside"
        lay Int
_ Doc
NoDoc        = String -> a
forall a. String -> a
error String
"display lay NoDoc"
        lay Int
_ (Union {})   = String -> a
forall a. String -> a
error String
"display lay Union"
        lay1 :: Int -> TextDetails -> Int -> Doc -> a
lay1 !Int
k TextDetails
s !Int
sl Doc
p    = let !r :: Int
r = Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sl
                             in Int -> a -> a
indent Int
k (TextDetails
s TextDetails -> a -> a
`txt` Int -> Doc -> a
lay2 Int
r Doc
p)
        lay2 :: Int -> Doc -> a
lay2 Int
k Doc
_ | Int
k Int -> Bool -> Bool
forall a b. a -> b -> b
`seq` Bool
False   = a
forall a. HasCallStack => a
undefined
        lay2 Int
k (NilAbove Doc
p)        = TextDetails
nlText TextDetails -> a -> a
`txt` Int -> Doc -> a
lay Int
k Doc
p
        lay2 Int
k (TextBeside TextDetails
s Int
sl Doc
p) = TextDetails
s TextDetails -> a -> a
`txt` Int -> Doc -> a
lay2 (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sl) Doc
p
        lay2 Int
k (Nest Int
_ Doc
p)          = Int -> Doc -> a
lay2 Int
k Doc
p
        lay2 Int
_ Doc
Empty               = a
end
        lay2 Int
_ (Above {})          = String -> a
forall a. String -> a
error String
"display lay2 Above"
        lay2 Int
_ (Beside {})         = String -> a
forall a. String -> a
error String
"display lay2 Beside"
        lay2 Int
_ Doc
NoDoc               = String -> a
forall a. String -> a
error String
"display lay2 NoDoc"
        lay2 Int
_ (Union {})          = String -> a
forall a. String -> a
error String
"display lay2 Union"
        indent :: Int -> a -> a
indent !Int
n a
r                = Int -> Char -> TextDetails
RStr Int
n Char
' ' TextDetails -> a -> a
`txt` a
r
    in
    Int -> Doc -> a
lay Int
0 Doc
doc
    }}
printDoc :: Mode -> Int -> Handle -> Doc -> IO ()
printDoc :: Mode -> Int -> Handle -> Doc -> IO ()
printDoc Mode
mode Int
cols Handle
hdl Doc
doc = Mode -> Int -> Handle -> Doc -> IO ()
printDoc_ Mode
mode Int
cols Handle
hdl (Doc
doc Doc -> Doc -> Doc
$$ String -> Doc
text String
"")
printDoc_ :: Mode -> Int -> Handle -> Doc -> IO ()
printDoc_ :: Mode -> Int -> Handle -> Doc -> IO ()
printDoc_ Mode
LeftMode Int
_ Handle
hdl Doc
doc
  = do { Handle -> Doc -> IO ()
printLeftRender Handle
hdl Doc
doc; Handle -> IO ()
hFlush Handle
hdl }
printDoc_ Mode
mode Int
pprCols Handle
hdl Doc
doc
  = do { Mode
-> Int
-> Float
-> (TextDetails -> IO () -> IO ())
-> IO ()
-> Doc
-> IO ()
forall a.
Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc -> a
fullRender Mode
mode Int
pprCols Float
1.5 TextDetails -> IO () -> IO ()
put IO ()
done Doc
doc ;
         Handle -> IO ()
hFlush Handle
hdl }
  where
    put :: TextDetails -> IO () -> IO ()
put (Chr Char
c)    IO ()
next = Handle -> Char -> IO ()
hPutChar Handle
hdl Char
c IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
next
    put (Str String
s)    IO ()
next = Handle -> String -> IO ()
hPutStr  Handle
hdl String
s IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
next
    put (PStr FastString
s)   IO ()
next = Handle -> String -> IO ()
hPutStr  Handle
hdl (FastString -> String
unpackFS FastString
s) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
next
                          
                          
    put (ZStr FastZString
s)   IO ()
next = Handle -> FastZString -> IO ()
hPutFZS  Handle
hdl FastZString
s IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
next
    put (LStr PtrString
s)   IO ()
next = Handle -> PtrString -> IO ()
hPutPtrString Handle
hdl PtrString
s IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
next
    put (RStr Int
n Char
c) IO ()
next
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
      = Int -> IO ()
putSpaces Int
n IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
next
      | Bool
otherwise
      = Handle -> String -> IO ()
hPutStr Handle
hdl (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
c) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
next
    putSpaces :: Int -> IO ()
putSpaces Int
n
      
      
      | Mode -> Bool
hasAsciiSpace Mode
mode
      , Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
100
      = Handle -> Ptr Any -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
hdl (Addr# -> Ptr Any
forall a. Addr# -> Ptr a
Ptr Addr#
spaces') Int
n
      | Mode -> Bool
hasAsciiSpace Mode
mode
      , Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
100
      = Handle -> Ptr Any -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
hdl (Addr# -> Ptr Any
forall a. Addr# -> Ptr a
Ptr Addr#
spaces') Int
100 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
putSpaces (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
100)
      | Bool
otherwise = Handle -> String -> IO ()
hPutStr Handle
hdl (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ')
    done :: IO ()
done = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () 
    
    spaces' :: Addr#
spaces' = Addr#
"                                                                                                    "#
  
hPutPtrString :: Handle -> PtrString -> IO ()
hPutPtrString :: Handle -> PtrString -> IO ()
hPutPtrString Handle
_handle (PtrString Ptr Word8
_ Int
0) = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
hPutPtrString Handle
handle  (PtrString Ptr Word8
a Int
l) = Handle -> Ptr Word8 -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
handle Ptr Word8
a Int
l
printLeftRender :: Handle -> Doc -> IO ()
printLeftRender :: Handle -> Doc -> IO ()
printLeftRender Handle
hdl Doc
doc = do
  BufHandle
b <- Handle -> IO BufHandle
newBufHandle Handle
hdl
  BufHandle -> Doc -> IO ()
bufLeftRender BufHandle
b Doc
doc
  BufHandle -> IO ()
bFlush BufHandle
b
bufLeftRender :: BufHandle -> Doc -> IO ()
bufLeftRender :: BufHandle -> Doc -> IO ()
bufLeftRender BufHandle
b Doc
doc = BufHandle -> Doc -> IO ()
layLeft BufHandle
b (Doc -> Doc
reduceDoc Doc
doc)
layLeft :: BufHandle -> Doc -> IO ()
layLeft :: BufHandle -> Doc -> IO ()
layLeft BufHandle
b Doc
_ | BufHandle
b BufHandle -> Bool -> Bool
forall a b. a -> b -> b
`seq` Bool
False  = IO ()
forall a. HasCallStack => a
undefined 
layLeft BufHandle
_ Doc
NoDoc              = String -> IO ()
forall a. String -> a
error String
"layLeft: NoDoc"
layLeft BufHandle
b (Union Doc
p Doc
q)        = BufHandle -> Doc -> IO ()
layLeft BufHandle
b (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$! Doc -> Doc -> Doc
first Doc
p Doc
q
layLeft BufHandle
b (Nest Int
_ Doc
p)         = BufHandle -> Doc -> IO ()
layLeft BufHandle
b (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$! Doc
p
layLeft BufHandle
b Doc
Empty              = BufHandle -> Char -> IO ()
bPutChar BufHandle
b Char
'\n'
layLeft BufHandle
b (NilAbove Doc
p)       = Doc
p Doc -> IO () -> IO ()
forall a b. a -> b -> b
`seq` (BufHandle -> Char -> IO ()
bPutChar BufHandle
b Char
'\n' IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BufHandle -> Doc -> IO ()
layLeft BufHandle
b Doc
p)
layLeft BufHandle
b (TextBeside TextDetails
s Int
_ Doc
p) = TextDetails
s TextDetails -> IO () -> IO ()
forall a b. a -> b -> b
`seq` (BufHandle -> TextDetails -> IO ()
put BufHandle
b TextDetails
s IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BufHandle -> Doc -> IO ()
layLeft BufHandle
b Doc
p)
 where
    put :: BufHandle -> TextDetails -> IO ()
put BufHandle
b TextDetails
_ | BufHandle
b BufHandle -> Bool -> Bool
forall a b. a -> b -> b
`seq` Bool
False = IO ()
forall a. HasCallStack => a
undefined
    put BufHandle
b (Chr Char
c)    = BufHandle -> Char -> IO ()
bPutChar BufHandle
b Char
c
    put BufHandle
b (Str String
s)    = BufHandle -> String -> IO ()
bPutStr  BufHandle
b String
s
    put BufHandle
b (PStr FastString
s)   = BufHandle -> FastString -> IO ()
bPutFS   BufHandle
b FastString
s
    put BufHandle
b (ZStr FastZString
s)   = BufHandle -> FastZString -> IO ()
bPutFZS  BufHandle
b FastZString
s
    put BufHandle
b (LStr PtrString
s)   = BufHandle -> PtrString -> IO ()
bPutPtrString BufHandle
b PtrString
s
    put BufHandle
b (RStr Int
n Char
c) = BufHandle -> Int -> Char -> IO ()
bPutReplicate BufHandle
b Int
n Char
c
layLeft BufHandle
_ Doc
_                  = String -> IO ()
forall a. String -> a
panic String
"layLeft: Unhandled case"
error :: String -> a
error :: forall a. String -> a
error = String -> a
forall a. String -> a
panic