X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=bd1fc21293620ea09e41abafde8f8e06fb73d9a3;hb=5b9a21bf48e3197816981575aeb1ab72544ed2ad;hp=1839aefa0d0faf2ae58c231e99ae737c77ec00fc;hpb=15cb792d18b1094e98c035dca6ecec5dad516056;p=ghc-hetmet.git diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 1839aef..bd1fc21 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 @@ -23,17 +23,16 @@ import HsPat import HsTypes import HsLit -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} @@ -52,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)] @@ -72,14 +73,14 @@ mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) nlHsTyApp :: name -> [Type] -> LHsExpr name -nlHsTyApp fun_id tys = noLoc (HsCoerce (mkCoTyApps tys) (HsVar fun_id)) +nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id)) -mkLHsCoerce :: ExprCoFn -> LHsExpr id -> LHsExpr id -mkLHsCoerce co_fn (L loc e) = L loc (mkHsCoerce co_fn e) +mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id +mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) -mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id -mkHsCoerce co_fn e | isIdCoercion co_fn = e - | otherwise = HsCoerce co_fn e +mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id +mkHsWrap co_fn e | isIdHsWrapper co_fn = e + | otherwise = HsWrap co_fn e mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) @@ -116,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 @@ -210,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} @@ -224,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 = idCoercion, bind_fvs = placeHolderNames } + fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, + fun_tick = Nothing } mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName @@ -314,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} @@ -377,15 +384,12 @@ 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 @@ -394,6 +398,16 @@ collectl (L l pat) 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