From: simonpj Date: Tue, 12 Apr 2011 15:39:18 +0000 (+0100) Subject: Initial commit for Pedro's new generic default methods X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=2a26efb65343e31957b043f63c43caf24d5eeb30 Initial commit for Pedro's new generic default methods (See his Haskell Symposium 2010 paper "A generic deriving mechaism for Haskell") --- diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index f02ae8d..238c091 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -48,11 +48,12 @@ module OccName ( -- ** Derived 'OccName's isDerivedOccName, - mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, + mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkGenD, mkGenC, mkGenS, mkGenR0, mkGenR0Co, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkInstTyCoOcc, mkEqPredCoOcc, @@ -540,9 +541,10 @@ isDerivedOccName occ = \end{code} \begin{code} -mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, - mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, - mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, +mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, + mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, + mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkGenD, mkGenR0, mkGenR0Co, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, @@ -554,6 +556,7 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkDataConWrapperOcc = mk_simple_deriv varName "$W" mkWorkerOcc = mk_simple_deriv varName "$w" mkDefaultMethodOcc = mk_simple_deriv varName "$dm" +mkGenDefMethodOcc = mk_simple_deriv varName "$gdm" mkClassOpAuxOcc = mk_simple_deriv varName "$c" mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon @@ -572,10 +575,19 @@ mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" --- Generic derivable classes +-- Generic derivable classes (old) mkGenOcc1 = mk_simple_deriv varName "$gfrom" mkGenOcc2 = mk_simple_deriv varName "$gto" +-- Generic deriving mechanism (new) +mkGenD = mk_simple_deriv tcName "D1" +mkGenC occ m = mk_deriv tcName ("C1_" ++ show m) (occNameString occ) +mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n) + (occNameString occ) + +mkGenR0 = mk_simple_deriv tcName "Rep0_" +mkGenR0Co = mk_simple_deriv tcName "CoRep0_" + -- data T = MkT ... deriving( Data ) needs defintions for -- $tT :: Data.Generics.Basics.DataType -- $cMkT :: Data.Generics.Basics.Constr diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index e34c696..611a231 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -420,6 +420,7 @@ rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Singleton => Ok -- Empty => Too hard, signature ignored rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc +rep_sig (L loc (GenericSig nm ty)) = rep_proto nm ty loc -- JPM: ? rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc rep_sig _ = return [] diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index e080bee..f1cdebb 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -597,6 +597,10 @@ data Sig name -- Signatures and pragmas -- f :: Num a => a -> a TypeSig (Located name) (LHsType name) + -- A type signature for a generic function inside a class + -- generic eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool + | GenericSig (Located name) (LHsType name) + -- A type signature in generated code, notably the code -- generated for record selectors. We simply record -- the desired Id itself, replete with its name, type @@ -666,18 +670,20 @@ okBindSig :: Sig a -> Bool okBindSig _ = True okHsBootSig :: Sig a -> Bool -okHsBootSig (TypeSig _ _) = True -okHsBootSig (FixSig _) = True -okHsBootSig _ = False +okHsBootSig (TypeSig _ _) = True +okHsBootSig (GenericSig _ _) = True -- JPM: Is this true? +okHsBootSig (FixSig _) = True +okHsBootSig _ = False okClsDclSig :: Sig a -> Bool okClsDclSig (SpecInstSig _) = False okClsDclSig _ = True -- All others OK okInstDclSig :: Sig a -> Bool -okInstDclSig (TypeSig _ _) = False -okInstDclSig (FixSig _) = False -okInstDclSig _ = True +okInstDclSig (TypeSig _ _) = False +okInstDclSig (GenericSig _ _) = False +okInstDclSig (FixSig _) = False +okInstDclSig _ = True sigForThisGroup :: NameSet -> LSig Name -> Bool sigForThisGroup ns sig @@ -706,9 +712,10 @@ isVanillaLSig (L _(TypeSig {})) = True isVanillaLSig _ = False isTypeLSig :: LSig name -> Bool -- Type signatures -isTypeLSig (L _(TypeSig {})) = True -isTypeLSig (L _(IdSig {})) = True -isTypeLSig _ = False +isTypeLSig (L _(TypeSig {})) = True +isTypeLSig (L _(GenericSig {})) = True +isTypeLSig (L _(IdSig {})) = True +isTypeLSig _ = False isSpecLSig :: LSig name -> Bool isSpecLSig (L _(SpecSig {})) = True @@ -731,6 +738,7 @@ isInlineLSig _ = False hsSigDoc :: Sig name -> SDoc hsSigDoc (TypeSig {}) = ptext (sLit "type signature") +hsSigDoc (GenericSig {}) = ptext (sLit "generic default type signature") hsSigDoc (IdSig {}) = ptext (sLit "id signature") hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma") hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma") @@ -745,6 +753,7 @@ eqHsSig :: Eq a => LSig a -> LSig a -> Bool eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2 eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2 eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2 +eqHsSig (L _ (GenericSig n1 _)) (L _ (GenericSig n2 _)) = unLoc n1 == unLoc n2 eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2 -- For specialisations, we don't have equality over -- HsType, so it's not convenient to spot duplicate @@ -758,6 +767,7 @@ instance (OutputableBndr name) => Outputable (Sig name) where ppr_sig :: OutputableBndr name => Sig name -> SDoc ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty) +ppr_sig (GenericSig var ty) = ptext (sLit "generic") <+> pprVarSig (unLoc var) (ppr ty) ppr_sig (IdSig id) = pprVarSig id (ppr (varType id)) ppr_sig (FixSig fix_sig) = ppr fix_sig ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl) diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index bf75f4c..4fbd13a 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -27,7 +27,7 @@ module HsUtils( nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, - -- Bindigns + -- Bindings mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, -- Literals diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index e71eefe..805fcd7 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -229,8 +229,9 @@ mkDataConStupidTheta tycon arg_tys univ_tvs ------------------------------------------------------ \begin{code} -type TcMethInfo = (Name, DefMethSpec, Type) -- A temporary intermediate, to communicate - -- between tcClassSigs and buildClass +type TcMethInfo = (Name, DefMethSpec, Type) + -- A temporary intermediate, to communicate between tcClassSigs and + -- buildClass. buildClass :: Bool -- True <=> do not include unfoldings -- on dict selectors @@ -332,7 +333,8 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec mk_op_item rec_clas (op_name, dm_spec, _) = do { dm_info <- case dm_spec of NoDM -> return NoDefMeth - GenericDM -> return GenDefMeth + GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc + ; return (GenDefMeth dm_name) } VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc ; return (DefMeth dm_name) } ; return (mkDictSelId no_unf op_name rec_clas, dm_info) } diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index b940cb1..8590b5c 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1335,9 +1335,9 @@ tyThingToIfaceDecl (AClass clas) (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) op_ty = funResultTy rho_ty - toDmSpec NoDefMeth = NoDM - toDmSpec GenDefMeth = GenericDM - toDmSpec (DefMeth _) = VanillaDM + toDmSpec NoDefMeth = NoDM + toDmSpec (GenDefMeth _) = GenericDM + toDmSpec (DefMeth _) = VanillaDM toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2) diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index b96eb56..a618cbc 100644 --- a/compiler/main/HscStats.lhs +++ b/compiler/main/HscStats.lhs @@ -55,6 +55,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) ("InstType ", inst_type_ds), ("InstData ", inst_data_ds), ("TypeSigs ", bind_tys), + ("GenericSigs ", generic_sigs), ("ValBinds ", val_bind_ds), ("FunBinds ", fn_bind_ds), ("InlineMeths ", method_inlines), @@ -74,7 +75,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) - (fixity_sigs, bind_tys, bind_specs, bind_inlines) + (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) = count_sigs [d | SigD d <- decls] -- NB: this omits fixity decls on local bindings and -- in class decls. ToDo @@ -112,13 +113,14 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) count_bind (FunBind {}) = (0,1) count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) - count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs) + count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs) - sig_info (FixSig _) = (1,0,0,0) - sig_info (TypeSig _ _) = (0,1,0,0) - sig_info (SpecSig _ _ _) = (0,0,1,0) - sig_info (InlineSig _ _) = (0,0,0,1) - sig_info _ = (0,0,0,0) + sig_info (FixSig _) = (1,0,0,0,0) + sig_info (TypeSig _ _) = (0,1,0,0,0) + sig_info (SpecSig _ _ _) = (0,0,1,0,0) + sig_info (InlineSig _ _) = (0,0,0,1,0) + sig_info (GenericSig _ _) = (0,0,0,0,1) + sig_info _ = (0,0,0,0,0) import_info (L _ (ImportDecl _ _ _ qual as spec)) = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec) @@ -137,13 +139,13 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) class_info decl@(ClassDecl {}) = case count_sigs (map unLoc (tcdSigs decl)) of - (_,classops,_,_) -> + (_,classops,_,_,_) -> (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) class_info _ = (0,0) inst_info (InstDecl _ inst_meths inst_sigs ats) = case count_sigs (map unLoc inst_sigs) of - (_,_,ss,is) -> + (_,_,ss,is,_) -> case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of (tyDecl, dtDecl) -> (addpr (foldr add2 (0,0) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 5c41d72..26f7e48 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -431,6 +431,7 @@ data Token | ITderiving | ITdo | ITelse + | ITgeneric | IThiding | ITif | ITimport @@ -635,6 +636,7 @@ reservedWordsFM = listToUFM $ ( "deriving", ITderiving, 0 ), ( "do", ITdo, 0 ), ( "else", ITelse, 0 ), + ( "generic", ITgeneric, bit genericsBit ), ( "hiding", IThiding, 0 ), ( "if", ITif, 0 ), ( "import", ITimport, 0 ), @@ -1752,7 +1754,7 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () -- integer genericsBit :: Int -genericsBit = 0 -- {| and |} +genericsBit = 0 -- {|, |} and "generic" ffiBit :: Int ffiBit = 1 parrBit :: Int diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index bfadfba..078cfa4 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -216,6 +216,7 @@ incorrect. 'deriving' { L _ ITderiving } 'do' { L _ ITdo } 'else' { L _ ITelse } + 'generic' { L _ ITgeneric } 'hiding' { L _ IThiding } 'if' { L _ ITif } 'import' { L _ ITimport } @@ -1232,9 +1233,13 @@ gdrh :: { LGRHS RdrName } : '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 } sigdecl :: { Located (OrdList (LHsDecl RdrName)) } - : infixexp '::' sigtypedoc {% do s <- checkValSig $1 $3 - ; return (LL $ unitOL (LL $ SigD s)) } - -- See Note [Declaration/signature overlap] for why we need infixexp here + : 'generic' infixexp '::' sigtypedoc + {% do (TypeSig l ty) <- checkValSig $2 $4 + ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) } + -- See Note [Declaration/signature overlap] for why we need infixexp here + | infixexp '::' sigtypedoc + {% do s <- checkValSig $1 $3 + ; return (LL $ unitOL (LL $ SigD s)) } | var ',' sig_vars '::' sigtypedoc { LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] } | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 47abf23..052b9a6 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -812,17 +812,20 @@ checkValSig lhs@(L l _) ty ppr lhs <+> text "::" <+> ppr ty) $$ text hint) where - hint = if looks_like_foreign lhs + hint = if foreign_RDR `looks_like` lhs then "Perhaps you meant to use -XForeignFunctionInterface?" - else "Should be of form :: " + else if generic_RDR `looks_like` lhs + then "Perhaps you meant to use -XGenerics?" + else "Should be of form :: " -- A common error is to forget the ForeignFunctionInterface flag -- so check for that, and suggest. cf Trac #3805 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword - looks_like_foreign (L _ (HsVar v)) = v == foreign_RDR - looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs - looks_like_foreign _ = False + looks_like s (L _ (HsVar v)) = v == s + looks_like s (L _ (HsApp lhs _)) = looks_like s lhs + looks_like s _ = False foreign_RDR = mkUnqual varName (fsLit "foreign") + generic_RDR = mkUnqual varName (fsLit "generic") checkDoAndIfThenElse :: LHsExpr RdrName -> Bool diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 24756d5..08d99dc 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -94,7 +94,7 @@ isUnboundName name = name `hasKey` unboundKey %* * %************************************************************************ -This section tells what the compiler knows about the assocation of +This section tells what the compiler knows about the association of names with uniques. These ones are the *non* wired-in ones. The wired in ones are defined in TysWiredIn etc. @@ -221,10 +221,25 @@ basicKnownKeyNames -- dotnet interop , objectTyConName, marshalObjectName, unmarshalObjectName , marshalStringName, unmarshalStringName, checkDotnetResName + + -- Generics + , rep0ClassName, rep1ClassName + , datatypeClassName, constructorClassName, selectorClassName + ] genericTyConNames :: [Name] -genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName] +genericTyConNames = [ + -- Old stuff + crossTyConName, plusTyConName, genUnitTyConName, + -- New stuff + v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, pTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, par0TyConName, + d1TyConName, c1TyConName, s1TyConName, noSelTyConName, + rep0TyConName, rep1TyConName + ] -- Know names from the DPH package which vary depending on the selected DPH backend. -- @@ -525,12 +540,61 @@ mkTyConRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyCon") undefined_RDR :: RdrName undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") +error_RDR :: RdrName +error_RDR = varQual_RDR gHC_ERR (fsLit "error") + +-- Old Generics (constructors and functions) crossDataCon_RDR, inlDataCon_RDR, inrDataCon_RDR, genUnitDataCon_RDR :: RdrName crossDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") inlDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inl") inrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inr") genUnitDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Unit") +-- Generics (constructors and functions) +u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, + k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, + prodDataCon_RDR, comp1DataCon_RDR, from0_RDR, from1_RDR, + to0_RDR, to1_RDR, datatypeName_RDR, moduleName_RDR, conName_RDR, + conFixity_RDR, conIsRecord_RDR, conIsTuple_RDR, + noArityDataCon_RDR, arityDataCon_RDR, + prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR, + rightAssocDataCon_RDR, notAssocDataCon_RDR :: RdrName + +--v1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "V1") +u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1") +par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1") +rec1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Rec1") +k1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "K1") +m1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "M1") + +l1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "L1") +r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1") + +prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") +comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1") + +from0_RDR = varQual_RDR gHC_GENERICS (fsLit "from0") +from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1") +to0_RDR = varQual_RDR gHC_GENERICS (fsLit "to0") +to1_RDR = varQual_RDR gHC_GENERICS (fsLit "to1") + +datatypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "datatypeName") +moduleName_RDR = varQual_RDR gHC_GENERICS (fsLit "moduleName") +selName_RDR = varQual_RDR gHC_GENERICS (fsLit "selName") +conName_RDR = varQual_RDR gHC_GENERICS (fsLit "conName") +conFixity_RDR = varQual_RDR gHC_GENERICS (fsLit "conFixity") +conIsRecord_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsRecord") +conIsTuple_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsTuple") + +noArityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NoArity") +arityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Arity") +prefixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Prefix") +infixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Infix") +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, traverse_RDR :: RdrName fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap") pure_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "pure") @@ -576,12 +640,47 @@ eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey leftDataConName = conName dATA_EITHER (fsLit "Left") leftDataConKey rightDataConName = conName dATA_EITHER (fsLit "Right") rightDataConKey --- Generics +-- Old Generics (types) crossTyConName, plusTyConName, genUnitTyConName :: Name crossTyConName = tcQual gHC_GENERICS (fsLit ":*:") crossTyConKey plusTyConName = tcQual gHC_GENERICS (fsLit ":+:") plusTyConKey genUnitTyConName = tcQual gHC_GENERICS (fsLit "Unit") genUnitTyConKey +-- Generics (types) +v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, pTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, par0TyConName, + d1TyConName, c1TyConName, s1TyConName, noSelTyConName, + rep0TyConName, rep1TyConName :: 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 + +sumTyConName = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey +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 +d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey +c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey +s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey +noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey + +rep0TyConName = tcQual gHC_GENERICS (fsLit "Rep0") rep0TyConKey +rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey + -- Base strings Strings unpackCStringName, unpackCStringAppendName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName, stringTyConName :: Name @@ -755,6 +854,16 @@ showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey readClassName :: Name readClassName = clsQual gHC_READ (fsLit "Read") readClassKey +-- Classes Representable0 and Representable1, Datatype, Constructor and Selector +rep0ClassName, rep1ClassName, datatypeClassName, constructorClassName, + selectorClassName :: Name +rep0ClassName = clsQual gHC_GENERICS (fsLit "Representable0") rep0ClassKey +rep1ClassName = clsQual gHC_GENERICS (fsLit "Representable1") rep1ClassKey + +datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey +constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey +selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey + -- parallel array types and functions enumFromToPName, enumFromThenToPName, nullPName, lengthPName, singletonPName, replicatePName, mapPName, filterPName, @@ -944,6 +1053,15 @@ applicativeClassKey, foldableClassKey, traversableClassKey :: Unique applicativeClassKey = mkPreludeClassUnique 34 foldableClassKey = mkPreludeClassUnique 35 traversableClassKey = mkPreludeClassUnique 36 + +rep0ClassKey, rep1ClassKey, datatypeClassKey, constructorClassKey, + selectorClassKey :: Unique +rep0ClassKey = mkPreludeClassUnique 37 +rep1ClassKey = mkPreludeClassUnique 38 + +datatypeClassKey = mkPreludeClassUnique 39 +constructorClassKey = mkPreludeClassUnique 40 +selectorClassKey = mkPreludeClassUnique 41 \end{code} %************************************************************************ @@ -1029,7 +1147,7 @@ ptrTyConKey = mkPreludeTyConUnique 74 funPtrTyConKey = mkPreludeTyConUnique 75 tVarPrimTyConKey = mkPreludeTyConUnique 76 --- Generic Type Constructors +-- Old Generic Type Constructors crossTyConKey, plusTyConKey, genUnitTyConKey :: Unique crossTyConKey = mkPreludeTyConUnique 79 plusTyConKey = mkPreludeTyConUnique 80 @@ -1086,6 +1204,41 @@ opaqueTyConKey = mkPreludeTyConUnique 133 stringTyConKey :: Unique stringTyConKey = mkPreludeTyConUnique 134 +-- Generics (Unique keys) +v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, + k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, + compTyConKey, rTyConKey, pTyConKey, dTyConKey, + cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey, + d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey, + rep0TyConKey, rep1TyConKey :: Unique + +v1TyConKey = mkPreludeTyConUnique 135 +u1TyConKey = mkPreludeTyConUnique 136 +par1TyConKey = mkPreludeTyConUnique 137 +rec1TyConKey = mkPreludeTyConUnique 138 +k1TyConKey = mkPreludeTyConUnique 139 +m1TyConKey = mkPreludeTyConUnique 140 + +sumTyConKey = mkPreludeTyConUnique 141 +prodTyConKey = mkPreludeTyConUnique 142 +compTyConKey = mkPreludeTyConUnique 143 + +rTyConKey = mkPreludeTyConUnique 144 +pTyConKey = mkPreludeTyConUnique 145 +dTyConKey = mkPreludeTyConUnique 146 +cTyConKey = mkPreludeTyConUnique 147 +sTyConKey = mkPreludeTyConUnique 148 + +rec0TyConKey = mkPreludeTyConUnique 149 +par0TyConKey = mkPreludeTyConUnique 150 +d1TyConKey = mkPreludeTyConUnique 151 +c1TyConKey = mkPreludeTyConUnique 152 +s1TyConKey = mkPreludeTyConUnique 153 +noSelTyConKey = mkPreludeTyConUnique 154 + +rep0TyConKey = mkPreludeTyConUnique 155 +rep1TyConKey = mkPreludeTyConUnique 156 + ---------------- Template Haskell ------------------- -- USES TyConUniques 200-299 ----------------------------------------------------- diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 0b10764..03dfa08 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -586,8 +586,20 @@ rnMethodBinds :: Name -- Class name -> RnM (LHsBinds Name, FreeVars) rnMethodBinds cls sig_fn gen_tyvars binds - = foldlM do_one (emptyBag,emptyFVs) (bagToList binds) + = do { checkDupRdrNames meth_names + -- Check that the same method is not given twice in the + -- same instance decl instance C T where + -- f x = ... + -- g y = ... + -- f x = ... + -- We must use checkDupRdrNames because the Name of the + -- method is the Name of the class selector, whose SrcSpan + -- points to the class declaration; and we use rnMethodBinds + -- for instance decls too + + ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) } where + meth_names = collectMethodBinders binds do_one (binds,fvs) bind = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) } @@ -663,7 +675,12 @@ renameSigs mb_names ok_sig sigs -- Check for duplicates on RdrName version, -- because renamed version has unboundName for -- not-in-scope binders, which gives bogus dup-sig errors - + -- NB: in a class decl, a 'generic' sig is not considered + -- equal to an ordinary sig, so we allow, say + -- class C a where + -- op :: a -> a + -- generic op :: Eq a => a -> a + ; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs ; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs' @@ -690,6 +707,11 @@ renameSig mb_names sig@(TypeSig v ty) ; new_ty <- rnHsSigType (quotes (ppr v)) ty ; return (TypeSig new_v new_ty) } +renameSig mb_names sig@(GenericSig v ty) + = do { new_v <- lookupSigOccRn mb_names sig v + ; new_ty <- rnHsSigType (quotes (ppr v)) ty + ; return (GenericSig new_v new_ty) } -- JPM: ? + renameSig _ (SpecInstSig ty) = do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty ; return (SpecInstSig new_ty) } diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index 9226cb4..44aa700 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -120,10 +120,11 @@ hsSigsFVs :: [LSig Name] -> FreeVars hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs) hsSigFVs :: Sig Name -> FreeVars -hsSigFVs (TypeSig _ ty) = extractHsTyNames ty -hsSigFVs (SpecInstSig ty) = extractHsTyNames ty -hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty -hsSigFVs _ = emptyFVs +hsSigFVs (TypeSig _ ty) = extractHsTyNames ty +hsSigFVs (GenericSig _ ty) = extractHsTyNames ty +hsSigFVs (SpecInstSig ty) = extractHsTyNames ty +hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty +hsSigFVs _ = emptyFVs ---------------- conDeclFVs :: LConDecl Name -> FreeVars diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 725baeb..e359127 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -443,19 +443,8 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- The typechecker (not the renamer) checks that all -- the bindings are for the right class let - meth_names = collectMethodBinders mbinds (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty') in - checkDupRdrNames meth_names `thenM_` - -- Check that the same method is not given twice in the - -- same instance decl instance C T where - -- f x = ... - -- g y = ... - -- f x = ... - -- We must use checkDupRdrNames because the Name of the - -- method is the Name of the class selector, whose SrcSpan - -- points to the class declaration - extendTyVarEnvForMethodBinds inst_tyvars ( -- (Slightly strangely) the forall-d tyvars scope over -- the method bindings too diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 8db89b9..62a3da8 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -97,48 +97,36 @@ Death to "ExpandingDicts". tcClassSigs :: Name -- Name of the class -> [LSig Name] -> LHsBinds Name - -> TcM [TcMethInfo] + -> TcM [TcMethInfo] -- One for each method tcClassSigs clas sigs def_methods - = do { dm_env <- mapM (addLocM (checkDefaultBind clas op_names)) - (bagToList def_methods) - ; mapM (tcClassSig (mkNameEnv dm_env)) op_sigs } - where - op_sigs = [sig | sig@(L _ (TypeSig _ _)) <- sigs] - op_names = [n | (L _ (TypeSig (L _ n) _)) <- op_sigs] - -checkDefaultBind :: Name -> [Name] -> HsBindLR Name Name -> TcM (Name, DefMethSpec) - -- Check default bindings - -- a) must be for a class op for this class - -- b) must be all generic or all non-generic -checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ }) - = do { -- Check that the op is from this class - checkTc (op `elem` ops) (badMethodErr clas op) - - -- Check that all the defns ar generic, or none are - ; case (none_generic, all_generic) of - (True, _) -> return (op, VanillaDM) - (_, True) -> return (op, GenericDM) - _ -> failWith (mixedGenericErr op) - } - where - n_generic = count (isJust . maybeGenericMatch) matches - none_generic = n_generic == 0 - all_generic = matches `lengthIs` n_generic - -checkDefaultBind _ _ b = pprPanic "checkDefaultBind" (ppr b) + = do { -- Check that all def_methods are in the class + ; op_info <- mapM (addLocM tc_sig) [sig | sig@(L _ (TypeSig _ _)) <- sigs] + ; let op_names = [ n | (n,_,_) <- op_info ] + ; sequence [ failWithTc (badMethodErr clas n) + | n <- dm_bind_names, not (n `elem` op_names) ] + -- Value binding for non class-method (ie no TypeSig) -tcClassSig :: NameEnv DefMethSpec -- Info about default methods; - -> LSig Name - -> TcM TcMethInfo + ; sequence [ failWithTc (badGenericMethod clas n) + | n <- genop_names, not (n `elem` dm_bind_names) ] + -- Generic signature without value binding -tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty)) - = setSrcSpan loc $ do - { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope - ; let dm = lookupNameEnv dm_env op_name `orElse` NoDM - ; return (op_name, dm, op_ty) } -tcClassSig _ s = pprPanic "tcClassSig" (ppr s) + ; return op_info } + where + dm_bind_names :: [Name] -- These ones have a value binding in the class decl + dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] + + genop_names :: [Name] -- These ones have a generic signature + genop_names = [n | L _ (GenericSig (L _ n) _) <- sigs] + + tc_sig (TypeSig (L _ op_name) op_hs_ty) + = do { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope + ; let dm | op_name `elem` genop_names = GenericDM + | op_name `elem` dm_bind_names = VanillaDM + | otherwise = NoDM + ; return (op_name, dm, op_ty) } + tc_sig sig = pprPanic "tc_cls_sig" (ppr sig) \end{code} @@ -174,62 +162,76 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, pred = mkClassPred clas (mkTyVarTys clas_tyvars) ; this_dict <- newEvVar pred + ; traceTc "TIM2" (ppr sigs) ; let tc_dm = tcDefMeth clas clas_tyvars - this_dict default_binds + this_dict default_binds sigs sig_fn prag_fn ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ mapM tc_dm op_items - ; return (listToBag (catMaybes dm_binds)) } + ; return (unionManyBags dm_binds) } tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) -tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name +tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> [LSig Name] -> SigFun -> PragFun -> ClassOpItem - -> TcM (Maybe (LHsBind Id)) + -> TcM (LHsBinds TcId) -- Generate code for polymorphic default methods only (hence DefMeth) -- (Generic default methods have turned into instance decls by now.) -- This is incompatible with Hugs, which expects a polymorphic -- default method for every class op, regardless of whether or not -- the programmer supplied an explicit default decl for the class. -- (If necessary we can fix that, but we don't have a convenient Id to hand.) -tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) - = case dm_info of - NoDefMeth -> return Nothing - GenDefMeth -> return Nothing - DefMeth dm_name -> do - { let sel_name = idName sel_id - ; local_dm_name <- newLocalName sel_name - -- Base the local_dm_name on the selector name, because - -- type errors from tcInstanceMethodBody come from here - - -- See Note [Silly default-method bind] - -- (possibly out of date) - - ; let meth_bind = findMethodBind sel_name binds_in - `orElse` pprPanic "tcDefMeth" (ppr sel_id) - -- dm_info = DefMeth dm_name only if there is a binding in binds_in - - dm_sig_fn _ = sig_fn sel_name - dm_id = mkDefaultMethodId sel_id dm_name - local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars) - local_dm_id = mkLocalId local_dm_name local_dm_type - prags = prag_fn sel_name - - ; dm_id_w_inline <- addInlinePrags dm_id prags - ; spec_prags <- tcSpecPrags dm_id prags - - ; warnTc (not (null spec_prags)) - (ptext (sLit "Ignoring SPECIALISE pragmas on default method") - <+> quotes (ppr sel_name)) - - ; liftM Just $ - tcInstanceMethodBody (ClsSkol clas) - tyvars - [this_dict] - dm_id_w_inline local_dm_id - dm_sig_fn IsDefaultMethod meth_bind } +tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info) + | NoDefMeth <- dm_info = return emptyBag + | otherwise + = do { (dm_id, tvs, sig_loc) <- tc_dm_id dm_info + ; let L loc meth_bind = findMethodBind sel_name binds_in + `orElse` pprPanic "tcDefMeth" (ppr sel_id) + dm_bind = L loc (meth_bind { fun_id = L loc (idName dm_id) }) + -- Substitute the meth_name for the binder + -- NB: the binding is always a FunBind + + dm_sig_fn _ = Just (clas_tv_names ++ tvs, sig_loc) + dm_prag_fn _ = prag_fn sel_name + + ; (binds,_) <- tcExtendIdEnv [dm_id] $ + tcPolyBinds TopLevel dm_sig_fn dm_prag_fn + NonRecursive NonRecursive + [dm_bind] + ; return binds } + where + sel_name = idName sel_id + clas_tv_names = map getName tyvars + + -- Find the 'generic op :: ty' signature among the sigs + -- If dm_info is GenDefMeth, the corresponding signature + -- should jolly well exist! Hence the panic + genop_lhs_ty = case [lty | L _ (GenericSig (L _ n) lty) <- sigs + , n == sel_name ] of + [lty] -> lty + _ -> pprPanic "tcDefMeth" (ppr sel_name $$ ppr sigs) + + tc_dm_id :: DefMeth -> TcM (Id, [Name], SrcSpan) + -- Make a default-method Id of the appropriate type + -- That may entail getting the generic-default signature + -- from the type signatures. + -- Also return the in-scope tyvars for the default method, and their binding site + tc_dm_id NoDefMeth = panic "tc_dm_id" + tc_dm_id (DefMeth dm_name) + | Just (tvs, loc) <- sig_fn sel_name + = return (mkDefaultMethodId sel_id dm_name, tvs, loc) + | otherwise + = pprPanic "No sig for" (ppr sel_name) + tc_dm_id (GenDefMeth dm_name) + = setSrcSpan loc $ + do { tau <- tcHsKindedType genop_lhs_ty + ; checkValidType (FunSigCtxt sel_name) tau + ; return ( mkExportedLocalId dm_name (mkForAllTys tyvars tau) + , hsExplicitTvs genop_lhs_ty, loc ) } + where + loc = getLoc genop_lhs_ty --------------- tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar] @@ -246,7 +248,7 @@ tcInstanceMethodBody skol_info tyvars dfun_ev_vars let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind - + ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id))) ; (ev_binds, (tc_bind, _)) <- checkConstraints skol_info tyvars dfun_ev_vars $ tcExtendIdEnv [local_meth_id] $ @@ -562,6 +564,11 @@ badMethodErr clas op = hsep [ptext (sLit "Class"), quotes (ppr clas), ptext (sLit "does not have a method"), quotes (ppr op)] +badGenericMethod :: Outputable a => a -> Name -> SDoc +badGenericMethod clas op + = hsep [ptext (sLit "Class"), quotes (ppr clas), + ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)] + badATErr :: Class -> Name -> SDoc badATErr clas at = hsep [ptext (sLit "Class"), quotes (ppr clas), diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 2988f08..ffa240d 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -40,10 +40,14 @@ import Name import NameSet import TyCon import TcType +import BuildTyCl +import BasicTypes import Var import VarSet import PrelNames import SrcLoc +import Unique +import UniqSupply import Util import ListSetOps import Outputable @@ -292,12 +296,14 @@ both of them. So we gather defs/uses from deriving just like anything else. tcDeriving :: [LTyClDecl Name] -- All type constructors -> [LInstDecl Name] -- All instance declarations -> [LDerivDecl Name] -- All stand-alone deriving declarations - -> TcM ([InstInfo Name], -- The generated "instance decls" - HsValBinds Name, -- Extra generated top-level bindings - DefUses) + -> TcM ([InstInfo Name] -- The generated "instance decls" + ,HsValBinds Name -- Extra generated top-level bindings + ,DefUses + ,[TyCon] -- Extra generated top-level types + ,[TyCon]) -- Extra generated type family instances tcDeriving tycl_decls inst_decls deriv_decls - = recoverM (return ([], emptyValBindsOut, emptyDUs)) $ + = recoverM (return ([], emptyValBindsOut, emptyDUs, [], [])) $ do { -- Fish the "deriving"-related information out of the TcEnv -- And make the necessary "equations". is_boot <- tcIsHsBoot @@ -313,14 +319,27 @@ tcDeriving tycl_decls inst_decls deriv_decls ; insts2 <- mapM (genInst False overlap_flag) final_specs - -- Generate the generic to/from functions from each type declaration - ; gen_binds <- mkGenericBinds is_boot tycl_decls - ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2) + -- Generate the (old) generic to/from functions from each type declaration + ; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls + + -- Generate the generic Representable0/1 instances from each type declaration + ; repInstsMeta <- genGenericRepBinds is_boot tycl_decls + + ; let repInsts = concat (map (\(a,b,c) -> a) repInstsMeta) + repMetaTys = map (\(a,b,c) -> b) repInstsMeta + repTyCons = map (\(a,b,c) -> c) repInstsMeta + -- Should we extendLocalInstEnv with repInsts? + + ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ repInsts) + + ; dflags <- getDOpts + ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" + (ddump_deriving inst_info rn_binds)) ; when (not (null inst_info)) $ dumpDerivingInfo (ddump_deriving inst_info rn_binds) - - ; return (inst_info, rn_binds, rn_dus) } + ; return ( inst_info, rn_binds, rn_dus + , concat (map metaTyCons2TyCons repMetaTys), repTyCons) } where ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc ddump_deriving inst_infos extra_binds @@ -1463,6 +1482,133 @@ genDerivBinds loc fix_env clas tycon ,(foldableClassKey, gen_Foldable_binds) ,(traversableClassKey, gen_Traversable_binds) ] + +-- Generate the binds for the generic representation +genGenericRepBinds :: Bool -> [LTyClDecl Name] + -> TcM [([(InstInfo RdrName, DerivAuxBinds)] + , MetaTyCons, TyCon)] +genGenericRepBinds isBoot tyclDecls + | isBoot = return [] + | otherwise = do + allTyDecls <- mapM tcLookupTyCon [ tcdName d | L _ d <- tyclDecls + , isDataDecl d ] + let tyDecls = filter tyConHasGenerics allTyDecls + inst1 <- mapM genGenericRepBind tyDecls + let (repInsts, metaTyCons, repTys) = unzip3 inst1 + metaInsts <- ASSERT (length tyDecls == length metaTyCons) + mapM genDtMeta (zip tyDecls metaTyCons) + return (ASSERT (length inst1 == length metaInsts) + [ (ri : mi, ms, rt) + | ((ri, ms, rt), mi) <- zip inst1 metaInsts ]) + +genGenericRepBind :: TyCon -> TcM ((InstInfo RdrName, DerivAuxBinds) + , MetaTyCons, TyCon) +genGenericRepBind tc = + do clas <- tcLookupClass rep0ClassName + uniqS <- newUniqueSupply + dfun_name <- new_dfun_name clas tc + let + -- Uniques for everyone + (uniqD:uniqs) = uniqsFromSupply uniqS + (uniqsC,us) = splitAt (length tc_cons) uniqs + uniqsS :: [[Unique]] -- Unique supply for the S datatypes + uniqsS = mkUniqsS tc_arits us + mkUniqsS [] _ = [] + mkUniqsS (n:t) us = case splitAt n us of + (us1,us2) -> us1 : mkUniqsS t us2 + + 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 + mod_name = nameModule (tyConName tc) + d_name = mkExternalName uniqD mod_name d_occ wiredInSrcSpan + c_names = [ mkExternalName u mod_name (c_occ m) wiredInSrcSpan + | (u,m) <- zip uniqsC [0..] ] + s_names = [ [ mkExternalName u mod_name (s_occ m n) wiredInSrcSpan + | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ] + tvs = tyConTyVars tc + tc_ty = mkTyConApp tc (mkTyVarTys tvs) + + mkTyCon name = ASSERT( isExternalName name ) + buildAlgTyCon name [] [] mkAbstractTyConRhs + NonRecursive False False NoParentTyCon Nothing + + metaDTyCon <- mkTyCon d_name + metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ] + metaSTyCons <- mapM sequence + [ [ mkTyCon s_name + | s_name <- s_namesC ] | s_namesC <- s_names ] + + let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons + + rep0_tycon <- tc_mkRep0TyCon tc metaDts + + let + mkInstRep0 = (InstInfo { iSpec = inst, iBinds = binds } + , [ {- No DerivAuxBinds -} ]) + inst = mkLocalInstance dfun NoOverlap + binds = VanillaInst (mkBindsRep0 tc) [] False + + dfun = mkDictFunId dfun_name (tyConTyVars tc) [] clas [tc_ty] + return (mkInstRep0, metaDts, rep0_tycon) + +genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)] +genDtMeta (tc,metaDts) = + do dClas <- tcLookupClass datatypeClassName + 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 + + -- Datatype + d_metaTycon = metaD metaDts + d_inst = mkLocalInstance d_dfun NoOverlap + d_binds = VanillaInst dBinds [] False + d_dfun = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas + [ mkTyConTy d_metaTycon ] + d_mkInst = (InstInfo { iSpec = d_inst, iBinds = d_binds }, []) + + -- Constructor + c_metaTycons = metaC metaDts + c_insts = [ mkLocalInstance (c_dfun c ds) NoOverlap + | (c, ds) <- myZip1 c_metaTycons c_dfun_names ] + c_binds = [ VanillaInst c [] False | c <- cBinds ] + c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas + [ mkTyConTy c ] + c_mkInst = [ (InstInfo { iSpec = is, iBinds = bs }, []) + | (is,bs) <- myZip1 c_insts c_binds ] + + -- Selector + s_metaTycons = metaS metaDts + s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) NoOverlap)) + (myZip2 s_metaTycons s_dfun_names) + s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ] + s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas + [ mkTyConTy s ] + s_mkInst = map (map (\(is,bs) -> (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 (d_mkInst : c_mkInst ++ concat s_mkInst) \end{code} diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 354e4b2..b5884a7 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -211,7 +211,7 @@ tcLookupFamInst tycon tys } tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type]) --- Find the instance of a data famliy +-- Find the instance of a data family -- Note [Looking up family instances for deriving] tcLookupDataFamInst tycon tys | not (isFamilyTyCon tycon) @@ -461,7 +461,7 @@ tcExtendGlobalTyVars gtv_var extra_global_tvs \begin{code} tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a -- Just pop the new rules into the EPS and envt resp - -- All the rules come from an interface file, not soruce + -- All the rules come from an interface file, not source -- Nevertheless, some may be for this module, if we read -- its interface instead of its source code tcExtendRules lcl_rules thing_inside @@ -681,7 +681,7 @@ newDFunName clas tys loc \end{code} Make a name for the representation tycon of a family instance. It's an -*external* name, like otber top-level names, and hence must be made with +*external* name, like other top-level names, and hence must be made with newGlobalBinder. \begin{code} diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 2c04cf4..362ac5d 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -42,7 +42,7 @@ import Name import HscTypes import PrelInfo import MkCore ( eRROR_ID ) -import PrelNames +import PrelNames hiding (error_RDR) import PrimOp import SrcLoc import TyCon diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 3bb27a7..0ffc466 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -397,12 +397,18 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- NB: class instance declarations can contain derivings as -- part of associated data type declarations failIfErrsM -- If the addInsts stuff gave any errors, don't - -- try the deriving stuff, becuase that may give + -- try the deriving stuff, because that may give -- more errors still - ; (deriv_inst_info, deriv_binds, deriv_dus) + ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts) <- tcDeriving tycl_decls inst_decls deriv_decls - ; gbl_env <- addInsts deriv_inst_info getGblEnv - ; return ( addTcgDUs gbl_env deriv_dus, + + -- Extend the global environment also with the generated datatypes for + -- the generic representation + ; gbl_env <- addFamInsts (map ATyCon deriv_ty_insts) $ + tcExtendGlobalEnv (map ATyCon (deriv_tys ++ deriv_ty_insts)) $ + addInsts deriv_inst_info getGblEnv +-- ; traceTc "Generic deriving" (vcat (map pprInstInfo deriv_inst_info)) + ; return ( addTcgDUs gbl_env deriv_dus, generic_inst_info ++ deriv_inst_info ++ local_info, aux_binds `plusHsValBinds` deriv_binds) }}} @@ -917,10 +923,14 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ---------------------- tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id) + + -- JPM: This is probably not that simple... + tc_default sel_id (GenDefMeth dm_name) = tc_default sel_id (DefMeth dm_name) +{- tc_default sel_id GenDefMeth -- Derivable type classes stuff = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id ; tc_body sel_id False {- Not generated code? -} meth_bind } - +-} tc_default sel_id NoDefMeth -- No default method at all = do { warnMissingMethod sel_id ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 3de19ed..d429a78 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -299,7 +299,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- any mutually recursive types are done right -- Just discard the auxiliary bindings; they are generated -- only for Haskell source code, and should already be in Core - (tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ; + (tcg_env, _aux_binds, _dm_ids, _) <- tcTyAndClassDecls emptyModDetails rn_decls ; setGblEnv tcg_env $ do { -- Make the new type env available to stuff slurped from interface files @@ -500,7 +500,7 @@ tcRnHsBootDecls decls -- Typecheck type/class decls ; traceTc "Tc2" empty - ; (tcg_env, aux_binds, dm_ids) + ; (tcg_env, aux_binds, dm_ids, _) <- tcTyAndClassDecls emptyModDetails tycl_decls ; setGblEnv tcg_env $ tcExtendIdEnv dm_ids $ do { @@ -847,7 +847,7 @@ tcTopSrcDecls boot_details -- The latter come in via tycl_decls traceTc "Tc2" empty ; - (tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ; + (tcg_env, aux_binds, dm_ids, kc_decls) <- tcTyAndClassDecls boot_details tycl_decls ; -- If there are any errors, tcTyAndClassDecls fails here setGblEnv tcg_env $ @@ -885,8 +885,9 @@ tcTopSrcDecls boot_details setLclTypeEnv tcl_env $ do { -- Environment doesn't change now -- Second pass over class and instance declarations, + -- now using the kind-checked decls traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ; + inst_binds <- tcInstDecls2 kc_decls inst_infos ; -- Foreign exports traceTc "Tc7" empty ; diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index a433d69..653394f 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -61,12 +61,14 @@ import Data.List %************************************************************************ \begin{code} + tcTyAndClassDecls :: ModDetails -> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order -> TcM (TcGblEnv, -- Input env extended by types and classes -- and their implicit Ids,DataCons HsValBinds Name, -- Renamed bindings for record selectors - [Id]) -- Default method ids + [Id], -- Default method ids + [LTyClDecl Name]) -- Kind-checked declarations -- Fails if there are any errors tcTyAndClassDecls boot_details decls_s @@ -89,7 +91,7 @@ tcTyAndClassDecls boot_details decls_s -- And now build the TyCons/Classes ; let rec_flags = calcRecFlags boot_details rec_tyclss - ; concatMapM (tcTyClDecl rec_flags) kc_decls } + ; concatMapM (tcTyClDecl rec_flags) kc_decls } ; tcExtendGlobalEnv tyclss $ do { -- Perform the validity check @@ -109,7 +111,10 @@ tcTyAndClassDecls boot_details decls_s ; dm_ids = mkDefaultMethodIds tyclss } ; env <- tcExtendGlobalEnv implicit_things getGblEnv - ; return (env, rec_sel_binds, dm_ids) } } + -- We need the kind-checked declarations later, so we return them + -- from here + ; kc_decls <- kcTyClDecls tyclds_s + ; return (env, rec_sel_binds, dm_ids, kc_decls) } } zipRecTyClss :: [[LTyClDecl Name]] -> [TyThing] -- Knot-tied @@ -488,6 +493,8 @@ kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) where kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty ; return (TypeSig nm op_ty') } + kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty + ; return (GenericSig nm op_ty') } kc_sig other_sig = return other_sig kcTyClDecl decl@(ForeignType {}) @@ -702,7 +709,7 @@ tcTyClDecl1 _parent calc_isrec NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs tc_name tycon (head data_cons) ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec - (want_generic && canDoGenerics data_cons) (not h98_syntax) + (want_generic && canDoGenerics stupid_theta data_cons) (not h98_syntax) NoParentTyCon Nothing }) ; return [ATyCon tycon] @@ -1134,7 +1141,7 @@ checkValidClass cls where (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls unary = isSingleton tyvars - no_generics = null [() | (_, GenDefMeth) <- op_stuff] + no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff] check_op constrained_class_methods (sel_id, dm) = addErrCtxt (classOpCtxt sel_id tau) $ do @@ -1157,8 +1164,10 @@ checkValidClass cls -- Check that for a generic method, the type of -- the method is sufficiently simple +{- -- JPM TODO ; checkTc (dm /= GenDefMeth || validGenericMethodType tau) (badGenericMethodType op_name op_ty) +-} } where op_name = idName sel_id diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index 1e16bc4..d9e44e5 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -81,7 +81,7 @@ type ClassOpItem = (Id, DefMeth) data DefMeth = NoDefMeth -- No default method | DefMeth Name -- A polymorphic default method - | GenDefMeth -- A generic default method + | GenDefMeth Name -- A generic default method deriving Eq -- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in @@ -91,7 +91,7 @@ defMethSpecOfDefMeth meth = case meth of NoDefMeth -> NoDM DefMeth _ -> VanillaDM - GenDefMeth -> GenericDM + GenDefMeth _ -> GenericDM \end{code} @@ -208,9 +208,9 @@ instance Show Class where showsPrec p c = showsPrecSDoc p (ppr c) instance Outputable DefMeth where - ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n - ppr GenDefMeth = ptext (sLit "Generic default method") - ppr NoDefMeth = empty -- No default method + ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n + ppr (GenDefMeth n) = ptext (sLit "Generic default method") <+> ppr n + ppr NoDefMeth = empty -- No default method pprFundeps :: Outputable a => [FunDep a] -> SDoc pprFundeps [] = empty diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs index 604db8d..6d1a2df 100644 --- a/compiler/types/Generics.lhs +++ b/compiler/types/Generics.lhs @@ -11,8 +11,10 @@ -- for details module Generics ( canDoGenerics, mkTyConGenericBinds, - mkGenericRhs, - validGenericInstanceType, validGenericMethodType + mkGenericRhs, + validGenericInstanceType, validGenericMethodType, + mkBindsRep0, tc_mkRep0TyCon, mkBindsMetaD, + MetaTyCons(..), metaTyCons2TyCons ) where @@ -22,14 +24,21 @@ import TcType import DataCon import TyCon -import Name +import Name hiding (varName) +import OccName (varName) +import Module (moduleName, moduleNameString) import RdrName import BasicTypes -import Var +import Var hiding (varName) import VarSet import Id import TysWiredIn import PrelNames +-- For generation of representation types +import TcEnv (tcLookupTyCon) +import TcRnMonad (TcM, newUnique) +import TcMType (newMetaTyVar) +import HscTypes import SrcLoc import Util @@ -37,6 +46,9 @@ import Bag import Outputable import FastString +import Data.List (splitAt) +import Debug.Trace (trace) + #include "HsVersions.h" \end{code} @@ -226,14 +238,18 @@ validGenericMethodType ty %************************************************************************ \begin{code} -canDoGenerics :: [DataCon] -> Bool +canDoGenerics :: ThetaType -> [DataCon] -> Bool -- Called on source-code data types, to see if we should generate -- generic functions for them. (This info is recorded in the interface file for -- imported data types.) -canDoGenerics data_cons +canDoGenerics stupid_theta data_cons = not (any bad_con data_cons) -- See comment below - && not (null data_cons) -- No values of the type + + -- && not (null data_cons) -- No values of the type + -- JPM: we now support empty datatypes + + && null stupid_theta -- We do not support datatypes with context (for now) where bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc) -- If any of the constructor has an unboxed type as argument, @@ -245,6 +261,8 @@ canDoGenerics data_cons -- Nor if the args are polymorphic types (I don't think) bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty) + -- JPM: TODO: I'm not sure I know what isTauTy checks for, so I'm leaving it + -- like this for now... \end{code} %************************************************************************ @@ -255,137 +273,351 @@ canDoGenerics data_cons \begin{code} type US = Int -- Local unique supply, just a plain Int -type FromAlt = (LPat RdrName, LHsExpr RdrName) - +type Alt = (LPat RdrName, LHsExpr RdrName) +{- +data GenRep = GenRep { + genBindsFrom0 :: TyCon -> LHsBinds RdrName + , genBindsTo0 :: TyCon -> LHsBinds RdrName + , genBindsFrom1 :: TyCon -> LHsBinds RdrName + , genBindsTo1 :: TyCon -> LHsBinds RdrName + , genBindsModuleName :: TyCon -> LHsBinds RdrName + , genBindsConName :: DataCon -> LHsBinds RdrName + , genBindsConFixity :: DataCon -> LHsBinds RdrName + , genBindsConIsRecord :: DataCon -> LHsBinds RdrName + , genBindsSelName :: DataCon -> Int -> LHsBinds RdrName + } +-} +-- Bindings for the Representable0 instance +mkBindsRep0 :: TyCon -> LHsBinds RdrName +mkBindsRep0 tycon = + unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches)) + `unionBags` + unitBag (L loc (mkFunBind (L loc to0_RDR) to0_matches)) + where + from0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from0_alts] + to0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to0_alts ] + loc = srcLocSpan (getSrcLoc tycon) + datacons = tyConDataCons tycon + + -- Recurse over the sum first + from0_alts, to0_alts :: [Alt] + (from0_alts, to0_alts) = mkSum (1 :: US) tycon datacons + +-- Disabled mkTyConGenericBinds :: TyCon -> LHsBinds RdrName -mkTyConGenericBinds tycon - = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches)) - `unionBags` - unitBag (L loc (mkFunBind (L loc to_RDR) to_matches)) +mkTyConGenericBinds tycon = + {- + unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches)) + `unionBags` + unitBag (L loc (mkFunBind (L loc to0_RDR) to0_matches)) + `unionBags` + mkMeta loc tycon + -} + emptyBag +{- where - from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] - to_matches = [mkSimpleHsAlt to_pat to_body] - loc = srcLocSpan (getSrcLoc tycon) - datacons = tyConDataCons tycon - (from_RDR, to_RDR) = mkGenericNames tycon + from0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from0_alts] + to0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to0_alts ] + loc = srcLocSpan (getSrcLoc tycon) + datacons = tyConDataCons tycon + (from0_RDR, to0_RDR) = mkGenericNames tycon -- Recurse over the sum first - from_alts :: [FromAlt] - (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons - init_us = 1::Int -- Unique supply - ----------------------------------------------------- --- Dealing with sums ----------------------------------------------------- - -mk_sum_stuff :: US -- Base for generating unique names - -> [DataCon] -- The data constructors - -> ([FromAlt], -- Alternatives for the T->Trep "from" function - InPat RdrName, LHsExpr RdrName) -- Arg and body of the Trep->T "to" function - --- For example, given --- data T = C | D Int Int Int --- --- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))], --- case cd of { Inl u -> C; --- Inr abc -> case abc of { a :*: bc -> --- case bc of { b :*: c -> --- D a b c }} }, --- cd) - -mk_sum_stuff us [datacon] - = ([from_alt], to_pat, to_body_fn app_exp) - where - n_args = dataConSourceArity datacon -- Existentials already excluded - - datacon_vars = map mkGenericLocal [us .. us+n_args-1] - us' = us + n_args - - datacon_rdr = getRdrName datacon - app_exp = nlHsVarApps datacon_rdr datacon_vars - from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) - - (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars - -mk_sum_stuff us datacons - = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts, - nlVarPat to_arg, - noLoc (HsCase (nlHsVar to_arg) - (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body, - mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body]))) + from0_alts, to0_alts :: [Alt] + (from0_alts, to0_alts) = mkSum init_us tycon datacons + init_us = 1 :: US -- Unique supply +-} + +-------------------------------------------------------------------------------- +-- Type representation +-------------------------------------------------------------------------------- +{- +mkRep0Ty :: TyCon -> LHsType Name +mkRep0Ty tycon = res + where + res = d1 `nlHsAppTy` (cons datacons) + d1 = nlHsTyVar d1TyConName `nlHsAppTy` nlHsTyVar d1TyConName -- TODO + c1 = nlHsTyVar c1TyConName `nlHsAppTy` nlHsTyVar c1TyConName -- TODO + s1 = nlHsTyVar s1TyConName `nlHsAppTy` nlHsTyVar noSelTyConName -- TODO + plus a b = nlHsTyVar sumTyConName `nlHsAppTy` a `nlHsAppTy` b + times a b = nlHsTyVar prodTyConName `nlHsAppTy` a `nlHsAppTy` b + k1 x = nlHsTyVar k1TyConName `nlHsAppTy` nlHsTyVar x + + datacons = tyConDataCons tycon + n_args datacon = dataConSourceArity datacon + datacon_vars datacon = map mkGenericLocal [1 .. n_args datacon] + + cons ds = c1 `nlHsAppTy` sum ds + sum [] = nlHsTyVar v1TyConName + sum l = foldBal plus (map sel l) + sel d = s1 `nlHsAppTy` prod (dataConOrigArgTys d) + prod [] = nlHsTyVar u1TyConName + prod l = foldBal times (map arg l) + arg :: Type -> LHsType Name + -- TODO + arg t = nlHsTyVar k1TyConName `nlHsAppTy` nlHsTyVar v1TyConName -- TODO +-} + +tc_mkRep0Ty :: -- The type to generate representation for + TyCon + -- Metadata datatypes to refer to + -> MetaTyCons + -- Generated representation0 type + -> TcM Type +tc_mkRep0Ty tycon metaDts = + do + d1 <- tcLookupTyCon d1TyConName + c1 <- tcLookupTyCon c1TyConName + s1 <- tcLookupTyCon s1TyConName + rec0 <- tcLookupTyCon rec0TyConName + u1 <- tcLookupTyCon u1TyConName + v1 <- tcLookupTyCon v1TyConName + plus <- tcLookupTyCon sumTyConName + times <- tcLookupTyCon prodTyConName + noSel <- tcLookupTyCon noSelTyConName + freshTy <- newMetaTyVar TauTv liftedTypeKind + + let mkSum a b = mkTyConApp plus [a,b] + mkProd a b = mkTyConApp times [a,b] + mkRec0 a = mkTyConApp rec0 [a] + mkD a = mkTyConApp d1 [metaDTyCon, sum (tyConDataCons a)] + mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a)] + mkS d a = mkTyConApp s1 [d, a] + + sum [] = mkTyConTy v1 + sum l = ASSERT (length metaCTyCons == length l) + foldBal mkSum [ mkC i d a + | (d,(a,i)) <- zip metaCTyCons (zip l [0..]) ] + prod :: Int -> [Type] -> Type + prod i [] = ASSERT (length metaSTyCons > i) + ASSERT (length (metaSTyCons !! i) == 0) + mkTyConTy u1 + prod i l = ASSERT (length metaSTyCons > i) + ASSERT (length l == length (metaSTyCons !! i)) + foldBal mkProd [ arg d a + | (d,a) <- zip (metaSTyCons !! i) l ] + + arg d t = mkS d (mkRec0 t) + + metaDTyCon = mkTyConTy (metaD metaDts) + metaCTyCons = map mkTyConTy (metaC metaDts) + metaSTyCons = map (map mkTyConTy) (metaS metaDts) + + return (mkD tycon) + +tc_mkRep0TyCon :: TyCon -- The type to generate representation for + -> MetaTyCons -- Metadata datatypes to refer to + -> TcM TyCon -- Generated representation0 type +tc_mkRep0TyCon tycon metaDts = +-- Consider the example input tycon `D`, where data D a b = D_ a + do + uniq1 <- newUnique + uniq2 <- newUnique + -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * + rep0Ty <- tc_mkRep0Ty tycon metaDts + -- `rep0` = GHC.Generics.Rep0 (type family) + rep0 <- tcLookupTyCon rep0TyConName + + let mod = nameModule (tyConName tycon) + loc = nameSrcSpan (tyConName tycon) + -- `repName` is a name we generate for the synonym + repName = mkExternalName uniq1 mod (mkGenR0 (nameOccName (tyConName tycon))) loc + -- `coName` is a name for the coercion + coName = mkExternalName uniq2 mod (mkGenR0 (nameOccName (tyConName tycon))) loc + -- `tyvars` = [a,b] + tyvars = tyConTyVars tycon + -- `appT` = D a b + appT = [mkTyConApp tycon (mkTyVarTys tyvars)] + -- Result + res = mkSynTyCon repName + -- rep0Ty has kind `kind of D` -> * + (tyConKind tycon `mkArrowKind` liftedTypeKind) + tyvars (SynonymTyCon rep0Ty) + (FamInstTyCon rep0 appT + (mkCoercionTyCon coName (tyConArity tycon) + -- co : forall a b. Rep0 (D a b) ~ `rep0Ty` a b + (CoAxiom tyvars (mkTyConApp rep0 appT) rep0Ty))) + + return res + +-------------------------------------------------------------------------------- +-- Meta-information +-------------------------------------------------------------------------------- + +data MetaTyCons = MetaTyCons { -- One meta datatype per dataype + 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 <+> ppr c <+> ppr s + +metaTyCons2TyCons :: MetaTyCons -> [TyCon] +metaTyCons2TyCons (MetaTyCons d c s) = 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 (L loc (mkFunBind (L loc name) matches)) + | (name, matches) <- l ] + dtBinds = mkBag [ (datatypeName_RDR, dtName_matches) + , (moduleName_RDR, moduleName_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 (isTupleCon c) + [(conIsTuple_RDR + ,conIsTuple_matches (dataConTyCon 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 + + dtName_matches = mkStringLHS . showPpr . nameOccName . tyConName + $ tycon + moduleName_matches = mkStringLHS . moduleNameString . moduleName + . nameModule . tyConName $ tycon + + conName_matches c = mkStringLHS . showPpr . nameOccName + . dataConName $ c + conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)] + conIsRecord_matches c = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] + -- TODO: check that this works + conIsTuple_matches c = [mkSimpleHsAlt nlWildPat + (nlHsApp (nlHsVar arityDataCon_RDR) + (nlHsIntLit + (toInteger (tupleTyConArity c))))] + + selName_matches s = mkStringLHS (showPpr (nameOccName s)) + + +-------------------------------------------------------------------------------- +-- Dealing with sums +-------------------------------------------------------------------------------- + +mkSum :: US -- Base for generating unique names + -> TyCon -- The type constructor + -> [DataCon] -- The data constructors + -> ([Alt], -- Alternatives for the T->Trep "from" function + [Alt]) -- Alternatives for the Trep->T "to" function + +-- Datatype without any constructors +mkSum _us tycon [] = ([from_alt], [to_alt]) + where + from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom)) + to_alt = (mkM1_P nlWildPat, makeError errMsgTo) + -- These M1s are meta-information for the datatype + makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s)) + errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon + errMsgTo = "No values for empty datatype " ++ showPpr tycon + +-- Datatype with at least one constructor +mkSum us _tycon datacons = + unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ] + +-- Build the sum for a particular constructor +mk1Sum :: US -- Base for generating unique names + -> Int -- The index of this constructor + -> Int -- Total number of constructors + -> DataCon -- The data constructor + -> (Alt, -- Alternative for the T->Trep "from" function + Alt) -- Alternative for the Trep->T "to" function +mk1Sum us i n datacon = (from_alt, to_alt) where - (l_datacons, r_datacons) = splitInHalf datacons - (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons - (r_from_alts, r_to_pat, r_to_body) = mk_sum_stuff us' r_datacons - - to_arg = mkGenericLocal us - us' = us+1 - - wrap :: RdrName -> [FromAlt] -> [FromAlt] - -- Wrap an application of the Inl or Inr constructor round each alternative - wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts] - - ----------------------------------------------------- --- Dealing with products ----------------------------------------------------- -mk_prod_stuff :: US -- Base for unique names - -> [RdrName] -- arg-ids; args of the original user-defined constructor - -- They are bound enclosing from_rhs - -- Please bind these in the to_body_fn - -> (US, -- Depleted unique-name supply - LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids - InPat RdrName, -- to_pat: - LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation - --- For example: --- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c), --- abc, --- \ -> case abc of { a :*: bc -> --- case bc of { b :*: c -> --- ) - --- We need to use different uniques in the branches --- because the returned to_body_fns are nested. --- Hence the returned unqique-name supply - -mk_prod_stuff us [] -- Unit case - = (us+1, - nlHsVar genUnitDataCon_RDR, - noLoc (SigPatIn (nlVarPat (mkGenericLocal us)) - (noLoc (HsTyVar (getRdrName genUnitTyConName)))), - -- Give a signature to the pattern so we get - -- data S a = Nil | S a - -- toS = \x -> case x of { Inl (g :: Unit) -> Nil - -- Inr x -> S x } - -- The (:: Unit) signature ensures that we'll infer the right - -- type for toS. If we leave it out, the type is too polymorphic - - \x -> x) - -mk_prod_stuff us [arg_var] -- Singleton case - = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x) - -mk_prod_stuff us arg_vars -- Two or more - = (us'', - nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs], - nlVarPat to_arg, --- gaw 2004 FIX? - \x -> noLoc (HsCase (nlHsVar to_arg) - (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))]))) + n_args = dataConSourceArity datacon -- Existentials already excluded + + datacon_vars = map mkGenericLocal [us .. us+n_args-1] + us' = us + n_args + + datacon_rdr = getRdrName datacon + app_exp = nlHsVarApps datacon_rdr datacon_vars + + from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) + from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E us' datacon_vars)) + + to_alt = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs) + -- These M1s are meta-information for the datatype + to_alt_rhs = app_exp + +-- Generates the L1/R1 sum pattern +genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName +genLR_P i n p + | n == 0 = error "impossible" + | n == 1 = p + | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i (div n 2) p] + | otherwise = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p] + where m = div n 2 + +-- Generates the L1/R1 sum expression +genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName +genLR_E i n e + | n == 0 = error "impossible" + | n == 1 = e + | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i (div n 2) e + | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m) e + where m = div n 2 + +-------------------------------------------------------------------------------- +-- Dealing with products +-------------------------------------------------------------------------------- + +-- Build a product expression +mkProd_E :: US -- Base for unique names + -> [RdrName] -- List of variables matched on the lhs + -> LHsExpr RdrName -- Resulting product expression +mkProd_E us [] = mkM1_E (nlHsVar u1DataCon_RDR) +mkProd_E us vars = mkM1_E (foldBal prod appVars) + -- These M1s are meta-information for the constructor where - to_arg = mkGenericLocal us - (l_arg_vars, r_arg_vars) = splitInHalf arg_vars - (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars - (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars - pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat] - -splitInHalf :: [a] -> ([a],[a]) -splitInHalf list = (left, right) - where - half = length list `div` 2 - left = take half list - right = drop half list + appVars = map wrapArg_E vars + prod a b = prodDataCon_RDR `nlHsApps` [a,b] + +-- TODO: Produce a P0 when v is a parameter +wrapArg_E :: RdrName -> LHsExpr RdrName +wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v]) + -- This M1 is meta-information for the selector + +-- Build a product pattern +mkProd_P :: US -- Base for unique names + -> [RdrName] -- List of variables to match + -> LPat RdrName -- Resulting product pattern +mkProd_P us [] = mkM1_P (nlNullaryConPat u1DataCon_RDR) +mkProd_P us vars = mkM1_P (foldBal prod appVars) + -- These M1s are meta-information for the constructor + where + appVars = map wrapArg_P vars + prod a b = prodDataCon_RDR `nlConPat` [a,b] + +-- TODO: Produce a P0 when v is a parameter +wrapArg_P :: RdrName -> LPat RdrName +wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v]) + -- This M1 is meta-information for the selector + mkGenericLocal :: US -> RdrName mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) @@ -399,6 +631,23 @@ mkGenericNames tycon tc_mod = ASSERT( isExternalName tc_name ) nameModule tc_name from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ) to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ) + +mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName +mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e + +mkM1_P :: LPat RdrName -> LPat RdrName +mkM1_P p = m1DataCon_RDR `nlConPat` [p] + +-- | Variant of foldr1 for producing balanced lists +foldBal :: (a -> a -> a) -> [a] -> a +foldBal op = foldBal' op (error "foldBal: empty list") + +foldBal' :: (a -> a -> a) -> a -> [a] -> a +foldBal' _ x [] = x +foldBal' _ _ [y] = y +foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l + in foldBal' op x a `op` foldBal' op x b + \end{code} %************************************************************************ diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index adb0470..0baa312 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -67,7 +67,7 @@ module TyCon( tyConExtName, -- External name for foreign types algTyConRhs, newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, - tupleTyConBoxity, + tupleTyConBoxity, tupleTyConArity, -- ** Manipulating TyCons tcExpandTyCon_maybe, coreExpandTyCon_maybe, @@ -1087,6 +1087,11 @@ isBoxedTupleTyCon _ = False tupleTyConBoxity :: TyCon -> Boxity tupleTyConBoxity tc = tyConBoxed tc +-- | Extract the arity of the given 'TyCon', if it is a 'TupleTyCon'. +-- Panics otherwise +tupleTyConArity :: TyCon -> Arity +tupleTyConArity tc = tyConArity tc + -- | Is this a recursive 'TyCon'? isRecursiveTyCon :: TyCon -> Bool isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True