X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsUtils.lhs;h=d9c45e6529c177edea88066958f869a35576627a;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=f8efa6cfb94f206e7047953e32c87d6b486eacac;hpb=9d7da331989abcd1844e9d03b8d1e4163796fa85;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs index f8efa6c..d9c45e6 100644 --- a/ghc/compiler/hsSyn/HsUtils.lhs +++ b/ghc/compiler/hsSyn/HsUtils.lhs @@ -79,6 +79,10 @@ 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 body) (HsLam matches)) where @@ -196,7 +200,7 @@ nlWildConPat :: DataCon -> LPat RdrName nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat))) -nlTuplePat pats box = noLoc (TuplePat pats box) +nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType) nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id @@ -225,6 +229,12 @@ nlHsFunTy a b = noLoc (HsFunTy a b) %************************************************************************ \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 [] rhs @@ -233,9 +243,7 @@ mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] -> LHsExpr RdrName -> LHsBind RdrName mk_easy_FunBind loc fun pats expr - = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames) - where - matches = mkMatchGroup [mkMatch pats expr emptyLocalBinds] + = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds] ------------ mk_FunBind :: SrcSpan -> RdrName @@ -244,9 +252,9 @@ mk_FunBind :: SrcSpan -> 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-} matches placeHolderNames) + = L loc $ mkFunBind (L loc fun) matches where - matches = mkMatchGroup [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs] + matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs] ------------ mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id @@ -289,10 +297,10 @@ collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds 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 +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 @@ -309,32 +317,6 @@ collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds %************************************************************************ %* * - Getting pattern signatures out of bindings -%* * -%************************************************************************ - -Get all the pattern type signatures out of a bunch of bindings - -\begin{code} -collectSigTysFromHsBinds :: LHsBinds name -> [LHsType name] -collectSigTysFromHsBinds binds = concatMap collectSigTysFromHsBind (bagToList binds) - -collectSigTysFromHsBind :: LHsBind name -> [LHsType name] -collectSigTysFromHsBind bind - = go (unLoc bind) - where - go (PatBind pat _ _ _) - = collectSigTysFromPat pat - go (FunBind f _ (MatchGroup ms _) _) - = [sig | L _ (Match [] (Just sig) _) <- 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 out_bind = panic "collectSigTysFromHsBind" -\end{code} - -%************************************************************************ -%* * Getting binders from statements %* * %************************************************************************ @@ -394,12 +376,13 @@ collectl (L l pat) bndrs ++ bndrs go (WildPat _) = bndrs go (LazyPat pat) = collectl pat bndrs + go (BangPat 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 (TuplePat pats _ _) = foldr collectl bndrs pats go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps) go (ConPatOut c _ ds bs ps _) = map noLoc ds @@ -425,15 +408,16 @@ 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 +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 (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}