-
Notifications
You must be signed in to change notification settings - Fork 0
/
Printshl.hs
201 lines (151 loc) · 7.81 KB
/
Printshl.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module Printshl where
-- pretty-printer generated by the BNF converter
import Absshl
import Data.Char
-- the top-level printing method
printTree :: Print a => a -> String
printTree = render . prt 0
type Doc = [ShowS] -> [ShowS]
doc :: ShowS -> Doc
doc = (:)
render :: Doc -> String
render d = rend 0 (map ($ "") $ d []) "" where
rend i ss = case ss of
"[" :ts -> showChar '[' . rend i ts
"(" :ts -> showChar '(' . rend i ts
"{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
"}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
"}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
";" :ts -> showChar ';' . new i . rend i ts
t : "," :ts -> showString t . space "," . rend i ts
t : ")" :ts -> showString t . showChar ')' . rend i ts
t : "]" :ts -> showString t . showChar ']' . rend i ts
t :ts -> space t . rend i ts
_ -> id
new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
space t = showString t . (\s -> if null s then "" else (' ':s))
parenth :: Doc -> Doc
parenth ss = doc (showChar '(') . ss . doc (showChar ')')
concatS :: [ShowS] -> ShowS
concatS = foldr (.) id
concatD :: [Doc] -> Doc
concatD = foldr (.) id
replicateS :: Int -> ShowS -> ShowS
replicateS n f = concatS (replicate n f)
-- the printer class does the job
class Print a where
prt :: Int -> a -> Doc
prtList :: [a] -> Doc
prtList = concatD . map (prt 0)
instance Print a => Print [a] where
prt _ = prtList
instance Print Char where
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
mkEsc :: Char -> Char -> ShowS
mkEsc q s = case s of
_ | s == q -> showChar '\\' . showChar s
'\\'-> showString "\\\\"
'\n' -> showString "\\n"
'\t' -> showString "\\t"
_ -> showChar s
prPrec :: Int -> Int -> Doc -> Doc
prPrec i j = if j<i then parenth else id
instance Print Integer where
prt _ x = doc (shows x)
instance Print Double where
prt _ x = doc (shows x)
instance Print Ident where
prt _ (Ident i) = doc (showString ( i))
instance Print Prog where
prt i e = case e of
Program blk -> prPrec i 0 (concatD [doc (showString "SOLUTION") , prt 0 blk , doc (showString "CYA")])
instance Print Blk where
prt i e = case e of
Block decs stms -> prPrec i 0 (concatD [prt 0 decs , prt 0 stms])
instance Print Stm where
prt i e = case e of
ForLoop id exp blk -> prPrec i 0 (concatD [doc (showString "FOR") , prt 0 id , doc (showString "IN") , prt 0 exp , doc (showString "DO") , prt 0 blk , doc (showString "DONE")])
IfStmt exp blk -> prPrec i 0 (concatD [doc (showString "IF") , prt 0 exp , doc (showString "THEN") , prt 0 blk , doc (showString "FI")])
IfElseStmt exp blk0 blk -> prPrec i 0 (concatD [doc (showString "IF") , prt 0 exp , doc (showString "THEN") , prt 0 blk0 , doc (showString "ELSE") , prt 0 blk , doc (showString "FI")])
ReturnStmt exp -> prPrec i 0 (concatD [doc (showString "RETURN") , prt 0 exp , doc (showString ";")])
PrintStmt exp -> prPrec i 0 (concatD [doc (showString "PRINT") , prt 0 exp , doc (showString ";")])
ExpStmt exp -> prPrec i 0 (concatD [prt 0 exp , doc (showString ";")])
AssignMultiple assms exps -> prPrec i 0 (concatD [prt 0 assms , doc (showString "=") , prt 0 exps , doc (showString ";")])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print AssM where
prt i e = case e of
AssignVar id -> prPrec i 0 (concatD [prt 0 id])
AssignArr id exp -> prPrec i 0 (concatD [prt 0 id , doc (showString "[") , prt 0 exp , doc (showString "]")])
prtList es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print AssE where
prt i e = case e of
AssignExp exp -> prPrec i 0 (concatD [prt 0 exp])
instance Print Dec where
prt i e = case e of
Declaration typ id -> prPrec i 0 (concatD [prt 0 typ , prt 0 id , doc (showString ";")])
DeclarationAssing typ id exp -> prPrec i 0 (concatD [prt 0 typ , prt 0 id , doc (showString "=") , prt 0 exp , doc (showString ";")])
DeclarationFunc typ id fargs blk -> prPrec i 0 (concatD [prt 0 typ , prt 0 id , doc (showString "(") , prt 0 fargs , doc (showString ")") , doc (showString "DO") , prt 0 blk , doc (showString "RETURNED")])
DeclarationArray typ id exp -> prPrec i 0 (concatD [prt 0 typ , prt 0 id , doc (showString "[") , prt 0 exp , doc (showString "]") , doc (showString ";")])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print FArg where
prt i e = case e of
FArgument typ id -> prPrec i 0 (concatD [prt 0 typ , prt 0 id])
FArgumentAssing typ id exp -> prPrec i 0 (concatD [prt 0 typ , prt 0 id , doc (showString "=") , prt 0 exp])
FArgumentFunc typ id fargs -> prPrec i 0 (concatD [prt 0 typ , prt 0 id , doc (showString "(") , prt 0 fargs , doc (showString ")")])
FArgumentRef typ id -> prPrec i 0 (concatD [doc (showString "REF") , prt 0 typ , prt 0 id])
FArgumentArr typ id -> prPrec i 0 (concatD [prt 0 typ , prt 0 id , doc (showString "[]")])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Typ where
prt i e = case e of
TInt -> prPrec i 0 (concatD [doc (showString "Integer")])
TBool -> prPrec i 0 (concatD [doc (showString "Boolean")])
TString -> prPrec i 0 (concatD [doc (showString "String")])
instance Print Exp where
prt i e = case e of
Eeq exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "==") , prt 2 exp])
Eneq exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "!=") , prt 2 exp])
Elthen exp0 exp -> prPrec i 2 (concatD [prt 2 exp0 , doc (showString "<") , prt 3 exp])
Egrthen exp0 exp -> prPrec i 2 (concatD [prt 2 exp0 , doc (showString ">") , prt 3 exp])
Ele exp0 exp -> prPrec i 2 (concatD [prt 2 exp0 , doc (showString "<=") , prt 3 exp])
Ege exp0 exp -> prPrec i 2 (concatD [prt 2 exp0 , doc (showString ">=") , prt 3 exp])
Eplus exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "+") , prt 4 exp])
Eminus exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "-") , prt 4 exp])
Etimes exp0 exp -> prPrec i 4 (concatD [prt 4 exp0 , doc (showString "*") , prt 5 exp])
Ediv exp0 exp -> prPrec i 4 (concatD [prt 4 exp0 , doc (showString "/") , prt 5 exp])
Einc id -> prPrec i 5 (concatD [prt 0 id , doc (showString "++")])
Edec id -> prPrec i 5 (concatD [prt 0 id , doc (showString "--")])
Einvok id iparams -> prPrec i 5 (concatD [prt 0 id , doc (showString "(") , prt 0 iparams , doc (showString ")")])
Evar id -> prPrec i 5 (concatD [prt 0 id])
Econst constraint -> prPrec i 5 (concatD [prt 0 constraint])
Elmb fargs exp -> prPrec i 5 (concatD [doc (showString "LAMBDA") , prt 0 fargs , doc (showString ":") , prt 0 exp])
Earr id exp -> prPrec i 5 (concatD [prt 0 id , doc (showString "[") , prt 0 exp , doc (showString "]")])
prtList es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Constraint where
prt i e = case e of
Eint n -> prPrec i 0 (concatD [prt 0 n])
Ebool boolt -> prPrec i 0 (concatD [prt 0 boolt])
Estring str -> prPrec i 0 (concatD [prt 0 str])
instance Print BoolT where
prt i e = case e of
Constraint_True -> prPrec i 0 (concatD [doc (showString "True")])
Constraint_False -> prPrec i 0 (concatD [doc (showString "False")])
instance Print IParam where
prt i e = case e of
InvokeParamater exp -> prPrec i 0 (concatD [prt 0 exp])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])