X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcDeriv.lhs;h=95d9695992effca339fb44b6e04ff2aad1cf7587;hb=b138da84e9821b9f27e4c6a224f7308bd58dd257;hp=dac3e4a7b9ac90a660655876bc35d79f0b44a8b1;hpb=99073d876ea762016683fb0b22b9d343ff864eb4;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index dac3e4a..95d9695 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -10,52 +10,48 @@ module TcDeriv ( tcDeriving ) where #include "HsVersions.h" -import HsSyn ( HsBinds(..), MonoBinds(..), collectLocatedMonoBinders ) +import HsSyn ( HsBinds(..), MonoBinds(..), TyClDecl(..), + collectLocatedMonoBinders ) import RdrHsSyn ( RdrNameMonoBinds ) -import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds ) +import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl ) import CmdLineOpts ( DynFlag(..), DynFlags ) import TcMonad -import TcEnv ( TcEnv, tcSetInstEnv, getTcGST, newDFunName ) +import TcEnv ( tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo, + tcLookupClass, tcLookupTyCon + ) import TcGenDeriv -- Deriv stuff -import InstEnv ( InstInfo(..), InstEnv, - pprInstInfo, simpleDFunClassTyCon, extendInstEnv ) +import InstEnv ( InstEnv, simpleDFunClassTyCon, extendInstEnv ) import TcSimplify ( tcSimplifyThetas ) import RnBinds ( rnMethodBinds, rnTopMonoBinds ) import RnEnv ( bindLocatedLocalsRn ) -import RnMonad ( --RnNameSupply, - renameSourceCode, thenRn, mapRn, returnRn ) -import HscTypes ( DFunId, GlobalSymbolTable, PersistentRenamerState ) +import RnMonad ( renameDerivedCode, thenRn, mapRn, returnRn ) +import HscTypes ( DFunId, PersistentRenamerState ) import BasicTypes ( Fixity ) -import Bag ( Bag, emptyBag, unionBags, listToBag ) import Class ( classKey, Class ) import ErrUtils ( dumpIfSet_dyn, Message ) import MkId ( mkDictFunId ) -import Id ( mkVanillaId, idType ) import DataCon ( dataConArgTys, isNullaryDataCon, isExistentialDataCon ) import PrelInfo ( needsDataDeclCtxtClassKeys ) import Maybes ( maybeToBool, catMaybes ) import Module ( Module ) -import Name ( Name, isLocallyDefined, getSrcLoc, NamedThing(..) ) +import Name ( Name, getSrcLoc ) import RdrName ( RdrName ) -import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, +import TyCon ( tyConTyVars, tyConDataCons, tyConTheta, maybeTyConSingleCon, isDataTyCon, - isEnumerationTyCon, isAlgTyCon, TyCon - ) -import Type ( TauType, PredType(..), mkTyVarTys, mkTyConApp, - mkSigmaTy, splitDFunTy, mkDictTy, - isUnboxedType, splitAlgTyConApp, classesToPreds + isEnumerationTyCon, TyCon ) -import TysWiredIn ( voidTy ) +import Type ( ThetaType, mkTyVarTys, mkTyConApp, + isUnLiftedType, mkClassPred ) import Var ( TyVar ) import PrelNames -import Bag ( bagToList ) -import Util ( zipWithEqual, sortLt, thenCmp ) +import Util ( zipWithEqual, sortLt ) import ListSetOps ( removeDups, assoc ) import Outputable +import List ( nub ) \end{code} %************************************************************************ @@ -147,9 +143,7 @@ type DerivEqn = (Name, Class, TyCon, [TyVar], DerivRhs) -- The Name is the name for the DFun we'll build -- The tyvars bind all the variables in the RHS -type DerivRhs = [(Class, [TauType])] -- Same as a ThetaType! - --[PredType] -- ... | Class Class [Type==TauType] - +type DerivRhs = ThetaType type DerivSoln = DerivRhs \end{code} @@ -189,16 +183,16 @@ tcDeriving :: PersistentRenamerState -> Module -- name of module under scrutiny -> InstEnv -- What we already know about instances -> (Name -> Maybe Fixity) -- used in deriving Show and Read - -> [TyCon] -- "local_tycons" ??? + -> [RenamedTyClDecl] -- All type constructors -> TcM ([InstInfo], -- The generated "instance decls". RenamedHsBinds) -- Extra generated bindings -tcDeriving prs mod inst_env_in get_fixity local_tycons +tcDeriving prs mod inst_env_in get_fixity tycl_decls = recoverTc (returnTc ([], EmptyBinds)) $ -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". - makeDerivEqns mod local_tycons `thenTc` \ eqns -> + makeDerivEqns tycl_decls `thenTc` \ eqns -> if null eqns then returnTc ([], EmptyBinds) else @@ -228,14 +222,14 @@ tcDeriving prs mod inst_env_in get_fixity local_tycons -- The only tricky bit is that the extra_binds must scope over the -- method bindings for the instances. (rn_method_binds_s, rn_extra_binds) - = renameSourceCode dflags mod prs ( + = renameDerivedCode dflags mod prs ( bindLocatedLocalsRn (ptext (SLIT("deriving"))) mbinders $ \ _ -> rnTopMonoBinds extra_mbinds [] `thenRn` \ (rn_extra_binds, _) -> mapRn rn_meths method_binds_s `thenRn` \ rn_method_binds_s -> returnRn (rn_method_binds_s, rn_extra_binds) ) - new_inst_infos = map gen_inst_info (new_dfuns `zip` rn_method_binds_s) + new_inst_infos = zipWith gen_inst_info new_dfuns rn_method_binds_s in ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" @@ -249,16 +243,10 @@ tcDeriving prs mod inst_env_in get_fixity local_tycons where -- Make a Real dfun instead of the dummy one we have so far - gen_inst_info :: (DFunId, RenamedMonoBinds) -> InstInfo - gen_inst_info (dfun, binds) - = InstInfo { iLocal = True, - iClass = clas, iTyVars = tyvars, - iTys = tys, iTheta = theta, - iDFunId = dfun, - iBinds = binds, - iLoc = getSrcLoc dfun, iPrags = [] } - where - (tyvars, theta, clas, tys) = splitDFunTy (idType dfun) + gen_inst_info :: DFunId -> RenamedMonoBinds -> InstInfo + gen_inst_info dfun binds + = InstInfo { iDFunId = dfun, + iBinds = binds, iPrags = [] } rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths' -- Ignore the free vars returned @@ -287,67 +275,57 @@ or} has just one data constructor (e.g., tuples). all those. \begin{code} -makeDerivEqns :: Module -> [TyCon] -> TcM [DerivEqn] +makeDerivEqns :: [RenamedTyClDecl] -> TcM [DerivEqn] -makeDerivEqns this_mod local_tycons - = let - think_about_deriving = need_deriving local_tycons - (derive_these, _) = removeDups cmp_deriv think_about_deriving - in - if null local_tycons then - returnTc [] -- Bale out now - else - mapTc mk_eqn derive_these `thenTc` \ maybe_eqns -> +makeDerivEqns tycl_decls + = mapTc mk_eqn derive_these `thenTc` \ maybe_eqns -> returnTc (catMaybes maybe_eqns) where ------------------------------------------------------------------ - need_deriving :: [TyCon] -> [(Class, TyCon)] - -- find the tycons that have `deriving' clauses; - - need_deriving tycons_to_consider - = foldr (\ tycon acc -> [(clas,tycon) | clas <- tyConDerivings tycon] ++ acc) - [] - tycons_to_consider - - ------------------------------------------------------------------ - cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> Ordering - cmp_deriv (c1, t1) (c2, t2) - = (c1 `compare` c2) `thenCmp` (t1 `compare` t2) + derive_these :: [(Name, Name)] + -- Find the (Class,TyCon) pairs that must be `derived' + -- NB: only source-language decls have deriving, no imported ones do + derive_these = [ (clas,tycon) + | TyData {tcdName = tycon, tcdDerivs = Just classes} <- tycl_decls, + clas <- nub classes ] ------------------------------------------------------------------ - mk_eqn :: (Class, TyCon) -> NF_TcM (Maybe DerivEqn) + mk_eqn :: (Name, Name) -> NF_TcM (Maybe DerivEqn) -- we swizzle the tyvars and datacons out of the tycon -- to make the rest of the equation - mk_eqn (clas, tycon) - = case chk_out clas tycon of + mk_eqn (clas_name, tycon_name) + = tcLookupClass clas_name `thenNF_Tc` \ clas -> + tcLookupTyCon tycon_name `thenNF_Tc` \ tycon -> + let + clas_key = classKey clas + tyvars = tyConTyVars tycon + tyvar_tys = mkTyVarTys tyvars + ty = mkTyConApp tycon tyvar_tys + data_cons = tyConDataCons tycon + locn = getSrcLoc tycon + constraints = extra_constraints ++ concat (map mk_constraints data_cons) + + -- "extra_constraints": see notes above about contexts on data decls + extra_constraints + | offensive_class = tyConTheta tycon + | otherwise = [] + + offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys + + mk_constraints data_con + = [ mkClassPred clas [arg_ty] + | arg_ty <- dataConArgTys data_con tyvar_tys, + not (isUnLiftedType arg_ty) -- No constraints for unlifted types? + ] + in + case chk_out clas tycon of Just err -> addErrTc err `thenNF_Tc_` returnNF_Tc Nothing - Nothing -> newDFunName this_mod clas tyvar_tys locn `thenNF_Tc` \ dfun_name -> + Nothing -> newDFunName clas [ty] locn `thenNF_Tc` \ dfun_name -> returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints)) - where - clas_key = classKey clas - tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ??? - tyvar_tys = mkTyVarTys tyvars - data_cons = tyConDataCons tycon - locn = getSrcLoc tycon - - constraints = extra_constraints ++ concat (map mk_constraints data_cons) - - -- "extra_constraints": see notes above about contexts on data decls - extra_constraints - | offensive_class = tyConTheta tycon - | otherwise = [] - where - offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys - mk_constraints data_con - = [ (clas, [arg_ty]) - | arg_ty <- instd_arg_tys, - not (isUnboxedType arg_ty) -- No constraints for unboxed types? - ] - where - instd_arg_tys = dataConArgTys data_con tyvar_tys + ------------------------------------------------------------------ chk_out :: Class -> TyCon -> Maybe Message @@ -427,7 +405,8 @@ solveDerivEqns inst_env_in orig_eqns in -- Simplify each RHS tcSetInstEnv inst_env ( - listTc [ tcAddErrCtxt (derivCtxt tc) $ + listTc [ tcAddSrcLoc (getSrcLoc tc) $ + tcAddErrCtxt (derivCtxt tc) $ tcSimplifyThetas deriv_rhs | (_, _,tc,_,deriv_rhs) <- orig_eqns ] ) `thenTc` \ next_solns -> @@ -456,10 +435,9 @@ add_solns dflags inst_env_in eqns solns -- They'll appear later, when we do the top-level extendInstEnvs mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta - = mkDictFunId dfun_name clas tyvars [mkTyConApp tycon (mkTyVarTys tyvars)] - (map pair2PredType theta) - - pair2PredType (clas, tautypes) = Class clas tautypes + = mkDictFunId dfun_name clas tyvars + [mkTyConApp tycon (mkTyVarTys tyvars)] + theta \end{code} %************************************************************************ @@ -530,7 +508,6 @@ the renamer. What a great hack! -- names.) gen_bind :: (Name -> Maybe Fixity) -> DFunId -> RdrNameMonoBinds gen_bind get_fixity dfun - | not (isLocallyDefined tycon) = EmptyMonoBinds | clas `hasKey` showClassKey = gen_Show_binds get_fixity tycon | clas `hasKey` readClassKey = gen_Read_binds get_fixity tycon | otherwise @@ -559,7 +536,7 @@ data Foo ... = ... con2tag_Foo :: Foo ... -> Int# tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# -maxtag_Foo :: Int -- ditto (NB: not unboxed) +maxtag_Foo :: Int -- ditto (NB: not unlifted) We have a @con2tag@ function for a tycon if: