4e29bbf5983f5bbe0dea285e5da2d4846d579cc8
[nofib.git] / real / rx / src / Syntax.hs
1 -- functions and operators
2
3
4 module Syntax
5
6 ( CType(..)
7 , Exp(..)
8
9
10
11 , appId, appArgs, appids
12 , isApp, isAppId, unAppId
13
14
15 , pr
16
17 , substExp
18
19 , cType, cArgs, isColl
20
21 )
22
23 where
24
25 -- import List
26 import Maybes
27
28 import Ids
29
30 import Pretty -- syslib ghc
31 import PrettyClass
32
33 import Options -- to find out about print format
34
35 import FiniteMap
36
37 -----------------------------------------------------------------------
38
39 data CType = CSet | CList | CTuple
40 deriving (Eq, Ord, Show)
41
42 data Exp
43 = App Id [Exp] -- function (identifier) application
44 | Coll CType [Exp]
45
46 deriving (Eq, Ord)
47
48 isApp (App _ _) = True; isApp _ = False
49 isColl (Coll _ _) = True; isColl _ = False
50
51 cType (Coll ct _) = ct
52 cArgs (Coll _ ca) = ca
53
54 appId (App id args) = id
55 appArgs (App id args) = args
56
57 isAppId (App id []) = True; isAppId _ = False
58 unAppId (App id []) = id; unAppId _ = error "unAppId"
59
60 appids (App id xs) = id : concat (map appids xs)
61 appids (Coll _ xs) = concat (map appids xs)
62
63 ------------------------------------------------------------------
64
65
66
67 substExp :: Exp -> Exp -> Exp -> Exp
68
69 substExp a val x | a == x = val
70 substExp a val (App id xs) = App id ( map (substExp a val) xs )
71 substExp a val (Coll t xs) = Coll t ( map (substExp a val) xs )
72
73
74 ----------------------------------------------
75
76 paren opts f p = if f then alParens opts p else p
77 brack opts f p = if f then alBrackets opts p else p
78 curls opts f p = if f then alBraces opts p else p
79
80 lgroup :: Pretty -> Pretty
81 lgroup p = ppBesides [ppStr "{", p, ppStr "}"]
82
83 instance Show Exp where showsPrec p = emitascii
84
85 -- todo: something more distinctive
86 pr opts = pp opts
87
88 instance PrettyClass Exp where
89
90 ppp opts p (Coll tc args) = (case tc of
91 CSet -> curls ; CList -> brack; CTuple -> paren)
92 opts True (ppCommas (map (pp opts) args))
93
94
95 ppp opts p (App f args) =
96 if null args
97 then ppfn opts f
98
99 else case idform f of
100 Active _ _ -> caseopts opts "code"
101 [ ("latex", activate opts p f args)
102 , ("plain", passivate opts p f args)
103 ]
104 Passive _ -> passivate opts p f args
105
106 activate :: Opts -> Int -> Id -> [ Exp ] -> Pretty
107 activate opts p f args =
108 let Active n cs = idform f
109
110 fs :: FiniteMap Int Pretty
111 fs = if length args /= n
112 then error ("active form used with wrong number of args, "
113 ++ show f ++ show args)
114 else listToFM (zip [1..n]
115 [lgroup (ppp opts 0 arg) | arg <- args])
116 -- note: individual args are formatted with
117 -- surrounding precedence level 0
118
119 atoi :: Char -> Int
120 atoi c = fromEnum c - fromEnum '0'
121
122 farg :: Int -> Pretty
123 farg i = lookupWithDefaultFM fs
124 (error ("arg no " ++ show i ++ " missing")) i
125
126 eat :: String -> Pretty
127 eat "" = ppNil
128 eat ('#' : c : cs) = farg (atoi c) `ppBeside` eat cs
129 eat (c : cs) = ppChar c `ppBeside` eat cs
130
131 in eat cs
132
133
134
135 passivate :: Opts -> Int -> Id -> [ Exp ] -> Pretty
136 passivate opts p f args =
137 if iduse f == Fn
138 then paren opts (p == 100)
139 (ppfn opts f `ppSep2`
140 ppNest tabstop (ppSepp
141 [ ppp opts 100 arg | arg <- args ])
142 )
143 else case args of
144 [x, y] -> props opts p f x y
145 _ -> error "in ppp: op needs exactly 2 args"
146
147
148 props opts p f x y =
149 case idprec f of
150 Nothing -> paren opts (0 < p) -- todo: 100 more abstract
151 (ppp opts 100 x `ppSep2` ppNest tabstop
152 (ppop opts f `ppSep2` (ppp opts 100 y)))
153 Just q ->
154 let qx = q + offset Lft f x
155 qy = q + offset Rght f y
156 in paren opts (q < p)
157 (ppp opts qx x `ppSep2` ppNest tabstop
158 (ppop opts f `ppSep2` (ppp opts qy y) ))
159
160
161 offset dir f (App id args) =
162 if idlook id == Fn then 0 -- harmless
163 else if idprec id == Nothing then 0 -- will get parens anyway
164 else if the (idprec id) /= the (idprec f) then 0 -- precs are distinct
165 else if id /= f then 1 -- same precs, different ops: need parens
166 else if idbind f == dir then 0 -- i am assoc, need no parens
167 else 1 -- i am not assoc, need paren
168
169
170 {-
171 ppp LaTeX p (App f args) =
172 let ff = idform f
173 fargs = [ lgroup (pp LaTeX arg) | arg <- args ]
174
175 expand "" = ppStr ""
176 expand ('#' : c : cs) =
177 let n = fromEnum c - fromEnum '0'
178 in (fargs !! (n - 1)) `ppBeside` (expand cs)
179 expand (c : cs) = ppChar c `ppBeside` expand cs
180
181 in expand ff
182
183 -}
184
185 {-
186 ppp st _ (Let x b) =
187 ppSep [ ppStr "let", ppNest 4 (pp st b)
188 , ppStr "in", ppNest 4 (pp st x) ]
189 -}
190
191 {-
192 ppp Ascii p (Con x y) = paren Ascii (conprec < p)
193 -- for debugging, show constructors:
194 -- (ppSep [ ppp Ascii conprec x, ppStr "^", ppp Ascii (conprec + 1) y ])
195 (ppSep [ ppp Ascii conprec x, ppp Ascii (conprec + 1) y ])
196
197 ppp LaTeX p (Con x y) = paren LaTeX (conprec < p)
198 (ppBesides [ ppStr "\\con"
199 -- make precedences in constructor args very low
200 -- in order to avoid parentheses that are visually unnecessary
201 , lgroup (ppp LaTeX 0 x)
202 , lgroup (ppp LaTeX 0 y)
203 ])
204 -}
205
206 {-
207 ppp st p (Bpp op (arg : args)) =
208 let q = opprec op
209 in paren st (q < p)
210
211 -- todo: check whether to hide application
212 -- todo: do precedences correctly
213
214 ( ppp st q arg `ppSep2`
215 ppNest tabstop
216 (ppSepp [ ppp st q op `ppSep2` ppp st (q+1) arg
217 | arg <- args ] ))
218 -}