diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/prelude/PrelNames.lhs | 59 | ||||
| -rw-r--r-- | compiler/typecheck/TcDeriv.lhs | 64 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenDeriv.lhs | 18 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenGenerics.lhs | 304 |
4 files changed, 137 insertions, 308 deletions
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index e0a5890619..b617730cbc 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -363,10 +363,13 @@ genericTyConNames :: [Name] genericTyConNames = [ v1TyConName, u1TyConName, par1TyConName, rec1TyConName, k1TyConName, m1TyConName, sumTyConName, prodTyConName, - compTyConName, rTyConName, pTyConName, dTyConName, - cTyConName, sTyConName, rec0TyConName, par0TyConName, + compTyConName, rTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, d1TyConName, c1TyConName, s1TyConName, noSelTyConName, - repTyConName, rep1TyConName + repTyConName, rep1TyConName, + prefixIDataConName, infixIDataConName, leftAssociativeDataConName, + rightAssociativeDataConName, notAssociativeDataConName, + metaDataDataConName, metaConsDataConName, metaSelDataConName ] \end{code} @@ -385,8 +388,9 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING, - gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST, - gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID, + gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST, gHC_TUPLE, + dATA_TUPLE, dATA_EITHER, dATA_MAYBE, dATA_STRING, + dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID, gHC_CONC, gHC_IO, gHC_IO_Exception, gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL, gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, @@ -412,6 +416,7 @@ gHC_LIST = mkBaseModule (fsLit "GHC.List") gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") dATA_EITHER = mkBaseModule (fsLit "Data.Either") +dATA_MAYBE = mkBaseModule (fsLit "Data.Maybe") dATA_STRING = mkBaseModule (fsLit "Data.String") dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable") @@ -719,7 +724,6 @@ leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative") rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative") notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative") - fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, foldMap_RDR, traverse_RDR, mempty_RDR, mappend_RDR :: RdrName fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap") @@ -776,16 +780,18 @@ leftDataConName = conName dATA_EITHER (fsLit "Left") leftDataConKey rightDataConName = conName dATA_EITHER (fsLit "Right") rightDataConKey -- Generics (types) -v1TyConName, u1TyConName, par1TyConName, rec1TyConName, +v1TyConName, u1TyConName, rec1TyConName, par1TyConName, k1TyConName, m1TyConName, sumTyConName, prodTyConName, - compTyConName, rTyConName, pTyConName, dTyConName, - cTyConName, sTyConName, rec0TyConName, par0TyConName, + compTyConName, rTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, d1TyConName, c1TyConName, s1TyConName, noSelTyConName, - repTyConName, rep1TyConName :: Name + repTyConName, rep1TyConName, + prefixIDataConName, infixIDataConName, leftAssociativeDataConName, + rightAssociativeDataConName, notAssociativeDataConName, + metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey -par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey rec1TyConName = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey k1TyConName = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey m1TyConName = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey @@ -795,13 +801,12 @@ prodTyConName = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey compTyConName = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey rTyConName = tcQual gHC_GENERICS (fsLit "R") rTyConKey -pTyConName = tcQual gHC_GENERICS (fsLit "P") pTyConKey dTyConName = tcQual gHC_GENERICS (fsLit "D") dTyConKey cTyConName = tcQual gHC_GENERICS (fsLit "C") cTyConKey sTyConName = tcQual gHC_GENERICS (fsLit "S") sTyConKey rec0TyConName = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey -par0TyConName = tcQual gHC_GENERICS (fsLit "Par0") par0TyConKey +par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey @@ -810,6 +815,16 @@ noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey +prefixIDataConName = conName gHC_GENERICS (fsLit "PrefixI") prefixIDataConKey +infixIDataConName = conName gHC_GENERICS (fsLit "InfixI") infixIDataConKey +leftAssociativeDataConName = conName gHC_GENERICS (fsLit "LeftAssociative") leftAssociativeDataConKey +rightAssociativeDataConName = conName gHC_GENERICS (fsLit "RightAssociative") rightAssociativeDataConKey +notAssociativeDataConName = conName gHC_GENERICS (fsLit "NotAssociative") notAssociativeDataConKey + +metaDataDataConName = conName gHC_GENERICS (fsLit "MetaData") metaDataDataConKey +metaConsDataConName = conName gHC_GENERICS (fsLit "MetaCons") metaConsDataConKey +metaSelDataConName = conName gHC_GENERICS (fsLit "MetaSel") metaSelDataConKey + -- Base strings Strings unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName, stringTyConName :: Name @@ -1422,7 +1437,7 @@ stringTyConKey = mkPreludeTyConUnique 134 v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, compTyConKey, rTyConKey, pTyConKey, dTyConKey, - cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey, + cTyConKey, sTyConKey, rec0TyConKey, d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey, repTyConKey, rep1TyConKey :: Unique @@ -1444,7 +1459,6 @@ cTyConKey = mkPreludeTyConUnique 147 sTyConKey = mkPreludeTyConUnique 148 rec0TyConKey = mkPreludeTyConUnique 149 -par0TyConKey = mkPreludeTyConUnique 150 d1TyConKey = mkPreludeTyConUnique 151 c1TyConKey = mkPreludeTyConUnique 152 s1TyConKey = mkPreludeTyConUnique 153 @@ -1507,7 +1521,11 @@ unitTyConKey = mkTupleTyConUnique BoxedTuple 0 charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey, ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, - ioDataConKey, integerDataConKey, eqBoxDataConKey, coercibleDataConKey :: Unique + ioDataConKey, integerDataConKey, eqBoxDataConKey, coercibleDataConKey, + prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey, + rightAssociativeDataConKey, notAssociativeDataConKey, + metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique + charDataConKey = mkPreludeDataConUnique 1 consDataConKey = mkPreludeDataConUnique 2 doubleDataConKey = mkPreludeDataConUnique 3 @@ -1545,6 +1563,15 @@ eqDataConKey = mkPreludeDataConUnique 28 gtDataConKey = mkPreludeDataConUnique 29 coercibleDataConKey = mkPreludeDataConUnique 32 + +prefixIDataConKey = mkPreludeDataConUnique 33 +infixIDataConKey = mkPreludeDataConUnique 34 +leftAssociativeDataConKey = mkPreludeDataConUnique 35 +rightAssociativeDataConKey = mkPreludeDataConUnique 36 +notAssociativeDataConKey = mkPreludeDataConUnique 37 +metaDataDataConKey = mkPreludeDataConUnique 38 +metaConsDataConKey = mkPreludeDataConUnique 39 +metaSelDataConKey = mkPreludeDataConUnique 40 \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 161bb773e4..1d73786f9e 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -35,7 +35,6 @@ import RnNames( extendGlobalRdrEnvRn ) import RnBinds import RnEnv import RnSource ( addTcgDUs ) -import HscTypes import Avail import Unify( tcUnifyTy ) @@ -145,10 +144,6 @@ data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin) -- 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 @@ -362,25 +357,20 @@ tcDeriving tycl_decls inst_decls deriv_decls ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls ; traceTc "tcDeriving 1" (ppr early_specs) - -- 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 forgetTheta early_specs - ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs - ; insts1 <- mapM (genInst commonAuxs) given_specs + ; insts1 <- mapM genInst given_specs -- the stand-alone derived instances (@insts1@) are used when inferring -- the contexts for "deriving" clauses' instances (@infer_specs@) ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $ inferInstanceContexts infer_specs - ; insts2 <- mapM (genInst commonAuxs) final_specs + ; insts2 <- mapM genInst final_specs ; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2) ; loc <- getSrcSpanM - ; let (binds, newTyCons, famInsts, extraInstances) = - genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff)) + ; let (binds, famInsts, extraInstances) = + genAuxBinds loc (unionManyBags deriv_stuff) ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds @@ -388,29 +378,22 @@ tcDeriving tycl_decls inst_decls deriv_decls ; dflags <- getDynFlags ; unless (isEmptyBag inst_info) $ liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - (ddump_deriving inst_info rn_binds newTyCons famInsts)) + (ddump_deriving inst_info rn_binds famInsts)) - ; let all_tycons = map ATyCon (bagToList newTyCons) - ; gbl_env <- tcExtendGlobalEnv all_tycons $ - tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $ - tcExtendLocalFamInstEnv (bagToList famInsts) $ + ; gbl_env <- tcExtendLocalFamInstEnv (bagToList famInsts) $ tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv ; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs) ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } where ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name - -> Bag TyCon -- ^ Empty data constructors -> Bag FamInst -- ^ Rep type family instances -> SDoc - ddump_deriving inst_infos extra_binds repMetaTys repFamInsts + ddump_deriving inst_infos extra_binds repFamInsts = hang (ptext (sLit "Derived instances:")) 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) $$ ppr extra_binds) - $$ hangP "Generic representation:" ( - hangP "Generated datatypes for meta-information:" - (vcat (map ppr (bagToList repMetaTys))) - $$ hangP "Representation types:" - (vcat (map pprRepTy (bagToList repFamInsts)))) + $$ hangP "GHC.Generics representation types:" + (vcat (map pprRepTy (bagToList repFamInsts))) hangP s x = text "" $$ hang (ptext (sLit s)) 2 x @@ -421,22 +404,6 @@ pprRepTy fi@(FamInst { fi_tys = lhs }) equals <+> ppr rhs where rhs = famInstRHS fi --- As of 24 April 2012, this only shares MetaTyCons between derivations of --- 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 = foldM snoc ([], emptyBag) where - snoc acc@(cas, stuff) (DS {ds_name = nm, ds_cls = cls, ds_tc = rep_tycon}) - | getUnique cls `elem` [genClassKey, gen1ClassKey] = - extendComAux $ genGenericMetaTyCons rep_tycon (nameModule nm) - | otherwise = return acc - where extendComAux m -- don't run m if its already in the accumulator - | any ((rep_tycon ==) . fst) cas = return acc - | otherwise = do (ca, new_stuff) <- m - return $ ((rep_tycon, ca) : cas, stuff `unionBags` new_stuff) - renameDeriv :: Bool -> [InstInfo RdrName] -> Bag (LHsBind RdrName, LSig RdrName) @@ -2037,11 +2004,9 @@ the renamer. What a great hack! -- Representation tycons differ from the tycon in the instance signature in -- case of instances for indexed families. -- -genInst :: CommonAuxiliaries - -> DerivSpec ThetaType +genInst :: DerivSpec ThetaType -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name) -genInst comauxs - spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args +genInst 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 , ds_name = dfun_name, ds_cls = clas, ds_loc = loc }) | is_newtype -- See Note [Bindings for Generalised Newtype Deriving] @@ -2063,7 +2028,6 @@ genInst comauxs | otherwise = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas dfun_name rep_tycon - (lookup rep_tycon comauxs) ; inst_spec <- newDerivClsInst theta spec ; traceTc "newder" (ppr inst_spec) ; let inst_info = InstInfo { iSpec = inst_spec @@ -2078,16 +2042,14 @@ genInst comauxs rhs_ty = newTyConInstRhs rep_tycon rep_tc_args genDerivStuff :: SrcSpan -> Class -> Name -> TyCon - -> Maybe CommonAuxiliary -> TcM (LHsBinds RdrName, BagDerivStuff) -genDerivStuff loc clas dfun_name tycon comaux_maybe +genDerivStuff loc clas dfun_name tycon | let ck = classKey clas , ck `elem` [genClassKey, gen1ClassKey] -- Special case because monadic = let gk = if ck == genClassKey then Gen0 else Gen1 -- TODO NSF: correctly identify when we're building Both instead of One - Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst in do - (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule dfun_name) + (binds, faminst) <- gen_Generic_binds gk tycon (nameModule dfun_name) return (binds, unitBag (DerivFamInst faminst)) | otherwise -- Non-monadic generators diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index f911d16565..4e882ba640 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -87,7 +87,6 @@ data DerivStuff -- Please add this auxiliary stuff = DerivAuxBind AuxBindSpec -- Generics - | DerivTyCon TyCon -- New data types | DerivFamInst FamInst -- New type family instances -- New top-level auxiliary bindings @@ -2018,7 +2017,6 @@ genAuxBindSpec loc (DerivMaxTag tycon) type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings ( Bag (LHsBind RdrName, LSig RdrName) -- Extra bindings (used by Generic only) - , Bag TyCon -- Extra top-level datatypes , Bag (FamInst) -- Extra family instances , Bag (InstInfo RdrName)) -- Extra instances @@ -2033,18 +2031,16 @@ genAuxBinds loc b = genAuxBinds' b2 where genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1) - , emptyBag, emptyBag, emptyBag) + , emptyBag, emptyBag) f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before f (DerivHsBind b) = add1 b - f (DerivTyCon t) = add2 t - f (DerivFamInst t) = add3 t - f (DerivInst i) = add4 i - - add1 x (a,b,c,d) = (x `consBag` a,b,c,d) - add2 x (a,b,c,d) = (a,x `consBag` b,c,d) - add3 x (a,b,c,d) = (a,b,x `consBag` c,d) - add4 x (a,b,c,d) = (a,b,c,x `consBag` d) + f (DerivFamInst t) = add2 t + f (DerivInst i) = add3 i + + add1 x (a,b,c) = (x `consBag` a,b,c) + add2 x (a,b,c) = (a,x `consBag` b,c) + add3 x (a,b,c) = (a,b,x `consBag` c) mk_data_type_name :: TyCon -> RdrName -- "$tT" mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 5bb0862de1..20b6968b51 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -11,10 +11,8 @@ The deriving code for the Generic class module TcGenGenerics (canDoGenerics, canDoGenerics1, GenericKind(..), - MetaTyCons, genGenericMetaTyCons, gen_Generic_binds, get_gen1_constrained_tys) where -import DynFlags import HsSyn import Type import Kind ( isKind ) @@ -24,20 +22,18 @@ import DataCon import TyCon import FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) import FamInst -import Module ( Module, moduleName, moduleNameString ) +import Module ( Module, moduleName, moduleNameFS ) import IfaceEnv ( newGlobalBinder ) import Name hiding ( varName ) +import NameEnv ( lookupNameEnv ) import RdrName import BasicTypes import TysWiredIn import PrelNames -import InstEnv import TcEnv -import MkId import TcRnMonad import HscTypes import ErrUtils( Validity(..), andValid ) -import BuildTyCl import SrcLoc import Bag import VarSet (elemVarSet) @@ -45,7 +41,7 @@ import Outputable import FastString import Util -import Control.Monad (mplus,forM) +import Control.Monad ( mplus ) #include "HsVersions.h" \end{code} @@ -64,120 +60,11 @@ For the generic representation we need to generate: \end{itemize} \begin{code} -gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module +gen_Generic_binds :: GenericKind -> TyCon -> Module -> TcM (LHsBinds RdrName, FamInst) -gen_Generic_binds gk tc metaTyCons mod = do - repTyInsts <- tc_mkRepFamInsts gk tc metaTyCons mod +gen_Generic_binds gk tc mod = do + repTyInsts <- tc_mkRepFamInsts gk tc mod return (mkBindsRep gk tc, repTyInsts) - -genGenericMetaTyCons :: TyCon -> Module -> TcM (MetaTyCons, BagDerivStuff) -genGenericMetaTyCons tc mod = - do loc <- getSrcSpanM - let - tc_name = tyConName tc - tc_cons = tyConDataCons tc - tc_arits = map dataConSourceArity tc_cons - - tc_occ = nameOccName tc_name - d_occ = mkGenD tc_occ - c_occ m = mkGenC tc_occ m - s_occ m n = mkGenS tc_occ m n - - mkTyCon name = ASSERT( isExternalName name ) - buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs - NonRecursive - False -- Not promotable - False -- Not GADT syntax - NoParentTyCon - - d_name <- newGlobalBinder mod d_occ loc - c_names <- forM (zip [0..] tc_cons) $ \(m,_) -> - newGlobalBinder mod (c_occ m) loc - s_names <- forM (zip [0..] tc_arits) $ \(m,a) -> forM [0..a-1] $ \n -> - newGlobalBinder mod (s_occ m n) loc - - let metaDTyCon = mkTyCon d_name - metaCTyCons = map mkTyCon c_names - metaSTyCons = map (map mkTyCon) s_names - - metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons - - -- pprTrace "rep0" (ppr rep0_tycon) $ - (,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts - --- both the tycon declarations and related instances -metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff -metaTyConsToDerivStuff tc metaDts = - do loc <- getSrcSpanM - dflags <- getDynFlags - dClas <- tcLookupClass datatypeClassName - let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc - d_dfun_name <- new_dfun_name dClas tc - cClas <- tcLookupClass constructorClassName - c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ] - sClas <- tcLookupClass selectorClassName - s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc - | _ <- x ] - | x <- metaS metaDts ]) - fix_env <- getFixityEnv - - let - (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc - mk_inst clas tc dfun_name - = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys) - OverlapFlag { overlapMode = NoOverlap - , isSafeOverlap = safeLanguageOn dflags } - [] clas tys - where - tys = [mkTyConTy tc] - - -- Datatype - d_metaTycon = metaD metaDts - d_inst = mk_inst dClas d_metaTycon d_dfun_name - d_binds = InstBindings { ib_binds = dBinds - , ib_tyvars = [] - , ib_pragmas = [] - , ib_extensions = [] - , ib_derived = True } - d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds }) - - -- Constructor - c_metaTycons = metaC metaDts - c_insts = [ mk_inst cClas c ds - | (c, ds) <- myZip1 c_metaTycons c_dfun_names ] - c_binds = [ InstBindings { ib_binds = c - , ib_tyvars = [] - , ib_pragmas = [] - , ib_extensions = [] - , ib_derived = True } - | c <- cBinds ] - c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs }) - | (is,bs) <- myZip1 c_insts c_binds ] - - -- Selector - s_metaTycons = metaS metaDts - s_insts = map (map (\(s,ds) -> mk_inst sClas s ds)) - (myZip2 s_metaTycons s_dfun_names) - s_binds = [ [ InstBindings { ib_binds = s - , ib_tyvars = [] - , ib_pragmas = [] - , ib_extensions = [] - , ib_derived = True } - | s <- ss ] | ss <- sBinds ] - s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec = is - , iBinds = bs}))) - (myZip2 s_insts s_binds) - - myZip1 :: [a] -> [b] -> [(a,b)] - myZip1 l1 l2 = ASSERT(length l1 == length l2) zip l1 l2 - - myZip2 :: [[a]] -> [[b]] -> [[(a,b)]] - myZip2 l1 l2 = - ASSERT(and (zipWith (>=) (map length l1) (map length l2))) - [ zip x1 x2 | (x1,x2) <- zip l1 l2 ] - - return $ mapBag DerivTyCon (metaTyCons2TyCons metaDts) - `unionBags` listToBag (d_mkInst : c_mkInst ++ concat s_mkInst) \end{code} %************************************************************************ @@ -429,7 +316,6 @@ gk2gkDC Gen0_ _ = Gen0_DC gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d - -- Bindings for the Generic instance mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName mkBindsRep gk tycon = @@ -463,10 +349,9 @@ mkBindsRep gk tycon = tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 -> TyCon -- The type to generate representation for - -> MetaTyCons -- Metadata datatypes to refer to -> Module -- Used as the location of the new RepTy -> TcM (FamInst) -- Generated representation0 coercion -tc_mkRepFamInsts gk tycon metaDts mod = +tc_mkRepFamInsts gk tycon mod = -- Consider the example input tycon `D`, where data D a b = D_ a -- Also consider `R:DInt`, where { data family D x y :: * -> * -- ; data instance D Int a b = D_ a } @@ -499,7 +384,7 @@ tc_mkRepFamInsts gk tycon metaDts mod = Nothing -> [mkTyConApp tycon tyvar_args] -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * - ; repTy <- tc_mkRepTy gk_ tycon metaDts + ; repTy <- tc_mkRepTy gk_ tycon -- `rep_name` is a name we generate for the synonym ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R @@ -582,16 +467,13 @@ tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 GenericKind_ -- The type to generate representation for -> TyCon - -- Metadata datatypes to refer to - -> MetaTyCons -- Generated representation0 type -> TcM Type -tc_mkRepTy gk_ tycon metaDts = +tc_mkRepTy gk_ tycon = do d1 <- tcLookupTyCon d1TyConName c1 <- tcLookupTyCon c1TyConName s1 <- tcLookupTyCon s1TyConName - nS1 <- tcLookupTyCon noSelTyConName rec0 <- tcLookupTyCon rec0TyConName rec1 <- tcLookupTyCon rec1TyConName par1 <- tcLookupTyCon par1TyConName @@ -601,37 +483,45 @@ tc_mkRepTy gk_ tycon metaDts = times <- tcLookupTyCon prodTyConName comp <- tcLookupTyCon compTyConName + let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon + + md <- tcLookupPromDataCon metaDataDataConName + mc <- tcLookupPromDataCon metaConsDataConName + ms <- tcLookupPromDataCon metaSelDataConName + pPrefix <- tcLookupPromDataCon prefixIDataConName + pInfix <- tcLookupPromDataCon infixIDataConName + pLA <- tcLookupPromDataCon leftAssociativeDataConName + pRA <- tcLookupPromDataCon rightAssociativeDataConName + pNA <- tcLookupPromDataCon notAssociativeDataConName + + fix_env <- getFixityEnv + let mkSum' a b = mkTyConApp plus [a,b] mkProd a b = mkTyConApp times [a,b] mkComp a b = mkTyConApp comp [a,b] mkRec0 a = mkTyConApp rec0 [a] mkRec1 a = mkTyConApp rec1 [a] mkPar1 = mkTyConTy par1 - mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)] - mkC i d a = mkTyConApp c1 [d, prod i (dataConInstOrigArgTys a $ mkTyVarTys $ tyConTyVars tycon) - (null (dataConFieldLabels a))] - -- This field has no label - mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a] - -- This field has a label - mkS False d a = mkTyConApp s1 [d, a] + mkD a = mkTyConApp d1 [ metaDataTy, sumP (tyConDataCons a) ] + mkC a = mkTyConApp c1 [ metaConsTy a + , prod (dataConInstOrigArgTys a + . mkTyVarTys . tyConTyVars $ tycon) + (dataConFieldLabels a)] + mkS mlbl a = mkTyConApp s1 [metaSelTy mlbl, a] -- Sums and products are done in the same way for both Rep and Rep1 sumP [] = mkTyConTy v1 - sumP l = ASSERT(length metaCTyCons == length l) - foldBal mkSum' [ mkC i d a - | (d,(a,i)) <- zip metaCTyCons (zip l [0..])] + sumP l = foldBal mkSum' . map mkC $ l -- The Bool is True if this constructor has labelled fields - prod :: Int -> [Type] -> Bool -> Type - prod i [] _ = ASSERT(length metaSTyCons > i) - ASSERT(length (metaSTyCons !! i) == 0) - mkTyConTy u1 - prod i l b = ASSERT(length metaSTyCons > i) - ASSERT(length l == length (metaSTyCons !! i)) - foldBal mkProd [ arg d t b - | (d,t) <- zip (metaSTyCons !! i) l ] - - arg :: Type -> Type -> Bool -> Type - arg d t b = mkS b d $ case gk_ of + prod :: [Type] -> [FieldLabel] -> Type + prod [] _ = mkTyConTy u1 + prod l fl = foldBal mkProd [ ASSERT(null fl || length fl > j) + arg t (if null fl then Nothing + else Just (fl !! j)) + | (t,j) <- zip l [0..] ] + + arg :: Type -> Maybe FieldLabel -> Type + arg t fl = mkS fl $ case gk_ of -- Here we previously used Par0 if t was a type variable, but we -- realized that we can't always guarantee that we are wrapping-up -- all type variables in Par0. So we decided to stop using Par0 @@ -639,93 +529,49 @@ tc_mkRepTy gk_ tycon metaDts = Gen0_ -> mkRec0 t Gen1_ argVar -> argPar argVar t where - -- Builds argument represention for Rep1 (more complicated due to + -- Builds argument representation for Rep1 (more complicated due to -- the presence of composition). argPar argVar = argTyFold argVar $ ArgTyAlg {ata_rec0 = mkRec0, ata_par1 = mkPar1, ata_rec1 = mkRec1, ata_comp = mkComp} - - metaDTyCon = mkTyConTy (metaD metaDts) - metaCTyCons = map mkTyConTy (metaC metaDts) - metaSTyCons = map (map mkTyConTy) (metaS metaDts) - - return (mkD tycon) - --------------------------------------------------------------------------------- --- Meta-information --------------------------------------------------------------------------------- - -data MetaTyCons = MetaTyCons { -- One meta datatype per datatype - metaD :: TyCon - -- One meta datatype per constructor - , metaC :: [TyCon] - -- One meta datatype per selector per constructor - , metaS :: [[TyCon]] } - -instance Outputable MetaTyCons where - ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s)) - -metaTyCons2TyCons :: MetaTyCons -> Bag TyCon -metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s) - - --- Bindings for Datatype, Constructor, and Selector instances -mkBindsMetaD :: FixityEnv -> TyCon - -> ( LHsBinds RdrName -- Datatype instance - , [LHsBinds RdrName] -- Constructor instances - , [[LHsBinds RdrName]]) -- Selector instances -mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) - where - mkBag l = foldr1 unionBags - [ unitBag (mkRdrFunBind (L loc name) matches) - | (name, matches) <- l ] - dtBinds = mkBag ( [ (datatypeName_RDR, dtName_matches) - , (moduleName_RDR, moduleName_matches)] - ++ ifElseEmpty (isNewTyCon tycon) - [ (isNewtypeName_RDR, isNewtype_matches) ] ) - - allConBinds = map conBinds datacons - conBinds c = mkBag ( [ (conName_RDR, conName_matches c)] - ++ ifElseEmpty (dataConIsInfix c) - [ (conFixity_RDR, conFixity_matches c) ] - ++ ifElseEmpty (length (dataConFieldLabels c) > 0) - [ (conIsRecord_RDR, conIsRecord_matches c) ] - ) - - ifElseEmpty p x = if p then x else [] - fixity c = case lookupFixity fix_env (dataConName c) of - Fixity n InfixL -> buildFix n leftAssocDataCon_RDR - Fixity n InfixR -> buildFix n rightAssocDataCon_RDR - Fixity n InfixN -> buildFix n notAssocDataCon_RDR - buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc - , nlHsIntLit (toInteger n)] - - allSelBinds = map (map selBinds) datasels - selBinds s = mkBag [(selName_RDR, selName_matches s)] - - loc = srcLocSpan (getSrcLoc tycon) - mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))] - datacons = tyConDataCons tycon - datasels = map dataConFieldLabels datacons - tyConName_user = case tyConFamInst_maybe tycon of Just (ptycon, _) -> tyConName ptycon Nothing -> tyConName tycon - dtName_matches = mkStringLHS . occNameString . nameOccName - $ tyConName_user - moduleName_matches = mkStringLHS . moduleNameString . moduleName - . nameModule . tyConName $ tycon - isNewtype_matches = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] - - conName_matches c = mkStringLHS . occNameString . nameOccName - . dataConName $ c - conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)] - conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] - - selName_matches s = mkStringLHS (occNameString (nameOccName s)) + dtName = mkStrLitTy . occNameFS . nameOccName $ tyConName_user + mdName = mkStrLitTy . moduleNameFS . moduleName . nameModule . tyConName + $ tycon + isNT = mkTyConTy $ if isNewTyCon tycon + then promotedTrueDataCon + else promotedFalseDataCon + + ctName = mkStrLitTy . occNameFS . nameOccName . dataConName + ctFix c = case myLookupFixity fix_env (dataConName c) of + Just (Fixity n InfixL) -> buildFix n pLA + Just (Fixity n InfixR) -> buildFix n pRA + Just (Fixity n InfixN) -> buildFix n pNA + Nothing -> mkTyConTy pPrefix + buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc + , mkNumLitTy (fromIntegral n)] + + myLookupFixity :: FixityEnv -> Name -> Maybe Fixity + myLookupFixity env n = case lookupNameEnv env n of + Just (FixItem _ fix) -> Just fix + Nothing -> Nothing + + isRec c = mkTyConTy $ if length (dataConFieldLabels c) > 0 + then promotedTrueDataCon + else promotedFalseDataCon + + selName = mkStrLitTy . occNameFS . nameOccName + + metaDataTy = mkTyConApp md [dtName, mdName, isNT] + metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c] + metaSelTy ml = mkTyConApp ms + [maybe (mkStrLitTy (mkFastString "")) selName ml] + return (mkD tycon) -------------------------------------------------------------------------------- -- Dealing with sums @@ -819,10 +665,10 @@ genLR_E i n e -------------------------------------------------------------------------------- -- Build a product expression -mkProd_E :: GenericKind_DC -- Generic or Generic1? - -> US -- Base for unique names +mkProd_E :: GenericKind_DC -- Generic or Generic1? + -> US -- Base for unique names -> [(RdrName, Type)] -- List of variables matched on the lhs and their types - -> LHsExpr RdrName -- Resulting product expression + -> LHsExpr RdrName -- Resulting product expression mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR) mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars) -- These M1s are meta-information for the constructor @@ -842,8 +688,6 @@ wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar v ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose` (nlHsVar fmap_RDR `nlHsApp` cnv)} - - -- Build a product pattern mkProd_P :: GenericKind -- Gen0 or Gen1 -> US -- Base for unique names |