{-
Copyright(C) 1999 Erik Meijer
-}
module Pretty where
{-
Quick reference for the simple Pretty-print Combinators
|---| |----| |-------|
|koe| <|> |beer| = |koebeer|
|---| |----| |-------|
|---| |----| |--------|
|koe| <+> |beer| = |koe beer|
|---| |----| |--------|
|---| |----| |----|
|koe| <-> |beer| = |koe |
|---| |----| |beer|
|----|
|---| |----| |-------|
|koe| <|> nest 2 |beer| = |koebeer|
|---| |----| |-------|
|---| |----| |------|
|koe| <-> nest 2 |beer| = |koe |
|---| |----| | beer|
|------|
empty =
-}
{-
Extremely simplified version of John Hughes' combinators,
without (sep), but with (empty).
TODO: use Okasaki-style catenable dequeues to represent Doc
(c) Erik Meijer and Arjan van IJzendoorn
October 199
-}
infixl 7 <+>
infixl 6 <|>
infixr 5 <->
instance Show Doc where
{ showsPrec = showsPrecDoc }
showsPrecDoc i = \d ->
case d of
{ Empty -> id
; Doc ds -> layout ds
}
data Doc
= Doc [(Int,ShowS)]
| Empty
layout :: [(Int,ShowS)] -> ShowS
layout = \ds ->
case ds of
{ [] -> showString ""
; [(n,s)] -> indent n.s
; (n,s):ds -> indent n.s.showString "\n".layout ds
}
width :: Doc -> Int
width = \d ->
case d of
{ Empty -> 0
; Doc ds -> maximum [ i + length (s "") | (i,s) <- ds ]
}
text :: String -> Doc
text = \s -> Doc [(0,showString s)]
nest :: Int -> Doc -> Doc
nest n = \d ->
case d of
{ Empty -> Empty
; Doc ds -> Doc [ (i+n,d) | (i,d) <- ds ]
}
(<->) :: Doc -> Doc -> Doc
Empty <-> Empty = Empty
Empty <-> (Doc d2) = Doc d2
(Doc d1) <-> Empty = Doc d1
(Doc d1) <-> (Doc d2) = Doc (d1++d2)
(<+>) :: Doc -> Doc -> Doc
a <+> b = a <|> (text " ") <|> b
(<|>) :: Doc -> Doc -> Doc
Empty <|> Empty = Empty
Empty <|> (Doc d2) = Doc d2
(Doc d1) <|> Empty = Doc d1
(Doc d1) <|> (Doc d2) =
let
{ (d,(i,s)) = (init d1,last d1)
; ((j,t),e) = (head d2,tail d2)
}
in
( Doc d
<-> Doc [(i,s.t)]
<-> nest (i + length (s "") - j) (Doc e)
)
-- Derived operations
empty :: Doc
empty = Empty
{-
horizontal s [a,b,c] =
a <|> (s <|> b) <|> (s <|> c)
-}
horizontal :: Doc -> [Doc] -> Doc
horizontal s = \ds ->
case ds of
{ [] -> empty
; ds -> foldr1 (\d -> \ds -> d <|> s <|> ds) ds
}
{-
vertical s [a,b,c] =
a
<->
(s <|> b)
<->
(s <|> c)
-}
vertical :: [Doc] -> Doc
vertical = \ds ->
case ds of
{ [] -> empty
; d:ds -> d <-> vertical ds
}
block (o,s,c) = \ds ->
case ds of
{ [] -> o<|>c
; [d] -> o<|>d<|>c
; d:ds -> (vertical ((o <|> d):[s <|> d | d <- ds ])) <-> c
}
-- Helper function
indent :: Int -> ShowS
indent = \n ->
showString [ ' ' | i <- [1..n] ]
|