TcDeriv.lhs 44.7 KB
 partain committed Jan 08, 1996 1 %  Simon Marlow committed Oct 11, 2006 2 % (c) The University of Glasgow 2006  simonm committed Dec 02, 1998 3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  partain committed Jan 08, 1996 4 5 6 7 8 % Handles @deriving@ clauses on @data@ declarations. \begin{code}  partain committed May 01, 1996 9 module TcDeriv ( tcDeriving ) where  partain committed Jan 08, 1996 10   simonm committed Jan 08, 1998 11 #include "HsVersions.h"  partain committed Mar 19, 1996 12   simonmar committed Dec 10, 2003 13 import HsSyn  Simon Marlow committed Oct 11, 2006 14 import DynFlags  partain committed Mar 19, 1996 15   Simon Marlow committed Oct 11, 2006 16 import Generics  simonpj committed Sep 13, 2002 17 import TcRnMonad  Simon Marlow committed Oct 11, 2006 18 import TcEnv  simonpj@microsoft.com committed Jan 02, 2007 19 20 import TcClassDcl( tcAddDeclCtxt ) -- Small helper import TcGenDeriv -- Deriv stuff  Simon Marlow committed Oct 11, 2006 21 22 23 import InstEnv import Inst import TcHsType  simonpj@microsoft.com committed Jan 02, 2007 24 import TcMType  Simon Marlow committed Oct 11, 2006 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 import TcSimplify import RnBinds import RnEnv import HscTypes import Class import Type import ErrUtils import MkId import DataCon import Maybes import RdrName import Name import NameSet import TyCon import TcType import Var import VarSet  simonpj committed Sep 28, 2000 44 import PrelNames  Simon Marlow committed Oct 11, 2006 45 46 47 import SrcLoc import Util import ListSetOps  simonm committed Jan 08, 1998 48 import Outputable  Ian Lynagh committed Mar 29, 2008 49 import FastString  simonmar committed Dec 10, 2003 50 import Bag  partain committed Jan 08, 1996 51 52 53 54 \end{code} %************************************************************************ %* *  simonpj@microsoft.com committed Sep 05, 2007 55  Overview  partain committed Jan 08, 1996 56 57 58 %* * %************************************************************************  simonpj@microsoft.com committed Sep 05, 2007 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 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 3. Add the derived bindings, generating InstInfos \begin{code} -- DerivSpec is purely local to this module data DerivSpec = DS { ds_loc :: SrcSpan , ds_orig :: InstOrigin , ds_name :: Name , ds_tvs :: [TyVar] , ds_theta :: ThetaType , ds_cls :: Class , ds_tys :: [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 -- The tyvars bind all the variables in the theta -- For family indexes, the tycon is the *family* tycon -- (not the representation tycon) -- ds_newtype = True <=> Newtype deriving -- False <=> Vanilla deriving type EarlyDerivSpec = Either DerivSpec DerivSpec -- Left ds => the context for the instance should be inferred  simonpj@microsoft.com committed Nov 20, 2007 90 91 92 93 94 95 96  -- 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) -- -- Right ds => the exact context for the instance is supplied -- by the programmer; it is ds_theta  simonpj@microsoft.com committed Sep 05, 2007 97 98 99 100 101 102 103 104 105 106 107  pprDerivSpec :: DerivSpec -> 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) \end{code} Inferring missing contexts ~~~~~~~~~~~~~~~~~~~~~~~~~~  partain committed Jan 08, 1996 108 109 Consider  partain committed Mar 19, 1996 110 111  data T a b = C1 (Foo a) (Bar b) | C2 Int (T b a)  partain committed Jan 08, 1996 112 113 114  | C3 (T a a) deriving (Eq)  partain committed Jun 05, 1996 115 116 117 118 [NOTE: See end of these comments for what to do with data (C a, D b) => T a b = ... ]  partain committed Jan 08, 1996 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 We want to come up with an instance declaration of the form instance (Ping a, Pong b, ...) => Eq (T a b) where x == y = ... It is pretty easy, albeit tedious, to fill in the code "...". The trick is to figure out what the context for the instance decl is, namely @Ping@, @Pong@ and friends. Let's call the context reqd for the T instance of class C at types (a,b, ...) C (T a b). Thus: Eq (T a b) = (Ping a, Pong b, ...) Now we can get a (recursive) equation from the @data@ decl: Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 u Eq (T b a) u Eq Int -- From C2 u Eq (T a a) -- From C3 Foo and Bar may have explicit instances for @Eq@, in which case we can just substitute for them. Alternatively, either or both may have their @Eq@ instances given by @deriving@ clauses, in which case they form part of the system of equations. Now all we need do is simplify and solve the equations, iterating to find the least fixpoint. Notice that the order of the arguments can switch around, as here in the recursive calls to T. Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b. We start with: Eq (T a b) = {} -- The empty set Next iteration: Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 u Eq (T b a) u Eq Int -- From C2 u Eq (T a a) -- From C3 After simplification: = Eq a u Ping b u {} u {} u {} = Eq a u Ping b Next iteration: Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 u Eq (T b a) u Eq Int -- From C2 u Eq (T a a) -- From C3 After simplification:  partain committed Mar 19, 1996 170  = Eq a u Ping b  partain committed Jan 08, 1996 171 172  u (Eq b u Ping a) u (Eq a u Ping a)  partain committed Mar 19, 1996 173   partain committed Jan 08, 1996 174 175 176 177 178 179 180 181 182 183 184 185  = Eq a u Ping b u Eq b u Ping a The next iteration gives the same result, so this is the fixpoint. We need to make a canonical form of the RHS to ensure convergence. We do this by simplifying the RHS to a form in which - the classes constrain only tyvars - the list is sorted by tyvar (major key) and then class (minor key) - no duplicates, of course So, here are the synonyms for the equation'' structures:  partain committed Jun 05, 1996 186   simonpj@microsoft.com committed Sep 05, 2007 187 188 Note [Data decl contexts] ~~~~~~~~~~~~~~~~~~~~~~~~~  partain committed Jun 05, 1996 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 Consider data (RealFloat a) => Complex a = !a :+ !a deriving( Read ) We will need an instance decl like: instance (Read a, RealFloat a) => Read (Complex a) where ... The RealFloat in the context is because the read method for Complex is bound to construct a Complex, and doing that requires that the argument type is in RealFloat. But this ain't true for Show, Eq, Ord, etc, since they don't construct a Complex; they only take them apart. Our approach: identify the offending classes, and add the data type context to the instance decl. The "offending classes" are Read, Enum?  simonpj committed Apr 01, 2002 210 211 212 213 214 FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that pattern matching against a constructor from a data type with a context gives rise to the constraints for that context -- or at least the thinned version. So now all classes are "offending".  simonpj@microsoft.com committed Sep 05, 2007 215 216 Note [Newtype deriving] ~~~~~~~~~~~~~~~~~~~~~~~  simonpj committed Apr 02, 2004 217 218 219 220 221 222 223 224 225 226 227 228 Consider this: class C a b instance C [a] Char newtype T = T Char deriving( C [a] ) Notice the free 'a' in the deriving. We have to fill this out to newtype T = T Char deriving( forall a. C [a] ) And then translate it to: instance C [a] Char => C [a] T where ...  simonpj@microsoft.com committed Sep 05, 2007 229 230 Note [Newtype deriving superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  simonpj@microsoft.com committed Nov 12, 2007 231 232 233 (See also Trac #1220 for an interesting exchange on newtype deriving and superclasses.)  simonpj@microsoft.com committed Sep 05, 2007 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 The 'tys' here come from the partial application in the deriving clause. The last arg is the new instance type. We must pass the superclasses; the newtype might be an instance of them in a different way than the representation type E.g. newtype Foo a = Foo a deriving( Show, Num, Eq ) Then the Show instance is not done via isomorphism; it shows Foo 3 as "Foo 3" The Num instance is derived via isomorphism, but the Show superclass dictionary must the Show instance for Foo, *not* the Show dictionary gotten from the Num dictionary. So we must build a whole new dictionary not just use the Num one. The instance we want is something like: instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where (+) = ((+)@a) ...etc... There may be a coercion needed which we get from the tycon for the newtype when the dict is constructed in TcInstDcls.tcInstDecl2  simonpj committed Apr 01, 2002 253   partain committed Jun 05, 1996 254   partain committed Jan 08, 1996 255 256 257 258 259 260 261 %************************************************************************ %* * \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}} %* * %************************************************************************ \begin{code}  chak@cse.unsw.edu.au. committed Jun 27, 2007 262 263 tcDeriving :: [LTyClDecl Name] -- All type constructors -> [LInstDecl Name] -- All instance declarations  bjorn@bringert.net committed Sep 18, 2006 264  -> [LDerivDecl Name] -- All stand-alone deriving declarations  simonpj@microsoft.com committed Jul 01, 2008 265  -> TcM ([InstInfo Name], -- The generated "instance decls"  simonpj committed Jul 19, 2005 266  HsValBinds Name) -- Extra generated top-level bindings  partain committed Apr 09, 1996 267   chak@cse.unsw.edu.au. committed Jun 27, 2007 268 tcDeriving tycl_decls inst_decls deriv_decls  twanvl committed Jan 17, 2008 269  = recoverM (return ([], emptyValBindsOut)) $ simonpj committed Oct 29, 2003 270  do { -- Fish the "deriving"-related information out of the TcEnv  simonpj@microsoft.com committed Sep 05, 2007 271 272  -- And make the necessary "equations". ; early_specs <- makeDerivSpecs tycl_decls inst_decls deriv_decls  simonpj committed Feb 19, 2003 273   simonpj@microsoft.com committed Sep 05, 2007 274 275  ; overlap_flag <- getOverlapFlag ; let (infer_specs, given_specs) = splitEithers early_specs  simonpj@microsoft.com committed Jul 01, 2008 276  ; insts1 <- mapM (genInst overlap_flag) given_specs  simonpj committed Jan 27, 2005 277   simonpj@microsoft.com committed Jul 01, 2008 278  ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1)$  simonpj@microsoft.com committed Sep 05, 2007 279  inferInstanceContexts overlap_flag infer_specs  simonpj committed Jan 27, 2005 280   simonpj@microsoft.com committed Jul 01, 2008 281  ; insts2 <- mapM (genInst overlap_flag) final_specs  simonpj committed Oct 29, 2003 282   simonpj@microsoft.com committed Sep 05, 2007 283  ; is_boot <- tcIsHsBoot  simonpj@microsoft.com committed Jul 01, 2008 284 285 286  -- Generate the generic to/from functions from each type declaration ; gen_binds <- mkGenericBinds is_boot ; (inst_info, rn_binds) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)  simonpj committed Dec 20, 2001 287   simonpj committed Oct 29, 2003 288  ; dflags <- getDOpts  twanvl committed Jan 17, 2008 289 290  ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" (ddump_deriving inst_info rn_binds))  simonpj committed Dec 20, 2001 291   simonpj@microsoft.com committed Sep 05, 2007 292  ; return (inst_info, rn_binds) }  simonpj committed Dec 20, 2001 293  where  simonpj@microsoft.com committed Jul 01, 2008 294  ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc  simonpj committed Dec 20, 2001 295  ddump_deriving inst_infos extra_binds  simonpj committed Jul 19, 2005 296  = vcat (map pprInstInfoDetails inst_infos) $$ppr extra_binds  partain committed Jan 08, 1996 297   simonpj@microsoft.com committed Jul 01, 2008 298 299 300 301 302 303 304 305 306 renameDeriv :: Bool -> LHsBinds RdrName -> [(InstInfo RdrName, DerivAuxBinds)] -> TcM ([InstInfo Name], HsValBinds Name) renameDeriv is_boot gen_binds insts | is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings -- The inst-info bindings will all be empty, but it's easier to -- just use rn_inst_info to change the type appropriately = do { rn_inst_infos <- mapM rn_inst_info inst_infos ; return (rn_inst_infos, emptyValBindsOut) }  simonpj committed Dec 20, 2001 307   simonpj@microsoft.com committed Sep 05, 2007 308  | otherwise  simonpj@microsoft.com committed Jul 01, 2008 309 310 311 312 313 314 315  = discardWarnings  -- Discard warnings about unused bindings etc do { (rn_gen, dus_gen) <- setOptM Opt_PatternSignatures  -- Type signatures in patterns -- are used in the generic binds rnTopBinds (ValBindsIn gen_binds []) ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to be kept alive -- Generate and rename any extra not-one-inst-decl-specific binds,  simonpj@microsoft.com committed Sep 05, 2007 316  -- notably "con2tag" and/or "tag2con" functions.  simonpj@microsoft.com committed Jul 01, 2008 317 318 319 320 321 322 323 324 325 326 327  -- Bring those names into scope before renaming the instances themselves ; loc <- getSrcSpanM -- Generic loc for shared bindings ; let aux_binds = listToBag  map (genAuxBind loc)  rm_dups []  concat deriv_aux_binds ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv (ValBindsIn aux_binds []) ; let aux_names = map unLoc (collectHsValBinders rn_aux_lhs) ; bindLocalNames aux_names  do { (rn_aux, _dus) <- rnTopBindsRHS aux_names rn_aux_lhs ; rn_inst_infos <- mapM rn_inst_info inst_infos ; return (rn_inst_infos, rn_aux plusHsValBinds rn_gen) } }  simonpj committed Aug 01, 2000 328   simonpj@microsoft.com committed Sep 05, 2007 329  where  simonpj@microsoft.com committed Jul 01, 2008 330 331  (inst_infos, deriv_aux_binds) = unzip insts  simonpj@microsoft.com committed Sep 05, 2007 332 333 334 335  -- Remove duplicate requests for auxilliary bindings rm_dups acc [] = acc rm_dups acc (b:bs) | any (isDupAux b) acc = rm_dups acc bs | otherwise = rm_dups (b:acc) bs  simonpj committed Nov 03, 2003 336   simonpj@microsoft.com committed Jul 01, 2008 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351  rn_inst_info (InstInfo { iSpec = inst, iBinds = NewTypeDerived }) = return (InstInfo { iSpec = inst, iBinds = NewTypeDerived }) rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs }) = -- Bring the right type variables into -- scope (yuk), and rename the method binds ASSERT( null sigs ) bindLocalNames (map Var.varName tyvars)  do { (rn_binds, _fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds ; return (InstInfo { iSpec = inst, iBinds = VanillaInst rn_binds [] }) } where (tyvars,_,clas,_) = instanceHead inst clas_nm = className clas  simonpj committed Nov 03, 2003 352 -----------------------------------------  simonpj@microsoft.com committed Jul 01, 2008 353 354 355 356 357 358 359 mkGenericBinds :: Bool -> TcM (LHsBinds RdrName) mkGenericBinds is_boot | is_boot = return emptyBag | otherwise = do { gbl_env <- getGblEnv ; let tcs = typeEnvTyCons (tcg_type_env gbl_env)  simonmar committed Dec 10, 2003 360 361  ; return (unionManyBags [ mkTyConGenericBinds tc | tc <- tcs, tyConHasGenerics tc ]) }  simonpj@microsoft.com committed Jul 01, 2008 362 363 364  -- We are only interested in the data type declarations, -- and then only in the ones whose 'has-generics' flag is on -- The predicate tyConHasGenerics finds both of these  partain committed Jan 08, 1996 365 366 367 368 369 \end{code} %************************************************************************ %* *  simonpj@microsoft.com committed Sep 05, 2007 370  From HsSyn to DerivSpec  partain committed Jan 08, 1996 371 372 373 %* * %************************************************************************  simonpj@microsoft.com committed Sep 05, 2007 374 @makeDerivSpecs@ fishes around to find the info about needed derived  partain committed Jan 08, 1996 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 instances. Complicating factors: \begin{itemize} \item We can only derive @Enum@ if the data type is an enumeration type (all nullary data constructors). \item We can only derive @Ix@ if the data type is an enumeration {\em or} has just one data constructor (e.g., tuples). \end{itemize} [See Appendix~E in the Haskell~1.2 report.] This code here deals w/ all those. \begin{code}  simonpj@microsoft.com committed Sep 05, 2007 390 391 392 393 makeDerivSpecs :: [LTyClDecl Name] -> [LInstDecl Name] -> [LDerivDecl Name] -> TcM [EarlyDerivSpec]  partain committed Jan 08, 1996 394   simonpj@microsoft.com committed Sep 05, 2007 395 makeDerivSpecs tycl_decls inst_decls deriv_decls  simonpj@microsoft.com committed Nov 20, 2007 396  = do { eqns1 <- mapAndRecoverM deriveTyData   chak@cse.unsw.edu.au. committed Jun 27, 2007 397 398 399 400  extractTyDataPreds tycl_decls ++ [ pd -- traverse assoc data families | L _ (InstDecl _ _ _ ats) <- inst_decls , pd <- extractTyDataPreds ats ]  simonpj@microsoft.com committed Nov 20, 2007 401  ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls  simonpj@microsoft.com committed Sep 05, 2007 402  ; return (catMaybes (eqns1 ++ eqns2)) }  chak@cse.unsw.edu.au. committed Jun 27, 2007 403 404 405 406  where extractTyDataPreds decls = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]  simonpj@microsoft.com committed Jan 02, 2007 407 408  ------------------------------------------------------------------  simonpj@microsoft.com committed Sep 05, 2007 409 deriveStandalone :: LDerivDecl Name -> TcM (Maybe EarlyDerivSpec)  simonpj@microsoft.com committed Jan 02, 2007 410 -- Standalone deriving declarations  Ian Lynagh committed Aug 10, 2007 411 -- e.g. deriving instance show a => Show (T a)  simonpj@microsoft.com committed Jan 02, 2007 412 413 414 415 -- Rather like tcLocalInstDecl deriveStandalone (L loc (DerivDecl deriv_ty)) = setSrcSpan loc  addErrCtxt (standaloneCtxt deriv_ty)   Ian Lynagh committed Aug 10, 2007 416 417 418 419 420 421 422  do { traceTc (text "standalone deriving decl for" <+> ppr deriv_ty) ; (tvs, theta, tau) <- tcHsInstHead deriv_ty ; traceTc (text "standalone deriving;" <+> text "tvs:" <+> ppr tvs <+> text "theta:" <+> ppr theta <+> text "tau:" <+> ppr tau) ; (cls, inst_tys) <- checkValidInstHead tau  simonpj@microsoft.com committed Jun 25, 2008 423 424 425  ; checkValidInstance tvs theta cls inst_tys -- C.f. TcInstDcls.tcLocalInstDecl1  Ian Lynagh committed Aug 10, 2007 426 427 428 429 430 431 432 433  ; let cls_tys = take (length inst_tys - 1) inst_tys inst_ty = last inst_tys ; traceTc (text "standalone deriving;" <+> text "class:" <+> ppr cls <+> text "class types:" <+> ppr cls_tys <+> text "type:" <+> ppr inst_ty) ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty (Just theta) }  simonpj@microsoft.com committed Jan 02, 2007 434 435  ------------------------------------------------------------------  simonpj@microsoft.com committed Sep 05, 2007 436 deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM (Maybe EarlyDerivSpec)  simonpj@microsoft.com committed Jul 01, 2008 437 438 439 440 441 deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, tcdTyVars = tv_names, tcdTyPats = ty_pats })) = setSrcSpan loc  -- Use the location of the 'deriving' item tcAddDeclCtxt decl   simonpj@microsoft.com committed Jan 02, 2007 442 443 444 445 446 447 448 449 450 451  do { let hs_ty_args = ty_pats orElse map (nlHsTyVar . hsLTyVarName) tv_names hs_app = nlHsTyConApp tycon_name hs_ty_args -- We get kinding info for the tyvars by typechecking (T a b) -- Hence forming a tycon application and then dis-assembling it ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app ; tcExtendTyVarEnv tvs  -- Deriving preds may (now) mention -- the type variables for the type constructor do { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred -- The "deriv_pred" is a LHsType to take account of the fact that for -- newtype deriving we allow deriving (forall a. C [a]).  Ian Lynagh committed Aug 10, 2007 452  ; mkEqnHelp DerivOrigin (tvs++deriv_tvs) cls cls_tys tc_app Nothing } }  simonpj@microsoft.com committed Sep 05, 2007 453 454  deriveTyData _other  simonpj@microsoft.com committed Apr 22, 2007 455  = panic "derivTyData" -- Caller ensures that only TyData can happen  simonpj@microsoft.com committed Jan 02, 2007 456 457  ------------------------------------------------------------------  Ian Lynagh committed Aug 10, 2007 458 mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type  simonpj@microsoft.com committed Nov 20, 2007 459 460  -> Maybe ThetaType -- Just => context supplied (standalone deriving) -- Nothing => context inferred (deriving on data decl)  simonpj@microsoft.com committed Sep 05, 2007 461  -> TcRn (Maybe EarlyDerivSpec)  Ian Lynagh committed Aug 10, 2007 462 mkEqnHelp orig tvs cls cls_tys tc_app mtheta  simonpj@microsoft.com committed Jan 02, 2007 463  | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app  simonpj@microsoft.com committed Jun 25, 2008 464 465 466 467 468  , isAlgTyCon tycon -- Check for functions, primitive types etc = do { (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon tc_args -- Be careful to test rep_tc here: in the case of families, -- we want to check the instance tycon, not the family tycon  simonpj@microsoft.com committed Nov 21, 2007 469  -- For standalone deriving (mtheta /= Nothing),  simonpj@microsoft.com committed Aug 04, 2008 470 471 472  -- check that all the data constructors are in scope. -- No need for this when deriving Typeable, becuase we don't need -- the constructors for that.  simonpj@microsoft.com committed Nov 21, 2007 473 474  -- By this time we know that the thing is algebraic -- because we've called checkInstHead in derivingStandalone  simonpj@microsoft.com committed Jun 25, 2008 475 476 477  ; rdr_env <- getGlobalRdrEnv ; let hidden_data_cons = isAbstractTyCon rep_tc || any not_in_scope (tyConDataCons rep_tc) not_in_scope dc = null (lookupGRE_Name rdr_env (dataConName dc))  simonpj@microsoft.com committed Aug 04, 2008 478 479 480  ; checkTc (isNothing mtheta || not hidden_data_cons || className cls elem typeableClassNames)  simonpj@microsoft.com committed Nov 21, 2007 481  (derivingHiddenErr tycon)  simonpj@microsoft.com committed Jan 02, 2007 482   Ian Lynagh committed Jul 10, 2007 483  ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable  Ian Lynagh committed Jul 08, 2007 484  ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving  chak@cse.unsw.edu.au. committed May 11, 2007 485 486  ; if isDataTyCon rep_tc then  simonpj@microsoft.com committed Nov 20, 2007 487 488  mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta  simonpj@microsoft.com committed Jan 02, 2007 489  else  simonpj@microsoft.com committed Sep 05, 2007 490  mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving  simonpj@microsoft.com committed Nov 20, 2007 491 492  tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta }  simonpj@microsoft.com committed Jan 02, 2007 493 494  | otherwise = baleOut (derivingThingErr cls cls_tys tc_app  simonpj@microsoft.com committed Jun 25, 2008 495  (ptext (sLit "The last argument of the instance must be a data or newtype application")))  simonpj@microsoft.com committed Jan 02, 2007 496   simonpj@microsoft.com committed Sep 05, 2007 497 498 baleOut :: Message -> TcM (Maybe a) baleOut err = do { addErrTc err; return Nothing }  simonpj@microsoft.com committed Jan 02, 2007 499 500 \end{code}  simonpj@microsoft.com committed Jun 06, 2008 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 Note [Looking up family instances for deriving] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tcLookupFamInstExact is an auxiliary lookup wrapper which requires that looked-up family instances exist. If called with a vanilla tycon, the old type application is simply returned. If we have data instance F () = ... deriving Eq data instance F () = ... deriving Eq then tcLookupFamInstExact will be confused by the two matches; but that can't happen because tcInstDecls1 doesn't call tcDeriving if there are any overlaps. There are two other things that might go wrong with the lookup. First, we might see a standalone deriving clause deriving Eq (F ()) when there is no data instance F () in scope. Note that it's OK to have data instance F [a] = ... deriving Eq (F [(a,b)]) where the match is not exact; the same holds for ordinary data types with standalone deriving declrations.  chak@cse.unsw.edu.au. committed May 14, 2007 524 525 526 527  \begin{code} tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type]) tcLookupFamInstExact tycon tys  chak@cse.unsw.edu.au. committed Aug 28, 2007 528 529 530 531 532  | not (isOpenTyCon tycon) = return (tycon, tys) | otherwise = do { maybeFamInst <- tcLookupFamInst tycon tys ; case maybeFamInst of  simonpj@microsoft.com committed Jun 06, 2008 533 534  Nothing -> famInstNotFound tycon tys Just famInst -> return famInst  chak@cse.unsw.edu.au. committed May 14, 2007 535  }  simonpj@microsoft.com committed Jun 06, 2008 536 537 538 539  famInstNotFound :: TyCon -> [Type] -> TcM a famInstNotFound tycon tys = failWithTc (ptext (sLit "No family instance for")  simonpj@microsoft.com committed Aug 04, 2008 540  <+> quotes (pprTypeApp tycon tys))  chak@cse.unsw.edu.au. committed May 14, 2007 541 542 \end{code}  simonpj@microsoft.com committed Jan 02, 2007 543 544 545 546 547 548 549 550  %************************************************************************ %* * Deriving data types %* * %************************************************************************ \begin{code}  Ian Lynagh committed Aug 10, 2007 551 mkDataTypeEqn :: InstOrigin -> Bool -> [Var] -> Class -> [Type]  simonpj@microsoft.com committed Sep 05, 2007 552 553 554  -> TyCon -> [Type] -> TyCon -> [Type] -> Maybe ThetaType -> TcRn (Maybe EarlyDerivSpec) -- Return 'Nothing' if error  Ian Lynagh committed Jul 08, 2007 555 mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys  Ian Lynagh committed Aug 10, 2007 556  tycon tc_args rep_tc rep_tc_args mtheta  Ian Lynagh committed Jul 08, 2007 557  | Just err <- checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc  simonpj@microsoft.com committed Jan 11, 2007 558  -- NB: pass the *representation* tycon to checkSideConditions  simonpj@microsoft.com committed Jan 02, 2007 559 560 561 562  = baleOut (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) err) | otherwise = ASSERT( null cls_tys )  simonpj@microsoft.com committed Sep 05, 2007 563 564  mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta  simonpj@microsoft.com committed Nov 20, 2007 565 566 567 568 mk_data_eqn, mk_typeable_eqn :: InstOrigin -> [TyVar] -> Class -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType -> TcM (Maybe EarlyDerivSpec)  simonpj@microsoft.com committed Sep 05, 2007 569 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta  simonpj@microsoft.com committed Nov 20, 2007 570 571  | getName cls elem typeableClassNames = mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta  simonpj@microsoft.com committed Jan 02, 2007 572 573 574  | otherwise = do { dfun_name <- new_dfun_name cls tycon  simonpj@microsoft.com committed Sep 05, 2007 575  ; loc <- getSrcSpanM  simonpj@microsoft.com committed Jan 02, 2007 576 577 578  ; let ordinary_constraints = [ mkClassPred cls [arg_ty] | data_con <- tyConDataCons rep_tc,  David Himmelstrup committed Jun 07, 2007 579 580  arg_ty <- ASSERT( isVanillaDataCon data_con ) dataConInstOrigArgTys data_con rep_tc_args,  simonpj@microsoft.com committed Jan 02, 2007 581 582  not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?  simonpj@microsoft.com committed Nov 28, 2007 583 584 585 586 587  -- See Note [Superclasses of derived instance] sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys) (classSCTheta cls) inst_tys = [mkTyConApp tycon tc_args]  simonpj@microsoft.com committed Sep 05, 2007 588 589  stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)  simonpj@microsoft.com committed Nov 28, 2007 590  all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints  simonpj@microsoft.com committed Jan 02, 2007 591   simonpj@microsoft.com committed Sep 05, 2007 592 593  spec = DS { ds_loc = loc, ds_orig = orig , ds_name = dfun_name, ds_tvs = tvs  simonpj@microsoft.com committed Nov 28, 2007 594  , ds_cls = cls, ds_tys = inst_tys  simonpj@microsoft.com committed Sep 05, 2007 595 596 597 598 599  , ds_theta = mtheta orElse all_constraints , ds_newtype = False } ; return (if isJust mtheta then Just (Right spec) -- Specified context else Just (Left spec)) } -- Infer context  simonpj@microsoft.com committed Jan 02, 2007 600   simonpj@microsoft.com committed Nov 20, 2007 601 602 603 604 605 606 607 608 609 610 611 612 mk_typeable_eqn orig tvs cls tycon tc_args rep_tc _rep_tc_args mtheta -- The Typeable class is special in several ways -- data T a b = ... deriving( Typeable ) -- gives -- instance Typeable2 T where ... -- Notice that: -- 1. There are no constraints in the instance -- 2. There are no type variables either -- 3. The actual class we want to generate isn't necessarily -- Typeable; it depends on the arity of the type | isNothing mtheta -- deriving on a data type decl = do { checkTc (cls hasKey typeableClassKey)  Ian Lynagh committed Apr 12, 2008 613  (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))  simonpj@microsoft.com committed Nov 20, 2007 614 615 616 617 618  ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon) ; mk_typeable_eqn orig tvs real_cls tycon [] rep_tc [] (Just []) } | otherwise -- standaone deriving = do { checkTc (null tc_args)  Ian Lynagh committed Apr 12, 2008 619  (ptext (sLit "Derived typeable instance must be of form (Typeable")  simonpj@microsoft.com committed Nov 20, 2007 620 621 622 623 624 625 626 627  <> int (tyConArity tycon) <+> ppr tycon <> rparen) ; dfun_name <- new_dfun_name cls tycon ; loc <- getSrcSpanM ; return (Just  Right  DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = [] , ds_cls = cls, ds_tys = [mkTyConApp tycon []] , ds_theta = mtheta orElse [], ds_newtype = False }) }  simonpj@microsoft.com committed Jan 02, 2007 628 629 630 ------------------------------------------------------------------ -- Check side conditions that dis-allow derivability for particular classes -- This is *apart* from the newtype-deriving mechanism  chak@cse.unsw.edu.au. committed Jan 04, 2007 631 632 633 634 -- -- Here we get the representation tycon in case of family instances as it has -- the data constructors - but we need to be careful to fall back to the -- family tycon (with indexes) in error messages.  simonpj@microsoft.com committed Jan 02, 2007 635   chak@cse.unsw.edu.au. committed Jan 04, 2007 636 checkSideConditions :: Bool -> Class -> [TcType] -> TyCon -> Maybe SDoc  Ian Lynagh committed Jul 08, 2007 637 checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc  simonpj@microsoft.com committed Jan 02, 2007 638 639 640  | notNull cls_tys = Just ty_args_why -- e.g. deriving( Foo s ) | otherwise  simonpj@microsoft.com committed Nov 20, 2007 641 642 643  = case sideConditions cls of Just cond -> cond (mayDeriveDataTypeable, rep_tc) Nothing -> Just non_std_why  partain committed Jan 08, 1996 644  where  Ian Lynagh committed Apr 12, 2008 645 646  ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class") non_std_why = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")  simonpj@microsoft.com committed Nov 20, 2007 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661  sideConditions :: Class -> Maybe Condition sideConditions cls | cls_key == eqClassKey = Just cond_std | cls_key == ordClassKey = Just cond_std | cls_key == readClassKey = Just cond_std | cls_key == showClassKey = Just cond_std | cls_key == enumClassKey = Just (cond_std andCond cond_isEnumeration) | cls_key == ixClassKey = Just (cond_std andCond (cond_isEnumeration orCond cond_isProduct)) | cls_key == boundedClassKey = Just (cond_std andCond (cond_isEnumeration orCond cond_isProduct)) | cls_key == dataClassKey = Just (cond_mayDeriveDataTypeable andCond cond_std) | getName cls elem typeableClassNames = Just (cond_mayDeriveDataTypeable andCond cond_typeableOK) | otherwise = Nothing where cls_key = getUnique cls  simonpj@microsoft.com committed Jan 02, 2007 662   simonpj@microsoft.com committed Jan 11, 2007 663 type Condition = (Bool, TyCon) -> Maybe SDoc  Ian Lynagh committed Jul 08, 2007 664  -- Bool is whether or not we are allowed to derive Data and Typeable  simonpj@microsoft.com committed Jan 11, 2007 665 666 667  -- TyCon is the *representation* tycon if the -- data type is an indexed one -- Nothing => OK  simonpj committed Apr 22, 2003 668   simonpj@microsoft.com committed Jan 02, 2007 669 670 671 672 673 674 orCond :: Condition -> Condition -> Condition orCond c1 c2 tc = case c1 tc of Nothing -> Nothing -- c1 succeeds Just x -> case c2 tc of -- c1 fails Nothing -> Nothing  Ian Lynagh committed Apr 12, 2008 675  Just y -> Just (x$$ ptext (sLit " and") $$y)  simonpj@microsoft.com committed Jan 02, 2007 676 677  -- Both fail  simonpj@microsoft.com committed Sep 05, 2007 678 andCond :: Condition -> Condition -> Condition  simonpj@microsoft.com committed Jan 02, 2007 679 680 681 682 683 andCond c1 c2 tc = case c1 tc of Nothing -> c2 tc -- c1 succeeds Just x -> Just x -- c1 fails cond_std :: Condition  Ian Lynagh committed Jul 08, 2007 684 cond_std (_, rep_tc)  simonpj@microsoft.com committed Jan 02, 2007 685 686 687 688  | any (not . isVanillaDataCon) data_cons = Just existential_why | null data_cons = Just no_cons_why | otherwise = Nothing where  chak@cse.unsw.edu.au. committed Jan 04, 2007 689 690  data_cons = tyConDataCons rep_tc no_cons_why = quotes (pprSourceTyCon rep_tc) <+>  Ian Lynagh committed Apr 12, 2008 691  ptext (sLit "has no data constructors")  chak@cse.unsw.edu.au. committed Jan 04, 2007 692  existential_why = quotes (pprSourceTyCon rep_tc) <+>  Ian Lynagh committed Apr 12, 2008 693  ptext (sLit "has non-Haskell-98 constructor(s)")  simonpj@microsoft.com committed Jan 02, 2007 694 695  cond_isEnumeration :: Condition  Ian Lynagh committed Jul 08, 2007 696 cond_isEnumeration (_, rep_tc)  chak@cse.unsw.edu.au. committed Jan 04, 2007 697 698  | isEnumerationTyCon rep_tc = Nothing | otherwise = Just why  simonpj@microsoft.com committed Jan 02, 2007 699  where  chak@cse.unsw.edu.au. committed Jan 04, 2007 700  why = quotes (pprSourceTyCon rep_tc) <+>  Ian Lynagh committed Apr 12, 2008 701  ptext (sLit "has non-nullary constructors")  simonpj@microsoft.com committed Jan 02, 2007 702 703  cond_isProduct :: Condition  Ian Lynagh committed Jul 08, 2007 704 cond_isProduct (_, rep_tc)  chak@cse.unsw.edu.au. committed Jan 04, 2007 705 706  | isProductTyCon rep_tc = Nothing | otherwise = Just why  simonpj@microsoft.com committed Jan 02, 2007 707  where  simonpj@microsoft.com committed May 02, 2007 708  why = quotes (pprSourceTyCon rep_tc) <+>  Ian Lynagh committed Apr 12, 2008 709  ptext (sLit "has more than one constructor")  simonpj@microsoft.com committed Jan 02, 2007 710 711 712 713 714  cond_typeableOK :: Condition -- OK for Typeable class -- Currently: (a) args all of kind * -- (b) 7 or fewer args  Ian Lynagh committed Jul 08, 2007 715 cond_typeableOK (_, rep_tc)  chak@cse.unsw.edu.au. committed Jan 04, 2007 716 717  | tyConArity rep_tc > 7 = Just too_many | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc))  simonpj@microsoft.com committed Jan 02, 2007 718  = Just bad_kind  chak@cse.unsw.edu.au. committed Jan 04, 2007 719  | isFamInstTyCon rep_tc = Just fam_inst -- no Typable for family insts  simonpj@microsoft.com committed Jan 02, 2007 720 721  | otherwise = Nothing where  chak@cse.unsw.edu.au. committed Jan 04, 2007 722  too_many = quotes (pprSourceTyCon rep_tc) <+>  Ian Lynagh committed Apr 12, 2008 723  ptext (sLit "has too many arguments")  chak@cse.unsw.edu.au. committed Jan 04, 2007 724  bad_kind = quotes (pprSourceTyCon rep_tc) <+>  Ian Lynagh committed Apr 12, 2008 725  ptext (sLit "has arguments of kind other than *'")  chak@cse.unsw.edu.au. committed Jan 04, 2007 726  fam_inst = quotes (pprSourceTyCon rep_tc) <+>  Ian Lynagh committed Apr 12, 2008 727  ptext (sLit "is a type family")  simonpj@microsoft.com committed Jan 02, 2007 728   Ian Lynagh committed Jul 08, 2007 729 730 731 732 cond_mayDeriveDataTypeable :: Condition cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _) | mayDeriveDataTypeable = Nothing | otherwise = Just why  simonpj@microsoft.com committed Jan 02, 2007 733  where  Ian Lynagh committed Apr 12, 2008 734  why = ptext (sLit "You need -XDeriveDataTypeable to derive an instance for this class")  simonpj@microsoft.com committed Jan 02, 2007 735   simonpj@microsoft.com committed Sep 05, 2007 736 std_class_via_iso :: Class -> Bool  simonpj@microsoft.com committed Jan 02, 2007 737 738 739 740 std_class_via_iso clas -- These standard classes can be derived for a newtype -- using the isomorphism trick *even if no -fglasgow-exts* = classKey clas elem [eqClassKey, ordClassKey, ixClassKey, boundedClassKey] -- Not Read/Show because they respect the type  simonpj@microsoft.com committed Feb 07, 2007 741  -- Not Enum, because newtypes are never in Enum  simonpj@microsoft.com committed Jan 02, 2007 742 743   simonpj@microsoft.com committed Sep 05, 2007 744 new_dfun_name :: Class -> TyCon -> TcM Name  simonpj@microsoft.com committed Jan 02, 2007 745 new_dfun_name clas tycon -- Just a simple wrapper  simonpj@microsoft.com committed Jul 01, 2008 746 747  = do { loc <- getSrcSpanM -- The location of the instance decl, not of the tycon ; newDFunName clas [mkTyConApp tycon []] loc }  simonpj@microsoft.com committed Jan 02, 2007 748 749 750 751  -- The type passed to newDFunName is only used to generate -- a suitable string; hence the empty type arg list \end{code}  simonpj@microsoft.com committed Nov 28, 2007 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 Note [Superclasses of derived instance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In general, a derived instance decl needs the superclasses of the derived class too. So if we have data T a = ...deriving( Ord ) then the initial context for Ord (T a) should include Eq (T a). Often this is redundant; we'll also generate an Ord constraint for each constructor argument, and that will probably generate enough constraints to make the Eq (T a) constraint be satisfied too. But not always; consider: data S a = S instance Eq (S a) instance Ord (S a) data T a = MkT (S a) deriving( Ord ) instance Num a => Eq (T a) The derived instance for (Ord (T a)) must have a (Num a) constraint! Similarly consider: data T a = MkT deriving( Data, Typeable ) Here there *is* no argument field, but we must nevertheless generate a context for the Data instances: instance Typable a => Data (T a) where ...  simonpj@microsoft.com committed Jan 02, 2007 776 777 778 779 780 781 782 783  %************************************************************************ %* * Deriving newtypes %* * %************************************************************************ \begin{code}  simonpj@microsoft.com committed Sep 05, 2007 784 mkNewTypeEqn :: InstOrigin -> Bool -> Bool -> [Var] -> Class  Ian Lynagh committed Jul 08, 2007 785  -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]  simonpj@microsoft.com committed Sep 05, 2007 786 787 788  -> Maybe ThetaType -> TcRn (Maybe EarlyDerivSpec) mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs  Ian Lynagh committed Aug 10, 2007 789  cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta  Ian Lynagh committed Jul 08, 2007 790  | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)  simonpj@microsoft.com committed Mar 16, 2007 791  = do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)  simonpj@microsoft.com committed Sep 05, 2007 792 793 794 795 796 797 798 799 800  ; dfun_name <- new_dfun_name cls tycon ; loc <- getSrcSpanM ; let spec = DS { ds_loc = loc, ds_orig = orig , ds_name = dfun_name, ds_tvs = dict_tvs , ds_cls = cls, ds_tys = inst_tys , ds_theta = mtheta orElse all_preds , ds_newtype = True } ; return (if isJust mtheta then Just (Right spec) else Just (Left spec)) }  simonpj@microsoft.com committed Mar 16, 2007 801 802  | isNothing mb_std_err -- Use the standard H98 method  simonpj@microsoft.com committed Sep 05, 2007 803  = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta  simonpj@microsoft.com committed Mar 16, 2007 804 805  -- Otherwise we can't derive  Ian Lynagh committed Jul 08, 2007 806  | newtype_deriving = baleOut cant_derive_err -- Too hard  simonpj@microsoft.com committed Sep 05, 2007 807  | otherwise = baleOut std_err -- Just complain about being a non-std instance  simonpj@microsoft.com committed Jan 02, 2007 808  where  Ian Lynagh committed Jul 08, 2007 809  mb_std_err = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon  simonpj@microsoft.com committed Mar 16, 2007 810 811  std_err = derivingThingErr cls cls_tys tc_app  vcat [fromJust mb_std_err,  Ian Lynagh committed Apr 12, 2008 812  ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")]  simonpj@microsoft.com committed Mar 16, 2007 813   simonpj committed Dec 20, 2001 814  -- Here is the plan for newtype derivings. We see  simonpj@microsoft.com committed Sep 23, 2006 815  -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)  simonpj committed Apr 02, 2004 816  -- where t is a type,  simonpj@microsoft.com committed Jan 02, 2007 817  -- ak+1...an is a suffix of a1..an, and are all tyars  simonpj@microsoft.com committed Sep 23, 2006 818  -- ak+1...an do not occur free in t, nor in the s1..sm  simonpj committed Apr 02, 2004 819 820  -- (C s1 ... sm) is a *partial applications* of class C -- with the last parameter missing  simonpj@microsoft.com committed Sep 23, 2006 821 822 823 824 825 826 827 828  -- (T a1 .. ak) matches the kind of C's last argument -- (and hence so does t) -- -- We generate the instance -- instance forall ({a1..ak} u fvs(s1..sm)). -- C s1 .. sm t => C s1 .. sm (T a1...ak) -- where T a1...ap is the partial application of -- the LHS of the correct kind and p >= k  simonpj committed Dec 20, 2001 829  --  simonpj@microsoft.com committed Sep 23, 2006 830 831 832 833 834 835 836  -- NB: the variables below are: -- tc_tvs = [a1, ..., an] -- tyvars_to_keep = [a1, ..., ak] -- rep_ty = t ak .. an -- deriv_tvs = fvs(s1..sm) \ tc_tvs -- tys = [s1, ..., sm] -- rep_fn' = t  simonpj committed Dec 20, 2001 837 838  -- -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )  simonpj@microsoft.com committed Sep 23, 2006 839  -- We generate the instance  simonpj committed Oct 18, 2002 840  -- instance Monad (ST s) => Monad (T s) where  partain committed Mar 19, 1996 841   simonpj@microsoft.com committed Jan 02, 2007 842 843  cls_tyvars = classTyVars cls kind = tyVarKind (last cls_tyvars)  simonpj committed Dec 20, 2001 844 845  -- Kind of the thing we want to instance -- e.g. argument kind of Monad, *->*  simonpj committed Nov 06, 2000 846   simonpj committed Dec 30, 2003 847  (arg_kinds, _) = splitKindFunTys kind  simonpj committed Dec 20, 2001 848 849 850 851  n_args_to_drop = length arg_kinds -- Want to drop 1 arg from (T s a) and (ST s a) -- to get instance Monad (ST s) => Monad (T s)  simonpj@microsoft.com committed Dec 21, 2007 852 853 854 855  -- Note [Newtype representation] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Need newTyConRhs (*not* a recursive representation finder) -- to get the representation type. For example  simonpj committed Nov 11, 2002 856 857 858 859  -- newtype B = MkB Int -- newtype A = MkA B deriving( Num ) -- We want the Num instance of B, *not* the Num instance of Int, -- when making the Num instance of A!  simonpj@microsoft.com committed Jan 02, 2007 860  rep_ty = newTyConInstRhs rep_tycon rep_tc_args  simonpj committed Nov 11, 2002 861  (rep_fn, rep_ty_args) = tcSplitAppTys rep_ty  simonpj committed Dec 20, 2001 862   simonpj@microsoft.com committed Jan 02, 2007 863 864 865  n_tyargs_to_keep = tyConArity tycon - n_args_to_drop dropped_tc_args = drop n_tyargs_to_keep tc_args dropped_tvs = tyVarsOfTypes dropped_tc_args  simonpj committed Dec 20, 2001 866   simonpj committed Oct 18, 2002 867  n_args_to_keep = length rep_ty_args - n_args_to_drop  simonpj committed Dec 21, 2001 868  args_to_drop = drop n_args_to_keep rep_ty_args  simonpj@microsoft.com committed Jan 02, 2007 869  args_to_keep = take n_args_to_keep rep_ty_args  simonpj committed Dec 20, 2001 870   simonpj@microsoft.com committed Apr 02, 2006 871  rep_fn' = mkAppTys rep_fn args_to_keep  simonpj@microsoft.com committed Jan 02, 2007 872 873  rep_tys = cls_tys ++ [rep_fn'] rep_pred = mkClassPred cls rep_tys  simonpj committed Oct 18, 2002 874  -- rep_pred is the representation dictionary, from where  chak@cse.unsw.edu.au. committed Dec 19, 2006 875 876 877  -- we are gong to get all the methods for the newtype -- dictionary  simonpj@microsoft.com committed Jan 02, 2007 878  tc_app = mkTyConApp tycon (take n_tyargs_to_keep tc_args)  chak@cse.unsw.edu.au. committed Sep 20, 2006 879   simonpj@microsoft.com committed Jan 02, 2007 880 881  -- Next we figure out what superclass dictionaries to use -- See Note [Newtype deriving superclasses] above  simonpj committed Oct 18, 2002 882   simonpj@microsoft.com committed Jan 02, 2007 883 884 885  inst_tys = cls_tys ++ [tc_app] sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys) (classSCTheta cls)  simonpj committed Oct 18, 2002 886 887 888  -- If there are no tyvars, there's no need -- to abstract over the dictionaries we need  simonpj@microsoft.com committed Sep 23, 2006 889 890 891 892 893  -- Example: newtype T = MkT Int deriving( C ) -- We get the derived instance -- instance C T -- rather than -- instance C Int => C T  simonpj@microsoft.com committed Jan 02, 2007 894  dict_tvs = filterOut (elemVarSet dropped_tvs) tvs  simonpj@microsoft.com committed Sep 23, 2006 895  all_preds = rep_pred : sc_theta -- NB: rep_pred comes first  simonpj committed Oct 18, 2002 896 897 898  ------------------------------------------------------------------- -- Figuring out whether we can only do this newtype-deriving thing  simonpj committed Dec 20, 2001 899   simonpj@microsoft.com committed Jan 02, 2007 900  right_arity = length cls_tys + 1 == classArity cls  simonpj committed Dec 20, 2001 901   simonpj committed May 06, 2003 902  -- Never derive Read,Show,Typeable,Data this way  simonpj@microsoft.com committed Jul 01, 2008 903 904  non_iso_class cls = className cls elem ([readClassName, showClassName, dataClassName] ++ typeableClassNames)  simonpj committed Dec 20, 2001 905  can_derive_via_isomorphism  simonpj@microsoft.com committed Jul 01, 2008 906  = not (non_iso_class cls)  simonpj committed Apr 08, 2003 907  && right_arity -- Well kinded;  simonpj committed Jan 23, 2003 908 909  -- eg not: newtype T ... deriving( ST ) -- because ST needs *2* type params  simonpj@microsoft.com committed Jan 02, 2007 910  && n_tyargs_to_keep >= 0 -- Type constructor has right kind:  simonpj committed Dec 21, 2001 911  -- eg not: newtype T = T Int deriving( Monad )  simonpj committed Apr 08, 2003 912  && n_args_to_keep >= 0 -- Rep type has right kind:  simonpj committed Dec 21, 2001 913 914  -- eg not: newtype T a = T Int deriving( Monad ) && eta_ok -- Eta reduction works  simonpj committed Jun 21, 2002 915 916 917 918  && not (isRecursiveTyCon tycon) -- Does not work for recursive tycons: -- newtype A = MkA [A] -- Don't want -- instance Eq [A] => Eq A !!  simonpj committed Jul 29, 2003 919 920 921 922  -- Here's a recursive newtype that's actually OK -- newtype S1 = S1 [T1 ()] -- newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad ) -- It's currently rejected. Oh well.  simonpj committed Apr 02, 2004 923 924 925 926  -- In fact we generate an instance decl that has method of form -- meth @ instTy = meth @ repTy -- (no coerce's). We'd need a coerce if we wanted to handle -- recursive newtypes too  simonpj committed Jul 29, 2003 927   simonpj committed Dec 21, 2001 928  -- Check that eta reduction is OK  simonpj@microsoft.com committed Jan 02, 2007 929 930 931 932 933  eta_ok = (args_to_drop tcEqTypes dropped_tc_args) -- (a) the dropped-off args are identical in the source and rep type -- newtype T a b = MkT (S [a] b) deriving( Monad ) -- Here the 'b' must be the same in the rep type (S [a] b)  simonpj@microsoft.com committed Sep 23, 2006 934  && (tyVarsOfType rep_fn' disjointVarSet dropped_tvs)  simonpj@microsoft.com committed Jan 02, 2007 935 936 937 938 939 940  -- (b) the remaining type args do not mention any of the dropped -- type variables && (tyVarsOfTypes cls_tys disjointVarSet dropped_tvs) -- (c) the type class args do not mention any of the dropped type -- variables  chak@cse.unsw.edu.au. committed Dec 19, 2006 941   simonpj@microsoft.com committed Jan 02, 2007 942 943 944  && all isTyVarTy dropped_tc_args -- (d) in case of newtype family instances, the eta-dropped -- arguments must be type variables (not more complex indexes)  simonpj committed Dec 20, 2001 945   simonpj@microsoft.com committed Jan 02, 2007 946  cant_derive_err = derivingThingErr cls cls_tys tc_app  Ian Lynagh committed Apr 12, 2008 947  (vcat [ptext (sLit "even with cunning newtype deriving:"),  simonpj committed Apr 08, 2003 948  if isRecursiveTyCon tycon then  Ian Lynagh committed Apr 12, 2008 949  ptext (sLit "the newtype may be recursive")  simonpj committed Apr 08, 2003 950 951  else empty, if not right_arity then  Ian Lynagh committed Apr 12, 2008 952  quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")  simonpj committed Apr 08, 2003 953  else empty,  simonpj@microsoft.com committed Jan 02, 2007 954  if not (n_tyargs_to_keep >= 0) then  Ian Lynagh committed Apr 12, 2008 955  ptext (sLit "the type constructor has wrong kind")  simonpj committed Apr 08, 2003 956  else if not (n_args_to_keep >= 0) then  Ian Lynagh committed Apr 12, 2008 957  ptext (sLit "the representation type has wrong kind")  simonpj committed Apr 08, 2003 958  else if not eta_ok then  Ian Lynagh committed Apr 12, 2008 959  ptext (sLit "the eta-reduction property does not hold")  simonpj committed Apr 08, 2003 960  else empty  simonpj committed Oct 18, 2002 961  ])  partain committed Jan 08, 1996 962 963 \end{code}  simonpj@microsoft.com committed Jan 02, 2007 964   partain committed Jan 08, 1996 965 966 967 968 969 970 %************************************************************************ %* * \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations} %* * %************************************************************************  partain committed Mar 19, 1996 971 A solution'' (to one of the equations) is a list of (k,TyVarTy tv)  partain committed Jan 08, 1996 972 973 974 975 terms, which is the final correct RHS for the corresponding original equation. \begin{itemize} \item  partain committed Jun 05, 1996 976 Each (k,TyVarTy tv) in a solution constrains only a type  partain committed Jan 08, 1996 977 978 979 variable, tv. \item  partain committed Jun 05, 1996 980 The (k,TyVarTy tv) pairs in a solution are canonically  partain committed Jan 08, 1996 981 982 983 984 985 ordered by sorting on type varible, tv, (major key) and then class, k, (minor key) \end{itemize} \begin{code}  simonpj@microsoft.com committed Sep 05, 2007 986 987 988 989 990 991 992 inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec] inferInstanceContexts _ [] = return [] inferInstanceContexts oflag infer_specs = do { traceTc (text "inferInstanceContexts" <+> vcat (map pprDerivSpec infer_specs)) ; iterate_deriv 1 initial_solutions }  partain committed Jan 08, 1996 993  where  simonpj@microsoft.com committed Sep 05, 2007 994  ------------------------------------------------------------------  partain committed Jan 08, 1996 995 996 997  -- The initial solutions for the equations claim that each -- instance has an empty context; this solution is certainly -- in canonical form.  simonpj@microsoft.com committed Sep 05, 2007 998 999  initial_solutions :: [ThetaType] initial_solutions = [ [] | _ <- infer_specs ]  partain committed Jan 08, 1996 1000   simonpj committed Sep 05, 1997 1001  ------------------------------------------------------------------  simonpj@microsoft.com committed Sep 05, 2007 1002  -- iterate_deriv calculates the next batch of solutions,  partain committed Jan 08, 1996 1003 1004  -- compares it with the current one; finishes if they are the -- same, otherwise recurses with the new solutions.  simonpj committed Sep 05, 1997 1005  -- It fails if any iteration fails  simonpj@microsoft.com committed Sep 05, 2007 1006 1007  iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec] iterate_deriv n current_solns  simonpj committed Feb 01, 2002 1008  | n > 20 -- Looks as if we are in an infinite loop  Ian Lynagh committed Jun 16, 2008 1009  -- This can happen if we have -XUndecidableInstances  simonpj committed Feb 01, 2002 1010 1011  -- (See TcSimplify.tcSimplifyDeriv.) = pprPanic "solveDerivEqns: probable loop"  simonpj@microsoft.com committed Sep 05, 2007 1012  (vcat (map pprDerivSpec infer_specs)$$ ppr current_solns)  simonpj committed Feb 01, 2002 1013  | otherwise  simonpj@microsoft.com committed Sep 05, 2007 1014  = do { -- Extend the inst info from the explicit instance decls  simonpj committed Dec 28, 2001 1015  -- with the current set of solutions, and simplify each RHS  simonpj@microsoft.com committed Sep 05, 2007 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026  let inst_specs = zipWithEqual "add_solns" (mkInstance2 oflag) current_solns infer_specs ; new_solns <- checkNoErrs $extendLocalInstEnv inst_specs$ mapM gen_soln infer_specs ; if (current_solns == new_solns) then return [ spec { ds_theta = soln } | (spec, soln) <- zip infer_specs current_solns ] else iterate_deriv (n+1) new_solns }  simonpj committed Sep 05, 1997 1027 1028  ------------------------------------------------------------------  simonpj@microsoft.com committed Sep 05, 2007 1029 1030 1031  gen_soln :: DerivSpec -> TcM [PredType] gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })  1032  = setSrcSpan loc $ simonpj@microsoft.com committed Sep 05, 2007 1033  addErrCtxt (derivInstCtxt clas inst_tys)$  simonpj@microsoft.com committed Jan 02, 2007 1034  do { theta <- tcSimplifyDeriv orig tyvars deriv_rhs  simonpj@microsoft.com committed Sep 05, 2007 1035  -- checkValidInstance tyvars theta clas inst_tys  simonpj@microsoft.com committed Jun 20, 2007 1036 1037  -- Not necessary; see Note [Exotic derived instance contexts] -- in TcSimplify  simonpj@microsoft.com committed Jan 02, 2007 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047  -- Check for a bizarre corner case, when the derived instance decl should -- have form instance C a b => D (T a) where ... -- Note that 'b' isn't a parameter of T. This gives rise to all sorts -- of problems; in particular, it's hard to compare solutions for -- equality when finding the fixpoint. So I just rule it out for now. ; let tv_set = mkVarSet tyvars weird_preds = [pred | pred <- theta, not (tyVarsOfPred pred subVarSet tv_set)] ; mapM_ (addErrTc . badDerivedPred) weird_preds `