2 % (c) The University of Glasgow, 1992-2003
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:
9 Parameterised by Module
10 ---------------- -------------
11 RdrName parser/RdrHsSyn
18 #include "HsVersions.h"
26 import RdrName ( RdrName, getRdrName, mkRdrUnqual )
29 import DataCon ( DataCon, dataConWrapId, dataConSourceArity )
30 import BasicTypes ( RecFlag(..) )
31 import OccName ( mkVarOcc )
34 import FastString ( mkFastString )
36 import Util ( nOfThem )
41 %************************************************************************
43 Some useful helpers for constructing syntax
45 %************************************************************************
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.
52 mkHsPar :: LHsExpr id -> LHsExpr id
53 mkHsPar e = L (getLoc e) (HsPar e)
55 mkSimpleMatch :: [LPat id] -> LHsExpr id -> Type -> LMatch id
56 mkSimpleMatch pats rhs rhs_ty
58 Match pats Nothing (GRHSs (unguardedRHS rhs) [] rhs_ty)
62 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
64 unguardedRHS :: LHsExpr id -> [LGRHS id]
65 unguardedRHS rhs@(L loc _) = [L loc (GRHS [L loc (ResultStmt rhs)])]
67 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
68 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
70 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
71 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
73 mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name
74 mkHsTyApp expr [] = expr
75 mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
77 mkHsDictApp expr [] = expr
78 mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
80 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
81 mkHsLam pats body = mkHsPar (L (getLoc match) (HsLam match))
83 match = mkSimpleMatch pats body placeHolderType
85 mkHsTyLam [] expr = expr
86 mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
88 mkHsDictLam [] expr = expr
89 mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
91 mkHsLet :: Bag (LHsBind name) -> LHsExpr name -> LHsExpr name
93 | isEmptyBag binds = expr
94 | otherwise = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
96 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
97 -- Used for constructing dictinoary terms etc, so no locations
98 mkHsConApp data_con tys args
99 = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args
101 mk_app f a = noLoc (HsApp f (noLoc a))
103 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
104 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
105 mkSimpleHsAlt pat expr
106 = mkSimpleMatch [pat] expr placeHolderType
108 glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
109 glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty)
110 = GRHSs grhss (binds1 : binds2) ty
112 -- These are the bits of syntax that contain rebindable names
113 -- See RnEnv.lookupSyntaxName
115 mkHsIntegral i = HsIntegral i placeHolderName
116 mkHsFractional f = HsFractional f placeHolderName
117 mkNPlusKPat n k = NPlusKPatIn n k placeHolderName
118 mkHsDo ctxt stmts = HsDo ctxt stmts [] placeHolderType
120 --- A useful function for building @OpApps@. The operator is always a
121 -- variable, and we don't know the fixity yet.
122 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
124 mkHsSplice e = HsSplice unqualSplice e
126 unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
127 -- A name (uniquified later) to
128 -- identify the splice
130 mkHsString s = HsString (mkFastString s)
134 %************************************************************************
136 Constructing syntax with no location info
138 %************************************************************************
141 nlHsVar :: id -> LHsExpr id
142 nlHsVar n = noLoc (HsVar n)
144 nlHsLit :: HsLit -> LHsExpr id
145 nlHsLit n = noLoc (HsLit n)
147 nlVarPat :: id -> LPat id
148 nlVarPat n = noLoc (VarPat n)
150 nlLitPat :: HsLit -> LPat id
151 nlLitPat l = noLoc (LitPat l)
153 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
154 nlHsApp f x = noLoc (HsApp f x)
156 nlHsIntLit n = noLoc (HsLit (HsInt n))
158 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
159 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
161 nlHsVarApps :: id -> [id] -> LHsExpr id
162 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
164 mk f a = HsApp (noLoc f) (noLoc a)
166 nlConVarPat :: id -> [id] -> LPat id
167 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
169 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
170 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
172 nlConPat :: id -> [LPat id] -> LPat id
173 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
175 nlNullaryConPat :: id -> LPat id
176 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
178 nlWildConPat :: DataCon -> LPat RdrName
179 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
180 (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
182 nlTuplePat pats box = noLoc (TuplePat pats box)
183 nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
185 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
186 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
188 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
190 nlHsLam match = noLoc (HsLam match)
191 nlHsPar e = noLoc (HsPar e)
192 nlHsIf cond true false = noLoc (HsIf cond true false)
193 nlHsCase expr matches = noLoc (HsCase expr matches)
194 nlTuple exprs box = noLoc (ExplicitTuple exprs box)
195 nlList exprs = noLoc (ExplicitList placeHolderType exprs)
197 nlHsAppTy f t = noLoc (HsAppTy f t)
198 nlHsTyVar x = noLoc (HsTyVar x)
199 nlHsFunTy a b = noLoc (HsFunTy a b)
201 nlExprStmt expr = noLoc (ExprStmt expr placeHolderType)
202 nlBindStmt pat expr = noLoc (BindStmt pat expr)
203 nlLetStmt binds = noLoc (LetStmt binds)
204 nlResultStmt expr = noLoc (ResultStmt expr)
205 nlParStmt stuff = noLoc (ParStmt stuff)
210 %************************************************************************
212 Bindings; with a location at the top
214 %************************************************************************
217 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
218 mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyBag rhs
220 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
221 -> LHsBinds RdrName -> LHsExpr RdrName
224 mk_easy_FunBind loc fun pats binds expr
225 = L loc (FunBind (L loc fun) False{-not infix-}
226 [mk_easy_Match pats binds expr])
228 mk_easy_Match pats binds expr
229 = mkMatch pats expr [HsBindGroup binds [] Recursive]
230 -- The renamer expects everything in its input to be a
231 -- "recursive" MonoBinds, and it is its job to sort things out
234 mk_FunBind :: SrcSpan
236 -> [([LPat RdrName], LHsExpr RdrName)]
239 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
240 mk_FunBind loc fun pats_and_exprs
241 = L loc (FunBind (L loc fun) False{-not infix-}
242 [mkMatch p e [] | (p,e) <-pats_and_exprs])
244 mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id
245 mkMatch pats expr binds
246 = noLoc (Match (map paren pats) Nothing
247 (GRHSs (unguardedRHS expr) binds placeHolderType))
251 L l _ -> L l (ParPat p)
255 %************************************************************************
257 Collecting binders from HsBindGroups and HsBinds
259 %************************************************************************
261 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
269 it should return [x, y, f, a, b] (remember, order important).
272 collectGroupBinders :: [HsBindGroup name] -> [Located name]
273 collectGroupBinders groups = foldr collect_group [] groups
275 collect_group (HsBindGroup bag sigs is_rec) acc
276 = foldrBag (collectAcc . unLoc) acc bag
277 collect_group (HsIPBinds _) acc = acc
280 collectAcc :: HsBind name -> [Located name] -> [Located name]
281 collectAcc (PatBind pat _) acc = collectLocatedPatBinders pat ++ acc
282 collectAcc (FunBind f _ _) acc = f : acc
283 collectAcc (VarBind f _) acc = noLoc f : acc
284 collectAcc (AbsBinds _ _ dbinds _ binds) acc
285 = [noLoc dp | (_,dp,_) <- dbinds] ++ acc
286 -- ++ foldr collectAcc acc binds
287 -- I don't think we want the binders from the nested binds
288 -- The only time we collect binders from a typechecked
289 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
291 collectHsBindBinders :: Bag (LHsBind name) -> [name]
292 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
294 collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name]
295 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
299 %************************************************************************
301 Getting pattern signatures out of bindings
303 %************************************************************************
305 Get all the pattern type signatures out of a bunch of bindings
308 collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name]
309 collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds)
311 collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
312 collectSigTysFromHsBind bind
315 go (PatBind pat _) = collectSigTysFromPat pat
316 go (FunBind f _ ms) = go_matches (map unLoc ms)
318 -- A binding like x :: a = f y
319 -- is parsed as FunMonoBind, but for this purpose we
320 -- want to treat it as a pattern binding
322 go_matches (Match [] (Just sig) _ : matches) = sig : go_matches matches
323 go_matches (match : matches) = go_matches matches
326 %************************************************************************
328 Getting binders from statements
330 %************************************************************************
333 collectStmtsBinders :: [LStmt id] -> [Located id]
334 collectStmtsBinders = concatMap collectLStmtBinders
336 collectLStmtBinders = collectStmtBinders . unLoc
338 collectStmtBinders :: Stmt id -> [Located id]
339 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
340 collectStmtBinders (BindStmt pat _) = collectLocatedPatBinders pat
341 collectStmtBinders (LetStmt binds) = collectGroupBinders binds
342 collectStmtBinders (ExprStmt _ _) = []
343 collectStmtBinders (ResultStmt _) = []
344 collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss
345 collectStmtBinders other = panic "collectStmtBinders"