28
9
printTree :: Print a => a -> String
29
10
printTree = render . prt 0
32
render :: [String] -> String
12
type Doc = [ShowS] -> [ShowS]
17
render :: Doc -> String
18
render d = rend 0 (map ($ "") $ d []) "" where
34
19
rend i ss = case ss of
35
"[" :ts -> cons "[" $ rend i ts
36
"(" :ts -> cons "(" $ rend i ts
37
"{" :ts -> cons "{" $ new (i+1) $ rend (i+1) ts
38
"}" : ";":ts -> new (i-1) $ space "}" $ cons ";" $ new (i-1) $ rend (i-1) ts
39
"}" :ts -> new (i-1) $ cons "}" $ new (i-1) $ rend (i-1) ts
40
";" :ts -> cons ";" $ new i $ rend i ts
41
t : "," :ts -> cons t $ space "," $ rend i ts
42
t : ")" :ts -> cons t $ cons ")" $ rend i ts
43
t : "]" :ts -> cons t $ cons "]" $ rend i ts
44
t :ts -> space t $ rend i ts
47
new i s = '\n' : replicate (2*i) ' ' ++ dropWhile isSpace s
48
space t s = if null s then t else t ++ " " ++ s
50
parenth :: [String] -> [String]
51
parenth ss = ["("] ++ ss ++ [")"]
20
"[" :ts -> showChar '[' . rend i ts
21
"(" :ts -> showChar '(' . rend i ts
22
"{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
23
"}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
24
"}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
25
";" :ts -> showChar ';' . new i . rend i ts
26
t : "," :ts -> showString t . space "," . rend i ts
27
t : ")" :ts -> showString t . showChar ')' . rend i ts
28
t : "]" :ts -> showString t . showChar ']' . rend i ts
29
t :ts -> space t . rend i ts
31
new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
32
space t = showString t . (\s -> if null s then "" else (' ':s))
35
parenth ss = doc (showChar '(') . ss . doc (showChar ')')
37
concatS :: [ShowS] -> ShowS
38
concatS = foldr (.) id
40
concatD :: [Doc] -> Doc
41
concatD = foldr (.) id
43
replicateS :: Int -> ShowS -> ShowS
44
replicateS n f = concatS (replicate n f)
53
46
-- the printer class does the job
54
47
class Print a where
55
prt :: Int -> a -> [String]
56
prtList :: [a] -> [String]
57
prtList = concat . map (prt 0)
48
prt :: Int -> a -> Doc
50
prtList = concatD . map (prt 0)
59
52
instance Print a => Print [a] where
55
instance Print Char where
56
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
57
prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
59
mkEsc :: Char -> Char -> ShowS
61
_ | s == q -> showChar '\\' . showChar s
62
'\\'-> showString "\\\\"
63
'\n' -> showString "\\n"
64
'\t' -> showString "\\t"
67
prPrec :: Int -> Int -> Doc -> Doc
68
prPrec i j = if j<i then parenth else id
62
71
instance Print Integer where
72
prt _ x = doc (shows x)
73
prtList es = case es of
75
[x] -> (concatD [prt 0 x])
76
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
65
79
instance Print Double where
68
instance Print Char where
69
prt _ s = ["'" ++ mkEsc s ++ "'"]
70
prtList s = ["\"" ++ concatMap mkEsc s ++ "\""]
73
_ | elem s "\\\"'" -> '\\':[s]
78
prPrec :: Int -> Int -> [String] -> [String]
79
prPrec i j = if j<i then parenth else id
80
prt _ x = doc (shows x)
82
83
instance Print Ident where
84
prt _ (Ident i) = doc (showString i)
84
85
prtList es = case es of
85
[x] -> (concat [prt 0 x])
86
x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
86
[x] -> (concatD [prt 0 x])
87
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
90
91
instance Print Grammar where
91
92
prt i e = case e of
92
Grammar defs -> prPrec i 0 (concat [prt 0 defs])
93
Grammar defs -> prPrec i 0 (concatD [prt 0 defs])
95
96
instance Print Def where
96
97
prt i e = case e of
97
Rule label cat items -> prPrec i 0 (concat [prt 0 label , ["."] , prt 0 cat , ["::="] , prt 0 items])
98
Comment str -> prPrec i 0 (concat [["comment"] , prt 0 str])
99
Comments str0 str -> prPrec i 0 (concat [["comment"] , prt 0 str0 , prt 0 str])
100
Internal label cat items -> prPrec i 0 (concat [["internal"] , prt 0 label , ["."] , prt 0 cat , ["::="] , prt 0 items])
101
Token id reg -> prPrec i 0 (concat [["token"] , prt 0 id , prt 0 reg])
102
Entryp ids -> prPrec i 0 (concat [["entrypoints"] , prt 0 ids])
103
Separator minimumsize cat str -> prPrec i 0 (concat [["separator"] , prt 0 minimumsize , prt 0 cat , prt 0 str])
104
Terminator minimumsize cat str -> prPrec i 0 (concat [["terminator"] , prt 0 minimumsize , prt 0 cat , prt 0 str])
105
Coercions id n -> prPrec i 0 (concat [["coercions"] , prt 0 id , prt 0 n])
106
Rules id rhss -> prPrec i 0 (concat [["rules"] , prt 0 id , ["::="] , prt 0 rhss])
107
Layout strs -> prPrec i 0 (concat [["layout"] , prt 0 strs])
108
LayoutStop strs -> prPrec i 0 (concat [["layout"] , ["stop"] , prt 0 strs])
109
LayoutTop -> prPrec i 0 (concat [["layout"] , ["toplevel"]])
98
Rule label cat items -> prPrec i 0 (concatD [prt 0 label , doc (showString ".") , prt 0 cat , doc (showString "::=") , prt 0 items])
99
Comment str -> prPrec i 0 (concatD [doc (showString "comment") , prt 0 str])
100
Comments str0 str -> prPrec i 0 (concatD [doc (showString "comment") , prt 0 str0 , prt 0 str])
101
Internal label cat items -> prPrec i 0 (concatD [doc (showString "internal") , prt 0 label , doc (showString ".") , prt 0 cat , doc (showString "::=") , prt 0 items])
102
Token id reg -> prPrec i 0 (concatD [doc (showString "token") , prt 0 id , prt 0 reg])
103
PosToken id reg -> prPrec i 0 (concatD [doc (showString "position") , doc (showString "token") , prt 0 id , prt 0 reg])
104
Entryp ids -> prPrec i 0 (concatD [doc (showString "entrypoints") , prt 0 ids])
105
Separator minimumsize cat str -> prPrec i 0 (concatD [doc (showString "separator") , prt 0 minimumsize , prt 0 cat , prt 0 str])
106
Terminator minimumsize cat str -> prPrec i 0 (concatD [doc (showString "terminator") , prt 0 minimumsize , prt 0 cat , prt 0 str])
107
Coercions id n -> prPrec i 0 (concatD [doc (showString "coercions") , prt 0 id , prt 0 n])
108
Rules id rhss -> prPrec i 0 (concatD [doc (showString "rules") , prt 0 id , doc (showString "::=") , prt 0 rhss])
109
Layout strs -> prPrec i 0 (concatD [doc (showString "layout") , prt 0 strs])
110
LayoutStop strs -> prPrec i 0 (concatD [doc (showString "layout") , doc (showString "stop") , prt 0 strs])
111
LayoutTop -> prPrec i 0 (concatD [doc (showString "layout") , doc (showString "toplevel")])
111
113
prtList es = case es of
113
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
115
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
115
117
instance Print Item where
116
118
prt i e = case e of
117
Terminal str -> prPrec i 0 (concat [prt 0 str])
118
NTerminal cat -> prPrec i 0 (concat [prt 0 cat])
119
Terminal str -> prPrec i 0 (concatD [prt 0 str])
120
NTerminal cat -> prPrec i 0 (concatD [prt 0 cat])
120
122
prtList es = case es of
122
x:xs -> (concat [prt 0 x , prt 0 xs])
124
x:xs -> (concatD [prt 0 x , prt 0 xs])
124
126
instance Print Cat where
125
127
prt i e = case e of
126
ListCat cat -> prPrec i 0 (concat [["["] , prt 0 cat , ["]"]])
127
IdCat id -> prPrec i 0 (concat [prt 0 id])
128
ListCat cat -> prPrec i 0 (concatD [doc (showString "[") , prt 0 cat , doc (showString "]")])
129
IdCat id -> prPrec i 0 (concatD [prt 0 id])
130
132
instance Print Label where
131
133
prt i e = case e of
132
Id id -> prPrec i 0 (concat [prt 0 id])
133
Wild -> prPrec i 0 (concat [["_"]])
134
ListE -> prPrec i 0 (concat [["["] , ["]"]])
135
ListCons -> prPrec i 0 (concat [["("] , [":"] , [")"]])
136
ListOne -> prPrec i 0 (concat [["("] , [":"] , ["["] , ["]"] , [")"]])
134
LabNoP labelid -> prPrec i 0 (concatD [prt 0 labelid])
135
LabP labelid profitems -> prPrec i 0 (concatD [prt 0 labelid , prt 0 profitems])
136
LabPF labelid0 labelid profitems -> prPrec i 0 (concatD [prt 0 labelid0 , prt 0 labelid , prt 0 profitems])
137
LabF labelid0 labelid -> prPrec i 0 (concatD [prt 0 labelid0 , prt 0 labelid])
140
instance Print LabelId where
142
Id id -> prPrec i 0 (concatD [prt 0 id])
143
Wild -> prPrec i 0 (concatD [doc (showString "_")])
144
ListE -> prPrec i 0 (concatD [doc (showString "[") , doc (showString "]")])
145
ListCons -> prPrec i 0 (concatD [doc (showString "(") , doc (showString ":") , doc (showString ")")])
146
ListOne -> prPrec i 0 (concatD [doc (showString "(") , doc (showString ":") , doc (showString "[") , doc (showString "]") , doc (showString ")")])
149
instance Print ProfItem where
151
ProfIt intlists ns -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "[") , prt 0 intlists , doc (showString "]") , doc (showString ",") , doc (showString "[") , prt 0 ns , doc (showString "]") , doc (showString ")")])
153
prtList es = case es of
154
[x] -> (concatD [prt 0 x])
155
x:xs -> (concatD [prt 0 x , prt 0 xs])
157
instance Print IntList where
159
Ints ns -> prPrec i 0 (concatD [doc (showString "[") , prt 0 ns , doc (showString "]")])
161
prtList es = case es of
163
[x] -> (concatD [prt 0 x])
164
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
139
166
instance Print RHS where
140
167
prt i e = case e of
141
RHS items -> prPrec i 0 (concat [prt 0 items])
168
RHS items -> prPrec i 0 (concatD [prt 0 items])
143
170
prtList es = case es of
144
[x] -> (concat [prt 0 x])
145
x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs])
171
[x] -> (concatD [prt 0 x])
172
x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
147
174
instance Print MinimumSize where
148
175
prt i e = case e of
149
MNonempty -> prPrec i 0 (concat [["nonempty"]])
150
MEmpty -> prPrec i 0 (concat [])
176
MNonempty -> prPrec i 0 (concatD [doc (showString "nonempty")])
177
MEmpty -> prPrec i 0 (concatD [])
153
180
instance Print Reg where
154
181
prt i e = case e of
155
RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])
156
RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])
157
RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["-"] , prt 2 reg])
158
RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])
159
RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])
160
ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])
161
REps -> prPrec i 3 (concat [["eps"]])
162
RChar c -> prPrec i 3 (concat [prt 0 c])
163
RAlts str -> prPrec i 3 (concat [["["] , prt 0 str , ["]"]])
164
RSeqs str -> prPrec i 3 (concat [["{"] , prt 0 str , ["}"]])
165
RDigit -> prPrec i 3 (concat [["digit"]])
166
RLetter -> prPrec i 3 (concat [["letter"]])
167
RUpper -> prPrec i 3 (concat [["upper"]])
168
RLower -> prPrec i 3 (concat [["lower"]])
169
RAny -> prPrec i 3 (concat [["char"]])
182
RSeq reg0 reg -> prPrec i 2 (concatD [prt 2 reg0 , prt 3 reg])
183
RAlt reg0 reg -> prPrec i 1 (concatD [prt 1 reg0 , doc (showString "|") , prt 2 reg])
184
RMinus reg0 reg -> prPrec i 1 (concatD [prt 2 reg0 , doc (showString "-") , prt 2 reg])
185
RStar reg -> prPrec i 3 (concatD [prt 3 reg , doc (showString "*")])
186
RPlus reg -> prPrec i 3 (concatD [prt 3 reg , doc (showString "+")])
187
ROpt reg -> prPrec i 3 (concatD [prt 3 reg , doc (showString "?")])
188
REps -> prPrec i 3 (concatD [doc (showString "eps")])
189
RChar c -> prPrec i 3 (concatD [prt 0 c])
190
RAlts str -> prPrec i 3 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")])
191
RSeqs str -> prPrec i 3 (concatD [doc (showString "{") , prt 0 str , doc (showString "}")])
192
RDigit -> prPrec i 3 (concatD [doc (showString "digit")])
193
RLetter -> prPrec i 3 (concatD [doc (showString "letter")])
194
RUpper -> prPrec i 3 (concatD [doc (showString "upper")])
195
RLower -> prPrec i 3 (concatD [doc (showString "lower")])
196
RAny -> prPrec i 3 (concatD [doc (showString "char")])