2 % (c) The University of Glasgow, 1992-2006
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"
42 %************************************************************************
44 Some useful helpers for constructing syntax
46 %************************************************************************
48 These functions attempt to construct a not-completely-useless SrcSpan
49 from their components, compared with the nl* functions below which
50 just attach noSrcSpan to everything.
53 mkHsPar :: LHsExpr id -> LHsExpr id
54 mkHsPar e = L (getLoc e) (HsPar e)
57 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
58 mkSimpleMatch pats rhs
60 Match pats Nothing (GRHSs (unguardedRHS rhs) emptyLocalBinds)
64 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
66 unguardedRHS :: LHsExpr id -> [LGRHS id]
67 unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
69 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
70 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
72 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
73 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
75 nlHsTyApp :: name -> [Type] -> LHsExpr name
76 nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
78 mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
79 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
81 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
82 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
83 | otherwise = HsWrap co_fn e
85 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
86 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
88 matches = mkMatchGroup [mkSimpleMatch pats body]
90 mkMatchGroup :: [LMatch id] -> MatchGroup id
91 mkMatchGroup matches = MatchGroup matches placeHolderType
93 mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
94 -- Used for the dictionary bindings gotten from TcSimplify
95 -- We make them recursive to be on the safe side
96 mkHsDictLet binds expr
97 | isEmptyLHsBinds binds = expr
98 | otherwise = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
100 val_binds = ValBindsOut [(Recursive, binds)] []
102 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
103 -- Used for constructing dictinoary terms etc, so no locations
104 mkHsConApp data_con tys args
105 = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
107 mk_app f a = noLoc (HsApp f (noLoc a))
109 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
110 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
111 mkSimpleHsAlt pat expr
112 = mkSimpleMatch [pat] expr
114 -------------------------------
115 -- These are the bits of syntax that contain rebindable names
116 -- See RnEnv.lookupSyntaxName
118 mkHsIntegral i = HsIntegral i noSyntaxExpr
119 mkHsFractional f = HsFractional f noSyntaxExpr
120 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
122 mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType
123 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
125 mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType
126 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
127 mkRecStmt stmts = RecStmt stmts [] [] [] emptyLHsBinds
129 -------------------------------
130 --- A useful function for building @OpApps@. The operator is always a
131 -- variable, and we don't know the fixity yet.
132 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
134 mkHsSplice e = HsSplice unqualSplice e
136 unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice"))
137 -- A name (uniquified later) to
138 -- identify the splice
140 mkHsString s = HsString (mkFastString s)
143 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
144 userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
148 %************************************************************************
150 Constructing syntax with no location info
152 %************************************************************************
155 nlHsVar :: id -> LHsExpr id
156 nlHsVar n = noLoc (HsVar n)
158 nlHsLit :: HsLit -> LHsExpr id
159 nlHsLit n = noLoc (HsLit n)
161 nlVarPat :: id -> LPat id
162 nlVarPat n = noLoc (VarPat n)
164 nlLitPat :: HsLit -> LPat id
165 nlLitPat l = noLoc (LitPat l)
167 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
168 nlHsApp f x = noLoc (HsApp f x)
170 nlHsIntLit n = noLoc (HsLit (HsInt n))
172 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
173 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
175 nlHsVarApps :: id -> [id] -> LHsExpr id
176 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
178 mk f a = HsApp (noLoc f) (noLoc a)
180 nlConVarPat :: id -> [id] -> LPat id
181 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
183 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
184 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
186 nlConPat :: id -> [LPat id] -> LPat id
187 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
189 nlNullaryConPat :: id -> LPat id
190 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
192 nlWildConPat :: DataCon -> LPat RdrName
193 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
194 (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
196 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
197 nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
199 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
200 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
202 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
204 nlHsLam match = noLoc (HsLam (mkMatchGroup [match]))
205 nlHsPar e = noLoc (HsPar e)
206 nlHsIf cond true false = noLoc (HsIf cond true false)
207 nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches))
208 nlTuple exprs box = noLoc (ExplicitTuple exprs box)
209 nlList exprs = noLoc (ExplicitList placeHolderType exprs)
211 nlHsAppTy f t = noLoc (HsAppTy f t)
212 nlHsTyVar x = noLoc (HsTyVar x)
213 nlHsFunTy a b = noLoc (HsFunTy a b)
218 %************************************************************************
220 Bindings; with a location at the top
222 %************************************************************************
225 mkFunBind :: Located id -> [LMatch id] -> HsBind id
226 -- Not infix, with place holders for coercion and free vars
227 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
228 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
232 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
233 mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
236 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
237 -> LHsExpr RdrName -> LHsBind RdrName
239 mk_easy_FunBind loc fun pats expr
240 = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
243 mk_FunBind :: SrcSpan -> RdrName
244 -> [([LPat RdrName], LHsExpr RdrName)]
247 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
248 mk_FunBind loc fun pats_and_exprs
249 = L loc $ mkFunBind (L loc fun) matches
251 matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
254 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
255 mkMatch pats expr binds
256 = noLoc (Match (map paren pats) Nothing
257 (GRHSs (unguardedRHS expr) binds))
261 L l _ -> L l (ParPat p)
265 %************************************************************************
267 Collecting binders from HsBindGroups and HsBinds
269 %************************************************************************
271 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
279 it should return [x, y, f, a, b] (remember, order important).
282 collectLocalBinders :: HsLocalBinds name -> [Located name]
283 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
284 collectLocalBinders (HsIPBinds _) = []
285 collectLocalBinders EmptyLocalBinds = []
287 collectHsValBinders :: HsValBinds name -> [Located name]
288 collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds
289 collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds
291 collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
293 collectAcc :: HsBind name -> [Located name] -> [Located name]
294 collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc
295 collectAcc (FunBind { fun_id = f }) acc = f : acc
296 collectAcc (VarBind { var_id = f }) acc = noLoc f : acc
297 collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc
298 = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
299 -- ++ foldr collectAcc acc binds
300 -- I don't think we want the binders from the nested binds
301 -- The only time we collect binders from a typechecked
302 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
304 collectHsBindBinders :: LHsBinds name -> [name]
305 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
307 collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
308 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
312 %************************************************************************
314 Getting binders from statements
316 %************************************************************************
319 collectLStmtsBinders :: [LStmt id] -> [Located id]
320 collectLStmtsBinders = concatMap collectLStmtBinders
322 collectStmtsBinders :: [Stmt id] -> [Located id]
323 collectStmtsBinders = concatMap collectStmtBinders
325 collectLStmtBinders :: LStmt id -> [Located id]
326 collectLStmtBinders = collectStmtBinders . unLoc
328 collectStmtBinders :: Stmt id -> [Located id]
329 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
330 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
331 collectStmtBinders (LetStmt binds) = collectLocalBinders binds
332 collectStmtBinders (ExprStmt _ _ _) = []
333 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
334 collectStmtBinders other = panic "collectStmtBinders"
338 %************************************************************************
340 %* Gathering stuff out of patterns
342 %************************************************************************
344 This function @collectPatBinders@ works with the ``collectBinders''
345 functions for @HsBinds@, etc. The order in which the binders are
346 collected is important; see @HsBinds.lhs@.
348 It collects the bounds *value* variables in renamed patterns; type variables
352 collectPatBinders :: LPat a -> [a]
353 collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
355 collectLocatedPatBinders :: LPat a -> [Located a]
356 collectLocatedPatBinders pat = collectl pat []
358 collectPatsBinders :: [LPat a] -> [a]
359 collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
361 collectLocatedPatsBinders :: [LPat a] -> [Located a]
362 collectLocatedPatsBinders pats = foldr collectl [] pats
364 ---------------------
365 collectl (L l pat) bndrs
368 go (VarPat var) = L l var : bndrs
369 go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders bs
371 go (WildPat _) = bndrs
372 go (LazyPat pat) = collectl pat bndrs
373 go (BangPat pat) = collectl pat bndrs
374 go (AsPat a pat) = a : collectl pat bndrs
375 go (ParPat pat) = collectl pat bndrs
377 go (ListPat pats _) = foldr collectl bndrs pats
378 go (PArrPat pats _) = foldr collectl bndrs pats
379 go (TuplePat pats _ _) = foldr collectl bndrs pats
381 go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps)
382 go (ConPatOut { pat_dicts = ds,
383 pat_binds = bs, pat_args = ps })
385 ++ collectHsBindLocatedBinders bs
386 ++ foldr collectl bndrs (hsConArgs ps)
387 go (LitPat _) = bndrs
388 go (NPat _ _ _ _) = bndrs
389 go (NPlusKPat n _ _ _) = n : bndrs
391 go (SigPatIn pat _) = collectl pat bndrs
392 go (SigPatOut pat _) = collectl pat bndrs
393 go (TypePat ty) = bndrs
394 go (DictPat ids1 ids2) = map noLoc ids1 ++ map noLoc ids2
396 go (CoPat _ pat ty) = collectl (noLoc pat) bndrs
400 collectSigTysFromPats :: [InPat name] -> [LHsType name]
401 collectSigTysFromPats pats = foldr collect_lpat [] pats
403 collectSigTysFromPat :: InPat name -> [LHsType name]
404 collectSigTysFromPat pat = collect_lpat pat []
406 collect_lpat pat acc = collect_pat (unLoc pat) acc
408 collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc)
409 collect_pat (TypePat ty) acc = ty:acc
411 collect_pat (LazyPat pat) acc = collect_lpat pat acc
412 collect_pat (BangPat pat) acc = collect_lpat pat acc
413 collect_pat (AsPat a pat) acc = collect_lpat pat acc
414 collect_pat (ParPat pat) acc = collect_lpat pat acc
415 collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats
416 collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats
417 collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
418 collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps)
419 collect_pat other acc = acc -- Literals, vars, wildcard
422 %************************************************************************
424 %* Getting the main binder name of a top declaration
426 %************************************************************************
430 getMainDeclBinder :: HsDecl name -> Maybe name
431 getMainDeclBinder (TyClD d) = Just (tcdName d)
432 getMainDeclBinder (ValD d)
433 = case collectAcc d [] of
434 [] -> Nothing -- see rn003
435 (name:_) -> Just (unLoc name)
436 getMainDeclBinder (SigD d) = sigNameNoLoc d
437 getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)
438 getMainDeclBinder (ForD (ForeignExport name _ _)) = Just (unLoc name)
439 getMainDeclBinder _ = Nothing