X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=5d106f191d3153349162b490630caa4eedecfaae;hb=206b4dec78250efef3cd927d64dc6cbc54a16c3d;hp=8cef12e97d5e65487e9871ca7fcd795764378ec6;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf;p=ghc-hetmet.git diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 8cef12e..5d106f1 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -13,11 +13,11 @@ which deal with the intantiated versions are located elsewhere: Id typecheck/TcHsSyn \begin{code} -{-# OPTIONS_GHC -w #-} +{-# OPTIONS -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details module HsUtils where @@ -32,6 +32,7 @@ import HsLit import RdrName import Var +import Coercion import Type import DataCon import Name @@ -87,7 +88,15 @@ mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id mkHsWrap co_fn e | isIdHsWrapper co_fn = e - | otherwise = HsWrap co_fn e + | otherwise = HsWrap co_fn e + +mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id +mkHsWrapCoI IdCo e = e +mkHsWrapCoI (ACo co) e = mkHsWrap (WpCo co) e + +coiToHsWrapper :: CoercionI -> HsWrapper +coiToHsWrapper IdCo = idHsWrapper +coiToHsWrapper (ACo co) = WpCo co mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) @@ -127,9 +136,16 @@ 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 +mkNPat lit neg = NPat lit neg noSyntaxExpr mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr +mkTransformStmt stmts usingExpr = TransformStmt (stmts, []) usingExpr Nothing +mkTransformByStmt stmts usingExpr byExpr = TransformStmt (stmts, []) usingExpr (Just byExpr) + +mkGroupUsingStmt stmts usingExpr = GroupStmt (stmts, []) (GroupByNothing usingExpr) +mkGroupByStmt stmts byExpr = GroupStmt (stmts, []) (GroupBySomething (Right noSyntaxExpr) byExpr) +mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt (stmts, []) (GroupBySomething (Left usingExpr) byExpr) + mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr mkRecStmt stmts = RecStmt stmts [] [] [] emptyLHsBinds @@ -239,20 +255,20 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatc fun_tick = Nothing } -mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName +mkVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs ------------ -mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] - -> LHsExpr RdrName -> LHsBind RdrName +mk_easy_FunBind :: SrcSpan -> id -> [LPat id] + -> LHsExpr id -> LHsBind id mk_easy_FunBind loc fun pats expr = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds] ------------ -mk_FunBind :: SrcSpan -> RdrName - -> [([LPat RdrName], LHsExpr RdrName)] - -> LHsBind RdrName +mk_FunBind :: SrcSpan -> id + -> [([LPat id], LHsExpr id)] + -> LHsBind id mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind" mk_FunBind loc fun pats_and_exprs @@ -289,18 +305,18 @@ where it should return [x, y, f, a, b] (remember, order important). \begin{code} -collectLocalBinders :: HsLocalBinds name -> [Located name] +collectLocalBinders :: HsLocalBindsLR idL idR -> [Located idL] collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds collectLocalBinders (HsIPBinds _) = [] collectLocalBinders EmptyLocalBinds = [] -collectHsValBinders :: HsValBinds name -> [Located name] +collectHsValBinders :: HsValBindsLR idL idR -> [Located idL] collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds where collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds -collectAcc :: HsBind name -> [Located name] -> [Located name] +collectAcc :: HsBindLR idL idR -> [Located idL] -> [Located idL] collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc collectAcc (FunBind { fun_id = f }) acc = f : acc collectAcc (VarBind { var_id = f }) acc = noLoc f : acc @@ -311,10 +327,10 @@ collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc -- The only time we collect binders from a typechecked -- binding (hence see AbsBinds) is in zonking in TcHsSyn -collectHsBindBinders :: LHsBinds name -> [name] +collectHsBindBinders :: LHsBindsLR idL idR -> [idL] collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds) -collectHsBindLocatedBinders :: LHsBinds name -> [Located name] +collectHsBindLocatedBinders :: LHsBindsLR idL idR -> [Located idL] collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds \end{code} @@ -326,24 +342,25 @@ collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds %************************************************************************ \begin{code} -collectLStmtsBinders :: OutputableBndr id => [LStmt id] -> [Located id] +collectLStmtsBinders :: [LStmtLR idL idR] -> [Located idL] collectLStmtsBinders = concatMap collectLStmtBinders -collectStmtsBinders :: OutputableBndr id => [Stmt id] -> [Located id] +collectStmtsBinders :: [StmtLR idL idR] -> [Located idL] collectStmtsBinders = concatMap collectStmtBinders -collectLStmtBinders :: OutputableBndr id => LStmt id -> [Located id] +collectLStmtBinders :: LStmtLR idL idR -> [Located idL] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: OutputableBndr id => Stmt id -> [Located id] +collectStmtBinders :: StmtLR idL idR -> [Located idL] -- 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 (ParStmt xs) = collectLStmtsBinders $ concatMap fst xs +collectStmtBinders (TransformStmt (stmts, _) _ _) = collectLStmtsBinders stmts +collectStmtBinders (GroupStmt (stmts, _) _) = collectLStmtsBinders stmts collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss -collectStmtBinders s = pprPanic "collectStmtBinders" (ppr s) \end{code} @@ -384,6 +401,7 @@ collectl (L l pat) bndrs go (LazyPat pat) = collectl pat bndrs go (BangPat pat) = collectl pat bndrs go (AsPat a pat) = a : collectl pat bndrs + go (ViewPat exp pat _) = collectl pat bndrs go (ParPat pat) = collectl pat bndrs go (ListPat pats _) = foldr collectl bndrs pats @@ -394,7 +412,7 @@ collectl (L l pat) bndrs go (ConPatOut {pat_args=ps}) = foldr collectl bndrs (hsConPatArgs ps) -- See Note [Dictionary binders in ConPatOut] go (LitPat _) = bndrs - go (NPat _ _ _ _) = bndrs + go (NPat _ _ _) = bndrs go (NPlusKPat n _ _ _) = n : bndrs go (SigPatIn pat _) = collectl pat bndrs @@ -413,6 +431,22 @@ 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.) +Desugaring of arrow case expressions needs these bindings (see DsArrows +and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its +own pat-binder-collector: + +Here's the problem. Consider + +data T a where + C :: Num a => a -> Int -> T a + +f ~(C (n+1) m) = (n,m) + +Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a), +and *also* uses that dictionary to match the (n+1) pattern. Yet, the +variables bound by the lazy pattern are n,m, *not* the dictionary d. +So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound. + \begin{code} collectSigTysFromPats :: [InPat name] -> [LHsType name] collectSigTysFromPats pats = foldr collect_lpat [] pats