Text/ParserCombinators/Parsec/examples/Mondrian/Pretty.hs

   1 {-
   2 Copyright(C) 1999 Erik Meijer
   3 -}
   4 module Pretty where
   5
   6 {-
   7
   8 Quick reference for the simple Pretty-print Combinators
   9
  10   |---|     |----|   |-------|
  11   |koe| <|> |beer| = |koebeer|
  12   |---|     |----|   |-------|
  13
  14   |---|     |----|   |--------|
  15   |koe| <+> |beer| = |koe beer|
  16   |---|     |----|   |--------|
  17
  18   |---|     |----|   |----|
  19   |koe| <-> |beer| = |koe |
  20   |---|     |----|   |beer|
  21                      |----|
  22
  23   |---|            |----|   |-------|
  24   |koe| <|> nest 2 |beer| = |koebeer|
  25   |---|            |----|   |-------|
  26
  27   |---|            |----|   |------|
  28   |koe| <-> nest 2 |beer| = |koe   |
  29   |---|            |----|   |  beer|
  30                             |------|
  31
  32   empty =
  33 -}
  34
  35 {-
  36
  37 Extremely simplified version of John Hughes' combinators,
  38 without (sep), but with (empty).
  39
  40 TODO: use Okasaki-style catenable dequeues to represent Doc
  41
  42 (c) Erik Meijer and Arjan van IJzendoorn
  43
  44 October 199
  45
  46 -}
  47
  48 infixl 7 <+>
  49 infixl 6 <|>
  50 infixr 5 <->
  51
  52 instance Show Doc where
  53   { showsPrec = showsPrecDoc }
  54
  55 showsPrecDoc i = \d ->
  56   case d of
  57     { Empty -> id
  58     ; Doc ds -> layout ds
  59     }
  60
  61 data Doc
  62   = Doc [(Int,ShowS)]
  63   | Empty
  64
  65 layout :: [(Int,ShowS)] -> ShowS
  66 layout = \ds ->
  67   case ds of
  68     { []       -> showString ""
  69     ; [(n,s)]  -> indent n.s
  70     ; (n,s):ds -> indent n.s.showString "\n".layout ds
  71     }
  72
  73 width :: Doc -> Int
  74 width = \d ->
  75   case d of
  76     { Empty -> 0
  77     ; Doc ds -> maximum [ i + length (s "") | (i,s) <- ds ]
  78     }
  79
  80 text :: String -> Doc
  81 text = \s -> Doc [(0,showString s)]
  82
  83 nest :: Int -> Doc -> Doc
  84 nest n = \d ->
  85   case d of
  86     { Empty -> Empty
  87     ; Doc ds -> Doc [ (i+n,d) | (i,d) <- ds ]
  88     }
  89
  90 (<->) :: Doc -> Doc -> Doc
  91 Empty <-> Empty = Empty
  92 Empty <-> (Doc d2) = Doc d2
  93 (Doc d1) <-> Empty = Doc d1
  94 (Doc d1) <-> (Doc d2) = Doc (d1++d2)
  95
  96 (<+>) :: Doc -> Doc -> Doc
  97 a <+> b = a <|> (text " ") <|> b
  98
  99 (<|>) :: Doc -> Doc -> Doc
 100 Empty <|> Empty = Empty
 101 Empty <|> (Doc d2) = Doc d2
 102 (Doc d1) <|> Empty = Doc d1
 103 (Doc d1) <|> (Doc d2) =
 104   let
 105     { (d,(i,s)) = (init d1,last d1)
 106     ; ((j,t),e) = (head d2,tail d2)
 107     }
 108   in
 109     (    Doc d
 110      <-> Doc [(i,s.t)]
 111      <-> nest (i + length (s "") - j) (Doc e)
 112     )
 113
 114 -- Derived operations
 115
 116 empty :: Doc
 117 empty = Empty
 118
 119 {-
 120
 121 horizontal s [a,b,c] =
 122   a <|> (s <|> b) <|> (s <|> c)
 123
 124 -}
 125
 126 horizontal :: Doc -> [Doc] -> Doc
 127 horizontal s = \ds ->
 128   case ds of
 129     { [] -> empty
 130     ; ds -> foldr1 (\d -> \ds -> d <|> s <|> ds) ds
 131     }
 132
 133 {-
 134
 135 vertical s [a,b,c] =
 136   a
 137   <->
 138   (s <|> b)
 139   <->
 140   (s <|> c)
 141
 142 -}
 143
 144 vertical :: [Doc] -> Doc
 145 vertical = \ds ->
 146   case ds of
 147     { [] -> empty
 148     ; d:ds -> d <-> vertical ds
 149     }
 150
 151 block (o,s,c) = \ds ->
 152   case ds of
 153     { [] -> o<|>c
 154     ; [d] -> o<|>d<|>c\r    ; d:ds -> (vertical ((o <|> d):[s <|> d | d <- ds ])) <-> c
 155     }
 156
 157 -- Helper function
 158
 159 indent :: Int -> ShowS
 160 indent = \n ->
 161   showString [ ' ' | i <- [1..n] ]