Skip to content
Snippets Groups Projects
Commit 51bebb7c authored by Joachim Breitner's avatar Joachim Breitner
Browse files

Refactor: Origin of inferred Thetas 

When doing non-standalone deriving, annotate each individual
unsimplified constraint with its own CtOrigin. This is just the
refactoring, so the CtOrigin is still CtDeriv in each case.
parent 0fe399c9
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
compiler/typecheck/TcDeriv.lhs
+ 157
− 103
View file @ 51bebb7c
......@@ -74,23 +74,22 @@ Overall plan
1. Convert the decls (i.e. data/newtype deriving clauses,
plus standalone deriving) to [EarlyDerivSpec]
2. Infer the missing contexts for the Left DerivSpecs
2. Infer the missing contexts for the InferTheta's
3. Add the derived bindings, generating InstInfos
\begin{code}
-- DerivSpec is purely local to this module
data DerivSpec = DS { ds_loc :: SrcSpan
, ds_orig :: CtOrigin
, ds_name :: Name
, ds_tvs :: [TyVar]
, ds_theta :: ThetaType
, ds_cls :: Class
, ds_tys :: [Type]
, ds_tc :: TyCon
, ds_tc_args :: [Type]
, ds_newtype :: Bool }
data DerivSpec theta = DS { ds_loc :: SrcSpan
, ds_name :: Name
, ds_tvs :: [TyVar]
, ds_theta :: theta
, ds_cls :: Class
, ds_tys :: [Type]
, ds_tc :: TyCon
, ds_tc_args :: [Type]
, ds_newtype :: Bool }
-- This spec implies a dfun declaration of the form
-- df :: forall tvs. theta => C tys
-- The Name is the name for the DFun we'll build
......@@ -100,6 +99,9 @@ data DerivSpec = DS { ds_loc :: SrcSpan
-- in ds_tc, ds_tc_args is the *representation* tycon
-- For non-family tycons, both are the same
-- the theta is either the given and final theta, in standalone deriving,
-- or the not-yet-simplified list of constraints together with their origin
-- ds_newtype = True <=> Newtype deriving
-- False <=> Vanilla deriving
\end{code}
......@@ -120,24 +122,61 @@ type DerivContext = Maybe ThetaType
-- Nothing <=> Vanilla deriving; infer the context of the instance decl
-- Just theta <=> Standalone deriving: context supplied by programmer
type EarlyDerivSpec = Either DerivSpec DerivSpec
-- Left ds => the context for the instance should be inferred
-- In this case ds_theta is the list of all the
-- constraints needed, such as (Eq [a], Eq a)
-- The inference process is to reduce this to a
-- simpler form (e.g. Eq a)
data PredOrigin = PredOrigin PredType CtOrigin
type ThetaOrigin = [PredOrigin]
mkPredOrigin :: CtOrigin -> PredType -> PredOrigin
mkPredOrigin origin pred = PredOrigin pred origin
mkThetaOrigin :: CtOrigin -> ThetaType -> ThetaOrigin
mkThetaOrigin origin = map (mkPredOrigin origin)
data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin)
| GivenTheta (DerivSpec ThetaType)
-- InferTheta ds => the context for the instance should be inferred
-- In this case ds_theta is the list of all the constraints
-- needed, such as (Eq [a], Eq a), together with a suitable CtLoc
-- to get good error messages.
-- The inference process is to reduce this to a simpler form (e.g.
-- Eq a)
--
-- Right ds => the exact context for the instance is supplied
-- by the programmer; it is ds_theta
-- GivenTheta ds => the exact context for the instance is supplied
-- by the programmer; it is ds_theta
forgetTheta :: EarlyDerivSpec -> DerivSpec ()
forgetTheta (InferTheta spec) = spec { ds_theta = () }
forgetTheta (GivenTheta spec) = spec { ds_theta = () }
earlyDSTyCon :: EarlyDerivSpec -> TyCon
earlyDSTyCon (InferTheta spec) = ds_tc spec
earlyDSTyCon (GivenTheta spec) = ds_tc spec
earlyDSLoc :: EarlyDerivSpec -> SrcSpan
earlyDSLoc (InferTheta spec) = ds_loc spec
earlyDSLoc (GivenTheta spec) = ds_loc spec
splitEarlyDerivSpec :: [EarlyDerivSpec] -> ([DerivSpec ThetaOrigin], [DerivSpec ThetaType])
splitEarlyDerivSpec [] = ([],[])
splitEarlyDerivSpec (InferTheta spec : specs) =
case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)
splitEarlyDerivSpec (GivenTheta spec : specs) =
case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)
pprDerivSpec :: DerivSpec -> SDoc
pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
ds_cls = c, ds_tys = tys, ds_theta = rhs })
= parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
<+> equals <+> ppr rhs)
instance Outputable DerivSpec where
instance Outputable theta => Outputable (DerivSpec theta) where
ppr = pprDerivSpec
instance Outputable EarlyDerivSpec where
ppr (InferTheta spec) = ppr spec <+> ptext (sLit "(Infer)")
ppr (GivenTheta spec) = ppr spec <+> ptext (sLit "(Given)")
instance Outputable PredOrigin where
ppr (PredOrigin ty _) = ppr ty -- The origin is not so interesting when debugging
\end{code}
......@@ -320,10 +359,10 @@ tcDeriving tycl_decls inst_decls deriv_decls
-- for each type, determine the auxliary declarations that are common
-- to multiple derivations involving that type (e.g. Generic and
-- Generic1 should use the same TcGenGenerics.MetaTyCons)
; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map (either id id) early_specs
; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map forgetTheta early_specs
; overlap_flag <- getOverlapFlag
; let (infer_specs, given_specs) = splitEithers early_specs
; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
; insts1 <- mapM (genInst True overlap_flag commonAuxs) given_specs
-- the stand-alone derived instances (@insts1@) are used when inferring
......@@ -381,7 +420,8 @@ pprRepTy fi@(FamInst { fi_tys = lhs })
-- Generic and Generic1; thus the types and logic are quite simple.
type CommonAuxiliary = MetaTyCons
type CommonAuxiliaries = [(TyCon, CommonAuxiliary)] -- NSF what is a more efficient map type?
commonAuxiliaries :: [DerivSpec] -> TcM (CommonAuxiliaries, BagDerivStuff)
commonAuxiliaries :: [DerivSpec ()] -> TcM (CommonAuxiliaries, BagDerivStuff)
commonAuxiliaries = foldM snoc ([], emptyBag) where
snoc acc@(cas, stuff) (DS {ds_name = nm, ds_cls = cls, ds_tc = rep_tycon})
| getUnique cls `elem` [genClassKey, gen1ClassKey] =
......@@ -507,10 +547,10 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
-- Check if an automatically generated DS for deriving Typeable should be
-- ommitted because the user had manually requested for an instance
hasInstance :: Name -> [EarlyDerivSpec] -> Bool
hasInstance n = any (\ds -> n == tyConName (either ds_tc ds_tc ds))
hasInstance n = any (\ds -> n == tyConName (earlyDSTyCon ds))
add_deriv_err eqn
= setSrcSpan (either ds_loc ds_loc eqn) $
= setSrcSpan (earlyDSLoc eqn) $
addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
2 (ptext (sLit "Use an instance declaration instead")))
......@@ -595,8 +635,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty))
; case tcSplitTyConApp_maybe inst_ty of
Just (tycon, tc_args)
| className cls == typeableClassName || isAlgTyCon tycon
-> mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys
tycon tc_args (Just theta)
-> mkEqnHelp tvs cls cls_tys tycon tc_args (Just theta)
_ -> -- Complain about functions, primitive types, etc,
-- except for the Typeable class
......@@ -670,7 +709,7 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
-- newtype T a s = ... deriving( ST s )
-- newtype K a a = ... deriving( Monad )
; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs)
; mkEqnHelp (varSetElemsKvsFirst univ_tvs)
cls cls_tys tc final_tc_args Nothing } }
derivePolyKindedTypeable :: Class -> [Type]
......@@ -687,7 +726,7 @@ derivePolyKindedTypeable cls cls_tys _tvs tc tc_args
; checkTc (allDistinctTyVars tc_args) $
derivingEtaErr cls cls_tys (mkTyConApp tc tc_kind_args)
; mkEqnHelp DerivOrigin kind_vars cls cls_tys tc tc_kind_args Nothing }
; mkEqnHelp kind_vars cls cls_tys tc tc_kind_args Nothing }
where
kind_vars = kindVarsOnly tc_args
tc_kind_args = mkTyVarTys kind_vars
......@@ -718,7 +757,7 @@ to find k:=*. Tricky stuff.
\begin{code}
mkEqnHelp :: CtOrigin -> [TyVar]
mkEqnHelp :: [TyVar]
-> Class -> [Type]
-> TyCon -> [Type]
-> DerivContext -- Just => context supplied (standalone deriving)
......@@ -729,18 +768,18 @@ mkEqnHelp :: CtOrigin -> [TyVar]
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded
mkEqnHelp orig tvs cls cls_tys tycon tc_args mtheta
mkEqnHelp tvs cls cls_tys tycon tc_args mtheta
| className cls `elem` oldTypeableClassNames
= do { dflags <- getDynFlags
; case checkOldTypeableConditions (dflags, tycon, tc_args) of
Just err -> bale_out err
Nothing -> mkOldTypeableEqn orig tvs cls tycon tc_args mtheta }
Nothing -> mkOldTypeableEqn tvs cls tycon tc_args mtheta }
| className cls == typeableClassName -- Polykinded Typeable
= do { dflags <- getDynFlags
; case checkTypeableConditions (dflags, tycon, tc_args) of
Just err -> bale_out err
Nothing -> mkPolyKindedTypeableEqn orig tvs cls tycon tc_args mtheta }
Nothing -> mkPolyKindedTypeableEqn tvs cls tycon tc_args mtheta }
| otherwise
= do { (rep_tc, rep_tc_args) <- lookup_data_fam tycon tc_args
......@@ -771,10 +810,10 @@ mkEqnHelp orig tvs cls cls_tys tycon tc_args mtheta
; dflags <- getDynFlags
; if isDataTyCon rep_tc then
mkDataTypeEqn orig dflags tvs cls cls_tys
mkDataTypeEqn dflags tvs cls cls_tys
tycon tc_args rep_tc rep_tc_args mtheta
else
mkNewTypeEqn orig dflags tvs cls cls_tys
mkNewTypeEqn dflags tvs cls cls_tys
tycon tc_args rep_tc rep_tc_args mtheta }
where
bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
......@@ -863,8 +902,7 @@ See Note [Eta reduction for data family axioms] in TcInstDcls.
%************************************************************************
\begin{code}
mkDataTypeEqn :: CtOrigin
-> DynFlags
mkDataTypeEqn :: DynFlags
-> [Var] -- Universally quantified type variables in the instance
-> Class -- Class for which we need to derive an instance
-> [Type] -- Other parameters to the class except the last
......@@ -876,7 +914,7 @@ mkDataTypeEqn :: CtOrigin
-> DerivContext -- Context of the instance, for standalone deriving
-> TcRn EarlyDerivSpec -- Return 'Nothing' if error
mkDataTypeEqn orig dflags tvs cls cls_tys
mkDataTypeEqn dflags tvs cls cls_tys
tycon tc_args rep_tc rep_tc_args mtheta
= case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of
-- NB: pass the *representation* tycon to checkSideConditions
......@@ -884,35 +922,43 @@ mkDataTypeEqn orig dflags tvs cls cls_tys
NonDerivableClass -> bale_out (nonStdErr cls)
DerivableClassError msg -> bale_out msg
where
go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
go_for_it = mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta
bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
mk_data_eqn :: CtOrigin -> [TyVar] -> Class
mk_data_eqn :: [TyVar] -> Class
-> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
-> TcM EarlyDerivSpec
mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
= do { loc <- getSrcSpanM
; dfun_name <- new_dfun_name cls tycon
; inferred_constraints <- inferConstraints cls inst_tys rep_tc rep_tc_args
; let spec = DS { ds_loc = loc, ds_orig = orig
, ds_name = dfun_name, ds_tvs = tvs
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tc, ds_tc_args = rep_tc_args
, ds_theta = mtheta `orElse` inferred_constraints
, ds_newtype = False }
; return (if isJust mtheta then Right spec -- Specified context
else Left spec) } -- Infer context
mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta
= do loc <- getSrcSpanM
dfun_name <- new_dfun_name cls tycon
case mtheta of
Nothing -> do --Infer context
inferred_constraints <- inferConstraints cls inst_tys rep_tc rep_tc_args
return $ InferTheta $ DS
{ ds_loc = loc
, ds_name = dfun_name, ds_tvs = tvs
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tc, ds_tc_args = rep_tc_args
, ds_theta = inferred_constraints
, ds_newtype = False }
Just theta -> do -- Specified context
return $ GivenTheta $ DS
{ ds_loc = loc
, ds_name = dfun_name, ds_tvs = tvs
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tc, ds_tc_args = rep_tc_args
, ds_theta = theta
, ds_newtype = False }
where
inst_tys = [mkTyConApp tycon tc_args]
----------------------
mkOldTypeableEqn :: CtOrigin -> [TyVar] -> Class
mkOldTypeableEqn :: [TyVar] -> Class
-> TyCon -> [TcType] -> DerivContext
-> TcM EarlyDerivSpec
-- The "old" (pre GHC 7.8 polykinded Typeable) deriving Typeable
-- used a horrid family of classes: Typeable, Typeable1, Typeable2, ... Typeable7
mkOldTypeableEqn orig tvs cls tycon tc_args mtheta
mkOldTypeableEqn tvs cls tycon tc_args mtheta
-- The Typeable class is special in several ways
-- data T a b = ... deriving( Typeable )
-- gives
......@@ -927,7 +973,7 @@ mkOldTypeableEqn orig tvs cls tycon tc_args mtheta
(ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
; real_cls <- tcLookupClass (oldTypeableClassNames `getNth` tyConArity tycon)
-- See Note [Getting base classes]
; mkOldTypeableEqn orig tvs real_cls tycon [] (Just []) }
; mkOldTypeableEqn tvs real_cls tycon [] (Just []) }
| otherwise -- standalone deriving
= do { checkTc (null tc_args)
......@@ -935,18 +981,18 @@ mkOldTypeableEqn orig tvs cls tycon tc_args mtheta
<> int (tyConArity tycon) <+> ppr tycon <> rparen)
; dfun_name <- new_dfun_name cls tycon
; loc <- getSrcSpanM
; return (Right $
DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
; return (GivenTheta $
DS { ds_loc = loc, ds_name = dfun_name, ds_tvs = []
, ds_cls = cls, ds_tys = [mkTyConApp tycon []]
, ds_tc = tycon, ds_tc_args = []
, ds_theta = mtheta `orElse` [], ds_newtype = False }) }
mkPolyKindedTypeableEqn :: CtOrigin -> [TyVar] -> Class
mkPolyKindedTypeableEqn :: [TyVar] -> Class
-> TyCon -> [TcType] -> DerivContext
-> TcM EarlyDerivSpec
-- We can arrive here from a 'deriving' clause
-- or from standalone deriving
mkPolyKindedTypeableEqn orig tvs cls tycon tc_args mtheta
mkPolyKindedTypeableEqn tvs cls tycon tc_args mtheta
= do { -- Check that we have not said, for example
-- deriving Typeable (T Int)
-- or deriving Typeable (S :: * -> *) where S is kind-polymorphic
......@@ -956,8 +1002,8 @@ mkPolyKindedTypeableEqn orig tvs cls tycon tc_args mtheta
; dfun_name <- new_dfun_name cls tycon
; loc <- getSrcSpanM
; let tc_app = mkTyConApp tycon tc_args
; return (Right $
DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name
; return (GivenTheta $
DS { ds_loc = loc, ds_name = dfun_name
, ds_tvs = filter isKindVar tvs, ds_cls = cls
, ds_tys = typeKind tc_app : [tc_app]
-- Remember, Typeable :: forall k. k -> *
......@@ -981,7 +1027,7 @@ mkPolyKindedTypeableEqn orig tvs cls tycon tc_args mtheta
inferConstraints :: Class -> [TcType]
-> TyCon -> [TcType]
-> TcM ThetaType
-> TcM ThetaOrigin
-- Generate a sufficiently large set of constraints that typechecking the
-- generated method definitions should succeed. This set will be simplified
-- before being used in the instance declaration
......@@ -1003,7 +1049,7 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
where
-- Constraints arising from the arguments of each constructor
con_arg_constraints cls' get_constrained_tys
= [ mkClassPred cls' [arg_ty]
= [ mkPredOrigin DerivOrigin (mkClassPred cls' [arg_ty])
| data_con <- tyConDataCons rep_tc,
arg_ty <- ASSERT( isVanillaDataCon data_con )
get_constrained_tys $
......@@ -1031,11 +1077,12 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
-- Constraints arising from superclasses
-- See Note [Superclasses of derived instance]
sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
(classSCTheta cls)
sc_constraints = mkThetaOrigin DerivOrigin $
substTheta (zipOpenTvSubst (classTyVars cls) inst_tys) (classSCTheta cls)
-- Stupid constraints
stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
stupid_constraints = mkThetaOrigin DerivOrigin $
substTheta subst (tyConStupidTheta rep_tc)
subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
-- Extra Data constraints
......@@ -1049,7 +1096,7 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
extra_constraints
| cls `hasKey` dataClassKey
, all (isLiftedTypeKind . typeKind) rep_tc_args
= [mkClassPred cls [ty] | ty <- rep_tc_args]
= [mkPredOrigin DerivOrigin (mkClassPred cls [ty]) | ty <- rep_tc_args]
| otherwise
= []
\end{code}
......@@ -1396,26 +1443,32 @@ a context for the Data instances:
%************************************************************************
\begin{code}
mkNewTypeEqn :: CtOrigin -> DynFlags -> [Var] -> Class
mkNewTypeEqn :: DynFlags -> [Var] -> Class
-> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
-> DerivContext
-> TcRn EarlyDerivSpec
mkNewTypeEqn orig dflags tvs
mkNewTypeEqn dflags tvs
cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
| might_derive_via_coercible && (newtype_deriving || std_class_via_coercible cls)
= do { traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
; dfun_name <- new_dfun_name cls tycon
; loc <- getSrcSpanM
; let spec = DS { ds_loc = loc, ds_orig = orig
, ds_name = dfun_name, ds_tvs = varSetElemsKvsFirst dfun_tvs
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
, ds_theta = mtheta `orElse` all_preds
, ds_newtype = True }
; return (if isJust mtheta then Right spec
else Left spec) }
= do traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
dfun_name <- new_dfun_name cls tycon
loc <- getSrcSpanM
case mtheta of
Just theta -> return $ GivenTheta $ DS
{ ds_loc = loc
, ds_name = dfun_name, ds_tvs = varSetElemsKvsFirst dfun_tvs
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
, ds_theta = theta
, ds_newtype = True }
Nothing -> return $ InferTheta $ DS
{ ds_loc = loc
, ds_name = dfun_name, ds_tvs = varSetElemsKvsFirst dfun_tvs
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
, ds_theta = all_preds
, ds_newtype = True }
| otherwise
= case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of
CanDerive -> go_for_it -- Use the standard H98 method
......@@ -1428,7 +1481,7 @@ mkNewTypeEqn orig dflags tvs
| otherwise -> bale_out non_std
where
newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags
go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
go_for_it = mk_data_eqn tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
bale_out msg = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg)
non_std = nonStdErr cls
......@@ -1482,6 +1535,7 @@ mkNewTypeEqn orig dflags tvs
rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
rep_tys = cls_tys ++ [rep_inst_ty]
rep_pred = mkClassPred cls rep_tys
rep_pred_o = mkPredOrigin DerivOrigin rep_pred
-- rep_pred is the representation dictionary, from where
-- we are gong to get all the methods for the newtype
-- dictionary
......@@ -1494,8 +1548,9 @@ mkNewTypeEqn orig dflags tvs
dfun_tvs = tyVarsOfTypes inst_tys
inst_ty = mkTyConApp tycon tc_args
inst_tys = cls_tys ++ [inst_ty]
sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
(classSCTheta cls)
sc_theta =
mkThetaOrigin DerivOrigin $
substTheta (zipOpenTvSubst cls_tyvars inst_tys) (classSCTheta cls)
-- Next we collect Coercible constaints between
......@@ -1503,6 +1558,7 @@ mkNewTypeEqn orig dflags tvs
-- newtype type; precisely the constraints required for the
-- calls to coercible that we are going to generate.
coercible_constraints =
mkThetaOrigin DerivOrigin $
map (\(Pair t1 t2) -> mkCoerciblePred t1 t2) $
mkCoerceClassMethEqn cls (varSetElemsKvsFirst dfun_tvs) inst_tys rep_inst_ty
......@@ -1513,7 +1569,7 @@ mkNewTypeEqn orig dflags tvs
-- instance C T
-- rather than
-- instance C Int => C T
all_preds = rep_pred : coercible_constraints ++ sc_theta -- NB: rep_pred comes first
all_preds = rep_pred_o : coercible_constraints ++ sc_theta -- NB: rep_pred comes first
-------------------------------------------------------------------
-- Figuring out whether we can only do this newtype-deriving thing
......@@ -1605,7 +1661,7 @@ ordered by sorting on type varible, tv, (major key) and then class, k,
\end{itemize}
\begin{code}
inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
inferInstanceContexts :: OverlapFlag -> [DerivSpec ThetaOrigin] -> TcM [DerivSpec ThetaType]
inferInstanceContexts _ [] = return []
......@@ -1625,7 +1681,7 @@ inferInstanceContexts oflag infer_specs
-- compares it with the current one; finishes if they are the
-- same, otherwise recurses with the new solutions.
-- It fails if any iteration fails
iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType]
iterate_deriv n current_solns
| n > 20 -- Looks as if we are in an infinite loop
-- This can happen if we have -XUndecidableInstances
......@@ -1640,22 +1696,21 @@ inferInstanceContexts oflag infer_specs
extendLocalInstEnv inst_specs $
mapM gen_soln infer_specs
; let eqList :: (a -> b -> Bool) -> [a] -> [b] -> Bool
eqList f xs ys = length xs == length ys && and (zipWith f xs ys)
; if (eqList (eqList eqType) current_solns new_solns) then
; if (current_solns `eqSolution` new_solns) then
return [ spec { ds_theta = soln }
| (spec, soln) <- zip infer_specs current_solns ]
else
iterate_deriv (n+1) new_solns }
eqSolution = eqListBy (eqListBy eqType)
------------------------------------------------------------------
gen_soln :: DerivSpec -> TcM [PredType]
gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
gen_soln :: DerivSpec ThetaOrigin -> TcM ThetaType
gen_soln (DS { ds_loc = loc, ds_tvs = tyvars
, ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
= setSrcSpan loc $
addErrCtxt (derivInstCtxt the_pred) $
do { theta <- simplifyDeriv orig the_pred tyvars deriv_rhs
do { theta <- simplifyDeriv the_pred tyvars deriv_rhs
-- checkValidInstance tyvars theta clas inst_tys
-- Not necessary; see Note [Exotic derived instance contexts]
-- in TcSimplify
......@@ -1669,7 +1724,7 @@ inferInstanceContexts oflag infer_specs
the_pred = mkClassPred clas inst_tys
------------------------------------------------------------------
mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> TcM ClsInst
mkInstance :: OverlapFlag -> ThetaType -> DerivSpec theta -> TcM ClsInst
mkInstance overlap_flag theta
(DS { ds_name = dfun_name
, ds_tvs = tvs, ds_cls = clas, ds_tys = tys })
......@@ -1697,15 +1752,14 @@ extendLocalInstEnv dfuns thing_inside
***********************************************************************************
\begin{code}
simplifyDeriv :: CtOrigin
-> PredType
simplifyDeriv :: PredType
-> [TyVar]
-> ThetaType -- Wanted
-> ThetaOrigin -- Wanted
-> TcM ThetaType -- Needed
-- Given instance (wanted) => C inst_ty
-- Simplify 'wanted' as much as possibles
-- Fail if not possible
simplifyDeriv orig pred tvs theta
simplifyDeriv pred tvs theta
= do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
-- The constraint solving machinery
-- expects *TcTyVars* not TyVars.
......@@ -1716,7 +1770,7 @@ simplifyDeriv orig pred tvs theta
skol_set = mkVarSet tvs_skols
doc = ptext (sLit "deriving") <+> parens (ppr pred)
; wanted <- newFlatWanteds orig (substTheta skol_subst theta)
; wanted <- mapM (\(PredOrigin t o) -> newFlatWanted o (substTy skol_subst t)) theta
; traceTc "simplifyDeriv" $
vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ]
......@@ -1893,7 +1947,7 @@ the renamer. What a great hack!
genInst :: Bool -- True <=> standalone deriving
-> OverlapFlag
-> CommonAuxiliaries
-> DerivSpec -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
-> DerivSpec ThetaType -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
genInst standalone_deriv oflag comauxs
spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
, ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys
......
compiler/typecheck/TcMType.lhs
+ 11
− 11
View file @ 51bebb7c
......@@ -36,7 +36,7 @@ module TcMType (
newEvVar, newEvVars, newEq, newDict,
newWantedEvVar, newWantedEvVars,
newTcEvBinds, addTcEvBind,
newFlatWanteds,
newFlatWanted, newFlatWanteds,
--------------------------------
-- Instantiation
......@@ -163,17 +163,17 @@ predTypeOccName ty = case classifyPredType ty of
*********************************************************************************
\begin{code}
newFlatWanted :: CtOrigin -> PredType -> TcM Ct
newFlatWanted orig pty
= do loc <- getCtLoc orig
v <- newWantedEvVar pty
return $ mkNonCanonical $
CtWanted { ctev_evar = v
, ctev_pred = pty
, ctev_loc = loc }
newFlatWanteds :: CtOrigin -> ThetaType -> TcM [Ct]
newFlatWanteds orig theta
= do { loc <- getCtLoc orig
; mapM (inst_to_wanted loc) theta }
where
inst_to_wanted loc pty
= do { v <- newWantedEvVar pty
; return $ mkNonCanonical $
CtWanted { ctev_evar = v
, ctev_pred = pty
, ctev_loc = loc } }
newFlatWanteds orig = mapM (newFlatWanted orig)
\end{code}
%************************************************************************
......
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