Refactor: Origin of inferred Thetas
authorJoachim Breitner <mail@joachim-breitner.de>
Mon, 2 Dec 2013 19:16:08 +0000 (19:16 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Tue, 3 Dec 2013 08:57:04 +0000 (08:57 +0000)
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.

compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcMType.lhs

index 73137b0..5931652 100644 (file)
@@ -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
index 4de5375..e0e577b 100644 (file)
@@ -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}
 
 %************************************************************************