Global renamings in HsSyn

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

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index d9c45e6..da0e24c 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -71,17 +71,15 @@ mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
 
-mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name
-mkHsTyApp expr []  = expr
-mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
+nlHsTyApp :: name -> [Type] -> LHsExpr name
+nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
 
-mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name
-mkHsDictApp expr []     = expr
-mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
+mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
+mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
 
-mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id
-mkHsCoerce co_fn e | isIdCoercion co_fn = e
-                  | otherwise          = HsCoerce co_fn e
+mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
+mkHsWrap co_fn e | isIdHsWrapper co_fn = e
+                | otherwise          = HsWrap co_fn e
 
 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
@@ -91,12 +89,6 @@ mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
 mkMatchGroup :: [LMatch id] -> MatchGroup id
 mkMatchGroup matches = MatchGroup matches placeHolderType
 
-mkHsTyLam []     expr = expr
-mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
-
-mkHsDictLam []    expr = expr
-mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts 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
@@ -109,7 +101,7 @@ mkHsDictLet binds expr
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 -- Used for constructing dictinoary terms etc, so no locations 
 mkHsConApp data_con tys args 
-  = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args
+  = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
   where
     mk_app f a = noLoc (HsApp f (noLoc a))
 
@@ -232,7 +224,7 @@ 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 }
 
 
 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
@@ -385,7 +377,9 @@ collectl (L l pat) bndrs
     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
+    go (ConPatOut { pat_dicts = ds, 
+                   pat_binds = bs, pat_args = ps })
+                                 = map noLoc ds
                                    ++ collectHsBindLocatedBinders bs
                                    ++ foldr collectl bndrs (hsConArgs ps)
     go (LitPat _)                = bndrs
@@ -397,6 +391,7 @@ collectl (L l 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
 \end{code}
 
 \begin{code}