%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+% (c) The University of Glasgow, 1992-2003
%
- Collects a variety of helper functions that
- construct or analyse HsSyn
+Here we collect a variety of helper functions that construct or
+analyse HsSyn. All these functions deal with generic HsSyn; functions
+which deal with the intantiated versions are located elsewhere:
+
+ Parameterised by Module
+ ---------------- -------------
+ RdrName parser/RdrHsSyn
+ Name rename/RnHsSyn
+ Id typecheck/TcHsSyn
\begin{code}
module HsUtils where
import Var ( Id )
import Type ( Type )
import DataCon ( DataCon, dataConWrapId, dataConSourceArity )
-import BasicTypes ( RecFlag(..) )
import OccName ( mkVarOcc )
import Name ( Name )
+import BasicTypes ( RecFlag(..) )
import SrcLoc
import FastString ( mkFastString )
import Outputable
%************************************************************************
%* *
- Some useful helpers for constructing expressions
+ Some useful helpers for constructing syntax
%* *
%************************************************************************
+These functions attempt to construct a not-completely-useless SrcSpan
+from their components, compared with the nl* functions below which
+just attach noSrcSpan to everything.
\begin{code}
mkHsPar :: LHsExpr id -> LHsExpr id
mkHsPar e = L (getLoc e) (HsPar e)
-mkSimpleMatch :: [LPat id] -> LHsExpr id -> Type -> LMatch id
-mkSimpleMatch pats rhs rhs_ty
- = addCLoc (head pats) rhs $
- Match pats Nothing (GRHSs (unguardedRHS rhs) [] rhs_ty)
+-- gaw 2004
+mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
+mkSimpleMatch pats rhs
+ = L loc $
+ Match pats Nothing (GRHSs (unguardedRHS rhs) emptyLocalBinds)
+ where
+ loc = case pats of
+ [] -> getLoc rhs
+ (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
unguardedRHS :: LHsExpr id -> [LGRHS id]
-unguardedRHS rhs@(L loc _) = [L loc (GRHS [L loc (ResultStmt rhs)])]
+unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
mkHsTyApp expr [] = expr
mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
+mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name
mkHsDictApp expr [] = expr
mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
-mkHsLam pats body = mkHsPar (L (getLoc match) (HsLam match))
+mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
where
- match = mkSimpleMatch pats body placeHolderType
+ matches = mkMatchGroup [mkSimpleMatch pats body]
+
+mkMatchGroup :: [LMatch id] -> MatchGroup id
+mkMatchGroup matches = MatchGroup matches placeHolderType
mkHsTyLam [] expr = expr
mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
mkHsDictLam [] expr = expr
mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
-mkHsLet :: Bag (LHsBind name) -> LHsExpr name -> LHsExpr name
-mkHsLet binds expr
- | isEmptyBag binds = expr
- | otherwise = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
+mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
+-- Used for the dictionary bindings gotten from TcSimplify
+-- We make them recursive to be on the safe side
+mkHsDictLet binds expr
+ | isEmptyLHsBinds binds = expr
+ | otherwise = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
+ where
+ val_binds = ValBindsOut [(Recursive, binds)]
mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
-- Used for constructing dictinoary terms etc, so no locations
mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
-- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
mkSimpleHsAlt pat expr
- = mkSimpleMatch [pat] expr placeHolderType
-
-glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
-glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty)
- = GRHSs grhss (binds1 : binds2) ty
+ = mkSimpleMatch [pat] expr
+-------------------------------
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName
-mkHsIntegral i = HsIntegral i placeHolderName
-mkHsFractional f = HsFractional f placeHolderName
-mkNPlusKPat n k = NPlusKPatIn n k placeHolderName
-mkHsDo ctxt stmts = HsDo ctxt stmts [] placeHolderType
+mkHsIntegral i = HsIntegral i noSyntaxExpr
+mkHsFractional f = HsFractional f noSyntaxExpr
+mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
+
+mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType
+mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
+mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType
+mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
+mkRecStmt stmts = RecStmt stmts [] [] [] emptyLHsBinds
+
+-------------------------------
--- A useful function for building @OpApps@. The operator is always a
-- variable, and we don't know the fixity yet.
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
%************************************************************************
%* *
- These ones do not pin on useful locations
- Used mainly for generated code
+ Constructing syntax with no location info
%* *
%************************************************************************
-
\begin{code}
nlHsVar :: id -> LHsExpr id
nlHsVar n = noLoc (HsVar n)
nlWildConPat :: DataCon -> LPat RdrName
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
- (PrefixCon (nOfThem (dataConSourceArity con) wildPat)))
+ (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
nlTuplePat pats box = noLoc (TuplePat pats box)
-wildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
+nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
-nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
-nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
+nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
+nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
-nlHsLam match = noLoc (HsLam match)
+nlHsLam match = noLoc (HsLam (mkMatchGroup [match]))
nlHsPar e = noLoc (HsPar e)
nlHsIf cond true false = noLoc (HsIf cond true false)
-nlHsCase expr matches = noLoc (HsCase expr matches)
+nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches))
nlTuple exprs box = noLoc (ExplicitTuple exprs box)
nlList exprs = noLoc (ExplicitList placeHolderType exprs)
nlHsAppTy f t = noLoc (HsAppTy f t)
nlHsTyVar x = noLoc (HsTyVar x)
nlHsFunTy a b = noLoc (HsFunTy a b)
-
-nlExprStmt expr = noLoc (ExprStmt expr placeHolderType)
-nlBindStmt pat expr = noLoc (BindStmt pat expr)
-nlLetStmt binds = noLoc (LetStmt binds)
-nlResultStmt expr = noLoc (ResultStmt expr)
-nlParStmt stuff = noLoc (ParStmt stuff)
\end{code}
\begin{code}
mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
-mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyBag rhs
+mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
+------------
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
- -> LHsBinds RdrName -> LHsExpr RdrName
- -> LHsBind RdrName
-
-mk_easy_FunBind loc fun pats binds expr
- = L loc (FunBind (L loc fun) False{-not infix-}
- [mk_easy_Match pats binds expr])
+ -> LHsExpr RdrName -> LHsBind RdrName
-mk_easy_Match pats binds expr
- = mkMatch pats expr [HsBindGroup binds [] Recursive]
- -- The renamer expects everything in its input to be a
- -- "recursive" MonoBinds, and it is its job to sort things out
- -- from there.
+mk_easy_FunBind loc fun pats expr
+ = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames)
+ where
+ matches = mkMatchGroup [mkMatch pats expr emptyLocalBinds]
-mk_FunBind :: SrcSpan
- -> RdrName
- -> [([LPat RdrName], LHsExpr RdrName)]
- -> LHsBind RdrName
+------------
+mk_FunBind :: SrcSpan -> RdrName
+ -> [([LPat RdrName], LHsExpr RdrName)]
+ -> LHsBind RdrName
mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
mk_FunBind loc fun pats_and_exprs
- = L loc (FunBind (L loc fun) False{-not infix-}
- [mkMatch p e [] | (p,e) <-pats_and_exprs])
+ = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames)
+ where
+ matches = mkMatchGroup [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
-mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id
+------------
+mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
mkMatch pats expr binds
= noLoc (Match (map paren pats) Nothing
- (GRHSs (unguardedRHS expr) binds placeHolderType))
+ (GRHSs (unguardedRHS expr) binds))
where
paren p = case p of
L _ (VarPat _) -> p
L l _ -> L l (ParPat p)
\end{code}
+
+%************************************************************************
+%* *
+ Collecting binders from HsBindGroups and HsBinds
+%* *
+%************************************************************************
+
+Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
+
+...
+where
+ (x, y) = ...
+ f i j = ...
+ [a, b] = ...
+
+it should return [x, y, f, a, b] (remember, order important).
+
+\begin{code}
+collectLocalBinders :: HsLocalBinds name -> [Located name]
+collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
+collectLocalBinders (HsIPBinds _) = []
+collectLocalBinders EmptyLocalBinds = []
+
+collectHsValBinders :: HsValBinds name -> [Located name]
+collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds
+collectHsValBinders (ValBindsOut binds) = foldr collect_one [] binds
+ where
+ collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
+
+collectAcc :: HsBind name -> [Located name] -> [Located name]
+collectAcc (PatBind pat _ _ _) acc = collectLocatedPatBinders pat ++ acc
+collectAcc (FunBind f _ _ _) acc = f : acc
+collectAcc (VarBind f _) acc = noLoc f : acc
+collectAcc (AbsBinds _ _ dbinds binds) acc
+ = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
+ -- ++ foldr collectAcc acc binds
+ -- I don't think we want the binders from the nested binds
+ -- The only time we collect binders from a typechecked
+ -- binding (hence see AbsBinds) is in zonking in TcHsSyn
+
+collectHsBindBinders :: LHsBinds name -> [name]
+collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
+
+collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
+collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
+\end{code}
+
+
+%************************************************************************
+%* *
+ Getting pattern signatures out of bindings
+%* *
+%************************************************************************
+
+Get all the pattern type signatures out of a bunch of bindings
+
+\begin{code}
+collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name]
+collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds)
+
+collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
+collectSigTysFromHsBind bind
+ = go (unLoc bind)
+ where
+ go (PatBind pat _ _ _)
+ = collectSigTysFromPat pat
+ go (FunBind f _ (MatchGroup ms _) _)
+ = [sig | L _ (Match [] (Just sig) _) <- ms]
+ -- A binding like x :: a = f y
+ -- is parsed as FunMonoBind, but for this purpose we
+ -- want to treat it as a pattern binding
+ go out_bind = panic "collectSigTysFromHsBind"
+\end{code}
+
+%************************************************************************
+%* *
+ Getting binders from statements
+%* *
+%************************************************************************
+
+\begin{code}
+collectLStmtsBinders :: [LStmt id] -> [Located id]
+collectLStmtsBinders = concatMap collectLStmtBinders
+
+collectStmtsBinders :: [Stmt id] -> [Located id]
+collectStmtsBinders = concatMap collectStmtBinders
+
+collectLStmtBinders :: LStmt id -> [Located id]
+collectLStmtBinders = collectStmtBinders . unLoc
+
+collectStmtBinders :: Stmt id -> [Located id]
+ -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
+collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
+collectStmtBinders (LetStmt binds) = collectLocalBinders binds
+collectStmtBinders (ExprStmt _ _ _) = []
+collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
+collectStmtBinders other = panic "collectStmtBinders"
+\end{code}
+
+
+%************************************************************************
+%* *
+%* Gathering stuff out of patterns
+%* *
+%************************************************************************
+
+This function @collectPatBinders@ works with the ``collectBinders''
+functions for @HsBinds@, etc. The order in which the binders are
+collected is important; see @HsBinds.lhs@.
+
+It collects the bounds *value* variables in renamed patterns; type variables
+are *not* collected.
+
+\begin{code}
+collectPatBinders :: LPat a -> [a]
+collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
+
+collectLocatedPatBinders :: LPat a -> [Located a]
+collectLocatedPatBinders pat = collectl pat []
+
+collectPatsBinders :: [LPat a] -> [a]
+collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
+
+collectLocatedPatsBinders :: [LPat a] -> [Located a]
+collectLocatedPatsBinders pats = foldr collectl [] pats
+
+---------------------
+collectl (L l pat) bndrs
+ = go pat
+ where
+ go (VarPat var) = L l var : bndrs
+ go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders bs
+ ++ bndrs
+ go (WildPat _) = bndrs
+ go (LazyPat pat) = collectl pat bndrs
+ go (AsPat a pat) = a : collectl pat bndrs
+ go (ParPat pat) = collectl pat bndrs
+
+ go (ListPat pats _) = foldr collectl bndrs pats
+ go (PArrPat pats _) = foldr collectl bndrs pats
+ go (TuplePat pats _) = foldr collectl bndrs pats
+
+ go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps)
+ go (ConPatOut c _ ds bs ps _) = map noLoc ds
+ ++ collectHsBindLocatedBinders bs
+ ++ foldr collectl bndrs (hsConArgs ps)
+ go (LitPat _) = bndrs
+ go (NPat _ _ _ _) = bndrs
+ go (NPlusKPat n _ _ _) = n : bndrs
+
+ go (SigPatIn pat _) = collectl pat bndrs
+ go (SigPatOut pat _) = collectl pat bndrs
+ go (TypePat ty) = bndrs
+ go (DictPat ids1 ids2) = map noLoc ids1 ++ map noLoc ids2
+ ++ bndrs
+\end{code}
+
+\begin{code}
+collectSigTysFromPats :: [InPat name] -> [LHsType name]
+collectSigTysFromPats pats = foldr collect_lpat [] pats
+
+collectSigTysFromPat :: InPat name -> [LHsType name]
+collectSigTysFromPat pat = collect_lpat pat []
+
+collect_lpat pat acc = collect_pat (unLoc pat) acc
+
+collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc)
+collect_pat (TypePat ty) acc = ty:acc
+
+collect_pat (LazyPat pat) acc = collect_lpat pat acc
+collect_pat (AsPat a pat) acc = collect_lpat pat acc
+collect_pat (ParPat pat) acc = collect_lpat pat acc
+collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats
+collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats
+collect_pat (TuplePat pats _) acc = foldr collect_lpat acc pats
+collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps)
+collect_pat other acc = acc -- Literals, vars, wildcard
+\end{code}