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
200
201
202
203
204
205
206
207
208
209
210
|
{-# OPTIONS -fno-warn-incomplete-patterns #-}
module GF.FCFG.PrintFCFG where
-- pretty-printer generated by the BNF converter
import GF.FCFG.AbsFCFG
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)
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print Double where
prt _ x = doc (shows x)
instance Print Ident where
prt _ (Ident i) = doc (showString i)
instance Print FGrammar where
prt i e = case e of
FGr frules -> prPrec i 0 (concatD [prt 0 frules])
instance Print FRule where
prt i e = case e of
FR abstract fsymbolss -> prPrec i 0 (concatD [prt 0 abstract , doc (showString ":=") , prt 0 fsymbolss])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Abstract where
prt i e = case e of
Abs fcat fcats name -> prPrec i 0 (concatD [prt 0 fcat , doc (showString "->") , prt 0 fcats , doc (showString ".") , prt 0 name])
instance Print FSymbol where
prt i e = case e of
FSymCat fcat n0 n -> prPrec i 0 (concatD [doc (showString "(") , prt 0 fcat , prt 0 n0 , prt 0 n , doc (showString ")")])
FSymTok str -> prPrec i 0 (concatD [prt 0 str])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print FCat where
prt i e = case e of
FC n id pathelss pathterms -> prPrec i 0 (concatD [doc (showString "(") , prt 0 n , prt 0 id , doc (showString "[") , prt 0 pathelss , doc (showString "]") , doc (showString "[") , prt 0 pathterms , doc (showString "]") , doc (showString ")")])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print PathEl where
prt i e = case e of
PLabel label -> prPrec i 0 (concatD [prt 0 label])
PTerm term -> prPrec i 0 (concatD [prt 0 term])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ".") , prt 0 xs])
instance Print PathTerm where
prt i e = case e of
PtT pathels term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 pathels , doc (showString ",") , prt 0 term , doc (showString ")")])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print Name where
prt i e = case e of
Nm id profiles -> prPrec i 0 (concatD [prt 0 id , doc (showString "[") , prt 0 profiles , doc (showString "]")])
instance Print Profile where
prt i e = case e of
Unify ns -> prPrec i 0 (concatD [doc (showString "[") , prt 0 ns , doc (showString "]")])
Const forest -> prPrec i 0 (concatD [prt 0 forest])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print Forest where
prt i e = case e of
FMeta -> prPrec i 0 (concatD [doc (showString "?")])
FNode id forestss -> prPrec i 0 (concatD [doc (showString "(") , prt 0 id , prt 0 forestss , doc (showString ")")])
FString str -> prPrec i 0 (concatD [prt 0 str])
FInt n -> prPrec i 0 (concatD [prt 0 n])
FFloat d -> prPrec i 0 (concatD [prt 0 d])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print Term where
prt i e = case e of
Arg n id pathels -> prPrec i 0 (concatD [doc (showString "(") , prt 0 n , prt 0 id , prt 0 pathels , doc (showString ")")])
Constr cident terms -> prPrec i 0 (concatD [doc (showString "(") , prt 0 cident , doc (showString "-") , prt 0 terms , doc (showString ")")])
Rec assocs -> prPrec i 0 (concatD [doc (showString "[") , prt 0 assocs , doc (showString "]")])
Proj term label -> prPrec i 0 (concatD [doc (showString "(") , prt 0 term , doc (showString ".") , prt 0 label , doc (showString ")")])
Tbl cases -> prPrec i 0 (concatD [doc (showString "[-") , prt 0 cases , doc (showString "-]")])
Select term0 term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "!") , prt 0 term , doc (showString ")")])
Vars terms -> prPrec i 0 (concatD [doc (showString "[|") , prt 0 terms , doc (showString "|]")])
Concat term0 term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "++") , prt 0 term , doc (showString ")")])
Tok str -> prPrec i 0 (concatD [prt 0 str])
Empty -> prPrec i 0 (concatD [doc (showString "(") , doc (showString ")")])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Case where
prt i e = case e of
Cas term0 term -> prPrec i 0 (concatD [prt 0 term0 , doc (showString "=>") , prt 0 term])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Assoc where
prt i e = case e of
Ass label term -> prPrec i 0 (concatD [prt 0 label , doc (showString "=") , prt 0 term])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Label where
prt i e = case e of
L id -> prPrec i 0 (concatD [prt 0 id])
LV n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n])
instance Print CIdent where
prt i e = case e of
CIQ id0 id -> prPrec i 0 (concatD [prt 0 id0 , doc (showString ".") , prt 0 id])
|
