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
import TcType
import Type
import Coercion
import TysPrim ( anyTypeOfKind )
import CostCentre
import Module
import Id
......@@ -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
-- So do self-recursive bindings, and recursive bindings
-- that have been chopped up with type signatures
dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
, abs_exports = [(tyvars, global, local, prags)]
dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = [export]
, abs_ev_binds = ev_binds, abs_binds = binds })
= ASSERT( all (`elem` tyvars) all_tyvars )
do { bind_prs <- ds_lhs_binds NoSccs binds
| ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = prags } <- export
= do { bind_prs <- ds_lhs_binds NoSccs binds
; ds_ev_binds <- dsTcEvBinds ev_binds
; wrap_fn <- dsHsWrapper wrap
; let core_bind = Rec (fromOL bind_prs)
rhs = addAutoScc auto_scc global $
wrap_fn $ -- Usually the identity
mkLams tyvars $ mkLams dicts $
wrapDsEvBinds ds_ev_binds $
Let core_bind $
......@@ -144,14 +145,14 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
; 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_binds = binds })
= do { bind_prs <- ds_lhs_binds NoSccs binds
; ds_ev_binds <- dsTcEvBinds ev_binds
; let env = mkABEnv exports
do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
= (lcl_id, addAutoScc auto_scc gbl_id rhs)
do_one (lcl_id,rhs) | Just export <- lookupVarEnv env lcl_id
= (lcl_id, addAutoScc auto_scc (abe_poly export) rhs)
| otherwise = (lcl_id,rhs)
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
tup_expr = mkBigCoreVarTup locals
tup_ty = exprType tup_expr
poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
poly_tup_rhs = mkLams tyvars $ mkLams dicts $
wrapDsEvBinds ds_ev_binds $
Let core_bind $
tup_expr
locals = [local | (_, _, local, _) <- exports]
local_tys = map idType locals
locals = map abe_mono exports
; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
; let mk_bind ((tyvars, global, _, spec_prags), n) -- locals!!n == local
= -- Need to make fresh locals to bind in the selector,
-- because some of the tyvars will be bound to 'Any'
do { let ty_args = map mk_ty_arg all_tyvars
substitute = substTyWith all_tyvars ty_args
; locals' <- newSysLocalsDs (map substitute local_tys)
; tup_id <- newSysLocalDs (substitute tup_ty)
; let rhs = mkLams tyvars $ mkLams dicts $
mkTupleSelector locals' (locals' !! n) tup_id $
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 mk_bind (ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = spec_prags })
= do { wrap_fn <- dsHsWrapper wrap
; tup_id <- newSysLocalDs tup_ty
; let rhs = wrap_fn $ mkLams tyvars $ mkLams dicts $
mkTupleSelector locals local tup_id $
mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
; let global' = addIdSpecialisations global rules
; 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.
; return ((poly_tup_id, poly_tup_rhs) `consOL`
......@@ -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
-- 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
-- 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}
Note [Rules and inlining]
......@@ -560,9 +551,6 @@ specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
-}
specUnfolding _ _ _
= return (noUnfolding, nilOL)
dsMkArbitraryType :: TcTyVar -> Type
dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
\end{code}
%************************************************************************
......
......@@ -136,7 +136,7 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
, abs_binds = binds }) body
= do { ds_ev_binds <- dsTcEvBinds ev_binds
; 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)
body1 binds
; return (wrapDsEvBinds ds_ev_binds body2) }
......@@ -542,8 +542,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
= nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
-- Reconstruct with the WrapId so that unpacking happens
wrap = mkWpEvVarApps theta_vars `WpCompose`
mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
wrap = mkWpEvVarApps theta_vars <.>
mkWpTyApps (mkTyVarTys ex_tvs) <.>
mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
, not (tv `elemVarEnv` wrap_subst) ]
rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
......
......@@ -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
......
......@@ -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
......
......@@ -910,19 +910,15 @@ languageExtensions :: Maybe Language -> [ExtensionFlag]
languageExtensions Nothing
-- Nothing => the default case
= Opt_MonoPatBinds -- Experimentally, I'm making this non-standard
-- 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
= Opt_NondecreasingIndentation -- This has been on by default for some time
: delete Opt_DatatypeContexts -- The Haskell' committee decided to
-- remove datatype contexts from the
-- language:
-- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html
(languageExtensions (Just Haskell2010))
-- NB: MonoPatBinds is no longer the default
languageExtensions (Just Haskell98)
= [Opt_ImplicitPrelude,
Opt_MonomorphismRestriction,
......@@ -1863,7 +1859,8 @@ xFlags = [
( "NPlusKPatterns", AlwaysAllowed, Opt_NPlusKPatterns, nop ),
( "DoAndIfThenElse", AlwaysAllowed, Opt_DoAndIfThenElse, 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 ),
( "AlternativeLayoutRule", AlwaysAllowed, Opt_AlternativeLayoutRule, nop ),
( "AlternativeLayoutRuleTransitional",AlwaysAllowed, Opt_AlternativeLayoutRuleTransitional, nop ),
......
......@@ -334,8 +334,10 @@ rnLocalValBindsRHS :: NameSet -- names bound by the LHSes
rnLocalValBindsRHS bound_names binds
= rnValBindsRHS trim (Just bound_names) binds
where
trim fvs = intersectNameSet bound_names fvs
-- Only keep the names the names from this group
trim fvs = filterNameSet isInternalName fvs
-- 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
-- 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
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
; 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 $
tcExtendIdEnv [local_meth_id] $
tcPolyBinds TopLevel meth_sig_fn no_prag_fn
NonRecursive NonRecursive
[lm_bind]
; let full_bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
, abs_exports = [(tyvars, meth_id, local_meth_id, specs)]
; let export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id
, 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_binds = tc_bind }
......@@ -357,8 +359,8 @@ mkGenericDefMethBind clas inst_tys sel_id dm_name
(vcat [ppr clas <+> ppr inst_tys,
nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
; return (noLoc $ mkFunBind (noLoc (idName sel_id))
[mkSimpleMatch [] rhs]) }
; return (noLoc $ mkTopFunBind (noLoc (idName sel_id))
[mkSimpleMatch [] rhs]) }
where
rhs = nlHsVar dm_name
\end{code}
......
......@@ -23,7 +23,7 @@ module TcEnv(
-- Local environment
tcExtendKindEnv, tcExtendKindEnvTvs,
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendGhciEnv,
tcExtendGhciEnv, tcExtendLetEnv,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
......@@ -76,6 +76,7 @@ import NameEnv
import HscTypes
import DynFlags
import SrcLoc
import BasicTypes
import Outputable
import Unique
import FastString
......@@ -371,23 +372,8 @@ tcExtendTyVarEnv tvs thing_inside
= tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
tcExtendTyVarEnv2 binds thing_inside = do
env@(TcLclEnv {tcl_env = le,
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
tcExtendTyVarEnv2 binds thing_inside
= tc_extend_local_env [(name, ATyVar name ty) | (name, ty) <- binds] thing_inside
getScopedTyVarBinds :: TcM [(Name, TcType)]
getScopedTyVarBinds
......@@ -397,32 +383,54 @@ getScopedTyVarBinds
\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 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 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
-- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
tcExtendIdEnv2 names_w_ids thing_inside
= do { env <- getLclEnv
; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) names_w_ids thing_inside }
= do { stage <- getStage
; 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
-- 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
-- OK to use a variable bound earlier in the interaction in a splice, becuase
-- GHCi has already compiled it to bytecode
-- Note especially that we bind them at
-- * TH level 'impLevel'. That's because it's OK to use a variable bound
-- 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
= do { env <- getLclEnv
; tc_extend_local_id_env env impLevel [(idName id, id) | id <- ids] thing_inside }
tc_extend_local_id_env -- This is the guy who does the work
:: TcLclEnv
-> ThLevel
-> [(Name,TcId)]
-> TcM a -> TcM a
= tc_extend_local_env [ (idName id, ATcId { tct_id = id
, tct_closed = is_top id
, tct_level = impLevel })
| id <- ids]
thing_inside
where
is_top id | isEmptyVarSet (tcTyVarsOfType (idType id)) = TopLevel
| 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:
-- (a) The kinds of the forall'd type variables are defaulted
-- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
......@@ -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
-- (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)
; gtvs' <- tcExtendGlobalTyVars (tcl_tyvars env) extra_global_tyvars
; let env' = env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}
; setLclEnv env' thing_inside }
; env1 <- getLclEnv
; let le' = extendNameEnvList (tcl_env env1) extra_env
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
extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
extra_env = [ (name, ATcId { tct_id = id,
tct_level = th_lvl })
| (name,id) <- names_w_ids]
le' = extendNameEnvList (tcl_env env) extra_env
rdr_env' = extendLocalRdrEnvList (tcl_rdr env) [name | (name,_) <- names_w_ids]
extend_gtvs env
| isEmptyVarSet extra_tvs
= return env
| otherwise
= do { g_var <- tcExtendGlobalTyVars (tcl_tyvars env) extra_tvs
; return (env { tcl_tyvars = g_var }) }
extra_tvs = foldr (unionVarSet . get_tvs) emptyVarSet extra_env
get_tvs (_, ATcId { tct_id = id, tct_closed = closed })
= case closed of
TopLevel -> ASSERT2( isEmptyVarSet id_tvs, ppr id $$ ppr (idType id) )
emptyVarSet
NotTopLevel -> id_tvs
where
id_tvs = tcTyVarsOfType (idType id)
get_tvs (_, ATyVar _ ty) = tcTyVarsOfType ty -- See Note [Global TyVars]
get_tvs other = pprPanic "get_tvs" (ppr other)
-- Note [Global TyVars]
-- 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.
tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet)
tcExtendGlobalTyVars gtv_var extra_global_tvs
......
......@@ -226,16 +226,6 @@ pprWithArising ev_vars
addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
pprErrCtxtLoc :: ReportErrCtxt -> SDoc
pprErrCtxtLoc ctxt
= case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
[] -> ptext (sLit "the top level") -- Should not happen
(orig:origs) -> ppr_skol orig $$
vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
where
ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
ppr_skol skol_info = ppr skol_info
getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)]
-- One item for each enclosing implication
getUserGivens (CEC {cec_encl = ctxt})
......@@ -514,13 +504,10 @@ reportDictErrs ctxt wanteds orig
| otherwise
= vcat [ couldNotDeduce givens (min_wanteds, orig)
, show_fixes (fix1 : (fixes2 ++ fixes3)) ]
, show_fixes (fixes1 ++ fixes2 ++ fixes3) ]
where
givens = getUserGivens ctxt
min_wanteds = mkMinimalBySCs wanteds
fix1 = sep [ ptext (sLit "add") <+> pprTheta min_wanteds
<+> ptext (sLit "to the context of")
, nest 2 $ pprErrCtxtLoc ctxt ]
fixes2 = case instance_dicts of
[] -> []
......@@ -544,6 +531,23 @@ reportDictErrs ctxt wanteds orig
show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
fixes1 | (orig:origs) <- mapCatMaybes get_good_orig (cec_encl ctxt)
= [sep [ ptext (sLit "add") <+> pprTheta min_wanteds
<+> ptext (sLit "to the context of")
, nest 2 $ ppr_skol orig $$
vcat [ ptext (sLit "or") <+> ppr_skol orig
| orig <- origs ]
] ]
| otherwise = []
ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
ppr_skol skol_info = ppr skol_info
-- Do not suggest adding constraints to an *inferred* type signature!
get_good_orig ic = case ctLocOrigin (ic_loc ic) of
SigSkol (InfSigCtxt {}) _ -> Nothing
origin -> Just origin
reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
-> PredType -> TcM (Maybe PredType)
-- Report an overlap error if this class constraint results
......
......@@ -425,15 +425,17 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
; new_exports <- mapM (zonkExport env3) exports
; return (new_val_binds, new_exports) }
; sig_warn True [b | (_,b,_,_) <- new_exports]
; sig_warn True (map abe_poly new_exports)
; return (AbsBinds { abs_tvs = tyvars, abs_ev_vars = new_evs, abs_ev_binds = new_ev_binds
, abs_exports = new_exports, abs_binds = new_val_bind }) }
where
zonkExport env (tyvars, global, local, prags)
-- The tyvars are already zonked
= zonkIdBndr env global `thenM` \ new_global ->
zonkSpecPrags env prags `thenM` \ new_prags ->
returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
zonkExport env (ABE{ abe_wrap = wrap, abe_poly = poly_id
, abe_mono = mono_id, abe_prags = prags })
= zonkIdBndr env poly_id `thenM` \ new_poly_id ->
zonkCoFn env wrap `thenM` \ (_, new_wrap) ->
zonkSpecPrags env prags `thenM` \ new_prags ->
returnM (ABE{ abe_wrap = new_wrap, abe_poly = new_poly_id
, abe_mono = zonkIdOcc env mono_id, abe_prags = new_prags })
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod
......
......@@ -781,7 +781,7 @@ tcInstDecls2 tycl_decls inst_decls
; let dm_ids = collectHsBindsBinders dm_binds
-- Add the default method Ids (again)
-- See Note [Default methods and instances]
; inst_binds_s <- tcExtendIdEnv dm_ids $
; inst_binds_s <- tcExtendLetEnv TopLevel dm_ids $
mapM tcInstDecl2 inst_decls
-- Done
......@@ -884,10 +884,11 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
dfun_args = map varToCoreExpr sc_args ++
map Var meth_ids
export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun
, abe_mono = self_dict, abe_prags = SpecPrags spec_inst_prags }
main_bind = AbsBinds { abs_tvs = inst_tyvars
, abs_ev_vars = dfun_ev_vars
, abs_exports = [(inst_tyvars, dfun_id_w_fun, self_dict,
SpecPrags spec_inst_prags)]
, abs_exports = [export]
, abs_ev_binds = emptyTcEvBinds
, abs_binds = unitBag dict_bind }
......@@ -1119,9 +1120,12 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
-- Copy the inline pragma (if any) from the default
-- method to this version. Note [INLINE and default methods]
export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id1
, abe_mono = local_meth_id
, abe_prags = mk_meth_spec_prags meth_id1 [] }
bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
, abs_exports = [( tyvars, meth_id1, local_meth_id
, mk_meth_spec_prags meth_id1 [])]
, abs_exports = [export]
, abs_ev_binds = EvBinds (unitBag self_ev_bind)
, abs_binds = unitBag meth_bind }
-- Default methods in an instance declaration can't have their own
......@@ -1215,9 +1219,10 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id
meth_bind = mkVarBind local_meth_id (L loc meth_rhs)
export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id
, abe_mono = local_meth_id, abe_prags = noSpecPrags }
bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
, abs_exports = [(tyvars, meth_id,
local_meth_id, noSpecPrags)]
, abs_exports = [export]
, abs_ev_binds = rep_ev_binds
, abs_binds = unitBag $ meth_bind }
......
......@@ -438,7 +438,9 @@ zonkTcTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTcTyVar (varSetElems tyvar
----------------- Types
zonkTcTypeCarefully :: TcType -> TcM TcType
-- Do not zonk type variables free in the environment
zonkTcTypeCarefully ty
zonkTcTypeCarefully ty = zonkTcType ty -- I think this function is out of date
{-
= do { env_tvs <- tcGetGlobalTyVars
; zonkType (zonk_tv env_tvs) ty }
where
......@@ -455,6 +457,7 @@ zonkTcTypeCarefully ty
; case cts of
Flexi -> return (TyVarTy tv)
Indirect ty -> zonkType (zonk_tv env_tvs) ty }
-}
zonkTcType :: TcType -> TcM TcType
-- Simply look through all Flexis
......@@ -836,6 +839,7 @@ checkValidType ctxt ty = do
ExprSigCtxt -> gen_rank 1
FunSigCtxt _ -> gen_rank 1
InfSigCtxt _ -> ArbitraryRank -- Inferred type
ConArgCtxt _ | polycomp -> gen_rank 2
-- We are given the type of the entire
-- constructor, hence rank 1
......
......@@ -1222,9 +1222,10 @@ mkPlan :: LStmt Name -> TcM PlanResult
mkPlan (L loc (ExprStmt expr _ _ _)) -- An expression typed at the prompt
= do { uniq <- newUnique -- is treated very specially
; let fresh_it = itName uniq
the_bind = L loc $ mkFunBind (L loc fresh_it) matches
the_bind = L loc $ mkTopFunBind (L loc fresh_it) matches
matches = [mkMatch [] expr emptyLocalBinds]
let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] []))
let_stmt = L loc $ LetStmt $ HsValBinds $
ValBindsOut [(NonRecursive,unitBag the_bind)] []
bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
(HsVar bindIOName) noSyntaxExpr
print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
......@@ -1343,10 +1344,11 @@ tcRnExpr hsc_env ictxt rdr_expr
uniq <- newUnique ;
let { fresh_it = itName uniq } ;
((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ;
((qtvs, dicts, _), lie_top) <- captureConstraints $
simplifyInfer TopLevel False {- No MR for now -}
[(fresh_it, res_ty)]
lie ;
((qtvs, dicts, _, _), lie_top) <- captureConstraints $
simplifyInfer True {- Free vars are closed -}
False {- No MR for now -}
[(fresh_it, res_ty)]
lie ;
_ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings
let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
......
......@@ -1015,7 +1015,7 @@ isUntouchable :: TcTyVar -> TcM Bool
isUntouchable tv = do { env <- getLclEnv
; return (varUnique tv < tcl_untch env) }
getLclTypeEnv :: TcM (NameEnv TcTyThing)
getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
......
......@@ -516,8 +516,9 @@ data TcTyThing
= AGlobal TyThing -- Used only in the return type of a lookup
| ATcId { -- Ids defined in this module; may not be fully zonked
tct_id :: TcId,
tct_level :: ThLevel }
tct_id :: TcId,
tct_closed :: TopLevelFlag, -- See Note [Bindings with closed types]
tct_level :: ThLevel }
| ATyVar Name TcType -- The type to which the lexically scoped type vaiable
-- is currently refined. We only need the Name
......@@ -543,6 +544,10 @@ pprTcTyThingCategory (ATcId {}) = ptext (sLit "Local identifier")
pprTcTyThingCategory (AThing {}) = ptext (sLit "Kinded thing")
\end{code}
Note [Bindings with closed types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
TODO: write me. This is all to do with OutsideIn
\begin{code}
type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, Message))
-- Monadic so that we have a chance
......@@ -1139,6 +1144,7 @@ data CtOrigin
| PArrSeqOrigin (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:]
| SectionOrigin
| TupleOrigin -- (..,..)
| AmbigOrigin Name -- f :: ty
| ExprSigOrigin -- e :: ty
| PatSigOrigin -- p :: ty
| PatOrigin -- Instantiating a polytyped pattern at a constructor
......@@ -1170,6 +1176,7 @@ pprO AppOrigin = ptext (sLit "an application")
pprO (SpecPragOrigin name) = hsep [ptext (sLit "a specialisation pragma for"), quotes (ppr name)]
pprO (IPOccOrigin name) = hsep [ptext (sLit "a use of implicit parameter"), quotes (ppr name)]
pprO RecordUpdOrigin = ptext (sLit "a record update")
pprO (AmbigOrigin name) = ptext (sLit "the ambiguity check for") <+> quotes (ppr name)
pprO ExprSigOrigin = ptext (sLit "an expression type signature")