[project @ 2002-05-31 12:22:33 by panne]
[packages/containers.git] / Text / ParserCombinators / Parsec / examples / Mondrian / SimpleMondrianPrinter.hs
1 {-
2 Copyright(C) 1999 Erik Meijer and Arjan van Yzendoorn
3 -}
4 module SimpleMondrianPrinter where
5
6 import Mondrian
7 import Pretty
8 import Utils
9
10 mondrianIndent :: Int
11 mondrianIndent = 2
12
13 compilationUnit :: CompilationUnit -> Doc
14 compilationUnit = \m ->
15 case m of
16 { Package n ds -> package m (name n) (decls ds)
17 }
18
19 package = \(Package n' ds') -> \n -> \ds ->
20 case null ds' of
21 { True -> text "package" <+> n <+> row ds
22 ; False -> text "package" <+> n <-> nest (-mondrianIndent) (column ds)
23 }
24
25 decls = \ds -> [ decl d | d <- ds ]
26
27 decl = \d ->
28 case d of
29 { ImportDecl ns -> importDecl d (name ns)
30 ; ClassDecl n xs ds -> classDecl d (name n) (extends xs) (decls ds)
31 ; SigDecl n t -> sigDecl (name n) (expr t)
32 ; VarDecl v (Lambda ns e) -> varDecl d (name v) (lambdas ns) (expr e)
33 ; VarDecl v e -> decl (VarDecl v (Lambda [] e))
34 }
35
36 extends = \xs ->
37 case xs of
38 { [] -> empty
39 ; [x] -> text "extends" <+> name x <+> empty
40 ; xs -> text "multiple inheritance not supported" <+> row [name x | x <- xs]
41 }
42
43 classDecl = \(ClassDecl n' xs' ds') -> \n -> \xs -> \ds ->
44 case ds' of
45 { [] -> text "class" <+> n <+> xs
46 ; otherwise -> text "class" <+> n <+> xs <-> column ds
47 }
48
49 sigDecl = \n -> \t -> n <+> text "::" <+> t
50
51 importDecl = \d -> \n -> text "import" <+> n
52
53 varDecl = \(VarDecl v' (Lambda ns' e')) -> \v -> \ns -> \e ->
54 if isSimpleExpr e'
55 then v <+> text "=" <+> ns <|> e
56 else v <+> text "=" <+> ns <-> nest mondrianIndent e
57
58 names = \ns -> horizontal (text " ") [ name n | n <- ns ]
59
60 name = \ns -> horizontal (text ".") [text n | n <- ns]
61
62 lambdas = \ns ->
63 case ns of
64 { [] -> empty
65 ; [n] -> text "\\" <|> name n <+> text "->" <+> empty
66 ; n:ns -> text "\\" <|> name n <+> text "->" <+> lambdas ns
67 }
68
69 expr = \e ->
70 case e of
71 { Lit l -> lit l
72 ; Var n -> name n
73 ; App f a -> application (expr f) (expr a)
74 ; Lambda ns b -> lambdaExpr e (lambdas ns) (expr b)
75 ; New n ds -> newExpr e (name n) (decls ds)
76 ; Case e1 as -> caseExpr e (expr e1) (arms as)
77 ; Let ds e1 -> letExpr e (decls ds) (expr e1)
78 ; Chain e1 oes -> chain e1 oes
79 }
80
81 application = \f -> \a -> text "(" <|> f <+> a <|> text ")"
82
83 newExpr = \(New n' ds') -> \n -> \ds ->
84 case ds' of
85 { [] -> text "new" <+> n
86 ; otherwise ->
87 if isSimpleDecls ds'
88 then text "new" <+> n <+> row ds
89 else text "new" <+> n <-> column ds
90 }
91
92 lambdaExpr = \(Lambda ns' e') -> \ns -> \e ->
93 if isSimpleExpr e'
94 then ns <|> e
95 else ns <-> nest mondrianIndent e
96
97 caseExpr :: Expr -> Doc -> [Doc] -> Doc
98 caseExpr = \(Case e' as') -> \e -> \as ->
99 case (isSimpleExpr e', isSimpleArms as') of
100 { (True, True) -> text "case" <+> e <+> text "of" <+> row as
101 ; (True, False)-> text "case" <+> e <+> text "of" <-> column as
102 ; (False, True) -> text "case" <-> nest mondrianIndent e <-> text "of" <+> row as
103 ; (False, False) -> text "case" <-> nest mondrianIndent e <-> text "of" <-> column as
104 }
105
106 letExpr = \(Let ds' e') -> \ds -> \e ->
107 case (length ds' == 1 && isSimpleDecls ds', isSimpleExpr e') of
108 { (True, True) -> text "let" <+> row ds <+> text "in" <+> e
109 ; (True, False) -> text "let" <+> row ds <-> text "in" <-> nest mondrianIndent e
110 ; (False, True) -> text "let" <-> column ds <-> text "in" <+> e
111 ; (False, False) -> text "let" <-> column ds <-> text "in" <-> nest mondrianIndent e
112 }
113
114 arms = \as -> [ arm (p,e) (pattern p) (expr e) | (p,e) <- as ]
115
116 arm = \(p',e') -> \p -> \e ->
117 if isSimplePattern p' && isSimpleExpr e'
118 then p <+> text "->" <+> e
119 else p <+> text "->" <-> nest mondrianIndent e
120
121 -- This is a dirty hack!
122
123 chain = \e -> \oes ->
124 case oes of
125 { [] -> bracket e
126 ; ([""],f):oes -> if (isSimpleExpr f)
127 then (bracket e) <+> chain f oes
128 else (bracket e) <-> nest 2 (chain f oes)
129 ; (o,f):oes -> if (isSimpleExpr f)
130 then (bracket e) <+> name o <+> chain f oes
131 else (bracket e) <-> name o <+> chain f oes
132 }
133
134 pattern = \p ->
135 case p of
136 { Pattern n ds ->
137 case ds of
138 { [] -> name n
139 ; otherwise -> name n <+> row (decls ds)
140 }
141 ; Default -> text "default"
142 }
143
144 lit = \l ->
145 case l of
146 { IntLit i -> text (show i)
147 ; CharLit c -> text (show c)
148 ; StringLit s -> text (show s)
149 }
150
151 bracket = \e ->
152 case e of
153 { Lit l -> expr e
154 ; Var n -> expr e
155 ; e -> par (expr e)
156 }
157
158 par = \e -> text "(" <|> e <|> text ")"
159
160 column = \ds -> nest mondrianIndent (block (text "{ ", text ";" <+> empty, text "}") ds)
161
162 row = \ds -> text "{" <|> horizontal (text ";" <+> empty) ds <|> text "}"