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
|
{-# OPTIONS_GHC -fglasgow-exts #-}
module GFCC.Print where
-- pretty-printer generated by the BNF converter
import GFCC.Abs
import Data.Char
import Data.List (intersperse)
-- 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
unwordsD :: [Doc] -> Doc
unwordsD = concatD . intersperse (doc (showChar ' '))
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
instance Print Char where
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
instance Print String where
prt _ 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 (Tree c) where
prt _i e = case e of
Grm header abstract concretes -> prPrec _i 0 (concatD [prt 0 header , doc (showString ";") , prt 0 abstract , doc (showString ";") , prt 0 concretes])
Hdr cid cids -> prPrec _i 0 (concatD [doc (showString "grammar") , prt 0 cid , doc (showString "(") , prt 0 cids , doc (showString ")")])
Abs absdefs -> prPrec _i 0 (concatD [doc (showString "abstract") , doc (showString "{") , prt 0 absdefs , doc (showString "}")])
Cnc cid cncdefs -> prPrec _i 0 (concatD [doc (showString "concrete") , prt 0 cid , doc (showString "{") , prt 0 cncdefs , doc (showString "}")])
Fun cid type' exp -> prPrec _i 0 (concatD [prt 0 cid , doc (showString ":") , prt 0 type' , doc (showString "=") , prt 0 exp])
Lin cid term -> prPrec _i 0 (concatD [prt 0 cid , doc (showString "=") , prt 0 term])
Typ cids cid -> prPrec _i 0 (concatD [prt 0 cids , doc (showString "->") , prt 0 cid])
Tr atom exps -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 atom , prt 0 exps , doc (showString ")")])
AC cid -> prPrec _i 0 (concatD [prt 0 cid])
AS str -> prPrec _i 0 (concatD [prt 0 str])
AI n -> prPrec _i 0 (concatD [prt 0 n])
AF d -> prPrec _i 0 (concatD [prt 0 d])
AM -> prPrec _i 0 (concatD [doc (showString "?")])
R terms -> prPrec _i 0 (concatD [doc (showString "[") , prt 0 terms , doc (showString "]")])
P term0 term1 -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "!") , prt 0 term1 , doc (showString ")")])
S terms -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 terms , doc (showString ")")])
K tokn -> prPrec _i 0 (concatD [prt 0 tokn])
V n -> prPrec _i 0 (concatD [doc (showString "$") , prt 0 n])
C n -> prPrec _i 0 (concatD [prt 0 n])
F cid -> prPrec _i 0 (concatD [prt 0 cid])
FV terms -> prPrec _i 0 (concatD [doc (showString "[|") , prt 0 terms , doc (showString "|]")])
W str term -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 str , doc (showString "+") , prt 0 term , doc (showString ")")])
RP term0 term1 -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "@") , prt 0 term1 , doc (showString ")")])
TM -> prPrec _i 0 (concatD [doc (showString "?")])
L cid term -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 cid , doc (showString "->") , prt 0 term , doc (showString ")")])
BV cid -> prPrec _i 0 (concatD [doc (showString "#") , prt 0 cid])
KS str -> prPrec _i 0 (concatD [prt 0 str])
KP strs variants -> prPrec _i 0 (concatD [doc (showString "[") , doc (showString "pre") , prt 0 strs , doc (showString "[") , prt 0 variants , doc (showString "]") , doc (showString "]")])
Var strs0 strs1 -> prPrec _i 0 (concatD [prt 0 strs0 , doc (showString "/") , prt 0 strs1])
CId str -> prPrec _i 0 (doc (showString str))
instance Print [Concrete] where
prt _ es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [AbsDef] where
prt _ es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [CncDef] where
prt _ es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [CId] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print [Term] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print [Exp] where
prt _ es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print [String] where
prt _ es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print [Variant] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
