X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=ef0ef5c5f0ac2baecd2093b153b33dd08dddaf0b;hb=cd54b707b0d77a3c62ee9f57b82dae98727f1c34;hp=063f4b1b6214085c3b8401c2bd955b3dab7ce4ff;hpb=d6645244236d85b97655e13d9b5e0bb13fb76e8a;p=ghc-hetmet.git

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 063f4b1..ef0ef5c 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -235,12 +235,13 @@ data IfaceExpr
   = IfaceLcl    IfLclName
   | IfaceExt    IfExtName
   | IfaceType   IfaceType
-  | IfaceTuple  Boxity [IfaceExpr]              -- Saturated; type arguments omitted
-  | IfaceLam    IfaceBndr IfaceExpr
-  | IfaceApp    IfaceExpr IfaceExpr
-  | IfaceCase   IfaceExpr IfLclName IfaceType [IfaceAlt]
-  | IfaceLet    IfaceBinding  IfaceExpr
-  | IfaceNote   IfaceNote IfaceExpr
+  | IfaceCo     IfaceType		-- We re-use IfaceType for coercions
+  | IfaceTuple 	Boxity [IfaceExpr]	-- Saturated; type arguments omitted
+  | IfaceLam 	IfaceBndr IfaceExpr
+  | IfaceApp 	IfaceExpr IfaceExpr
+  | IfaceCase	IfaceExpr IfLclName [IfaceAlt]
+  | IfaceLet	IfaceBinding  IfaceExpr
+  | IfaceNote	IfaceNote IfaceExpr
   | IfaceCast   IfaceExpr IfaceCoercion
   | IfaceLit    Literal
   | IfaceFCall  ForeignCall IfaceType
@@ -600,29 +601,30 @@ pprIfaceExpr _       (IfaceLit l)       = ppr l
 pprIfaceExpr _       (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
 pprIfaceExpr _       (IfaceTick m ix)   = braces (text "tick" <+> ppr m <+> ppr ix)
 pprIfaceExpr _       (IfaceType ty)     = char '@' <+> pprParendIfaceType ty
+pprIfaceExpr _       (IfaceCo co)       = text "@~" <+> pprParendIfaceType co
 
 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
 pprIfaceExpr _       (IfaceTuple c as)  = tupleParens c (interpp'SP as)
 
-pprIfaceExpr add_par e@(IfaceLam _ _)
+pprIfaceExpr add_par i@(IfaceLam _ _)
   = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
                   pprIfaceExpr noParens body])
   where
-    (bndrs,body) = collect [] e
+    (bndrs,body) = collect [] i
     collect bs (IfaceLam b e) = collect (b:bs) e
     collect bs e              = (reverse bs, e)
 
-pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
-  = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
-                        <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
-                        <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
-                  pprIfaceExpr noParens rhs <+> char '}'])
+pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
+  = add_par (sep [ptext (sLit "case") 
+			<+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") 
+			<+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
+  		  pprIfaceExpr noParens rhs <+> char '}'])
 
-pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
-  = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
-                        <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
-                        <+> ppr bndr <+> char '{',
-                  nest 2 (sep (map ppr_alt alts)) <+> char '}'])
+pprIfaceExpr add_par (IfaceCase scrut bndr alts)
+  = add_par (sep [ptext (sLit "case") 
+		 	<+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") 
+			<+> ppr bndr <+> char '{',
+  		  nest 2 (sep (map ppr_alt alts)) <+> char '}'])
 
 pprIfaceExpr _       (IfaceCast expr co)
   = sep [pprParendIfaceExpr expr,
@@ -798,6 +800,8 @@ freeNamesIfType (IfaceTyConApp tc ts) =
 freeNamesIfType (IfaceForAllTy tv t)  =
    freeNamesIfTvBndr tv &&& freeNamesIfType t
 freeNamesIfType (IfaceFunTy s t)      = freeNamesIfType s &&& freeNamesIfType t
+freeNamesIfType (IfaceCoConApp tc ts) = 
+   freeNamesIfCo tc &&& fnList freeNamesIfType ts
 
 freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet
 freeNamesIfTvBndrs = fnList freeNamesIfTvBndr
@@ -840,25 +844,25 @@ freeNamesIfExpr :: IfaceExpr -> NameSet
 freeNamesIfExpr (IfaceExt v)      = unitNameSet v
 freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
 freeNamesIfExpr (IfaceType ty)    = freeNamesIfType ty
+freeNamesIfExpr (IfaceCo co)      = freeNamesIfType co
 freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
 freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body
 freeNamesIfExpr (IfaceApp f a)    = freeNamesIfExpr f &&& freeNamesIfExpr a
 freeNamesIfExpr (IfaceCast e co)  = freeNamesIfExpr e &&& freeNamesIfType co
 freeNamesIfExpr (IfaceNote _n r)  = freeNamesIfExpr r
 
-freeNamesIfExpr (IfaceCase s _ ty alts)
-  = freeNamesIfExpr s
+freeNamesIfExpr (IfaceCase s _ alts)
+  = freeNamesIfExpr s 
     &&& fnList fn_alt alts &&& fn_cons alts
-    &&& freeNamesIfType ty
   where
     fn_alt (_con,_bs,r) = freeNamesIfExpr r
 
     -- Depend on the data constructors.  Just one will do!
     -- Note [Tracking data constructors]
-    fn_cons []                              = emptyNameSet
-    fn_cons ((IfaceDefault    ,_,_) : alts) = fn_cons alts
-    fn_cons ((IfaceDataAlt con,_,_) : _   ) = unitNameSet con
-    fn_cons (_                      : _   ) = emptyNameSet
+    fn_cons []                            = emptyNameSet
+    fn_cons ((IfaceDefault    ,_,_) : xs) = fn_cons xs
+    fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con
+    fn_cons (_                      : _ ) = emptyNameSet
 
 freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body)
   = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body
@@ -875,6 +879,10 @@ freeNamesIfTc (IfaceTc tc) = unitNameSet tc
 -- ToDo: shouldn't we include IfaceIntTc & co.?
 freeNamesIfTc _ = emptyNameSet
 
+freeNamesIfCo :: IfaceCoCon -> NameSet
+freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc
+freeNamesIfCo _ = emptyNameSet
+
 freeNamesIfRule :: IfaceRule -> NameSet
 freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
                            , ifRuleArgs = es, ifRuleRhs = rhs })