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
|
{-# OPTIONS -fno-warn-incomplete-patterns #-}
module GF.Command.PrintGFShell where
-- pretty-printer generated by the BNF converter
import GF.Command.AbsGFShell
import 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)
prtList es = case es of
[x] -> (concatD [prt 0 x , doc (showString ",")])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print CommandLine where
prt i e = case e of
CLine pipes -> prPrec i 0 (concatD [prt 0 pipes])
CEmpty -> prPrec i 0 (concatD [])
instance Print Pipe where
prt i e = case e of
PComm commands -> prPrec i 0 (concatD [prt 0 commands])
prtList es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Command where
prt i e = case e of
Comm id options argument -> prPrec i 0 (concatD [prt 0 id , prt 0 options , prt 0 argument])
CNoarg id options -> prPrec i 0 (concatD [prt 0 id , prt 0 options])
prtList es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
instance Print Option where
prt i e = case e of
OOpt id -> prPrec i 0 (concatD [doc (showString "-") , prt 0 id])
OFlag id value -> prPrec i 0 (concatD [doc (showString "-") , prt 0 id , doc (showString "=") , prt 0 value])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print Value where
prt i e = case e of
VId id -> prPrec i 0 (concatD [prt 0 id])
VInt n -> prPrec i 0 (concatD [prt 0 n])
instance Print Argument where
prt i e = case e of
ATree tree -> prPrec i 0 (concatD [prt 0 tree])
instance Print Tree where
prt i e = case e of
TApp id trees -> prPrec i 1 (concatD [prt 0 id , prt 2 trees])
TAbs ids tree -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 ids , doc (showString "->") , prt 0 tree])
TId id -> prPrec i 2 (concatD [prt 0 id])
TInt n -> prPrec i 2 (concatD [prt 0 n])
TStr str -> prPrec i 2 (concatD [prt 0 str])
TFloat d -> prPrec i 2 (concatD [prt 0 d])
prtList es = case es of
[x] -> (concatD [prt 2 x])
x:xs -> (concatD [prt 2 x , prt 2 xs])
|
