Commit e9dfb6e5 authored by Facundo Domínguez's avatar Facundo Domínguez Committed by Ben Gamari

Improve the error messages for static forms.

Now the message explains why closed variables are not closed when
encountered in the body of (static ...).

This required adding to the local environment the free variables of
the local bindings in scope. Thus we can analyze and explain why a
variable is not closed when encountered.

Test Plan: ./validate

Reviewers: austin, simonpj, bgamari

Reviewed By: bgamari

Subscribers: mboes, thomie

Differential Revision: https://phabricator.haskell.org/D2167

GHC Trac Issues: #12003
parent b020db2a
......@@ -16,7 +16,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
TcPragEnv, mkPragEnv,
tcUserTypeSig, instTcTySig, chooseInferredQuantifiers,
instTcTySigFromId, tcExtendTyVarEnvFromSig,
badBootDeclErr ) where
badBootDeclErr) where
import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcMonoExpr )
......@@ -407,7 +407,7 @@ tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
------------------------
tc_group :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> (RecFlag, LHsBinds Name) -> TopLevelFlag -> TcM thing
-> (RecFlag, LHsBinds Name) -> IsGroupClosed -> TcM thing
-> TcM ([(RecFlag, LHsBinds TcId)], thing)
-- Typecheck one strongly-connected component of the original program.
......@@ -470,7 +470,7 @@ recursivePatSynErr binds
tc_single :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> LHsBind Name -> TopLevelFlag -> TcM thing
-> LHsBind Name -> IsGroupClosed -> TcM thing
-> TcM (LHsBinds TcId, thing)
tc_single _top_lvl sig_fn _prag_fn
(L _ (PatSynBind psb@PSB{ psb_id = L _ name }))
......@@ -522,7 +522,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv
-> RecFlag -- Whether the group is really recursive
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> TopLevelFlag -- Whether the group is closed
-> IsGroupClosed -- Whether the group is closed
-> [LHsBind Name] -- None are PatSynBind
-> TcM (LHsBinds TcId, [TcId])
......@@ -1913,12 +1913,12 @@ instance Outputable GeneralisationPlan where
ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
decideGeneralisationPlan
:: DynFlags -> [LHsBind Name] -> TopLevelFlag -> TcSigFun
:: DynFlags -> [LHsBind Name] -> IsGroupClosed -> TcSigFun
-> GeneralisationPlan
decideGeneralisationPlan dflags lbinds closed sig_fn
| unlifted_pat_binds = NoGen
| Just bind_sig <- one_funbind_with_sig = sig_plan bind_sig
| mono_local_binds = NoGen
| mono_local_binds closed = NoGen
| otherwise = InferGen mono_restriction
where
binds = map unLoc lbinds
......@@ -1946,8 +1946,8 @@ decideGeneralisationPlan dflags lbinds closed sig_fn
mono_restriction = xopt LangExt.MonomorphismRestriction dflags
&& any restricted binds
mono_local_binds = xopt LangExt.MonoLocalBinds dflags
&& not (isTopLevel closed)
mono_local_binds ClosedGroup = False
mono_local_binds _ = xopt LangExt.MonoLocalBinds dflags
no_sig n = noCompleteSig (sig_fn n)
......@@ -1974,17 +1974,23 @@ decideGeneralisationPlan dflags lbinds closed sig_fn
-- No args => like a pattern binding
-- Some args => a function binding
isClosedBndrGroup :: Bag (LHsBind Name) -> TcM TopLevelFlag
isClosedBndrGroup :: Bag (LHsBind Name) -> TcM IsGroupClosed
isClosedBndrGroup binds = do
type_env <- getLclTypeEnv
if foldrBag (is_closed_ns type_env . fvs . unLoc) True binds
then return TopLevel
else return NotTopLevel
if foldUFM (is_closed_ns type_env) True fv_env
then return ClosedGroup
else return $ NonClosedGroup fv_env
where
fvs :: HsBind Name -> NameSet
fvs (FunBind { bind_fvs = vs }) = vs
fvs (PatBind { bind_fvs = vs }) = vs
fvs _ = emptyNameSet
fv_env :: NameEnv NameSet
fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
bindFvs :: HsBindLR Name idR -> [(Name, NameSet)]
bindFvs (FunBind { fun_id = f, bind_fvs = fvs })
= [(unLoc f, fvs)]
bindFvs (PatBind { pat_lhs = pat, bind_fvs = fvs })
= [(b, fvs) | b <- collectPatBinders pat]
bindFvs _
= []
is_closed_ns :: TcTypeEnv -> NameSet -> Bool -> Bool
is_closed_ns type_env ns b = b && nameSetAll (is_closed_id type_env) ns
......@@ -1995,10 +2001,11 @@ isClosedBndrGroup binds = do
is_closed_id type_env name
| Just thing <- lookupNameEnv type_env name
= case thing of
ATcId { tct_closed = cl } -> isTopLevel cl -- This is the key line
ATyVar {} -> False -- In-scope type variables
AGlobal {} -> True -- are not closed!
_ -> pprPanic "is_closed_id" (ppr name)
ATcId { tct_info = ClosedLet } -> True -- This is the key line
ATcId {} -> False
ATyVar {} -> False -- In-scope type variables
AGlobal {} -> True -- are not closed!
_ -> pprPanic "is_closed_id" (ppr name)
| otherwise
= True
-- The free-var set for a top level binding mentions
......
......@@ -407,40 +407,45 @@ tcExtendTyVarEnv2 binds thing_inside
tyvar' = setTyVarName tyvar name'
name' = tidyNameOcc name occ'
isTypeClosedLetBndr :: Id -> TopLevelFlag
isTypeClosedLetBndr :: Id -> Bool
-- See Note [Bindings with closed types] in TcRnTypes
-- Note that we decided if a let-bound variable is closed by
-- looking at its type, which is slightly more liberal, and a whole
-- lot easier to implement, than looking at its free variables
isTypeClosedLetBndr id
| isEmptyVarSet (tyCoVarsOfType (idType id)) = TopLevel
| otherwise = NotTopLevel
| isEmptyVarSet (tyCoVarsOfType (idType id)) = True
| otherwise = False
tcExtendLetEnv :: TopLevelFlag -> TopLevelFlag -> [TcId] -> TcM a -> TcM a
tcExtendLetEnv :: TopLevelFlag -> IsGroupClosed -> [TcId] -> TcM a -> TcM a
-- Used for both top-level value bindings and and nested let/where-bindings
-- Adds to the TcIdBinderStack too
tcExtendLetEnv top_lvl closed_group ids thing_inside
= tcExtendIdBndrs [TcIdBndr id top_lvl | id <- ids] $
tcExtendLetEnvIds' top_lvl closed_group [(idName id, id) | id <- ids]
tcExtendLetEnvIds' top_lvl closed_group
[(idName id, id) | id <- ids]
thing_inside
tcExtendLetEnvIds :: TopLevelFlag -> [(Name,TcId)] -> TcM a -> TcM a
tcExtendLetEnvIds :: TopLevelFlag -> [(Name, TcId)] -> TcM a -> TcM a
-- Used for both top-level value bindings and and nested let/where-bindings
-- Does not extend the TcIdBinderStack
tcExtendLetEnvIds top_lvl
= tcExtendLetEnvIds' top_lvl TopLevel
= tcExtendLetEnvIds' top_lvl ClosedGroup
tcExtendLetEnvIds' :: TopLevelFlag -> TopLevelFlag -> [(Name,TcId)] -> TcM a
tcExtendLetEnvIds' :: TopLevelFlag -> IsGroupClosed
-> [(Name,TcId)] -> TcM a
-> TcM a
-- Used for both top-level value bindings and and nested let/where-bindings
-- Does not extend the TcIdBinderStack
tcExtendLetEnvIds' top_lvl closed_group pairs thing_inside
= tc_extend_local_env top_lvl
[ (name, ATcId { tct_id = id
, tct_closed = case closed_group of
TopLevel -> isTypeClosedLetBndr id
_ -> closed_group })
| (name,id) <- pairs ] $
[ (name, ATcId { tct_id = let_id
, tct_info = case closed_group of
ClosedGroup
| isTypeClosedLetBndr let_id -> ClosedLet
| otherwise -> NonClosedLet emptyNameSet False
NonClosedGroup fvs ->
NonClosedLet
(maybe emptyNameSet id $ lookupNameEnv fvs name)
(isTypeClosedLetBndr let_id)
})
| (name, let_id) <- pairs ] $
thing_inside
tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
......@@ -460,7 +465,7 @@ tcExtendIdEnv2 names_w_ids thing_inside
| (_,mono_id) <- names_w_ids ] $
do { tc_extend_local_env NotTopLevel
[ (name, ATcId { tct_id = id
, tct_closed = NotTopLevel })
, tct_info = NotLetBound })
| (name,id) <- names_w_ids] $
thing_inside }
......@@ -512,11 +517,12 @@ tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
where
extra_tvs = foldr get_tvs emptyVarSet tc_ty_things
get_tvs (_, ATcId { tct_id = id, tct_closed = closed }) tvs
get_tvs (_, ATcId { tct_id = id, tct_info = closed }) tvs
= case closed of
TopLevel -> ASSERT2( isEmptyVarSet id_tvs, ppr id $$ ppr (idType id) )
tvs
NotTopLevel -> tvs `unionVarSet` id_tvs
ClosedLet ->
ASSERT2( isEmptyVarSet id_tvs, ppr id $$ ppr (idType id) ) tvs
_ ->
tvs `unionVarSet` id_tvs
where id_tvs = tyCoVarsOfType (idType id)
get_tvs (_, ATyVar _ tv) tvs -- See Note [Global TyVars]
......
......@@ -49,6 +49,8 @@ import ConLike
import DataCon
import PatSyn
import Name
import NameEnv
import NameSet
import RdrName
import TyCon
import Type
......@@ -2499,11 +2501,152 @@ fieldNotInType p rdr
************************************************************************
-}
-- | A data type to describe why a variable is not closed.
data NotClosedReason = NotLetBoundReason
| NotTypeClosed VarSet
| NotClosed Name NotClosedReason
-- | Checks if the given name is closed and emits an error if not.
--
-- See Note [Not-closed error messages].
checkClosedInStaticForm :: Name -> TcM ()
checkClosedInStaticForm name = do
thing <- tcLookup name
case thing of
ATcId { tct_closed = NotTopLevel } ->
addErrTc $ quotes (ppr name) <+>
text "is used in a static form but it is not closed."
_ -> return ()
type_env <- getLclTypeEnv
case checkClosed type_env name of
Nothing -> return ()
Just reason -> addErrTc $ explain name reason
where
-- See Note [Checking closedness].
checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed type_env n = checkLoop type_env (unitNameSet n) n
checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
checkLoop type_env visited n = do
-- The @visited@ set is an accumulating parameter that contains the set of
-- visited nodes, so we avoid repeating cycles in the traversal.
case lookupNameEnv type_env n of
Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of
ClosedLet -> Nothing
NotLetBound -> Just NotLetBoundReason
NonClosedLet fvs type_closed -> listToMaybe $
-- Look for a non-closed variable in fvs
[ NotClosed n' reason
| n' <- nameSetElemsStable fvs
, not (elemNameSet n' visited)
, Just reason <- [checkLoop type_env (extendNameSet visited n') n']
] ++
if type_closed then
[]
else
-- We consider non-let-bound variables easier to figure out than
-- non-closed types, so we report non-closed types to the user
-- only if we cannot spot the former.
[ NotTypeClosed $ tyCoVarsOfType (idType tcid) ]
-- The binding is closed.
_ -> Nothing
-- Converts a reason into a human-readable sentence.
--
-- @explain name reason@ starts with
--
-- "<name> is used in a static form but it is not closed because it"
--
-- and then follows a list of causes. For each id in the path, the text
--
-- "uses <id> which"
--
-- is appended, yielding something like
--
-- "uses <id> which uses <id1> which uses <id2> which"
--
-- until the end of the path is reached, which is reported as either
--
-- "is not let-bound"
--
-- when the final node is not let-bound, or
--
-- "has a non-closed type because it contains the type variables:
-- v1, v2, v3"
--
-- when the final node has a non-closed type.
--
explain :: Name -> NotClosedReason -> SDoc
explain name reason =
quotes (ppr name) <+> text "is used in a static form but it is not closed"
<+> text "because it"
$$
sep (causes reason)
causes :: NotClosedReason -> [SDoc]
causes NotLetBoundReason = [text "is not let-bound."]
causes (NotTypeClosed vs) =
[ text "has a non-closed type because it contains the"
, text "type variables:" <+>
pprVarSet vs (hsep . punctuate comma . map (quotes . ppr))
]
causes (NotClosed n reason) =
let msg = text "uses" <+> quotes (ppr n) <+> text "which"
in case reason of
NotClosed _ _ -> msg : causes reason
_ -> let (xs0, xs1) = splitAt 1 $ causes reason
in fmap (msg <+>) xs0 ++ xs1
-- Note [Not-closed error messages]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- When variables in a static form are not closed, we go through the trouble
-- of explaining why they aren't.
--
-- Thus, the following program
--
-- > {-# LANGUAGE StaticPointers #-}
-- > module M where
-- >
-- > f x = static g
-- > where
-- > g = h
-- > h = x
--
-- produces the error
--
-- 'g' is used in a static form but it is not closed because it
-- uses 'h' which uses 'x' which is not let-bound.
--
-- And a program like
--
-- > {-# LANGUAGE StaticPointers #-}
-- > module M where
-- >
-- > import Data.Typeable
-- > import GHC.StaticPtr
-- >
-- > f :: Typeable a => a -> StaticPtr TypeRep
-- > f x = const (static (g undefined)) (h x)
-- > where
-- > g = h
-- > h = typeOf
--
-- produces the error
--
-- 'g' is used in a static form but it is not closed because it
-- uses 'h' which has a non-closed type because it contains the
-- type variables: 'a'
--
-- Note [Checking closedness]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- @checkClosed@ checks if a binding is closed and returns a reason if it is
-- not.
--
-- The bindings define a graph where the nodes are ids, and there is an edge
-- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free
-- variables.
--
-- When @n@ is not closed, it has to exist in the graph some node reachable
-- from @n@ that it is not a let-bound variable or that it has a non-closed
-- type. Thus, the "reason" is a path from @n@ to this offending node.
--
-- When @n@ is not closed, we traverse the graph reachable from @n@ to build
-- the reason.
--
......@@ -1639,8 +1639,9 @@ runTcInteractive hsc_env thing_inside
-- See Note [Initialising the type environment for GHCi]
is_closed thing
| AnId id <- thing
, NotTopLevel <- isTypeClosedLetBndr id
= Left (idName id, ATcId { tct_id = id, tct_closed = NotTopLevel })
, not (isTypeClosedLetBndr id)
= Left (idName id, ATcId { tct_id = id
, tct_info = NotLetBound })
| otherwise
= Right thing
......
......@@ -40,6 +40,8 @@ module TcRnTypes(
-- Typechecker types
TcTypeEnv, TcIdBinderStack, TcIdBinder(..),
TcTyThing(..), PromotionErr(..),
IdBindingInfo(..),
IsGroupClosed(..),
SelfBootInfo(..),
pprTcTyThingCategory, pprPECategory,
......@@ -885,7 +887,7 @@ data TcTyThing
| ATcId { -- Ids defined in this module; may not be fully zonked
tct_id :: TcId,
tct_closed :: TopLevelFlag } -- See Note [Bindings with closed types]
tct_info :: IdBindingInfo } -- See Note [Bindings with closed types]
| ATyVar Name TcTyVar -- The type variable to which the lexically scoped type
-- variable is bound. We only need the Name
......@@ -922,11 +924,51 @@ instance Outputable TcTyThing where -- Debugging only
ppr elt@(ATcId {}) = text "Identifier" <>
brackets (ppr (tct_id elt) <> dcolon
<> ppr (varType (tct_id elt)) <> comma
<+> ppr (tct_closed elt))
<+> ppr (tct_info elt))
ppr (ATyVar n tv) = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv
ppr (ATcTyCon tc) = text "ATcTyCon" <+> ppr tc
ppr (APromotionErr err) = text "APromotionErr" <+> ppr err
-- | Describes how an Id is bound.
--
-- It is used for the following purposes:
--
-- a) for static forms in TcExpr.checkClosedInStaticForm and
-- b) to figure out when a nested binding can be generalised (in
-- TcBinds.decideGeneralisationPlan).
--
-- See Note [Meaning of IdBindingInfo].
data IdBindingInfo
= NotLetBound
| ClosedLet
| NonClosedLet NameSet Bool
-- Note [Meaning of IdBindingInfo]
--
-- @NotLetBound@ means that the Id is not let-bound (e.g. it is bound in a
-- lambda-abstraction or in a case pattern).
--
-- @ClosedLet@ means that the Id is let-bound, it is closed and its type is
-- closed as well.
--
-- @NonClosedLet fvs type-closed@ means that the Id is let-bound but it is not
-- closed. The @fvs@ set contains the free variables of the rhs. The type-closed
-- flag indicates if the type of Id is closed.
instance Outputable IdBindingInfo where
ppr NotLetBound = text "NotLetBound"
ppr ClosedLet = text "TopLevelLet"
ppr (NonClosedLet fvs closed_type) =
text "TopLevelLet" <+> ppr fvs <+> ppr closed_type
-- | Tells if a group of binders is closed.
--
-- When it is not closed, it provides a map of binder ids to the free vars
-- in their right-hand sides.
--
data IsGroupClosed = ClosedGroup
| NonClosedGroup (NameEnv NameSet)
instance Outputable PromotionErr where
ppr ClassPE = text "ClassPE"
ppr TyConPE = text "TyConPE"
......@@ -969,7 +1011,7 @@ have no free type variables, and it is the type variables in the
environment that makes things tricky for OutsideIn generalisation.
Definition:
A variable is "closed", and has tct_closed set to TopLevel,
A variable is "closed", and has tct_info set to TopLevel,
iff
a) all its free variables are imported, or are let-bound and closed
b) generalisation is not restricted by the monomorphism restriction
......
RnStaticPointersFail01.hs:5:7:
‘x’ is used in a static form but it is not closed.
‘x’ is used in a static form but it is not closed because it
is not let-bound.
In the expression: static x
In an equation for ‘f’: f x = static x
......@@ -2,6 +2,9 @@
module RnStaticPointersFail03 where
import Data.Typeable
import GHC.StaticPtr
f x = static (x . id)
f0 x = static (k . id)
......@@ -11,3 +14,9 @@ f0 x = static (k . id)
f1 x = static (k . id)
where
k = id
f2 :: Typeable a => a -> StaticPtr TypeRep
f2 x = const (static (g undefined)) (h x)
where
g = h
h = typeOf
RnStaticPointersFail03.hs:5:7:
‘x’ is used in a static form but it is not closed.
RnStaticPointersFail03.hs:8:7:
‘x’ is used in a static form but it is not closed because it
is not let-bound.
In the expression: static (x . id)
In an equation for ‘f’: f x = static (x . id)
RnStaticPointersFail03.hs:7:8:
‘k’ is used in a static form but it is not closed.
In the expression: static (k . id)
In an equation for ‘f0’:
f0 x
= static (k . id)
where
k = const (const () x)
RnStaticPointersFail03.hs:10:8:
‘k’ is used in a static form but it is not closed because it
uses ‘x’ which is not let-bound.
In the expression: static (k . id)
In an equation for ‘f0’:
f0 x
= static (k . id)
where
k = const (const () x)
RnStaticPointersFail03.hs:19:15:
‘g’ is used in a static form but it is not closed because it
uses ‘h’ which has a non-closed type because it contains the
type variables: ‘a’
In the first argument of ‘const’, namely ‘(static (g undefined))’
In the expression: const (static (g undefined)) (h x)
In an equation for ‘f2’:
f2 x
= const (static (g undefined)) (h x)
where
g = h
h = typeOf
......@@ -115,7 +115,7 @@ test('T8448', normal, compile_fail, [''])
test('T8149', normal, compile, [''])
test('RnStaticPointersFail01', [], compile_fail, [''])
test('RnStaticPointersFail02', [], compile_fail, [''])
test('RnStaticPointersFail03', [], compile_fail, [''])
test('RnStaticPointersFail03', [], compile_fail, ['-dsuppress-uniques'])
test('T9006',
extra_clean(['T9006a.hi', 'T9006a.o']),
multimod_compile_fail, ['T9006', '-v0'])
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment