Major improvement to pattern bindings

This patch makes a number of related improvements

a) Implements the Haskell Prime semantics for pattern bindings
   (Trac #2357).  That is, a pattern binding p = e is typed
   just as if it had been written
        t = e
        f = case t of p -> f
        g = case t of p -> g
        ... etc ...
   where f,g are the variables bound by p. In paricular it's
   ok to say
      (f,g) = (\x -> x, \y -> True)
   and f and g will get propertly inferred types
      f :: a -> a
      g :: a -> Int

b) Eliminates the MonoPatBinds flag altogether.  (For the moment
   it is deprecated and has no effect.)  Pattern bindings are now
   generalised as per (a).  Fixes Trac #2187 and #4940, in the
   way the users wanted!

c) Improves the OutsideIn algorithm generalisation decision.
   Given a definition without a type signature (implying "infer
   the type"), the published algorithm rule is this:
      - generalise *top-level* functions, and
      - do not generalise *nested* functions
   The new rule is
      - generalise a binding whose free variables have
        Guaranteed Closed Types
      - do not generalise other bindings

   Generally, a top-level let-bound function has a Guaranteed
   Closed Type, and so does a nested function whose free vaiables
   are top-level functions, and so on. (However a top-level
   function that is bitten by the Monomorphism Restriction does
   not have a GCT.)

   Example:
     f x = let { foo y = y } in ...
   Here 'foo' has no free variables, so it is generalised despite
   being nested.

d) When inferring a type f :: ty for a definition f = e, check that
   the compiler would accept f :: ty as a type signature for that
   same definition.  The type is rejected precisely when the type
   is ambiguous.

   Example:
      class Wob a b where
        to :: a -> b
        from :: b -> a

      foo x = [x, to (from x)]
   GHC 7.0 would infer the ambiguous type
      foo :: forall a b. Wob a b => b -> [b]
   but that type would give an error whenever it is called; and
   GHC 7.0 would reject that signature if given by the
   programmer.  The new type checker rejects it up front.

   Similarly, with the advent of type families, ambiguous types are
   easy to write by mistake.  See Trac #1897 and linked tickets for
   many examples.  Eg
      type family F a :: *
      f ::: F a -> Int
      f x = 3
   This is rejected because (F a ~ F b) does not imply a~b.  Previously
   GHC would *infer* the above type for f, but was unable to check it.
   Now even the inferred type is rejected -- correctly.

The main implemenation mechanism is to generalise the abe_wrap
field of ABExport (in HsBinds), from [TyVar] to HsWrapper. This
beautiful generalisation turned out to make everything work nicely
with minimal programming effort.  All the work was fiddling around
the edges; the core change was easy!

2 files changed, 39 insertions, 21 deletions

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index fcba55af81..4b06737d6e 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -150,7 +150,7 @@ data HsBindLR idL idR
        -- AbsBinds only gets used when idL = idR after renaming,
        -- but these need to be idL's for the collect... code in HsUtil 
        -- to have the right type
-	abs_exports :: [([TyVar], idL, idL, TcSpecPrags)],	-- (tvs, poly_id, mono_id, prags)
+	abs_exports :: [ABExport idL],
 
         abs_ev_binds :: TcEvBinds,     -- Evidence bindings
 	abs_binds    :: LHsBinds idL   -- Typechecked user bindings
@@ -171,6 +171,14 @@ data HsBindLR idL idR
 	-- (You can get a PhD for explaining the True Meaning
 	--  of this last construct.)
 
+data ABExport id 
+  = ABE { abe_poly  :: id 
+        , abe_mono  :: id 
+        , abe_wrap  :: HsWrapper  -- See Note [AbsBinds wrappers]
+             -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
+        , abe_prags :: TcSpecPrags }
+  deriving (Data, Typeable)
+
 placeHolderNames :: NameSet
 -- Used for the NameSet in FunBind and PatBind prior to the renamer
 placeHolderNames = panic "placeHolderNames"
@@ -306,17 +314,19 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
   = sep [ptext (sLit "AbsBinds"),
   	 brackets (interpp'SP tyvars),
   	 brackets (interpp'SP dictvars),
-  	 brackets (sep (punctuate comma (map ppr_exp exports)))]
+  	 brackets (sep (punctuate comma (map ppr exports)))]
     $$
-    nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
+    nest 2 ( vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
   			-- Print type signatures
   	     $$ pprLHsBinds val_binds )
     $$
     ifPprDebug (ppr ev_binds)
-  where
-    ppr_exp (tvs, gbl, lcl, prags)
-	= vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
-	  	nest 2 (pprTcSpecPrags prags)]
+
+instance (OutputableBndr id) => Outputable (ABExport id) where
+  ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
+    = vcat [ ppr gbl <+> ptext (sLit "<=") <+> ppr lcl
+	   , nest 2 (pprTcSpecPrags prags)
+           , nest 2 (ppr wrap)]
 \end{code}
 
 
@@ -513,12 +523,12 @@ mkWpLet (EvBinds b) | isEmptyBag b = WpHole
 mkWpLet ev_binds                   = WpLet ev_binds
 
 mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
-mk_co_lam_fn f as = foldr (\x wrap -> f x `WpCompose` wrap) WpHole as
+mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as
 
 mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
 -- For applications, the *first* argument must
 -- come *last* in the composition sequence
-mk_co_app_fn f as = foldr (\x wrap -> wrap `WpCompose` f x) WpHole as
+mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as
 
 idHsWrapper :: HsWrapper
 idHsWrapper = WpHole
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 33d800d66a..cd95571964 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -29,7 +29,7 @@ module HsUtils(
   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
 
   -- Bindings
-  mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, 
+  mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
 
   -- Literals
   mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, 
@@ -407,14 +407,23 @@ missingTupArg = Missing placeHolderType
 %************************************************************************
 
 \begin{code}
-mkFunBind :: Located id -> [LMatch id] -> HsBind id
+mkFunBind :: Located RdrName -> [LMatch RdrName] -> HsBind RdrName
 -- 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 = idHsWrapper, bind_fvs = placeHolderNames,
-			    fun_tick = Nothing }
-
-
-mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
+mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
+                          , fun_matches = mkMatchGroup ms
+			  , fun_co_fn = idHsWrapper
+                          , bind_fvs = placeHolderNames
+			  , fun_tick = Nothing }
+
+mkTopFunBind :: Located Name -> [LMatch Name] -> HsBind Name
+-- In Name-land, with empty bind_fvs
+mkTopFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
+                             , fun_matches = mkMatchGroup ms
+			     , fun_co_fn = idHsWrapper
+                             , bind_fvs = emptyNameSet	-- NB: closed binding
+			     , fun_tick = Nothing }
+
+mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 
 mkVarBind :: id -> LHsExpr id -> LHsBind id
@@ -422,9 +431,8 @@ mkVarBind var rhs = L (getLoc rhs) $
 		    VarBind { var_id = var, var_rhs = rhs, var_inline = False }
 
 ------------
-mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
-		-> LHsExpr id -> LHsBind id
-
+mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
+		-> LHsExpr RdrName -> LHsBind RdrName
 mk_easy_FunBind loc fun pats expr
   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 
@@ -483,7 +491,7 @@ collect_bind (PatBind { pat_lhs = p })    acc = collect_lpat p acc
 collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
 collect_bind (VarBind { var_id = f })     acc = f : acc
 collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
-  = [dp | (_,dp,_,_) <- dbinds] ++ acc 
+  = map abe_poly dbinds ++ acc 
 	-- ++ foldr collect_bind acc binds
 	-- I don't think we want the binders from the nested binds
 	-- The only time we collect binders from a typechecked