Commit 49dbe605 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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!
parent 20ceffb6
...@@ -37,7 +37,6 @@ import Digraph ...@@ -37,7 +37,6 @@ import Digraph
import TcType import TcType
import Type import Type
import Coercion import Coercion
import TysPrim ( anyTypeOfKind )
import CostCentre import CostCentre
import Module import Module
import Id import Id
...@@ -122,15 +121,17 @@ dsHsBind auto_scc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) ...@@ -122,15 +121,17 @@ dsHsBind auto_scc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
-- Non-recursive bindings come through this way -- Non-recursive bindings come through this way
-- So do self-recursive bindings, and recursive bindings -- So do self-recursive bindings, and recursive bindings
-- that have been chopped up with type signatures -- that have been chopped up with type signatures
dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = [(tyvars, global, local, prags)] , abs_exports = [export]
, abs_ev_binds = ev_binds, abs_binds = binds }) , abs_ev_binds = ev_binds, abs_binds = binds })
= ASSERT( all (`elem` tyvars) all_tyvars ) | ABE { abe_wrap = wrap, abe_poly = global
do { bind_prs <- ds_lhs_binds NoSccs binds , abe_mono = local, abe_prags = prags } <- export
= do { bind_prs <- ds_lhs_binds NoSccs binds
; ds_ev_binds <- dsTcEvBinds ev_binds ; ds_ev_binds <- dsTcEvBinds ev_binds
; wrap_fn <- dsHsWrapper wrap
; let core_bind = Rec (fromOL bind_prs) ; let core_bind = Rec (fromOL bind_prs)
rhs = addAutoScc auto_scc global $ rhs = addAutoScc auto_scc global $
wrap_fn $ -- Usually the identity
mkLams tyvars $ mkLams dicts $ mkLams tyvars $ mkLams dicts $
wrapDsEvBinds ds_ev_binds $ wrapDsEvBinds ds_ev_binds $
Let core_bind $ Let core_bind $
...@@ -144,14 +145,14 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts ...@@ -144,14 +145,14 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
; return (main_bind `consOL` spec_binds) } ; return (main_bind `consOL` spec_binds) }
dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = exports, abs_ev_binds = ev_binds , abs_exports = exports, abs_ev_binds = ev_binds
, abs_binds = binds }) , abs_binds = binds })
= do { bind_prs <- ds_lhs_binds NoSccs binds = do { bind_prs <- ds_lhs_binds NoSccs binds
; ds_ev_binds <- dsTcEvBinds ev_binds ; ds_ev_binds <- dsTcEvBinds ev_binds
; let env = mkABEnv exports ; let env = mkABEnv exports
do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id do_one (lcl_id,rhs) | Just export <- lookupVarEnv env lcl_id
= (lcl_id, addAutoScc auto_scc gbl_id rhs) = (lcl_id, addAutoScc auto_scc (abe_poly export) rhs)
| otherwise = (lcl_id,rhs) | otherwise = (lcl_id,rhs)
core_bind = Rec (map do_one (fromOL bind_prs)) core_bind = Rec (map do_one (fromOL bind_prs))
...@@ -159,37 +160,27 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts ...@@ -159,37 +160,27 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
tup_expr = mkBigCoreVarTup locals tup_expr = mkBigCoreVarTup locals
tup_ty = exprType tup_expr tup_ty = exprType tup_expr
poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $ poly_tup_rhs = mkLams tyvars $ mkLams dicts $
wrapDsEvBinds ds_ev_binds $ wrapDsEvBinds ds_ev_binds $
Let core_bind $ Let core_bind $
tup_expr tup_expr
locals = [local | (_, _, local, _) <- exports] locals = map abe_mono exports
local_tys = map idType locals
; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs) ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
; let mk_bind ((tyvars, global, _, spec_prags), n) -- locals!!n == local ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
= -- Need to make fresh locals to bind in the selector, , abe_mono = local, abe_prags = spec_prags })
-- because some of the tyvars will be bound to 'Any' = do { wrap_fn <- dsHsWrapper wrap
do { let ty_args = map mk_ty_arg all_tyvars ; tup_id <- newSysLocalDs tup_ty
substitute = substTyWith all_tyvars ty_args ; let rhs = wrap_fn $ mkLams tyvars $ mkLams dicts $
; locals' <- newSysLocalsDs (map substitute local_tys) mkTupleSelector locals local tup_id $
; tup_id <- newSysLocalDs (substitute tup_ty) mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
; let rhs = mkLams tyvars $ mkLams dicts $ rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
mkTupleSelector locals' (locals' !! n) tup_id $ ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
dicts
full_rhs = Let (NonRec poly_tup_id poly_tup_rhs) rhs
; (spec_binds, rules) <- dsSpecs full_rhs spec_prags
; let global' = addIdSpecialisations global rules ; let global' = addIdSpecialisations global rules
; return ((global', rhs) `consOL` spec_binds) } ; return ((global', rhs) `consOL` spec_binds) }
where
mk_ty_arg all_tyvar
| all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
| otherwise = dsMkArbitraryType all_tyvar
; export_binds_s <- mapM mk_bind (exports `zip` [0..]) ; export_binds_s <- mapM mk_bind exports
-- Don't scc (auto-)annotate the tuple itself. -- Don't scc (auto-)annotate the tuple itself.
; return ((poly_tup_id, poly_tup_rhs) `consOL` ; return ((poly_tup_id, poly_tup_rhs) `consOL`
...@@ -311,14 +302,14 @@ dictArity dicts = count isId dicts ...@@ -311,14 +302,14 @@ dictArity dicts = count isId dicts
------------------------ ------------------------
type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags) type AbsBindEnv = VarEnv (ABExport Id)
-- Maps the "lcl_id" for an AbsBind to -- Maps the "lcl_id" for an AbsBind to
-- its "gbl_id" and associated pragmas, if any -- its "gbl_id" and associated pragmas, if any
mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv mkABEnv :: [ABExport Id] -> AbsBindEnv
-- Takes the exports of a AbsBinds, and returns a mapping -- Takes the exports of a AbsBinds, and returns a mapping
-- lcl_id -> (tyvars, gbl_id, lcl_id, prags) -- lcl_id -> (tyvars, gbl_id, lcl_id, prags)
mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports] mkABEnv exports = mkVarEnv [ (abe_mono export, export) | export <- exports]
\end{code} \end{code}
Note [Rules and inlining] Note [Rules and inlining]
...@@ -560,9 +551,6 @@ specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops) ...@@ -560,9 +551,6 @@ specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
-} -}
specUnfolding _ _ _ specUnfolding _ _ _
= return (noUnfolding, nilOL) = return (noUnfolding, nilOL)
dsMkArbitraryType :: TcTyVar -> Type
dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -136,7 +136,7 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] ...@@ -136,7 +136,7 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
, abs_binds = binds }) body , abs_binds = binds }) body
= do { ds_ev_binds <- dsTcEvBinds ev_binds = do { ds_ev_binds <- dsTcEvBinds ev_binds
; let body1 = foldr bind_export body exports ; let body1 = foldr bind_export body exports
bind_export (_, g, l, _) b = bindNonRec g (Var l) b bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body)
body1 binds body1 binds
; return (wrapDsEvBinds ds_ev_binds body2) } ; return (wrapDsEvBinds ds_ev_binds body2) }
...@@ -542,8 +542,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) ...@@ -542,8 +542,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
= nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id) = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con)) inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
-- Reconstruct with the WrapId so that unpacking happens -- Reconstruct with the WrapId so that unpacking happens
wrap = mkWpEvVarApps theta_vars `WpCompose` wrap = mkWpEvVarApps theta_vars <.>
mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose` mkWpTyApps (mkTyVarTys ex_tvs) <.>
mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
, not (tv `elemVarEnv` wrap_subst) ] , not (tv `elemVarEnv` wrap_subst) ]
rhs = foldl (\a b -> nlHsApp a b) inst_con val_args rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
......
...@@ -150,7 +150,7 @@ data HsBindLR idL idR ...@@ -150,7 +150,7 @@ data HsBindLR idL idR
-- AbsBinds only gets used when idL = idR after renaming, -- AbsBinds only gets used when idL = idR after renaming,
-- but these need to be idL's for the collect... code in HsUtil -- but these need to be idL's for the collect... code in HsUtil
-- to have the right type -- 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_ev_binds :: TcEvBinds, -- Evidence bindings
abs_binds :: LHsBinds idL -- Typechecked user bindings abs_binds :: LHsBinds idL -- Typechecked user bindings
...@@ -171,6 +171,14 @@ data HsBindLR idL idR ...@@ -171,6 +171,14 @@ data HsBindLR idL idR
-- (You can get a PhD for explaining the True Meaning -- (You can get a PhD for explaining the True Meaning
-- of this last construct.) -- 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 placeHolderNames :: NameSet
-- Used for the NameSet in FunBind and PatBind prior to the renamer -- Used for the NameSet in FunBind and PatBind prior to the renamer
placeHolderNames = panic "placeHolderNames" placeHolderNames = panic "placeHolderNames"
...@@ -306,17 +314,19 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars ...@@ -306,17 +314,19 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
= sep [ptext (sLit "AbsBinds"), = sep [ptext (sLit "AbsBinds"),
brackets (interpp'SP tyvars), brackets (interpp'SP tyvars),
brackets (interpp'SP dictvars), 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 -- Print type signatures
$$ pprLHsBinds val_binds ) $$ pprLHsBinds val_binds )
$$ $$
ifPprDebug (ppr ev_binds) ifPprDebug (ppr ev_binds)
where
ppr_exp (tvs, gbl, lcl, prags) instance (OutputableBndr id) => Outputable (ABExport id) where
= vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl, ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
nest 2 (pprTcSpecPrags prags)] = vcat [ ppr gbl <+> ptext (sLit "<=") <+> ppr lcl
, nest 2 (pprTcSpecPrags prags)
, nest 2 (ppr wrap)]
\end{code} \end{code}
...@@ -513,12 +523,12 @@ mkWpLet (EvBinds b) | isEmptyBag b = WpHole ...@@ -513,12 +523,12 @@ mkWpLet (EvBinds b) | isEmptyBag b = WpHole
mkWpLet ev_binds = WpLet ev_binds mkWpLet ev_binds = WpLet ev_binds
mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper 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 mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
-- For applications, the *first* argument must -- For applications, the *first* argument must
-- come *last* in the composition sequence -- 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 :: HsWrapper
idHsWrapper = WpHole idHsWrapper = WpHole
......
...@@ -29,7 +29,7 @@ module HsUtils( ...@@ -29,7 +29,7 @@ module HsUtils(
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
-- Bindings -- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
-- Literals -- Literals
mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString,
...@@ -407,14 +407,23 @@ missingTupArg = Missing placeHolderType ...@@ -407,14 +407,23 @@ missingTupArg = Missing placeHolderType
%************************************************************************ %************************************************************************
\begin{code} \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 -- Not infix, with place holders for coercion and free vars
mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms, mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, , fun_matches = mkMatchGroup ms
fun_tick = Nothing } , fun_co_fn = idHsWrapper
, bind_fvs = placeHolderNames
, fun_tick = Nothing }
mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
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 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
mkVarBind :: id -> LHsExpr id -> LHsBind id mkVarBind :: id -> LHsExpr id -> LHsBind id
...@@ -422,9 +431,8 @@ mkVarBind var rhs = L (getLoc rhs) $ ...@@ -422,9 +431,8 @@ mkVarBind var rhs = L (getLoc rhs) $
VarBind { var_id = var, var_rhs = rhs, var_inline = False } VarBind { var_id = var, var_rhs = rhs, var_inline = False }
------------ ------------
mk_easy_FunBind :: SrcSpan -> id -> [LPat id] mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-> LHsExpr id -> LHsBind id -> LHsExpr RdrName -> LHsBind RdrName
mk_easy_FunBind loc fun pats expr mk_easy_FunBind loc fun pats expr
= L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds] = 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 ...@@ -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 (FunBind { fun_id = L _ f }) acc = f : acc
collect_bind (VarBind { var_id = f }) acc = f : acc collect_bind (VarBind { var_id = f }) acc = f : acc
collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) 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 -- ++ foldr collect_bind acc binds
-- I don't think we want the binders from the nested binds -- I don't think we want the binders from the nested binds
-- The only time we collect binders from a typechecked -- The only time we collect binders from a typechecked
......
...@@ -910,19 +910,15 @@ languageExtensions :: Maybe Language -> [ExtensionFlag] ...@@ -910,19 +910,15 @@ languageExtensions :: Maybe Language -> [ExtensionFlag]
languageExtensions Nothing languageExtensions Nothing
-- Nothing => the default case -- Nothing => the default case
= Opt_MonoPatBinds -- Experimentally, I'm making this non-standard = Opt_NondecreasingIndentation -- This has been on by default for some time
-- behaviour the default, to see if anyone notices
-- SLPJ July 06
-- In due course I'd like Opt_MonoLocalBinds to be on by default
-- But NB it's implied by GADTs etc
-- SLPJ September 2010
: Opt_NondecreasingIndentation -- This has been on by default for some time
: delete Opt_DatatypeContexts -- The Haskell' committee decided to : delete Opt_DatatypeContexts -- The Haskell' committee decided to
-- remove datatype contexts from the -- remove datatype contexts from the
-- language: -- language:
-- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html
(languageExtensions (Just Haskell2010)) (languageExtensions (Just Haskell2010))
-- NB: MonoPatBinds is no longer the default
languageExtensions (Just Haskell98) languageExtensions (Just Haskell98)
= [Opt_ImplicitPrelude, = [Opt_ImplicitPrelude,
Opt_MonomorphismRestriction, Opt_MonomorphismRestriction,
...@@ -1863,7 +1859,8 @@ xFlags = [ ...@@ -1863,7 +1859,8 @@ xFlags = [
( "NPlusKPatterns", AlwaysAllowed, Opt_NPlusKPatterns, nop ), ( "NPlusKPatterns", AlwaysAllowed, Opt_NPlusKPatterns, nop ),
( "DoAndIfThenElse", AlwaysAllowed, Opt_DoAndIfThenElse, nop ), ( "DoAndIfThenElse", AlwaysAllowed, Opt_DoAndIfThenElse, nop ),
( "RebindableSyntax", AlwaysAllowed, Opt_RebindableSyntax, nop ), ( "RebindableSyntax", AlwaysAllowed, Opt_RebindableSyntax, nop ),
( "MonoPatBinds", AlwaysAllowed, Opt_MonoPatBinds, nop ), ( "MonoPatBinds", AlwaysAllowed, Opt_MonoPatBinds,
\ turn_on -> when turn_on $ deprecate "Experimental feature now removed; has no effect" ),
( "ExplicitForAll", AlwaysAllowed, Opt_ExplicitForAll, nop ), ( "ExplicitForAll", AlwaysAllowed, Opt_ExplicitForAll, nop ),
( "AlternativeLayoutRule", AlwaysAllowed, Opt_AlternativeLayoutRule, nop ), ( "AlternativeLayoutRule", AlwaysAllowed, Opt_AlternativeLayoutRule, nop ),
( "AlternativeLayoutRuleTransitional",AlwaysAllowed, Opt_AlternativeLayoutRuleTransitional, nop ), ( "AlternativeLayoutRuleTransitional",AlwaysAllowed, Opt_AlternativeLayoutRuleTransitional, nop ),
......
...@@ -334,8 +334,10 @@ rnLocalValBindsRHS :: NameSet -- names bound by the LHSes ...@@ -334,8 +334,10 @@ rnLocalValBindsRHS :: NameSet -- names bound by the LHSes
rnLocalValBindsRHS bound_names binds rnLocalValBindsRHS bound_names binds
= rnValBindsRHS trim (Just bound_names) binds = rnValBindsRHS trim (Just bound_names) binds
where where
trim fvs = intersectNameSet bound_names fvs trim fvs = filterNameSet isInternalName fvs
-- Only keep the names the names from this group -- Keep Internal Names; these are the non-top-level ones
-- As well as dependency analysis, we need these for the
-- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
-- for local binds -- for local binds
-- wrapper that does both the left- and right-hand sides -- wrapper that does both the left- and right-hand sides
......
This diff is collapsed.
...@@ -235,15 +235,17 @@ tcInstanceMethodBody skol_info tyvars dfun_ev_vars ...@@ -235,15 +235,17 @@ tcInstanceMethodBody skol_info tyvars dfun_ev_vars
-- Substitute the local_meth_name for the binder -- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind -- NB: the binding is always a FunBind
; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id))) ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id)))
; (ev_binds, (tc_bind, _)) ; (ev_binds, (tc_bind, _, _))
<- checkConstraints skol_info tyvars dfun_ev_vars $ <- checkConstraints skol_info tyvars dfun_ev_vars $
tcExtendIdEnv [local_meth_id] $ tcExtendIdEnv [local_meth_id] $
tcPolyBinds TopLevel meth_sig_fn no_prag_fn tcPolyBinds TopLevel meth_sig_fn no_prag_fn
NonRecursive NonRecursive NonRecursive NonRecursive
[lm_bind] [lm_bind]
; let full_bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars ; let export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id
, abs_exports = [(tyvars, meth_id, local_meth_id, specs)] , abe_mono = local_meth_id, abe_prags = specs }
full_bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
, abs_exports = [export]
, abs_ev_binds = ev_binds , abs_ev_binds = ev_binds
, abs_binds = tc_bind } , abs_binds = tc_bind }
...@@ -357,8 +359,8 @@ mkGenericDefMethBind clas inst_tys sel_id dm_name ...@@ -357,8 +359,8 @@ mkGenericDefMethBind clas inst_tys sel_id dm_name
(vcat [ppr clas <+> ppr inst_tys, (vcat [ppr clas <+> ppr inst_tys,
nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
; return (noLoc $ mkFunBind (noLoc (idName sel_id)) ; return (noLoc $ mkTopFunBind (noLoc (idName sel_id))
[mkSimpleMatch [] rhs]) } [mkSimpleMatch [] rhs]) }
where where
rhs = nlHsVar dm_name rhs = nlHsVar dm_name
\end{code} \end{code}
......
...@@ -23,7 +23,7 @@ module TcEnv( ...@@ -23,7 +23,7 @@ module TcEnv(
-- Local environment -- Local environment
tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendKindEnv, tcExtendKindEnvTvs,
tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendGhciEnv, tcExtendGhciEnv, tcExtendLetEnv,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupTyVar, getScopedTyVarBinds, tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
...@@ -76,6 +76,7 @@ import NameEnv ...@@ -76,6 +76,7 @@ import NameEnv
import HscTypes import HscTypes
import DynFlags import DynFlags
import SrcLoc import SrcLoc
import BasicTypes
import Outputable import Outputable
import Unique import Unique
import FastString import FastString
...@@ -371,23 +372,8 @@ tcExtendTyVarEnv tvs thing_inside ...@@ -371,23 +372,8 @@ tcExtendTyVarEnv tvs thing_inside
= tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
tcExtendTyVarEnv2 binds thing_inside = do tcExtendTyVarEnv2 binds thing_inside
env@(TcLclEnv {tcl_env = le, = tc_extend_local_env [(name, ATyVar name ty) | (name, ty) <- binds] thing_inside
tcl_tyvars = gtvs,
tcl_rdr = rdr_env}) <- getLclEnv
let
rdr_env' = extendLocalRdrEnvList rdr_env (map fst binds)
new_tv_set = tcTyVarsOfTypes (map snd binds)
le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
-- It's important to add the in-scope tyvars to the global tyvar set
-- as well. Consider
-- f (_::r) = let g y = y::r in ...
-- Here, g mustn't be generalised. This is also important during
-- class and instance decls, when we mustn't generalise the class tyvars
-- when typechecking the methods.
gtvs' <- tcExtendGlobalTyVars gtvs new_tv_set
setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
getScopedTyVarBinds :: TcM [(Name, TcType)] getScopedTyVarBinds :: TcM [(Name, TcType)]
getScopedTyVarBinds getScopedTyVarBinds
...@@ -397,32 +383,54 @@ getScopedTyVarBinds ...@@ -397,32 +383,54 @@ getScopedTyVarBinds
\begin{code} \begin{code}
tcExtendLetEnv :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
tcExtendLetEnv closed ids thing_inside
= do { stage <- getStage
; tc_extend_local_env [ (idName id, ATcId { tct_id = id
, tct_closed = closed
, tct_level = thLevel stage })
| id <- ids]
thing_inside }
tcExtendIdEnv :: [TcId] -> TcM a -> TcM a tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside tcExtendIdEnv ids thing_inside
= tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside tcExtendIdEnv1 name id thing_inside
= tcExtendIdEnv2 [(name,id)] thing_inside
tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
-- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above) -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
tcExtendIdEnv2 names_w_ids thing_inside tcExtendIdEnv2 names_w_ids thing_inside
= do { env <- getLclEnv = do { stage <- getStage
; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) names_w_ids thing_inside } ; tc_extend_local_env [ (name, ATcId { tct_id = id
, tct_closed = NotTopLevel
, tct_level = thLevel stage })
| (name,id) <- names_w_ids]
thing_inside }
tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a
-- Used to bind Ids for GHCi identifiers bound earlier in the user interaction -- Used to bind Ids for GHCi identifiers bound earlier in the user interaction
-- Note especially that we bind them at TH level 'impLevel'. That's because it's -- Note especially that we bind them at
-- OK to use a variable bound earlier in the interaction in a splice, becuase -- * TH level 'impLevel'. That's because it's OK to use a variable bound
-- GHCi has already compiled it to bytecode -- earlier in the interaction in a splice, because
-- GHCi has already compiled it to bytecode
-- * Closedness flag is TopLevel. The thing's type is closed
tcExtendGhciEnv ids thing_inside tcExtendGhciEnv ids thing_inside
= do { env <- getLclEnv = tc_extend_local_env [ (idName id, ATcId { tct_id = id
; tc_extend_local_id_env env impLevel [(idName id, id) | id <- ids] thing_inside } , tct_closed = is_top id
, tct_level = impLevel })
tc_extend_local_id_env -- This is the guy who does the work | id <- ids]
:: TcLclEnv thing_inside
-> ThLevel where
-> [(Name,TcId)] is_top id | isEmptyVarSet (tcTyVarsOfType (idType id)) = TopLevel
-> TcM a -> TcM a | otherwise = NotTopLevel
tc_extend_local_env :: [(Name, TcTyThing)] -> TcM a -> TcM a
-- This is the guy who does the work
-- Invariant: the TcIds are fully zonked. Reasons: -- Invariant: the TcIds are fully zonked. Reasons:
-- (a) The kinds of the forall'd type variables are defaulted -- (a) The kinds of the forall'd type variables are defaulted
-- (see Kind.defaultKind, done in zonkQuantifiedTyVar) -- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
...@@ -430,18 +438,41 @@ tc_extend_local_id_env -- This is the guy who does the work ...@@ -430,18 +438,41 @@ tc_extend_local_id_env -- This is the guy who does the work
-- in the types, because instantiation does not look through such things -- in the types, because instantiation does not look through such things
-- (c) The call to tyVarsOfTypes is ok without looking through refs -- (c) The call to tyVarsOfTypes is ok without looking through refs
tc_extend_local_id_env env th_lvl names_w_ids thing_inside tc_extend_local_env extra_env thing_inside
= do { traceTc "env2" (ppr extra_env) = do { traceTc "env2" (ppr extra_env)
; gtvs' <- tcExtendGlobalTyVars (tcl_tyvars env) extra_global_tyvars ; env1 <- getLclEnv
; let env' = env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'} ; let le' = extendNameEnvList (tcl_env env1) extra_env
; setLclEnv env' thing_inside } rdr_env' = extendLocalRdrEnvList (tcl_rdr env1) (map fst extra_env)
env2 = env1 {tcl_env = le', tcl_rdr = rdr_env'}
; env3 <- extend_gtvs env2
; setLclEnv env3 thing_inside }
where where
extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]