X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=db9460ee573d7b03ec4f1b97369a5590226e7ae3;hp=1839aefa0d0faf2ae58c231e99ae737c77ec00fc;hb=432b9c9322181a3644083e3c19b7e240d90659e7;hpb=15cb792d18b1094e98c035dca6ecec5dad516056 diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 1839aef..db9460e 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 @@ -15,25 +15,23 @@ which deal with the intantiated versions are located elsewhere: \begin{code} module HsUtils where -#include "HsVersions.h" - import HsBinds import HsExpr 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 Coercion +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 +50,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 +72,22 @@ 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)) + +mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id +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 -mkLHsCoerce :: ExprCoFn -> LHsExpr id -> LHsExpr id -mkLHsCoerce co_fn (L loc e) = L loc (mkHsCoerce co_fn e) +mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id +mkHsWrapCoI IdCo e = e +mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e -mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id -mkHsCoerce co_fn e | isIdCoercion co_fn = e - | otherwise = HsCoerce co_fn e +coiToHsWrapper :: CoercionI -> HsWrapper +coiToHsWrapper IdCo = idHsWrapper +coiToHsWrapper (ACo co) = WpCast co mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) @@ -99,7 +107,7 @@ mkHsDictLet binds expr val_binds = ValBindsOut [(Recursive, binds)] [] mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id --- Used for constructing dictinoary terms etc, so no locations +-- Used for constructing dictionary terms etc, so no locations mkHsConApp data_con tys args = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args where @@ -114,13 +122,45 @@ mkSimpleHsAlt pat expr -- These are the bits of syntax that contain rebindable names -- See RnEnv.lookupSyntaxName -mkHsIntegral i = HsIntegral i noSyntaxExpr -mkHsFractional f = HsFractional f noSyntaxExpr +mkHsIntegral :: Integer -> PostTcType -> HsOverLit id +mkHsFractional :: Rational -> PostTcType -> HsOverLit id +mkHsIsString :: FastString -> PostTcType -> HsOverLit id +mkHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id + +mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id +mkNPlusKPat :: Located id -> HsOverLit id -> Pat id + +mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR +mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR + +mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR +mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR +mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR + +mkExprStmt :: LHsExpr idR -> StmtLR idL idR +mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR +mkRecStmt :: [LStmtLR idL idR] -> StmtLR idL idR + + +mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noSyntaxExpr +mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noSyntaxExpr +mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr + +noRebindableInfo :: Bool +noRebindableInfo = error "noRebindableInfo" -- Just another placeholder; + 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 @@ -128,14 +168,26 @@ 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 :: LHsExpr id -> id -> LHsExpr id -> HsExpr id mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2 +mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName mkHsSplice e = HsSplice unqualSplice e -unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice")) +unqualSplice :: RdrName +unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) -- A name (uniquified later) to -- identify the splice +mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName +mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualQuasiQuote quoter span quote + +unqualQuasiQuote :: RdrName +unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) + -- A name (uniquified later) to + -- identify the quasi-quote + +mkHsString :: String -> HsLit mkHsString s = HsString (mkFastString s) ------------- @@ -166,6 +218,7 @@ nlLitPat l = noLoc (LitPat l) nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id nlHsApp f x = noLoc (HsApp f x) +nlHsIntLit :: Integer -> LHsExpr id nlHsIntLit n = noLoc (HsLit (HsInt n)) nlHsApps :: id -> [LHsExpr id] -> LHsExpr id @@ -192,14 +245,25 @@ nlWildConPat :: DataCon -> LPat RdrName nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat))) +nlTuplePat :: [LPat id] -> Boxity -> LPat id nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType) + +nlWildPat :: LPat id nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body) +nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) +nlHsLam :: LMatch id -> LHsExpr id +nlHsPar :: LHsExpr id -> LHsExpr id +nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id +nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id +nlTuple :: [LHsExpr id] -> Boxity -> LHsExpr id +nlList :: [LHsExpr id] -> LHsExpr id + nlHsLam match = noLoc (HsLam (mkMatchGroup [match])) nlHsPar e = noLoc (HsPar e) nlHsIf cond true false = noLoc (HsIf cond true false) @@ -207,9 +271,16 @@ nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches)) nlTuple exprs box = noLoc (ExplicitTuple exprs box) nlList exprs = noLoc (ExplicitList placeHolderType exprs) +nlHsAppTy :: LHsType name -> LHsType name -> LHsType name +nlHsTyVar :: name -> LHsType name +nlHsFunTy :: LHsType name -> LHsType name -> LHsType name + nlHsAppTy f t = noLoc (HsAppTy f t) nlHsTyVar x = noLoc (HsTyVar x) nlHsFunTy a b = noLoc (HsFunTy a b) + +nlHsTyConApp :: name -> [LHsType name] -> LHsType name +nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys \end{code} @@ -224,25 +295,26 @@ 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 +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 _ _ [] = panic "TcGenDeriv:mk_FunBind" mk_FunBind loc fun pats_and_exprs = L loc $ mkFunBind (L loc fun) matches where @@ -277,32 +349,32 @@ 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 (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds -collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds +collectHsValBinders :: HsValBindsLR idL idR -> [Located idL] +collectHsValBinders (ValBindsIn binds _) = 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 :: 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 -collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc +collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = _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 :: 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} @@ -314,22 +386,25 @@ collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds %************************************************************************ \begin{code} -collectLStmtsBinders :: [LStmt id] -> [Located id] +collectLStmtsBinders :: [LStmtLR idL idR] -> [Located idL] collectLStmtsBinders = concatMap collectLStmtBinders -collectStmtsBinders :: [Stmt id] -> [Located id] +collectStmtsBinders :: [StmtLR idL idR] -> [Located idL] collectStmtsBinders = concatMap collectStmtBinders -collectLStmtBinders :: LStmt id -> [Located id] +collectLStmtBinders :: LStmtLR idL idR -> [Located idL] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: 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 (RecStmt ss _ _ _ _) = collectLStmtsBinders ss -collectStmtBinders other = panic "collectStmtBinders" +collectStmtBinders (ExprStmt _ _ _) = [] +collectStmtBinders (ParStmt xs) = collectLStmtsBinders + $ concatMap fst xs +collectStmtBinders (TransformStmt (stmts, _) _ _) = collectLStmtsBinders stmts +collectStmtBinders (GroupStmt (stmts, _) _) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss \end{code} @@ -360,6 +435,7 @@ collectLocatedPatsBinders :: [LPat a] -> [Located a] collectLocatedPatsBinders pats = foldr collectl [] pats --------------------- +collectl :: LPat name -> [Located name] -> [Located name] collectl (L l pat) bndrs = go pat where @@ -370,30 +446,53 @@ 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 _ pat _) = 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 { pat_dicts = ds, - pat_binds = bs, pat_args = ps }) - = map noLoc ds - ++ collectHsBindLocatedBinders bs - ++ foldr collectl bndrs (hsConArgs ps) + go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) + 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 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 + go (QuasiQuotePat _) = bndrs + go (TypePat _) = bndrs + go (CoPat _ pat _) = 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.) + +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 @@ -401,18 +500,20 @@ collectSigTysFromPats pats = foldr collect_lpat [] pats collectSigTysFromPat :: InPat name -> [LHsType name] collectSigTysFromPat pat = collect_lpat pat [] +collect_lpat :: InPat name -> [LHsType name] -> [LHsType name] collect_lpat pat acc = collect_pat (unLoc pat) acc +collect_pat :: Pat name -> [LHsType name] -> [LHsType name] 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 (BangPat pat) acc = collect_lpat pat acc -collect_pat (AsPat a pat) acc = collect_lpat pat acc +collect_pat (AsPat _ 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 +collect_pat (ConPatIn _ ps) acc = foldr collect_lpat acc (hsConPatArgs ps) +collect_pat _ acc = acc -- Literals, vars, wildcard \end{code}