Pretty printing (was: Standard Library for text formatting?)

[Zdenek Dvorak]

Hello,

> > After doing some searching, it seems that "pretty printing" is
> > a prominant "Haskell way" of doing text output.  I still am
> > interested in finding a library of standard text formatting
> > (String formatting) functions, but it seems like it might
> > be worth my while investigating pretty printing.
>
>Pretty printing is not very suited for printf like formatting,

I have looked for something simmilar some time ago, but unsuccesfully. 
Pretty printing libraries are not very useful for breaking paragraphs into 
lines, distributing spaces evenly, etc. (at least I was not able to persuade 
them to work like that). I have written following module that implements 
stupid first-fit algorithm for these purposes; the interface is simmilar to 
the pretty printing libraries.

Zdenek Dvorak

module ReportPrinter (
LowDoc,HighDoc,
(<>),(<+>),($$),(<$>),
int, lowText, text, empty,
colon, comma, space, semi, period,
brackets, parens,
vcat, sep,
punctuate,
high, nest, par,
render
) where

data LowDoc=Text String |
            Join LowDoc LowDoc |
            Append LowDoc LowDoc |
            Empty deriving (Show)

data HighDoc=HLowDoc LowDoc |
             Paragraph Int HighDoc |
             Nest Int HighDoc |
             Above HighDoc HighDoc |
             Beside HighDoc HighDoc deriving (Show)

(<>)::LowDoc->LowDoc->LowDoc
x <> Empty = x
Empty <> x = x
x <> y     = Join x y

(<+>)::LowDoc->LowDoc->LowDoc
x <+> Empty = x
Empty <+> x = x
x <+> y     = Append x y

(<$>)::HighDoc->HighDoc->HighDoc
x <$> HLowDoc Empty=x
HLowDoc Empty <$> x=x
x <$> y=Beside x y

($$)::HighDoc->HighDoc->HighDoc
x $$ HLowDoc Empty=x
HLowDoc Empty $$ x=x
x $$ y=Above x y

lowText::String->LowDoc
lowText=Text

text::String->LowDoc
text str=sep $ map lowText $ words str

int::Int->LowDoc
int=text . show

empty::LowDoc
empty=Empty

colon::LowDoc
colon=lowText ":"

comma::LowDoc
comma=lowText ","

space::LowDoc
space=lowText " "

semi::LowDoc
semi=lowText ";"

period::LowDoc
period=lowText "."

brackets::LowDoc->LowDoc
brackets doc=lowText "[" <> doc <> lowText "]"

parens::LowDoc->LowDoc
parens doc=lowText "(" <> doc <> lowText ")"

sep::[LowDoc]->LowDoc
sep=foldl (<+>) empty

high::LowDoc->HighDoc
high=HLowDoc

vcat::[HighDoc]->HighDoc
vcat=foldl ($$) (high empty)

punctuate::LowDoc->[LowDoc]->[LowDoc]
punctuate _ [] = []
punctuate _ [x] = [x]
punctuate pun (h:t) = (h <> pun) : punctuate pun t

nest::Int->HighDoc->HighDoc
nest=Nest

par::Int->HighDoc->HighDoc
par=Paragraph

render::Int->HighDoc->String
render width doc=highRender width 0 0 doc ""

highRender::Int->Int->Int->HighDoc->String->String
highRender width indFirst indRest doc rest=
case doc of
  HLowDoc lowDoc     -> lowRender width indFirst indRest lowDoc rest
  Paragraph ind pDoc -> highRender width indFirst (indRest+ind) pDoc rest
  Nest ind pDoc      -> highRender width (indFirst+ind) (indRest+ind) pDoc 
rest
  Above doc1 doc2    -> highRender width indFirst indRest doc1 $
                        highRender width indRest indRest doc2 rest
  Beside doc1 doc2   -> error "Rendering two HighDocs beside not supported."

lowRender::Int->Int->Int->LowDoc->String->String
lowRender width indFirst indRest doc rest=
  stringRender width indFirst indRest strs rest
  where
   (strs,_) = stringify False doc []
   stringify False (Text txt) rest =
               ((txt,length txt):rest,False)
   stringify True (Text txt) [] =
               ([(txt,length txt)],False)
   stringify True (Text txt) ((txt',len'):rest) =
               ((txt++txt',length txt+len'):rest,False)
   stringify join Empty rest = (rest,join)
   stringify join (Append doc1 doc2) rest =
     let (rest',join')=stringify join doc2 rest
      in stringify join' doc1 rest'
   stringify join (Join doc1 doc2) rest =
     let (rest',_)=stringify join doc2 rest
      in stringify True doc1 rest'

stringRender::Int->Int->Int->[(String,Int)]->String->String
stringRender width indFirst indRest [] rest=rest
stringRender width indFirst indRest strs rest=
let (lne,rst)=cutLine (width-indFirst) strs
     rest'=stringRender width indRest indRest rst rest
  in lineRender (rst==[]) width indFirst lne rest'


cutLine tot ((txt,len):t)=(txt:lne',rst)
where
  (lne',rst)=cutLine' (tot-len) t
  cutLine' ml []=([],[])
  cutLine' ml r@((tx,ln):t')
   | ml>ln     = let (lne'',rst')=cutLine' (ml-ln-1) t'
                  in (tx:lne'',rst')
   | otherwise = ([],r)

lineRender::Bool->Int->Int->[String]->String->String
lineRender last width ind lne rest=indent ind rslt
where
  totlen   = sum $ map length lne
  words    = length lne
  reqlen   = totlen + words - 1
  havelen  = width - ind
  distsp   = if havelen > reqlen && not last then havelen - reqlen else 0
  count    = words `div` 2
  rslt     = distribSpaces count distsp words lne rest
  indent n = (take n (cycle " ") ++)

distribSpaces::Int->Int->Int->[String]->String->String
distribSpaces _ _ _ [h] rest = h ++ '\n' : rest
distribSpaces count minus plus (h:t) rest = h ++ ' ' : spaced
where
  (spaced,count') = recount count
  rest' = distribSpaces (count'-minus) minus plus t rest
  recount cnt
   | cnt < 0   = let (spaced',cnt')=recount (cnt+plus)
                  in (' ':spaced',cnt')
   | otherwise = (rest',cnt)

_________________________________________________________________
Join the world’s largest e-mail service with MSN Hotmail. 
http://www.hotmail.com