X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsUtils.lhs;h=df4885fb6b533b5ae4951a2042dd12264fc8a3ec;hb=04feba252e40d16101b92948cd1e13c7bc1f3062;hp=789887c49bcbb1220cd02afb09cbd5ed432e0cb8;hpb=c7b389309e5cdc86db9845573900b560c7a2fa05;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs index 789887c..df4885f 100644 --- a/ghc/compiler/hsSyn/HsUtils.lhs +++ b/ghc/compiler/hsSyn/HsUtils.lhs @@ -27,9 +27,9 @@ import RdrName ( RdrName, getRdrName, mkRdrUnqual ) import Var ( Id ) import Type ( Type ) import DataCon ( DataCon, dataConWrapId, dataConSourceArity ) -import BasicTypes ( RecFlag(..) ) -import OccName ( mkVarOcc ) +import OccName ( mkVarOccFS ) import Name ( Name ) +import BasicTypes ( RecFlag(..) ) import SrcLoc import FastString ( mkFastString ) import Outputable @@ -52,13 +52,18 @@ just attach noSrcSpan to everything. 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) @@ -70,13 +75,21 @@ mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name 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) +mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id +mkHsCoerce co_fn e | isIdCoercion co_fn = e + | otherwise = HsCoerce co_fn e + 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) @@ -84,10 +97,14 @@ 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 @@ -99,31 +116,39 @@ mkHsConApp data_con tys args 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 mkHsSplice e = HsSplice unqualSplice e -unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice")) +unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice")) -- A name (uniquified later) to -- identify the splice mkHsString s = HsString (mkFastString s) + +------------- +userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)] +userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ] \end{code} @@ -173,32 +198,26 @@ nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon [])) 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 +nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType) +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} @@ -210,37 +229,38 @@ nlParStmt stuff = noLoc (ParStmt stuff) %************************************************************************ \begin{code} +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 } + + 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 $ mkFunBind (L loc fun) [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 $ mkFunBind (L loc fun) matches + where + matches = [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 @@ -265,78 +285,137 @@ where it should return [x, y, f, a, b] (remember, order important). \begin{code} -collectGroupBinders :: [HsBindGroup name] -> [Located name] -collectGroupBinders groups = foldr collect_group [] groups - where - collect_group (HsBindGroup bag sigs is_rec) acc - = foldrBag (collectAcc . unLoc) acc bag - collect_group (HsIPBinds _) acc = acc - +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 sigs) = 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 +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 + = [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 :: Bag (LHsBind name) -> [name] +collectHsBindBinders :: LHsBinds name -> [name] collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds) -collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name] +collectHsBindLocatedBinders :: LHsBinds name -> [Located name] collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds \end{code} %************************************************************************ %* * - Getting pattern signatures out of bindings + Getting binders from statements %* * %************************************************************************ -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) +collectLStmtsBinders :: [LStmt id] -> [Located id] +collectLStmtsBinders = concatMap collectLStmtBinders -collectSigTysFromHsBind :: LHsBind name -> [LHsType name] -collectSigTysFromHsBind bind - = go (unLoc bind) - where - go (PatBind pat _) = collectSigTysFromPat pat - go (FunBind f _ ms) = go_matches (map unLoc 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_matches [] = [] - go_matches (Match [] (Just sig) _ : matches) = sig : go_matches matches - go_matches (match : matches) = go_matches matches +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} + %************************************************************************ %* * - Getting binders from statements +%* 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} -collectStmtsBinders :: [LStmt id] -> [Located id] -collectStmtsBinders = concatMap collectLStmtBinders +collectPatBinders :: LPat a -> [a] +collectPatBinders pat = map unLoc (collectLocatedPatBinders pat) -collectLStmtBinders = collectStmtBinders . unLoc +collectLocatedPatBinders :: LPat a -> [Located a] +collectLocatedPatBinders pat = collectl pat [] -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) = collectGroupBinders binds -collectStmtBinders (ExprStmt _ _) = [] -collectStmtBinders (ResultStmt _) = [] -collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss -collectStmtBinders other = panic "collectStmtBinders" +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}