diff options
| -rw-r--r-- | compiler/typecheck/TcDeriv.lhs | 260 | ||||
| -rw-r--r-- | compiler/typecheck/TcMType.lhs | 22 |
2 files changed, 168 insertions, 114 deletions
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 73137b01e6..5931652edf 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -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 diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 4de5375c55..e0e577b9ef 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -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} %************************************************************************ |