Commit 85aa6ef0 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Check generic-default method for ambiguity

Fixes Trac #7497 and #12151.   In some earlier upheaval I introduced
a bug in the ambiguity check for genreric-default method.

This patch fixes it.  But in fixing it I realised that the
sourc-location of any such error message was bogus, so I fixed
that too, which involved a slightly wider change; see the
comments with TcMethInfo.
parent e10497b9
......@@ -32,7 +32,7 @@ import Type
import Id
import TcType
import SrcLoc( noSrcSpan )
import SrcLoc( SrcSpan, noSrcSpan )
import DynFlags
import TcRnMonad
import UniqSupply
......@@ -274,9 +274,23 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
(mkTyVarTys (binderVars (univ_tvs ++ ex_tvs)))
------------------------------------------------------
type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
-- A temporary intermediate, to communicate between
-- tcClassSigs and buildClass.
type TcMethInfo -- A temporary intermediate, to communicate
-- between tcClassSigs and buildClass.
= ( Name -- Name of the class op
, Type -- Type of the class op
, Maybe (DefMethSpec (SrcSpan, Type)))
-- Nothing => no default method
--
-- Just VanillaDM => There is an ordinary
-- polymorphic default method
--
-- Just (GenericDM (loc, ty)) => There is a generic default metho
-- Here is its type, and the location
-- of the type signature
-- We need that location /only/ to attach it to the
-- generic default method's Name; and we need /that/
-- only to give the right location of an ambiguity error
-- for the generic default method, spat out by checkValidClass
buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> [TyConBinder] -- Of the tycon
......@@ -376,12 +390,20 @@ buildClass tycon_name binders roles sc_theta
mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
mk_op_item rec_clas (op_name, _, dm_spec)
= do { dm_info <- case dm_spec of
Nothing -> return Nothing
Just spec -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
; return (Just (dm_name, spec)) }
= do { dm_info <- mk_dm_info op_name dm_spec
; return (mkDictSelId op_name rec_clas, dm_info) }
mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type))
-> TcRnIf n m (Maybe (Name, DefMethSpec Type))
mk_dm_info _ Nothing
= return Nothing
mk_dm_info op_name (Just VanillaDM)
= do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
; return (Just (dm_name, VanillaDM)) }
mk_dm_info op_name (Just (GenericDM (loc, dm_ty)))
= do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc
; return (Just (dm_name, GenericDM dm_ty)) }
{-
Note [Class newtypes and equality predicates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -407,6 +429,14 @@ newImplicitBinder :: Name -- Base name
-- For source type/class decls, this is the first occurrence
-- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
newImplicitBinder base_name mk_sys_occ
= newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name)
newImplicitBinderLoc :: Name -- Base name
-> (OccName -> OccName) -- Occurrence name modifier
-> SrcSpan
-> TcRnIf m n Name -- Implicit name
-- Just the same, but lets you specify the SrcSpan
newImplicitBinderLoc base_name mk_sys_occ loc
| Just mod <- nameModule_maybe base_name
= newGlobalBinder mod occ loc
| otherwise -- When typechecking a [d| decl bracket |],
......@@ -416,7 +446,6 @@ newImplicitBinder base_name mk_sys_occ
; return (mkInternalName uniq occ loc) }
where
occ = mk_sys_occ (nameOccName base_name)
loc = nameSrcSpan base_name
-- | Make the 'TyConRepName' for this 'TyCon'
newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
......
......@@ -437,13 +437,13 @@ tc_iface_decl _parent ignore_prags
tc_dm :: SDoc
-> Maybe (DefMethSpec IfaceType)
-> IfL (Maybe (DefMethSpec Type))
-> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
tc_dm _ Nothing = return Nothing
tc_dm _ (Just VanillaDM) = return (Just VanillaDM)
tc_dm doc (Just (GenericDM ty))
= do { -- Must be done lazily to avoid sucking in types
; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty
; return (Just (GenericDM ty')) }
; return (Just (GenericDM (noSrcSpan, ty'))) }
tc_at cls (IfaceAT tc_decl if_def)
= do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
......
......@@ -103,7 +103,7 @@ tcClassSigs clas sigs def_methods
= do { traceTc "tcClassSigs 1" (ppr clas)
; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
; let gen_dm_env :: NameEnv Type
; let gen_dm_env :: NameEnv (SrcSpan, Type)
gen_dm_env = mkNameEnv gen_dm_prs
; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
......@@ -125,7 +125,7 @@ tcClassSigs clas sigs def_methods
dm_bind_names :: [Name] -- These ones have a value binding in the class decl
dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
tc_sig :: NameEnv Type -> ([Located Name], LHsSigType Name)
tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType Name)
-> TcM [TcMethInfo]
tc_sig gen_dm_env (op_names, op_hs_ty)
= do { traceTc "ClsSig 1" (ppr op_names)
......@@ -133,13 +133,13 @@ tcClassSigs clas sigs def_methods
; traceTc "ClsSig 2" (ppr op_names)
; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }
where
f nm | Just ty <- lookupNameEnv gen_dm_env nm = Just (GenericDM ty)
f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty)
| nm `elem` dm_bind_names = Just VanillaDM
| otherwise = Nothing
tc_gen_sig (op_names, gen_hs_ty)
= do { gen_op_ty <- tcClassSigType op_names gen_hs_ty
; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] }
; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] }
{-
************************************************************************
......
......@@ -2415,7 +2415,7 @@ checkValidClass cls
; unless constrained_class_methods $
mapM_ check_constraint (tail (theta1 ++ theta2))
; check_dm ctxt dm
; check_dm ctxt sel_id dm
}
where
ctxt = FunSigCtxt op_name True -- Report redundant class constraints
......@@ -2447,17 +2447,21 @@ checkValidClass cls
where
fam_tvs = tyConTyVars fam_tc
check_dm :: UserTypeCtxt -> DefMethInfo -> TcM ()
check_dm :: UserTypeCtxt -> Id -> DefMethInfo -> TcM ()
-- Check validity of the /top-level/ generic-default type
-- E.g for class C a where
-- default op :: forall b. (a~b) => blah
-- we do not want to do an ambiguity check on a type with
-- a free TyVar 'a' (Trac #11608). See TcType
-- Note [TyVars and TcTyVars during type checking]
-- Hence the mkSpecForAllTys to close the type.
check_dm ctxt (Just (_, GenericDM ty))
= checkValidType ctxt (mkSpecForAllTys tyvars ty)
check_dm _ _ = return ()
-- Hence the mkDefaultMethodType to close the type.
check_dm ctxt sel_id (Just (dm_name, dm_spec@(GenericDM {})))
= setSrcSpan (getSrcSpan dm_name) $
-- We have carefully set the SrcSpan on the generic
-- default-method Name to be that of the generic
-- default type signature
checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec)
check_dm _ _ _ = return ()
checkFamFlag :: Name -> TcM ()
-- Check that we don't use families without -XTypeFamilies
......
......@@ -18,7 +18,7 @@ module TcTyDecls(
checkClassCycles,
-- * Implicits
tcAddImplicits,
tcAddImplicits, mkDefaultMethodType,
-- * Record selectors
mkRecSelBinds, mkOneRecordSelector
......@@ -647,17 +647,18 @@ mkDefaultMethodIds :: [TyCon] -> [Id]
-- the filled-in default methods of each instance declaration
-- See Note [Default method Ids and Template Haskell]
mkDefaultMethodIds tycons
= [ mkExportedVanillaId dm_name (mk_dm_ty cls sel_id dm_spec)
= [ mkExportedVanillaId dm_name (mkDefaultMethodType cls sel_id dm_spec)
| tc <- tycons
, Just cls <- [tyConClass_maybe tc]
, (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ]
where
mk_dm_ty :: Class -> Id -> DefMethSpec Type -> Type
mk_dm_ty _ sel_id VanillaDM = idType sel_id
mk_dm_ty cls _ (GenericDM dm_ty) = mkSpecSigmaTy cls_tvs [pred] dm_ty
where
cls_tvs = classTyVars cls
pred = mkClassPred cls (mkTyVarTys cls_tvs)
mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type
-- Returns the top-level type of the default method
mkDefaultMethodType _ sel_id VanillaDM = idType sel_id
mkDefaultMethodType cls _ (GenericDM dm_ty) = mkSpecSigmaTy cls_tvs [pred] dm_ty
where
cls_tvs = classTyVars cls
pred = mkClassPred cls (mkTyVarTys cls_tvs)
{-
************************************************************************
......
......@@ -10,7 +10,7 @@ module Class (
ClassOpItem,
ClassATItem(..),
ClassMinimalDef,
DefMethInfo, pprDefMethInfo, defMethSpecOfDefMeth,
DefMethInfo, pprDefMethInfo,
FunDep, pprFundeps, pprFunDep,
......@@ -110,14 +110,6 @@ data ClassATItem
type ClassMinimalDef = BooleanFormula Name -- Required methods
-- | Convert a `DefMethInfo` to a `DefMethSpec`, which discards the name field in
-- the `DefMeth` constructor of the `DefMeth`.
defMethSpecOfDefMeth :: DefMethInfo -> Maybe (DefMethSpec Type)
defMethSpecOfDefMeth meth
= case meth of
Nothing -> Nothing
Just (_, spec) -> Just spec
{-
Note [Associated type defaults]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -13,6 +13,8 @@ import Type
import TyCon
import DataCon
import DynFlags
import BasicTypes( DefMethSpec(..) )
import SrcLoc( SrcSpan, noSrcSpan )
import Var
import Name
import Outputable
......@@ -124,6 +126,13 @@ vectMethod id defMeth ty
; return (Var.varName id', ty', defMethSpecOfDefMeth defMeth)
}
-- | Convert a `DefMethInfo` to a `DefMethSpec`, which discards the name field in
-- the `DefMeth` constructor of the `DefMeth`.
defMethSpecOfDefMeth :: DefMethInfo -> Maybe (DefMethSpec (SrcSpan, Type))
defMethSpecOfDefMeth Nothing = Nothing
defMethSpecOfDefMeth (Just (_, VanillaDM)) = Just VanillaDM
defMethSpecOfDefMeth (Just (_, GenericDM ty)) = Just (GenericDM (noSrcSpan, ty))
-- |Vectorise the RHS of an algebraic type.
--
vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
......
{-# LANGUAGE DefaultSignatures #-}
-- {-# LANGUAGE AllowAmbiguousTypes #-} -- Not required with GHC 8.0.1.
module T12151 where
class Put a where
put :: a
default put :: t -- This should be `a` instead of `t`
put = undefined
T12151.hs:9:13: error:
• Could not deduce (Put a0)
from the context: Put a
bound by the type signature for:
put :: Put a => t
at T12151.hs:9:13-15
The type variable ‘a0’ is ambiguous
• In the ambiguity check for ‘put’
To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
When checking the class method: put :: forall a. Put a => a
In the class declaration for ‘Put’
{-# LANGUAGE DefaultSignatures, FlexibleContexts, DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
module T7437 where
import GHC.Generics
class GPut f where
gput :: f a -> [()]
class Put a where
put :: a -> [()]
default put :: (Generic t, GPut (Rep t)) => t -> [()]
put = gput . from
T7437.hs:14:13: error:
• Could not deduce (Put a0)
from the context: (Put a, Generic t, GPut (Rep t))
bound by the type signature for:
put :: (Put a, Generic t, GPut (Rep t)) => t -> [()]
at T7437.hs:14:13-15
The type variable ‘a0’ is ambiguous
• In the ambiguity check for ‘put’
To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
When checking the class method: put :: forall a. Put a => a -> [()]
In the class declaration for ‘Put’
......@@ -421,3 +421,5 @@ test('T11990b', normal, compile_fail, [''])
test('T12063', [ expect_broken(12063), extra_clean(['T12063.hi-boot', 'T12063.o-boot', 'T12063a.hi', 'T12063a.o']) ],
multimod_compile_fail, ['T12063', '-v0'])
test('T11974b', normal, compile_fail, [''])
test('T12151', normal, compile_fail, [''])
test('T7437', normal, compile_fail, [''])
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