[project @ 2005-03-09 17:51:03 by simonpj]
[ghc-hetmet.git] / ghc / compiler / hsSyn / HsUtils.lhs
1 %
2 % (c) The University of Glasgow, 1992-2003
3 %
4
5 Here we collect a variety of helper functions that construct or
6 analyse HsSyn.  All these functions deal with generic HsSyn; functions
7 which deal with the intantiated versions are located elsewhere:
8
9    Parameterised by     Module
10    ----------------     -------------
11    RdrName              parser/RdrHsSyn
12    Name                 rename/RnHsSyn
13    Id                   typecheck/TcHsSyn       
14
15 \begin{code}
16 module HsUtils where
17
18 #include "HsVersions.h"
19
20 import HsBinds
21 import HsExpr
22 import HsPat
23 import HsTypes  
24 import HsLit
25
26 import RdrName          ( RdrName, getRdrName, mkRdrUnqual )
27 import Var              ( Id )
28 import Type             ( Type )
29 import DataCon          ( DataCon, dataConWrapId, dataConSourceArity )
30 import BasicTypes       ( RecFlag(..) )
31 import OccName          ( mkVarOcc )
32 import Name             ( Name )
33 import SrcLoc
34 import FastString       ( mkFastString )
35 import Outputable
36 import Util             ( nOfThem )
37 import Bag
38 \end{code}
39
40
41 %************************************************************************
42 %*                                                                      *
43         Some useful helpers for constructing syntax
44 %*                                                                      *
45 %************************************************************************
46
47 These functions attempt to construct a not-completely-useless SrcSpan
48 from their components, compared with the nl* functions below which
49 just attach noSrcSpan to everything.
50
51 \begin{code}
52 mkHsPar :: LHsExpr id -> LHsExpr id
53 mkHsPar e = L (getLoc e) (HsPar e)
54
55 -- gaw 2004
56 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
57 mkSimpleMatch pats rhs 
58   = L loc $
59     Match pats Nothing (GRHSs (unguardedRHS rhs) [])
60   where
61     loc = case pats of
62                 []      -> getLoc rhs
63                 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
64
65 unguardedRHS :: LHsExpr id -> [LGRHS id]
66 unguardedRHS rhs@(L loc _) = [L loc (GRHS [L loc (ResultStmt rhs)])]
67
68 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
69 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
70
71 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
72 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
73
74 mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name
75 mkHsTyApp expr []  = expr
76 mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
77
78 mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name
79 mkHsDictApp expr []      = expr
80 mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
81
82 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
83 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
84         where
85           matches = mkMatchGroup [mkSimpleMatch pats body]
86
87 mkMatchGroup :: [LMatch id] -> MatchGroup id
88 mkMatchGroup matches = MatchGroup matches placeHolderType
89
90 mkHsTyLam []     expr = expr
91 mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
92
93 mkHsDictLam []    expr = expr
94 mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
95
96 mkHsLet :: LHsBinds name -> LHsExpr name -> LHsExpr name
97 mkHsLet binds expr 
98   | isEmptyLHsBinds binds = expr
99   | otherwise             = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
100
101 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
102 -- Used for constructing dictinoary terms etc, so no locations 
103 mkHsConApp data_con tys args 
104   = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args
105   where
106     mk_app f a = noLoc (HsApp f (noLoc a))
107
108 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
109 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
110 mkSimpleHsAlt pat expr 
111   = mkSimpleMatch [pat] expr
112
113 glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
114 -- gaw 2004
115 glueBindsOnGRHSs binds1 (GRHSs grhss binds2)
116   = GRHSs grhss (binds1 : binds2)
117
118 -- These are the bits of syntax that contain rebindable names
119 -- See RnEnv.lookupSyntaxName
120
121 mkHsIntegral   i      = HsIntegral   i  placeHolderName
122 mkHsFractional f      = HsFractional f  placeHolderName
123 mkNPlusKPat n k       = NPlusKPatIn n k placeHolderName
124 mkHsDo ctxt stmts     = HsDo ctxt stmts [] placeHolderType
125
126 --- A useful function for building @OpApps@.  The operator is always a
127 -- variable, and we don't know the fixity yet.
128 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
129
130 mkHsSplice e = HsSplice unqualSplice e
131
132 unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
133                 -- A name (uniquified later) to
134                 -- identify the splice
135
136 mkHsString s = HsString (mkFastString s)
137 \end{code}
138
139
140 %************************************************************************
141 %*                                                                      *
142         Constructing syntax with no location info
143 %*                                                                      *
144 %************************************************************************
145
146 \begin{code}
147 nlHsVar :: id -> LHsExpr id
148 nlHsVar n = noLoc (HsVar n)
149
150 nlHsLit :: HsLit -> LHsExpr id
151 nlHsLit n = noLoc (HsLit n)
152
153 nlVarPat :: id -> LPat id
154 nlVarPat n = noLoc (VarPat n)
155
156 nlLitPat :: HsLit -> LPat id
157 nlLitPat l = noLoc (LitPat l)
158
159 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
160 nlHsApp f x = noLoc (HsApp f x)
161
162 nlHsIntLit n = noLoc (HsLit (HsInt n))
163
164 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
165 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
166              
167 nlHsVarApps :: id -> [id] -> LHsExpr id
168 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
169                  where
170                    mk f a = HsApp (noLoc f) (noLoc a)
171
172 nlConVarPat :: id -> [id] -> LPat id
173 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
174
175 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
176 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
177
178 nlConPat :: id -> [LPat id] -> LPat id
179 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
180
181 nlNullaryConPat :: id -> LPat id
182 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
183
184 nlWildConPat :: DataCon -> LPat RdrName
185 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
186                                    (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
187
188 nlTuplePat pats box = noLoc (TuplePat pats box)
189 nlWildPat  = noLoc (WildPat placeHolderType)    -- Pre-typechecking
190
191 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
192 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
193
194 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
195
196 nlHsLam match           = noLoc (HsLam (mkMatchGroup [match]))
197 nlHsPar e               = noLoc (HsPar e)
198 nlHsIf cond true false  = noLoc (HsIf cond true false)
199 nlHsCase expr matches   = noLoc (HsCase expr (mkMatchGroup matches))
200 nlTuple exprs box       = noLoc (ExplicitTuple exprs box)
201 nlList exprs            = noLoc (ExplicitList placeHolderType exprs)
202
203 nlHsAppTy f t           = noLoc (HsAppTy f t)
204 nlHsTyVar x             = noLoc (HsTyVar x)
205 nlHsFunTy a b           = noLoc (HsFunTy a b)
206
207 nlExprStmt expr         = noLoc (ExprStmt expr placeHolderType)
208 nlBindStmt pat expr     = noLoc (BindStmt pat expr)
209 nlLetStmt binds         = noLoc (LetStmt binds)
210 nlResultStmt expr       = noLoc (ResultStmt expr)
211 nlParStmt stuff         = noLoc (ParStmt stuff)
212 \end{code}
213
214
215
216 %************************************************************************
217 %*                                                                      *
218                 Bindings; with a location at the top
219 %*                                                                      *
220 %************************************************************************
221
222 \begin{code}
223 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
224 mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyLHsBinds rhs
225
226 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
227                     -> LHsBinds RdrName -> LHsExpr RdrName
228                     -> LHsBind RdrName
229
230 mk_easy_FunBind loc fun pats binds expr
231   = L loc (FunBind (L loc fun) False{-not infix-} 
232                    (mkMatchGroup [mk_easy_Match pats binds expr]))
233
234 mk_easy_Match pats binds expr
235   = mkMatch pats expr [HsBindGroup binds [] Recursive]
236         -- The renamer expects everything in its input to be a
237         -- "recursive" MonoBinds, and it is its job to sort things out
238         -- from there.
239
240 mk_FunBind      :: SrcSpan 
241                 -> RdrName
242                 -> [([LPat RdrName], LHsExpr RdrName)]
243                 -> LHsBind RdrName
244
245 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
246 mk_FunBind loc fun pats_and_exprs
247   = L loc (FunBind (L loc fun) False{-not infix-} 
248                    (mkMatchGroup [mkMatch p e [] | (p,e) <-pats_and_exprs]))
249
250 mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id
251 mkMatch pats expr binds
252   = noLoc (Match (map paren pats) Nothing 
253 -- gaw 2004
254                  (GRHSs (unguardedRHS expr) binds))
255   where
256     paren p = case p of
257                 L _ (VarPat _) -> p
258                 L l _          -> L l (ParPat p)
259 \end{code}
260
261
262 %************************************************************************
263 %*                                                                      *
264         Collecting binders from HsBindGroups and HsBinds
265 %*                                                                      *
266 %************************************************************************
267
268 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
269
270 ...
271 where
272   (x, y) = ...
273   f i j  = ...
274   [a, b] = ...
275
276 it should return [x, y, f, a, b] (remember, order important).
277
278 \begin{code}
279 collectGroupBinders :: [HsBindGroup name] -> [Located name]
280 collectGroupBinders groups = foldr collect_group [] groups
281         where
282           collect_group (HsBindGroup bag sigs is_rec) acc
283                 = foldrBag (collectAcc . unLoc) acc bag
284           collect_group (HsIPBinds _) acc = acc
285
286
287 collectAcc :: HsBind name -> [Located name] -> [Located name]
288 collectAcc (PatBind pat _ _) acc = collectLocatedPatBinders pat ++ acc
289 collectAcc (FunBind f _ _) acc   = f : acc
290 collectAcc (VarBind f _) acc  = noLoc f : acc
291 collectAcc (AbsBinds _ _ dbinds _ binds) acc
292   = [noLoc dp | (_,dp,_) <- dbinds] ++ acc
293         -- ++ foldr collectAcc acc binds
294         -- I don't think we want the binders from the nested binds
295         -- The only time we collect binders from a typechecked 
296         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
297
298 collectHsBindBinders :: Bag (LHsBind name) -> [name]
299 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
300
301 collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name]
302 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
303 \end{code}
304
305
306 %************************************************************************
307 %*                                                                      *
308         Getting pattern signatures out of bindings
309 %*                                                                      *
310 %************************************************************************
311
312 Get all the pattern type signatures out of a bunch of bindings
313
314 \begin{code}
315 collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name]
316 collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds)
317
318 collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
319 collectSigTysFromHsBind bind
320   = go (unLoc bind)
321   where
322     go (PatBind pat _ _) 
323         = collectSigTysFromPat pat
324     go (FunBind f _ (MatchGroup ms _))
325         = [sig | L _ (Match [] (Just sig) _) <- ms]
326         -- A binding like    x :: a = f y
327         -- is parsed as FunMonoBind, but for this purpose we    
328         -- want to treat it as a pattern binding
329 \end{code}
330
331 %************************************************************************
332 %*                                                                      *
333         Getting binders from statements
334 %*                                                                      *
335 %************************************************************************
336
337 \begin{code}
338 collectStmtsBinders :: [LStmt id] -> [Located id]
339 collectStmtsBinders = concatMap collectLStmtBinders
340
341 collectLStmtBinders = collectStmtBinders . unLoc
342
343 collectStmtBinders :: Stmt id -> [Located id]
344   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
345 collectStmtBinders (BindStmt pat _)   = collectLocatedPatBinders pat
346 collectStmtBinders (LetStmt binds)    = collectGroupBinders binds
347 collectStmtBinders (ExprStmt _ _)     = []
348 collectStmtBinders (ResultStmt _)     = []
349 collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss
350 collectStmtBinders other              = panic "collectStmtBinders"
351 \end{code}
352
353
354 %************************************************************************
355 %*                                                                      *
356 %*      Gathering stuff out of patterns
357 %*                                                                      *
358 %************************************************************************
359
360 This function @collectPatBinders@ works with the ``collectBinders''
361 functions for @HsBinds@, etc.  The order in which the binders are
362 collected is important; see @HsBinds.lhs@.
363
364 It collects the bounds *value* variables in renamed patterns; type variables
365 are *not* collected.
366
367 \begin{code}
368 collectPatBinders :: LPat a -> [a]
369 collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
370
371 collectLocatedPatBinders :: LPat a -> [Located a]
372 collectLocatedPatBinders pat = collectl pat []
373
374 collectPatsBinders :: [LPat a] -> [a]
375 collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
376
377 collectLocatedPatsBinders :: [LPat a] -> [Located a]
378 collectLocatedPatsBinders pats = foldr collectl [] pats
379
380 ---------------------
381 collectl (L l (VarPat var)) bndrs = L l var : bndrs
382 collectl (L l (VarPatOut var bs)) bndrs = L l var : collectHsBindLocatedBinders bs 
383                                           ++ bndrs
384 collectl (L l pat) bndrs = collect pat bndrs
385
386 ---------------------
387 collect (WildPat _)                bndrs = bndrs
388 collect (LazyPat pat)              bndrs = collectl pat bndrs
389 collect (AsPat a pat)              bndrs = a : collectl pat bndrs
390 collect (ParPat  pat)              bndrs = collectl pat bndrs
391
392 collect (ListPat pats _)           bndrs = foldr collectl bndrs pats
393 collect (PArrPat pats _)           bndrs = foldr collectl bndrs pats
394 collect (TuplePat pats _)          bndrs = foldr collectl bndrs pats
395
396 collect (ConPatIn c ps)            bndrs = foldr collectl bndrs (hsConArgs ps)
397 collect (ConPatOut c _ ds bs ps _) bndrs = map noLoc ds
398                                            ++ collectHsBindLocatedBinders bs
399                                            ++ foldr collectl bndrs (hsConArgs ps)
400 collect (LitPat _)               bndrs = bndrs
401 collect (NPatIn _ _)             bndrs = bndrs
402 collect (NPatOut _ _ _)          bndrs = bndrs
403
404 collect (NPlusKPatIn n _ _)      bndrs = n : bndrs
405 collect (NPlusKPatOut n _ _ _)   bndrs = n : bndrs
406
407 collect (SigPatIn pat _)         bndrs = collectl pat bndrs
408 collect (SigPatOut pat _)        bndrs = collectl pat bndrs
409 collect (TypePat ty)             bndrs = bndrs
410 collect (DictPat ids1 ids2)      bndrs = map noLoc ids1 ++ map noLoc ids2
411                                            ++ bndrs
412 \end{code}
413
414 \begin{code}
415 collectSigTysFromPats :: [InPat name] -> [LHsType name]
416 collectSigTysFromPats pats = foldr collect_lpat [] pats
417
418 collectSigTysFromPat :: InPat name -> [LHsType name]
419 collectSigTysFromPat pat = collect_lpat pat []
420
421 collect_lpat pat acc = collect_pat (unLoc pat) acc
422
423 collect_pat (SigPatIn pat ty)  acc = collect_lpat pat (ty:acc)
424 collect_pat (TypePat ty)       acc = ty:acc
425
426 collect_pat (LazyPat pat)      acc = collect_lpat pat acc
427 collect_pat (AsPat a pat)      acc = collect_lpat pat acc
428 collect_pat (ParPat  pat)      acc = collect_lpat pat acc
429 collect_pat (ListPat pats _)   acc = foldr collect_lpat acc pats
430 collect_pat (PArrPat pats _)   acc = foldr collect_lpat acc pats
431 collect_pat (TuplePat pats _)  acc = foldr collect_lpat acc pats
432 collect_pat (ConPatIn c ps)    acc = foldr collect_lpat acc (hsConArgs ps)
433 collect_pat other              acc = acc        -- Literals, vars, wildcard
434 \end{code}