Fix scoped type variables for expression type signatures

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

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 940b6d3..0588047 100644 (file)
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -25,7 +25,7 @@ import BasicTypes     ( IPName, RecFlag(..), InlineSpec(..), Fixity )
 import Outputable      
 import SrcLoc          ( Located(..), SrcSpan, unLoc )
 import Util            ( sortLe )
-import Var             ( TyVar, DictId, Id )
+import Var             ( TyVar, DictId, Id, Var )
 import Bag             ( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags )
 \end{code}
 
@@ -76,7 +76,7 @@ data HsBind id
 
        fun_matches :: MatchGroup id,   -- The payload
 
-       fun_co_fn :: ExprCoFn,  -- Coercion from the type of the MatchGroup to the type of
+       fun_co_fn :: HsWrapper, -- Coercion from the type of the MatchGroup to the type of
                                -- the Id.  Example:
                                --      f :: Int -> forall a. a -> a
                                --      f x y = y
@@ -84,9 +84,7 @@ data HsBind id
                                -- (with a free type variable a').  The coercion will take
                                -- a CoreExpr of this type and convert it to a CoreExpr of
                                -- type         Int -> forall a'. a' -> a'
-                               -- Notice that the coercion captures the free a'.  That's
-                               -- why coercions are (CoreExpr -> CoreExpr), rather than
-                               -- just CoreExpr (with a functional type)
+                               -- Notice that the coercion captures the free a'.
 
        bind_fvs :: NameSet     -- After the renamer, this contains a superset of the 
                                -- Names of the other binders in this binding group that 
@@ -298,50 +296,67 @@ instance (OutputableBndr id) => Outputable (IPBind id) where
 %************************************************************************
 
 \begin{code}
--- A ExprCoFn is an expression with a hole in it
+-- A HsWrapper is an expression with a hole in it
 -- We need coercions to have concrete form so that we can zonk them
 
-data ExprCoFn
-  = CoHole                     -- The identity coercion
+data HsWrapper
+  = WpHole                     -- The identity coercion
 
-  | CoCompose ExprCoFn ExprCoFn        -- (\a1..an. []) `CoCompose` (\x1..xn. [])
+  | WpCompose HsWrapper HsWrapper      -- (\a1..an. []) `WpCompose` (\x1..xn. [])
                                --      = (\a1..an \x1..xn. [])
 
-  | ExprCoFn Coercion          -- A cast:  [] `cast` co
+  | WpCo Coercion              -- A cast:  [] `cast` co
                                -- Guaranteedn not the identity coercion
 
-       -- Non-empty list in all of these, so that the identity coercion
-       -- is always exactly CoHole, not, say, (CoTyLams [])
-  | CoApps [Var]               -- [] x1 .. xn; the xi are dicts or coercions
-  | CoTyApps [Type]            -- [] t1 .. tn
-  | CoLams [Id]                -- \x1..xn. []; the xi are dicts or coercions
-  | CoTyLams [TyVar]           -- \a1..an. []
-  | CoLet (LHsBinds Id)                -- Would be nicer to be core bindings
-
-instance Outputable ExprCoFn where
-  ppr CoHole        = ptext SLIT("<>")
-  ppr (ExprCoFn co)  = ppr co
-  ppr (CoApps ids)   = ppr CoHole <+> interppSP ids
-  ppr (CoTyApps tys) = ppr CoHole <+> hsep (map pprParendType tys)
-  ppr (CoTyLams tvs) = sep [ptext SLIT("/\\") <> hsep (map (pprBndr LambdaBind) tvs),
-                           ptext SLIT("->") <+> ppr CoHole]
-  ppr (CoLams ids)   = sep [ptext SLIT("\\") <> hsep (map (pprBndr LambdaBind) ids),
-                           ptext SLIT("->") <+> ppr CoHole]
-  ppr (CoLet binds)  = sep [ptext SLIT("let") <+> braces (ppr binds),
-                           ppr CoHole]
-  ppr (CoCompose co1 co2) = sep [ppr co1, ptext SLIT("<.>"), ppr co2]
-
-(<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn
-CoHole <.> c = c
-c <.> CoHole = c
-c1 <.> c2    = c1 `CoCompose` c2
-
-idCoercion :: ExprCoFn
-idCoercion = CoHole
-
-isIdCoercion :: ExprCoFn -> Bool
-isIdCoercion CoHole = True
-isIdCoercion other  = False
+  | WpApp Var                  -- [] x; the xi are dicts or coercions
+  | WpTyApp Type               -- [] t
+  | WpLam Id                   -- \x. []; the xi are dicts or coercions
+  | WpTyLam TyVar              -- \a. []
+
+       -- Non-empty bindings, so that the identity coercion
+       -- is always exactly WpHole
+  | WpLet (LHsBinds Id)                -- let binds in []
+                               -- (would be nicer to be core bindings)
+
+instance Outputable HsWrapper where 
+  ppr co_fn = pprHsWrapper (ptext SLIT("<>")) co_fn
+
+pprHsWrapper :: SDoc -> HsWrapper -> SDoc
+pprHsWrapper it WpHole = it
+pprHsWrapper it (WpCompose f1 f2) = pprHsWrapper (pprHsWrapper it f2) f1
+pprHsWrapper it (WpCo co)     = it <+> ptext SLIT("`cast`") <+> pprParendType co
+pprHsWrapper it (WpApp id)    = it <+> ppr id
+pprHsWrapper it (WpTyApp ty)  = it <+> ptext SLIT("@") <+> pprParendType ty
+pprHsWrapper it (WpLam id)    = ptext SLIT("\\") <> pprBndr LambdaBind id <> dot <+> it
+pprHsWrapper it (WpTyLam tv)  = ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot <+> it
+pprHsWrapper it (WpLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it]
+
+(<.>) :: HsWrapper -> HsWrapper -> HsWrapper
+WpHole <.> c = c
+c <.> WpHole = c
+c1 <.> c2    = c1 `WpCompose` c2
+
+mkWpTyApps :: [Type] -> HsWrapper
+mkWpTyApps tys = mk_co_fn WpTyApp (reverse tys)
+
+mkWpApps :: [Id] -> HsWrapper
+mkWpApps ids = mk_co_fn WpApp (reverse ids)
+
+mkWpTyLams :: [TyVar] -> HsWrapper
+mkWpTyLams ids = mk_co_fn WpTyLam ids
+
+mkWpLams :: [Id] -> HsWrapper
+mkWpLams ids = mk_co_fn WpLam ids
+
+mk_co_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
+mk_co_fn f as = foldr (WpCompose . f) WpHole as
+
+idHsWrapper :: HsWrapper
+idHsWrapper = WpHole
+
+isIdHsWrapper :: HsWrapper -> Bool
+isIdHsWrapper WpHole = True
+isIdHsWrapper other  = False
 \end{code}