remove empty dir

[ghc-hetmet.git] / ghc / compiler / hsSyn / HsUtils.lhs

diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs
index f8efa6c..d9c45e6 100644 (file)
--- 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}