X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=c1d1a10b2eaf1fa59c8b8a2de920e80826e73931;hb=74b27e20425336403d80e942ee3faf00f8c36ef8;hp=b0978ec6494b5f296fb2b6d07a0af9a6782ec735;hpb=85eebc52605f5fd4d3bbdb1a37f7134948f740ca;p=ghc-hetmet.git diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index b0978ec..c1d1a10 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -1,5 +1,5 @@ % -% (c) The University of Glasgow, 1992-2003 +% (c) The University of Glasgow, 1992-2006 % Here we collect a variety of helper functions that construct or @@ -22,19 +22,17 @@ import HsExpr import HsPat import HsTypes import HsLit -import HsDecls - -import RdrName ( RdrName, getRdrName, mkRdrUnqual ) -import Var ( Id ) -import Type ( Type ) -import DataCon ( DataCon, dataConWrapId, dataConSourceArity ) -import OccName ( mkVarOccFS ) -import Name ( Name ) -import BasicTypes ( RecFlag(..) ) + +import RdrName +import Var +import Type +import DataCon +import Name +import BasicTypes import SrcLoc -import FastString ( mkFastString ) +import FastString import Outputable -import Util ( nOfThem ) +import Util import Bag \end{code} @@ -53,16 +51,18 @@ just attach noSrcSpan to everything. mkHsPar :: LHsExpr id -> LHsExpr id mkHsPar e = L (getLoc e) (HsPar e) --- gaw 2004 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id mkSimpleMatch pats rhs = L loc $ - Match pats Nothing (GRHSs (unguardedRHS rhs) emptyLocalBinds) + Match pats Nothing (unguardedGRHSs rhs) where loc = case pats of [] -> getLoc rhs (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) +unguardedGRHSs :: LHsExpr id -> GRHSs id +unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds + unguardedRHS :: LHsExpr id -> [LGRHS id] unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)] @@ -117,6 +117,7 @@ mkSimpleHsAlt pat expr mkHsIntegral i = HsIntegral i noSyntaxExpr mkHsFractional f = HsFractional f noSyntaxExpr +mkHsIsString s = HsIsString s noSyntaxExpr mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType @@ -211,6 +212,8 @@ 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) + +nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys \end{code} @@ -225,7 +228,8 @@ nlHsFunTy a b = noLoc (HsFunTy a b) mkFunBind :: Located id -> [LMatch id] -> HsBind id -- Not infix, with place holders for coercion and free vars mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms, - fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames } + fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, + fun_tick = Nothing } mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName @@ -315,22 +319,24 @@ collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds %************************************************************************ \begin{code} -collectLStmtsBinders :: [LStmt id] -> [Located id] +collectLStmtsBinders :: OutputableBndr id => [LStmt id] -> [Located id] collectLStmtsBinders = concatMap collectLStmtBinders -collectStmtsBinders :: [Stmt id] -> [Located id] +collectStmtsBinders :: OutputableBndr id => [Stmt id] -> [Located id] collectStmtsBinders = concatMap collectStmtBinders -collectLStmtBinders :: LStmt id -> [Located id] +collectLStmtBinders :: OutputableBndr id => LStmt id -> [Located id] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: Stmt id -> [Located id] +collectStmtBinders :: OutputableBndr id => 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" +collectStmtBinders (ExprStmt _ _ _) = [] +collectStmtBinders (ParStmt xs) = collectLStmtsBinders + $ concatMap fst xs +collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss +collectStmtBinders s = pprPanic "collectStmtBinders" (ppr s) \end{code} @@ -378,23 +384,28 @@ collectl (L l pat) bndrs go (TuplePat pats _ _) = foldr collectl bndrs pats go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps) - go (ConPatOut { pat_dicts = ds, - pat_binds = bs, pat_args = ps }) - = map noLoc ds - ++ collectHsBindLocatedBinders bs - ++ foldr collectl bndrs (hsConArgs ps) + go (ConPatOut {pat_args=ps}) = foldr collectl bndrs (hsConArgs ps) + -- See Note [Dictionary binders in ConPatOut] 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 go (CoPat _ pat ty) = collectl (noLoc pat) bndrs \end{code} +Note [Dictionary binders in ConPatOut] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do *not* gather (a) dictionary and (b) dictionary bindings as binders +of a ConPatOut pattern. For most calls it doesn't matter, because +it's pre-typechecker and there are no ConPatOuts. But it does matter +more in the desugarer; for example, DsUtils.mkSelectorBinds uses +collectPatBinders. In a lazy pattern, for example f ~(C x y) = ..., +we want to generate bindings for x,y but not for dictionaries bound by +C. (The type checker ensures they would not be used.) + \begin{code} collectSigTysFromPats :: [InPat name] -> [LHsType name] collectSigTysFromPats pats = foldr collect_lpat [] pats @@ -417,24 +428,3 @@ 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} - -%************************************************************************ -%* * -%* Getting the main binder name of a top declaration -%* * -%************************************************************************ - -\begin{code} - -getMainDeclBinder :: HsDecl name -> Maybe name -getMainDeclBinder (TyClD d) = Just (tcdName d) -getMainDeclBinder (ValD d) - = case collectAcc d [] of - [] -> Nothing -- see rn003 - (name:_) -> Just (unLoc name) -getMainDeclBinder (SigD d) = sigNameNoLoc d -getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name) -getMainDeclBinder (ForD (ForeignExport name _ _)) = Just (unLoc name) -getMainDeclBinder _ = Nothing - -\end{code}