From: simonpj Date: Tue, 3 Oct 2000 08:43:05 +0000 (+0000) Subject: [project @ 2000-10-03 08:43:00 by simonpj] X-Git-Tag: Approximately_9120_patches~3703 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=710e207487929c4a5977b5ee3bc6e539091953db [project @ 2000-10-03 08:43:00 by simonpj] -------------------------------------- Adding generics SLPJ Oct 2000 -------------------------------------- This big commit adds Hinze/PJ-style generic class definitions, based on work by Andrei Serjantov. For example: class Bin a where toBin :: a -> [Int] fromBin :: [Int] -> (a, [Int]) toBin {| Unit |} Unit = [] toBin {| a :+: b |} (Inl x) = 0 : toBin x toBin {| a :+: b |} (Inr y) = 1 : toBin y toBin {| a :*: b |} (x :*: y) = toBin x ++ toBin y fromBin {| Unit |} bs = (Unit, bs) fromBin {| a :+: b |} (0:bs) = (Inl x, bs') where (x,bs') = fromBin bs fromBin {| a :+: b |} (1:bs) = (Inr y, bs') where (y,bs') = fromBin bs fromBin {| a :*: b |} bs = (x :*: y, bs'') where (x,bs' ) = fromBin bs (y,bs'') = fromBin bs' Now we can say simply instance Bin a => Bin [a] and the compiler will derive the appropriate code automatically. (About 9k lines of diffs. Ha!) Generic related things ~~~~~~~~~~~~~~~~~~~~~~ * basicTypes/BasicTypes: The EP type (embedding-projection pairs) * types/TyCon: An extra field in an algebraic tycon (genInfo) * types/Class, and hsSyn/HsBinds: Each class op (or ClassOpSig) carries information about whether it a) has no default method b) has a polymorphic default method c) has a generic default method There's a new data type for this: Class.DefMeth * types/Generics: A new module containing good chunk of the generic-related code It has a .hi-boot file (alas). * typecheck/TcInstDcls, typecheck/TcClassDcl: Most of the rest of the generics-related code * hsSyn/HsTypes: New infix type form to allow types of the form data a :+: b = Inl a | Inr b * parser/Parser.y, Lex.lhs, rename/ParseIface.y: Deal with the new syntax * prelude/TysPrim, TysWiredIn: Need to generate generic stuff for the wired-in TyCons * rename/RnSource RnBinds: A rather gruesome hack to deal with scoping of type variables from a generic patterns. Details commented in the ClassDecl case of RnSource.rnDecl. Of course, there are many minor renamer consequences of the other changes above. * lib/std/PrelBase.lhs Data type declarations for Unit, :+:, :*: Slightly unrelated housekeeping ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * hsSyn/HsDecls: ClassDecls now carry the Names for their implied declarations (superclass selectors, tycon, etc) in a list, rather than laid out one by one. This simplifies code between the parser and the type checker. * prelude/PrelNames, TysWiredIn: All the RdrNames are now together in PrelNames. * utils/ListSetOps: Add finite mappings based on equality and association lists (Assoc a b) Move stuff from List.lhs that is related --- diff --git a/ghc/compiler/DEPEND-NOTES b/ghc/compiler/DEPEND-NOTES index 8efc369..2135879 100644 --- a/ghc/compiler/DEPEND-NOTES +++ b/ghc/compiler/DEPEND-NOTES @@ -16,7 +16,7 @@ then then Class (loop TyCon.TyCon, loop Type.Type) then - TyCon (loop Type.Type, loop Type.Kind, loop DataCon.DataCon) + TyCon (loop Type.Type, loop Type.Kind, loop DataCon.DataCon, loop Generics.GenInfo) then Type (loop DataCon.DataCon, loop Subst.substTy) then @@ -26,7 +26,7 @@ then then Literal (TysPrim, PprType), DataCon then - TysWiredIn (DataCon.mkDataCon, loop MkId.mkDataConId) + TysWiredIn (DataCon.mkDataCon, loop MkId.mkDataConId, loop Generics.mkGenInfo) then PrimOp (PprType, TysWiredIn) then @@ -45,7 +45,7 @@ then then CoreUnfold (OccurAnal.occurAnalyseGlobalExpr) then - Rules (Unfolding), Subst (Unfolding, CoreFVs), CoreTidy (noUnfolding) + Rules (Unfolding), Subst (Unfolding, CoreFVs), CoreTidy (noUnfolding), Generics (mkTopUnfolding) then MkId (CoreUnfold.mkUnfolding, Subst) then diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index b0100e6..6a8c583 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -34,8 +34,9 @@ module BasicTypes( OccInfo(..), seqOccInfo, isFragileOcc, isDeadOcc, isLoopBreaker, InsideLam, insideLam, notInsideLam, - OneBranch, oneBranch, notOneBranch + OneBranch, oneBranch, notOneBranch, + EP(..) ) where #include "HsVersions.h" @@ -197,6 +198,42 @@ isNonRec Recursive = False isNonRec NonRecursive = True \end{code} +%************************************************************************ +%* * +\subsection[Generic]{Generic flag} +%* * +%************************************************************************ + +This is the "Embedding-Projection pair" datatype, it contains +two pieces of code (normally either RenamedHsExpr's or Id's) +If we have a such a pair (EP from to), the idea is that 'from' and 'to' +represents functions of type + + from :: T -> Tring + to :: Tring -> T + +And we should have + + to (from x) = x + +T and Tring are arbitrary, but typically T is the 'main' type while +Tring is the 'representation' type. (This just helps us remember +whether to use 'from' or 'to'. + +\begin{code} +data EP a = EP { fromEP :: a, -- :: T -> Tring + toEP :: a } -- :: Tring -> T +\end{code} + +Embedding-projection pairs are used in several places: + +First of all, each type constructor has an EP associated with it, the +code in EP converts (datatype T) from T to Tring and back again. + +Secondly, when we are filling in Generic methods (in the typechecker, +tcMethodBinds), we are constructing bimaps by induction on the structure +of the type of the method signature. + %************************************************************************ %* * diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index 0419228..50aac8c 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -47,7 +47,7 @@ import CmdLineOpts ( opt_UnboxStrictFields ) import PprType () -- Instances import Maybes ( maybeToBool ) import Maybe -import Util ( assoc ) +import ListSetOps ( assoc ) \end{code} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index c743dbb..d32cd53 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -9,7 +9,7 @@ module Id ( -- Simple construction mkId, mkVanillaId, mkSysLocal, mkUserLocal, - mkTemplateLocals, mkWildId, mkTemplateLocal, + mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal, -- Taking an Id apart idName, idType, idUnique, idInfo, @@ -29,7 +29,8 @@ module Id ( isIP, isSpecPragmaId, isRecordSelector, isPrimOpId, isPrimOpId_maybe, - isDataConId, isDataConId_maybe, isDataConWrapId, isDataConWrapId_maybe, + isDataConId, isDataConId_maybe, isDataConWrapId, + isDataConWrapId_maybe, isBottomingId, isExportedId, isUserExportedId, hasNoBinding, @@ -62,24 +63,28 @@ module Id ( idCafInfo, idCprInfo, idLBVarInfo, - idOccInfo + idOccInfo, ) where #include "HsVersions.h" -import CoreSyn ( Unfolding, CoreRules ) +import CoreSyn ( Unfolding, CoreRules, CoreExpr, Expr(..), + AltCon (..), Alt, mkApps, Arg ) import BasicTypes ( Arity ) import Var ( Id, DictId, isId, mkIdVar, idName, idType, idUnique, idInfo, setIdName, setVarType, setIdUnique, - setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, + setIdInfo, lazySetIdInfo, modifyIdInfo, + maybeModifyIdInfo, externallyVisibleId ) import VarSet -import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars, seqType, splitTyConApp_maybe ) +import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars, + seqType, splitAlgTyConApp_maybe, mkTyVarTy, + mkTyConApp, splitTyConApp_maybe) import IdInfo @@ -95,9 +100,14 @@ import PrimOp ( PrimOp, primOpIsCheap ) import TysPrim ( statePrimTyCon ) import FieldLabel ( FieldLabel ) import SrcLoc ( SrcLoc ) -import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques ) +import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques, + getNumBuiltinUniques ) import Outputable - +import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, + mkAlgTyConRep, tyConName, + tyConTyVars, tyConDataCons ) +import DataCon ( DataCon, dataConWrapId, dataConOrigArgTys ) +import Var ( Var ) infixl 1 `setIdUnfolding`, `setIdArityInfo`, `setIdDemandInfo`, @@ -160,6 +170,11 @@ mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl")) (getBuiltinUniques (length tys)) tys +mkTemplateLocalsNum :: Int -> [Type] -> [Id] +mkTemplateLocalsNum n tys = zipWith (mkSysLocal SLIT("tpl")) + (getNumBuiltinUniques n (length tys)) + tys + mkTemplateLocal :: Int -> Type -> Id mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty \end{code} @@ -451,3 +466,13 @@ zapLamIdInfo :: Id -> Id zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id \end{code} + + + + + + + + + + diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 13effb9..d5d2910 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -40,7 +40,7 @@ import TysWiredIn ( boolTy, charTy, mkListTy ) import PrelNames ( pREL_ERR, pREL_GHC ) import PrelRules ( primOpRule ) import Rules ( addRule ) -import Type ( Type, ClassContext, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys, +import Type ( Type, ThetaType, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy, classesToPreds, isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tyVarsOfTypes, splitSigmaTy, splitFunTy_maybe, @@ -92,7 +92,7 @@ import Maybes import PrelNames import Maybe ( isJust ) import Outputable -import Util ( assoc ) +import ListSetOps ( assoc, assocMaybe ) import UnicodeUtil ( stringToUtf8 ) import Char ( ord ) \end{code} @@ -111,8 +111,9 @@ wiredInIds -- is 'open'; that is can be unified with an unboxed type -- -- [The interface file format now carry such information, but there's - -- no way yet of expressing at the definition site for these error-reporting - -- functions that they have an 'open' result type. -- sof 1/99] + -- no way yet of expressing at the definition site for these + -- error-reporting + -- functions that they have an 'open' result type. -- sof 1/99] aBSENT_ERROR_ID , eRROR_ID @@ -618,13 +619,13 @@ mkDictFunId :: Name -- Name to use for the dict fun; -> Class -> [TyVar] -> [Type] - -> ClassContext + -> ThetaType -> Id -mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta +mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta = mkVanillaId dfun_name dfun_ty where - dfun_theta = classesToPreds inst_decl_theta + dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) {- 1 dec 99: disable the Mark Jones optimisation for the sake of compatibility with Hugs. @@ -653,7 +654,6 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta -- instance Wob b => Baz T b where.. -- Now sc_theta' has Foo T -} - dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) \end{code} diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index bc3ded6..ddfae90 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -13,7 +13,7 @@ module Name ( mkLocalName, mkImportedLocalName, mkSysLocalName, mkCCallName, mkTopName, mkIPName, mkDerivedName, mkGlobalName, mkKnownKeyGlobal, - mkWiredInIdName, mkWiredInTyConName, + mkWiredInIdName, mkWiredInTyConName, mkUnboundName, isUnboundName, maybeWiredInIdName, maybeWiredInTyConName, @@ -28,6 +28,7 @@ module Name ( nameSrcLoc, isLocallyDefinedName, isDllName, isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, + isTyVarName, -- Environment NameEnv, mkNameEnv, @@ -121,8 +122,8 @@ mkGlobalName uniq mod occ prov = Name { n_uniq = uniq, n_sort = Global mod, n_occ = occ, n_prov = prov } -mkKnownKeyGlobal :: (RdrName, Unique) -> Name -mkKnownKeyGlobal (rdr_name, uniq) +mkKnownKeyGlobal :: RdrName -> Unique -> Name +mkKnownKeyGlobal rdr_name uniq = mkGlobalName uniq (mkVanillaModule (rdrNameModule rdr_name)) (rdrNameOcc rdr_name) systemProvenance @@ -166,13 +167,10 @@ mkWiredInIdName :: Unique -> Module -> OccName -> Id -> Name mkWiredInIdName uniq mod occ id = Name { n_uniq = uniq, n_sort = WiredInId mod id, n_occ = occ, n_prov = SystemProv } --- mkWiredInTyConName takes a FAST_STRING instead of --- an OccName, which is a bit yukky but that's what the --- clients find easiest. -mkWiredInTyConName :: Unique -> Module -> FAST_STRING -> TyCon -> Name -mkWiredInTyConName uniq mod fs tycon +mkWiredInTyConName :: Unique -> Module -> OccName -> TyCon -> Name +mkWiredInTyConName uniq mod occ tycon = Name { n_uniq = uniq, n_sort = WiredInTyCon mod tycon, - n_occ = mkSrcOccFS tcName fs, n_prov = SystemProv } + n_occ = occ, n_prov = SystemProv } --------------------------------------------------------------------- @@ -493,6 +491,9 @@ isLocalName _ = False isGlobalName (Name {n_sort = Local}) = False isGlobalName other = True +isTyVarName :: Name -> Bool +isTyVarName name = isTvOcc (nameOccName name) + -- Global names are by definition those that are visible -- outside the module, *as seen by the linker*. Externally visible -- does not mean visible at the source level (that's isExported). @@ -567,6 +568,7 @@ elemNameEnv :: Name -> NameEnv a -> Bool unitNameEnv :: Name -> a -> NameEnv a lookupNameEnv :: NameEnv a -> Name -> Maybe a lookupNameEnv_NF :: NameEnv a -> Name -> a +mapNameEnv :: (a->b) -> NameEnv a -> NameEnv b emptyNameEnv = emptyUFM mkNameEnv = listToUFM @@ -578,6 +580,7 @@ plusNameEnv_C = plusUFM_C extendNameEnvList= addListToUFM delFromNameEnv = delFromUFM elemNameEnv = elemUFM +mapNameEnv = mapUFM unitNameEnv = unitUFM lookupNameEnv = lookupUFM diff --git a/ghc/compiler/basicTypes/NameSet.lhs b/ghc/compiler/basicTypes/NameSet.lhs index 1c9d02b..e09bfac 100644 --- a/ghc/compiler/basicTypes/NameSet.lhs +++ b/ghc/compiler/basicTypes/NameSet.lhs @@ -9,7 +9,7 @@ module NameSet ( NameSet, emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets, minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, - delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet + delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet ) where #include "HsVersions.h" @@ -41,6 +41,7 @@ isEmptyNameSet :: NameSet -> Bool delFromNameSet :: NameSet -> Name -> NameSet delListFromNameSet :: NameSet -> [Name] -> NameSet foldNameSet :: (Name -> b -> b) -> b -> NameSet -> b +filterNameSet :: (Name -> Bool) -> NameSet -> NameSet isEmptyNameSet = isEmptyUniqSet emptyNameSet = emptyUniqSet @@ -55,6 +56,7 @@ elemNameSet = elementOfUniqSet nameSetToList = uniqSetToList delFromNameSet = delOneFromUniqSet foldNameSet = foldUniqSet +filterNameSet = filterUniqSet delListFromNameSet set ns = foldl delFromNameSet set ns \end{code} diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index 5eb623b..9efd4af 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -18,6 +18,7 @@ module OccName ( mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc, mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc, + mkGenOcc1, mkGenOcc2, isSysOcc, isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc, @@ -308,7 +309,8 @@ mkDictOcc = mk_simple_deriv varName "$d" mkIPOcc = mk_simple_deriv varName "$i" mkSpecOcc = mk_simple_deriv varName "$s" mkForeignExportOcc = mk_simple_deriv varName "$f" - +mkGenOcc1 = mk_simple_deriv varName "$gfrom" -- Generics +mkGenOcc2 = mk_simple_deriv varName "$gto" -- Generics mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ) diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 3d13ce5..dda19bf 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -41,7 +41,7 @@ module Unique ( mkPreludeMiscIdUnique, mkPreludeDataConUnique, mkPreludeTyConUnique, mkPreludeClassUnique, - getBuiltinUniques, mkBuiltinUnique, + getNumBuiltinUniques, getBuiltinUniques, mkBuiltinUnique, mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3 ) where @@ -286,7 +286,7 @@ Allocation of unique supply characters: mkAlphaTyVarUnique i = mkUnique '1' i mkPreludeClassUnique i = mkUnique '2' i -mkPreludeTyConUnique i = mkUnique '3' i +mkPreludeTyConUnique i = mkUnique '3' (3*i) mkTupleTyConUnique Boxed a = mkUnique '4' a mkTupleTyConUnique Unboxed a = mkUnique '5' a @@ -329,5 +329,10 @@ mkPseudoUnique3 i = mkUnique 'E' i -- used in NCG spiller to create spill Virtua getBuiltinUniques :: Int -> [Unique] getBuiltinUniques n = map (mkUnique 'B') [1 .. n] + +getNumBuiltinUniques :: Int -- First unique + -> Int -- Number required + -> [Unique] +getNumBuiltinUniques base n = map (mkUnique 'B') [base .. base+n-1] \end{code} diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 9ab2ab2..37ef6e8 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.35 2000/07/11 16:03:37 simonmar Exp $ +% $Id: CgExpr.lhs,v 1.36 2000/10/03 08:43:00 simonpj Exp $ % %******************************************************** %* * @@ -47,7 +47,8 @@ import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep ) import TyCon ( maybeTyConSingleCon, isUnboxedTupleTyCon, isEnumerationTyCon ) import Type ( Type, typePrimRep, splitTyConApp_maybe, repType ) -import Maybes ( assocMaybe, maybeToBool ) +import Maybes ( maybeToBool ) +import ListSetOps ( assocMaybe ) import Unique ( mkBuiltinUnique ) import BasicTypes ( TopLevelFlag(..), RecFlag(..) ) import Outputable diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 7428e5e..7b721a4 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgTailCall.lhs,v 1.26 2000/07/14 08:14:53 simonpj Exp $ +% $Id: CgTailCall.lhs,v 1.27 2000/10/03 08:43:00 simonpj Exp $ % %******************************************************** %* * @@ -48,13 +48,14 @@ import ClosureInfo ( nodeMustPointToIt, import CmdLineOpts ( opt_DoSemiTagging ) import Id ( Id, idType, idName ) import DataCon ( DataCon, dataConTyCon, dataConTag, fIRST_TAG ) -import Maybes ( assocMaybe, maybeToBool ) +import Maybes ( maybeToBool ) import PrimRep ( PrimRep(..) ) import StgSyn ( StgArg, GenStgArg(..) ) import Type ( isUnLiftedType ) import TyCon ( TyCon ) import PrimOp ( PrimOp ) import Util ( zipWithEqual ) +import ListSetOps ( assocMaybe ) import Unique ( mkPseudoUnique1 ) import Outputable import Panic ( panic, assertPanic ) diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index eaf006b..4094342 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -18,7 +18,7 @@ import DsUtils import Id ( Id ) import CoreSyn import Type ( mkTyVarTys ) -import Util ( equivClassesByUniq ) +import ListSetOps ( equivClassesByUniq ) import Unique ( Uniquable(..) ) \end{code} diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 894a632..b33ab92 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -25,6 +25,7 @@ import BasicTypes ( RecFlag(..), Fixity ) import Outputable import SrcLoc ( SrcLoc ) import Var ( TyVar ) +import Class ( DefMeth (..) ) \end{code} %************************************************************************ @@ -236,11 +237,9 @@ data Sig name (HsType name) SrcLoc - | ClassOpSig name -- Selector name - (Maybe -- Nothing for source-file class signatures - (name, -- Default-method name (if any) - Bool)) -- True <=> there is an explicit, programmer-supplied - -- default declaration in the class decl + | ClassOpSig name -- Selector name + (Maybe (DefMeth name)) -- Nothing for source-file class signatures + -- Gives DefMeth info for interface files sigs (HsType name) SrcLoc @@ -338,8 +337,15 @@ ppr_sig (ClassOpSig var dm ty _) = sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)] where pp_dm = case dm of - Just (_, True) -> equals -- Default-method indicator - other -> empty + Just (DefMeth _) -> equals -- Default method indicator + Just GenDefMeth -> semi -- Generic method indicator + Just NoDefMeth -> empty -- No Method at all + -- Not convinced this is right... + -- Not used in interface file output hopefully + -- but needed for ddump-rn ?? + other -> dot + -- empty -- No method at all + ppr_sig (SpecSig var ty _) = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon], diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 0ed79e2..0767de0 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -15,7 +15,10 @@ module HsDecls ( BangType(..), getBangType, IfaceSig(..), SpecDataSig(..), DeprecDecl(..), DeprecTxt, - hsDeclName, instDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule + hsDeclName, instDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule, + toClassDeclNameList, + fromClassDeclNameList + ) where #include "HsVersions.h" @@ -91,12 +94,13 @@ hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x) tyClDeclName :: TyClDecl name pat -> name -tyClDeclName (TyData _ _ name _ _ _ _ _ _) = name +tyClDeclName (TyData _ _ name _ _ _ _ _ _ _ _) = name tyClDeclName (TySynonym name _ _ _) = name -tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ _ _ _) = name +tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ ) = name instDeclName :: InstDecl name pat -> name instDeclName (InstDecl _ _ _ (Just name) _) = name + \end{code} \begin{code} @@ -186,10 +190,12 @@ data TyClDecl name pat -- expect... (DataPragmas name) SrcLoc + name -- generic converter functions + name -- generic converter functions - | TySynonym name -- type constructor - [HsTyVarBndr name] -- type variables - (HsType name) -- synonym expansion + | TySynonym name -- type constructor + [HsTyVarBndr name] -- type variables + (HsType name) -- synonym expansion SrcLoc | ClassDecl (HsContext name) -- context... @@ -199,15 +205,29 @@ data TyClDecl name pat [Sig name] -- methods' signatures (MonoBinds name pat) -- default methods (ClassPragmas name) - name name name [name] -- The names of the tycon, datacon wrapper, datacon worker, - -- and superclass selectors for this class. - -- These are filled in as the ClassDecl is made. + [name] -- The names of the tycon, datacon + -- wrapper, datacon worker, + -- and superclass selectors for this + -- class (the first 3 are at the front + -- of the list in this order) + -- These are filled in as the + -- ClassDecl is made. SrcLoc +-- Put type signatures in and explain further!! + -- The names of the tycon, datacon + -- wrapper, datacon worker, + -- and superclass selectors for this + -- class (the first 3 are at the front + -- of the list in this order) + -- These are filled in as the +toClassDeclNameList (a,b,c,ds) = a:b:c:ds +fromClassDeclNameList (a:b:c:ds) = (a,b,c,ds) + instance Ord name => Eq (TyClDecl name pat) where -- Used only when building interface files - (==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _) - (TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _) + (==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _ _ _) + (TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _ _ _) = n1 == n2 && nd1 == nd2 && eqWithHsTyVars tvs1 tvs2 (\ env -> @@ -220,8 +240,8 @@ instance Ord name => Eq (TyClDecl name pat) where = n1 == n2 && eqWithHsTyVars tvs1 tvs2 (\ env -> eq_hsType env ty1 ty2) - (==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ _ _ _ _) - (ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ _ _ _ _) + (==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ _ ) + (ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ _ ) = n1 == n2 && eqWithHsTyVars tvs1 tvs2 (\ env -> eq_hsContext env cxt1 cxt2 && @@ -242,7 +262,7 @@ eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _) -- This is used for comparing declarations before putting -- them into interface files, and the name of the default -- method isn't relevant - (Just (_,explicit_dm1)) `eq_dm` (Just (_,explicit_dm2)) = explicit_dm1 == explicit_dm2 + (Just (explicit_dm1)) `eq_dm` (Just (explicit_dm2)) = explicit_dm1 == explicit_dm2 Nothing `eq_dm` Nothing = True dm1 `eq_dm` dm2 = False \end{code} @@ -251,9 +271,9 @@ eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _) countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int) -- class, data, newtype, synonym decls countTyClDecls decls - = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ _ _ _ <- decls], - length [() | TyData DataType _ _ _ _ _ _ _ _ <- decls], - length [() | TyData NewType _ _ _ _ _ _ _ _ <- decls], + = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ <- decls], + length [() | TyData DataType _ _ _ _ _ _ _ _ _ _ <- decls], + length [() | TyData NewType _ _ _ _ _ _ _ _ _ _ <- decls], length [() | TySynonym _ _ _ _ <- decls]) isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool @@ -261,10 +281,10 @@ isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool isSynDecl (TySynonym _ _ _ _) = True isSynDecl other = False -isDataDecl (TyData _ _ _ _ _ _ _ _ _) = True -isDataDecl other = False +isDataDecl (TyData _ _ _ _ _ _ _ _ _ _ _) = True +isDataDecl other = False -isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ _ _ _) = True +isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ ) = True isClassDecl other = False \end{code} @@ -276,7 +296,7 @@ instance (Outputable name, Outputable pat) = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals) 4 (ppr mono_ty) - ppr (TyData new_or_data context tycon tyvars condecls ncons derivings pragmas src_loc) + ppr (TyData new_or_data context tycon tyvars condecls ncons derivings pragmas src_loc gen_conv1 gen_conv2) -- The generic names are not printed out ATM = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars <+> equals) (pp_condecls condecls ncons) @@ -286,7 +306,7 @@ instance (Outputable name, Outputable pat) NewType -> SLIT("newtype") DataType -> SLIT("data") - ppr (ClassDecl context clas tyvars fds sigs methods pragmas _ _ _ _ src_loc) + ppr (ClassDecl context clas tyvars fds sigs methods pragmas _ src_loc) | null sigs -- No "where" part = top_matter diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 829f9ab..8cbc038 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -153,6 +153,7 @@ data HsExpr id pat | HsSCC FAST_STRING -- "set cost centre" (_scc_) annotation (HsExpr id pat) -- expr whose cost is to be measured + \end{code} These constructors only appear temporarily in the parser. @@ -165,6 +166,8 @@ The renamer translates them into the Right Thing. (HsExpr id pat) | ELazyPat (HsExpr id pat) -- ~ pattern + + | HsType (HsType id) -- Explicit type argument; e.g f {| Int |} x y \end{code} Everything from here on appears only in typechecker output. @@ -362,6 +365,8 @@ ppr_expr (DictApp expr dnames) = hang (ppr_expr expr) 4 (brackets (interpp'SP dnames)) +ppr_expr (HsType id) = ppr id + \end{code} Parenthesize unless very simple: diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs index 151e499..effa2f7 100644 --- a/ghc/compiler/hsSyn/HsMatches.lhs +++ b/ghc/compiler/hsSyn/HsMatches.lhs @@ -14,11 +14,12 @@ module HsMatches where import HsExpr ( HsExpr, Stmt(..) ) import HsBinds ( HsBinds(..), nullBinds ) import HsTypes ( HsTyVarBndr, HsType ) - -- Others import Type ( Type ) import SrcLoc ( SrcLoc ) import Outputable +import HsPat ( InPat (..) ) +import List \end{code} %************************************************************************ @@ -44,11 +45,11 @@ patterns in each equation. \begin{code} data Match id pat = Match - [HsTyVarBndr id] -- Tyvars wrt which this match is universally quantified - -- empty after typechecking - [pat] -- The patterns - (Maybe (HsType id)) -- A type signature for the result of the match - -- Nothing after typechecking + [id] -- Tyvars wrt which this match is universally quantified + -- empty after typechecking + [pat] -- The patterns + (Maybe (HsType id)) -- A type signature for the result of the match + -- Nothing after typechecking (GRHSs id pat) @@ -131,3 +132,4 @@ pprGRHS is_case (GRHS guarded locn) ExprStmt expr _ = last guarded -- Last stmt should be a ExprStmt for guards guards = init guarded \end{code} + diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index f28d443..0447e3d 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -72,6 +72,15 @@ data InPat name | RecPatIn name -- record [(name, InPat name, Bool)] -- True <=> source used punning +-- Generics + | TypePatIn (HsType name) -- Type pattern for generic definitions + -- e.g f{| a+b |} = ... + -- These show up only in class + -- declarations, + -- and should be a top-level pattern + +-- /Generics + data OutPat id = WildPat Type -- wild card | VarPat id -- variable (type is in the Id) @@ -163,6 +172,8 @@ pprInPat (RecPatIn con rpats) where pp_rpat (v, _, True) = ppr v pp_rpat (v, p, _) = hsep [ppr v, char '=', ppr p] + +pprInPat (TypePatIn ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}") \end{code} \begin{code} @@ -317,9 +328,11 @@ collect (ParPatIn pat) bndrs = collect pat bndrs collect (ListPatIn pats) bndrs = foldr collect bndrs pats collect (TuplePatIn pats _) bndrs = foldr collect bndrs pats collect (RecPatIn c fields) bndrs = foldr (\ (f,pat,_) bndrs -> collect pat bndrs) bndrs fields +-- Generics +collect (TypePatIn ty) bndrs = bndrs +-- assume the type variables do not need to be bound \end{code} - \begin{code} collectSigTysFromPats :: [InPat name] -> [HsType name] collectSigTysFromPats pats = foldr collect_pat [] pats @@ -338,4 +351,7 @@ collect_pat (ParPatIn pat) acc = collect_pat pat acc collect_pat (ListPatIn pats) acc = foldr collect_pat acc pats collect_pat (TuplePatIn pats _) acc = foldr collect_pat acc pats collect_pat (RecPatIn c fields) acc = foldr (\ (f,pat,_) acc -> collect_pat pat acc) acc fields +-- Generics +collect_pat (TypePatIn ty) acc = ty:acc \end{code} + diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index ad446c3..f0f7c94 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -24,7 +24,7 @@ module HsSyn ( module HsTypes, Fixity, NewOrData, - collectTopBinders, collectMonoBinders + collectTopBinders, collectMonoBinders, collectLocatedMonoBinders ) where #include "HsVersions.h" @@ -116,18 +116,25 @@ it should return @[x, y, f, a, b]@ (remember, order important). \begin{code} collectTopBinders :: HsBinds name (InPat name) -> Bag (name,SrcLoc) -collectTopBinders EmptyBinds = emptyBag -collectTopBinders (MonoBind b _ _) = collectMonoBinders b -collectTopBinders (ThenBinds b1 b2) - = collectTopBinders b1 `unionBags` collectTopBinders b2 - -collectMonoBinders :: MonoBinds name (InPat name) -> Bag (name,SrcLoc) -collectMonoBinders EmptyMonoBinds = emptyBag -collectMonoBinders (PatMonoBind pat _ loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat)) -collectMonoBinders (FunMonoBind f _ matches loc) = unitBag (f,loc) -collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders" -collectMonoBinders (CoreMonoBind v expr) = error "collectMonoBinders" -collectMonoBinders (AndMonoBinds bs1 bs2) = collectMonoBinders bs1 `unionBags` - collectMonoBinders bs2 +collectTopBinders EmptyBinds = emptyBag +collectTopBinders (MonoBind b _ _) = listToBag (collectLocatedMonoBinders b) +collectTopBinders (ThenBinds b1 b2) = collectTopBinders b1 `unionBags` collectTopBinders b2 + +collectLocatedMonoBinders :: MonoBinds name (InPat name) -> [(name,SrcLoc)] +collectLocatedMonoBinders binds + = go binds [] + where + go EmptyMonoBinds acc = acc + go (PatMonoBind pat _ loc) acc = map (\v->(v,loc)) (collectPatBinders pat) ++ acc + go (FunMonoBind f _ _ loc) acc = (f,loc) : acc + go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc) + +collectMonoBinders :: MonoBinds name (InPat name) -> [name] +collectMonoBinders binds + = go binds [] + where + go EmptyMonoBinds acc = acc + go (PatMonoBind pat _ loc) acc = collectPatBinders pat ++ acc + go (FunMonoBind f _ _ loc) acc = f : acc + go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc) \end{code} - diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 14157d7..1bcebd8 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -25,6 +25,7 @@ module HsTypes ( #include "HsVersions.h" +import {-# SOURCE #-} HsExpr ( HsExpr ) import Class ( FunDep ) import Type ( Type, Kind, PredType(..), UsageAnn(..), ClassContext, getTyVar_maybe, splitSigmaTy, unUsgTy, boxedTypeKind @@ -41,6 +42,7 @@ import PrelNames ( mkTupConRdrName, listTyConKey, hasKey, Uniquable(..) ) import Maybes ( maybeToBool ) import FiniteMap import Outputable + \end{code} This is the syntax for types as seen in type signatures. @@ -56,7 +58,7 @@ data HsType name (HsContext name) (HsType name) - | HsTyVar name -- Type variable + | HsTyVar name -- Type variable or type constructor | HsAppTy (HsType name) (HsType name) @@ -68,7 +70,9 @@ data HsType name | HsTupleTy (HsTupCon name) [HsType name] -- Element types (length gives arity) - + -- Generics + | HsOpTy (HsType name) name (HsType name) + | HsNumTy Integer -- these next two are only used in interfaces | HsPredTy (HsPred name) @@ -253,6 +257,9 @@ ppr_mono_ty ctxt_prec (HsUsgTy u ty) HsUsOnce -> ptext SLIT("-") HsUsMany -> ptext SLIT("!") HsUsVar uv -> ppr uv +-- Generics +ppr_mono_ty ctxt_prec (HsNumTy n) = integer n +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) = ppr ty1 <+> ppr op <+> ppr ty2 \end{code} @@ -411,6 +418,9 @@ eq_hsType env (HsFunTy a1 b1) (HsFunTy a2 b2) eq_hsType env (HsPredTy p1) (HsPredTy p2) = eq_hsPred env p1 p2 +eq_hsType env (HsOpTy lty1 op1 rty1) (HsOpTy lty2 op2 rty2) + = eq_hsVar env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2 + eq_hsType env (HsUsgTy u1 ty1) (HsUsgTy u2 ty2) = eqUsg u1 u2 && eq_hsType env ty1 ty2 diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index d93c8b0..adab1aa 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -166,7 +166,7 @@ import Argv import Constants -- Default values for some flags import FastString ( headFS ) -import Maybes ( assocMaybe, firstJust, maybeToBool ) +import Maybes ( firstJust, maybeToBool ) import Panic ( panic, panic# ) #if __GLASGOW_HASKELL__ < 301 @@ -258,7 +258,7 @@ lookup_def_int :: String -> Int -> Int lookup_def_float :: String -> Float -> Float lookup_str :: String -> Maybe String -lookUp sw = maybeToBool (assoc_opts sw) +lookUp sw = sw `elem` argv lookup_str sw = firstJust (map (startsWith sw) unpacked_opts) @@ -278,7 +278,6 @@ lookup_def_float sw def = case (lookup_str sw) of Nothing -> def -- Use default Just xx -> read xx -assoc_opts = assocMaybe [ (a, True) | a <- argv ] unpacked_opts = map _UNPK_ argv {- @@ -287,8 +286,6 @@ unpacked_opts = map _UNPK_ argv a pure Win32 application where I think there's a command-line length limit of 255. unpacked_opts understands the @ option. -assoc_opts = assocMaybe [ (_PK_ a, True) | a <- unpacked_opts ] - unpacked_opts :: [String] unpacked_opts = concat $ diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index cf0ee0e..ad9cde2 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -46,10 +46,7 @@ import BSD import IOExts ( unsafePerformIO ) import NativeInfo ( os, arch ) #endif -#ifdef GHCI import StgInterp ( runStgI ) -import CompManager -#endif \end{code} @@ -84,7 +81,7 @@ doIt :: ([CoreToDo], [StgToDo]) -> IO () doIt (core_cmds, stg_cmds) = doIfSet opt_Verbose - (hPutStr stderr "Glasgow Haskell Compiler, version " >> + (hPutStr stderr "Glasgow Haskell Compiler, Version " >> hPutStr stderr compiler_version >> hPutStr stderr ", for Haskell 98, compiled by GHC version " >> hPutStr stderr booter_version >> @@ -338,11 +335,11 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) spec_info (Just (False, _)) = (0,0,0,0,1,0) spec_info (Just (True, _)) = (0,0,0,0,0,1) - data_info (TyData _ _ _ _ _ nconstrs derivs _ _) + data_info (TyData _ _ _ _ _ nconstrs derivs _ _ _ _) = (nconstrs, case derivs of {Nothing -> 0; Just ds -> length ds}) data_info other = (0,0) - class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ _ _ _ _) + class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ _ ) = case count_sigs meth_sigs of (_,classops,_,_) -> (classops, addpr (count_monobinds def_meths)) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index a8da5dc..1d709ef 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -12,7 +12,7 @@ import IO ( openFile, hClose, IOMode(..) ) import HsSyn import HsCore ( HsIdInfo(..), toUfExpr ) -import RdrHsSyn ( RdrNameRuleDecl ) +import RdrHsSyn ( RdrNameRuleDecl, mkTyData ) import HsPragmas ( DataPragmas(..), ClassPragmas(..) ) import HsTypes ( toHsTyVars ) import BasicTypes ( Fixity(..), NewOrData(..), @@ -26,7 +26,7 @@ import CmdLineOpts import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding, idSpecialisation ) -import Var ( isId ) +import Var ( isId, varName ) import VarSet import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks ) import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..), @@ -48,7 +48,7 @@ import OccName ( OccName, pprOccName ) import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize ) -import Class ( classExtraBigSig ) +import Class ( classExtraBigSig, DefMeth(..) ) import FieldLabel ( fieldLabelType ) import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType, classesToPreds @@ -105,8 +105,8 @@ writeIface this_mod old_iface new_iface Just final_iface -> do let mod_vers_unchanged = case old_iface of - Just iface -> pi_vers iface == pi_vers final_iface - Nothing -> False + Just iface -> pi_vers iface == pi_vers final_iface + Nothing -> False when (mod_vers_unchanged && opt_D_dump_rn_trace) $ putStrLn "Module version unchanged, but usages differ; hence need new hi file" @@ -390,8 +390,7 @@ ifaceInstances inst_infos -- instance Foo Tibble where ... -- and this instance decl wouldn't get imported into a module -- that mentioned T but not Tibble. - forall_ty = mkSigmaTy tvs (classesToPreds theta) - (deNoteType (mkDictTy clas tys)) + forall_ty = mkSigmaTy tvs theta (deNoteType (mkDictTy clas tys)) tidy_ty = tidyTopType forall_ty in InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (toRdrName dfun_id)) noSrcLoc @@ -409,7 +408,7 @@ ifaceTyCon tycon ifaceTyCon tycon | isAlgTyCon tycon - = TyClD (TyData new_or_data (toHsContext (tyConTheta tycon)) + = TyClD (mkTyData new_or_data (toHsContext (tyConTheta tycon)) (toRdrName tycon) (toHsTyVars tyvars) (map ifaceConDecl (tyConDataCons tycon)) @@ -454,24 +453,28 @@ ifaceClass clas (toHsFDs clas_fds) (map toClassOpSig op_stuff) EmptyMonoBinds NoClassPragmas - bogus bogus bogus [] noSrcLoc + [] noSrcLoc ) where bogus = error "ifaceClass" (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas - toClassOpSig (sel_id, dm_id, explicit_dm) - = ASSERT( sel_tyvars == clas_tyvars) - ClassOpSig (toRdrName sel_id) (Just (bogus, explicit_dm)) (toHsType op_ty) noSrcLoc + toClassOpSig (sel_id, def_meth) = + ASSERT(sel_tyvars == clas_tyvars) + ClassOpSig (toRdrName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc where (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id) + def_meth' = case def_meth of + NoDefMeth -> NoDefMeth + GenDefMeth -> GenDefMeth + DefMeth id -> DefMeth (toRdrName id) \end{code} %************************************************************************ %* * \subsection{Value bindings} -%* * +%* * %************************************************************************ \begin{code} @@ -665,7 +668,6 @@ ifaceId get_idinfo is_rec id rhs find_fvs expr = exprSomeFreeVars interestingId expr - interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id) \end{code} diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 88667c4..d182ce1 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -184,6 +184,8 @@ data Token | ITocurly -- special symbols | ITccurly + | ITocurlybar -- {|, for type applications + | ITccurlybar -- |}, for type applications | ITvccurly | ITobrack | ITcbrack @@ -381,7 +383,7 @@ lexer cont buf s@(PState{ where line = srcLocLine loc - tab y bol atbol buf = --trace ("tab: " ++ show (I# y) ++ " : " ++ show (currentChar buf)) $ + tab y bol atbol buf = -- trace ("tab: " ++ show (I# y) ++ " : " ++ show (currentChar buf)) $ case currentChar# buf of '\NUL'# -> @@ -407,8 +409,7 @@ lexer cont buf s@(PState{ -- and throw out any unrecognised pragmas as comments. Any -- pragmas we know about are dealt with later (after any layout -- processing if necessary). - - '{'# | lookAhead# buf 1# `eqChar#` '-'# -> + '{'# | lookAhead# buf 1# `eqChar#` '-'# -> if lookAhead# buf 2# `eqChar#` '#'# then if lookAhead# buf 3# `eqChar#` '#'# then is_a_token else case expandWhile# is_space (setCurrentPos# buf 3#) of { buf1-> @@ -472,8 +473,7 @@ nested_comment cont buf = loop buf loop buf = case currentChar# buf of '\NUL'# | bufferExhausted (stepOn buf) -> - lexError "unterminated `{-'" buf - + lexError "unterminated `{-'" buf -- -} '-'# | lookAhead# buf 1# `eqChar#` '}'# -> cont (stepOnBy# buf 2#) @@ -526,7 +526,7 @@ lexBOL cont buf s@(PState{ lexToken :: (Token -> P a) -> Int# -> P a lexToken cont glaexts buf = - --trace "lexToken" $ + -- trace "lexToken" $ case currentChar# buf of -- special symbols ---------------------------------------------------- @@ -540,12 +540,16 @@ lexToken cont glaexts buf = ']'# -> cont ITcbrack (incLexeme buf) ','# -> cont ITcomma (incLexeme buf) ';'# -> cont ITsemi (incLexeme buf) - '}'# -> \ s@PState{context = ctx} -> case ctx of (_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'} _ -> lexError "too many '}'s" buf s + '|'# -> case lookAhead# buf 1# of + '}'# | flag glaexts -> cont ITccurlybar + (setCurrentPos# buf 2#) + _ -> lex_sym cont (incLexeme buf) + '#'# -> case lookAhead# buf 1# of ')'# | flag glaexts -> cont ITcubxparen (setCurrentPos# buf 2#) '-'# -> case lookAhead# buf 2# of @@ -559,16 +563,18 @@ lexToken cont glaexts buf = -> cont ITbackquote (incLexeme buf) '{'# -> -- look for "{-##" special iface pragma - case lookAhead# buf 1# of + case lookAhead# buf 1# of + '|'# | flag glaexts + -> cont ITocurlybar (setCurrentPos# buf 2#) '-'# -> case lookAhead# buf 2# of '#'# -> case lookAhead# buf 3# of - '#'# -> + '#'# -> let (lexeme, buf') = doDiscard False (stepOnBy# (stepOverLexeme buf) 4#) in - cont (ITpragma lexeme) buf' + cont (ITpragma lexeme) buf' _ -> lex_prag cont (setCurrentPos# buf 3#) - _ -> cont ITocurly (incLexeme buf) - _ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf) + _ -> cont ITocurly (incLexeme buf) + _ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf) -- strings/characters ------------------------------------------------- '\"'#{-"-} -> lex_string cont glaexts [] (incLexeme buf) @@ -908,6 +914,7 @@ lex_id cont glaexts buf = }}} lex_sym cont buf = + -- trace "lex_sym" $ case expandWhile# is_symbol buf of buf' -> case lookupUFM haskellKeySymsFM lexeme of { Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $ @@ -919,6 +926,7 @@ lex_sym cont buf = lex_con cont glaexts buf = + -- trace ("con: "{-++unpackFS lexeme-}) $ case expandWhile# is_ident buf of { buf1 -> case slurp_trailing_hashes buf1 glaexts of { buf' -> @@ -927,13 +935,13 @@ lex_con cont glaexts buf = _ -> just_a_conid where - just_a_conid = --trace ("con: "++unpackFS lexeme) $ - cont (ITconid lexeme) buf' + just_a_conid = cont (ITconid lexeme) buf' lexeme = lexemeToFastString buf' munch = lex_qid cont glaexts lexeme (incLexeme buf') just_a_conid }} lex_qid cont glaexts mod buf just_a_conid = + -- trace ("quid: "{-++unpackFS lexeme-}) $ case currentChar# buf of '['# -> -- Special case for [] case lookAhead# buf 1# of @@ -961,6 +969,7 @@ lex_id3 cont glaexts mod buf just_a_conid let start_new_lexeme = stepOverLexeme buf in + -- trace ("lex_id31 "{-++unpackFS lexeme-}) $ case expandWhile# is_symbol start_new_lexeme of { buf' -> let lexeme = lexemeToFastString buf' @@ -975,6 +984,7 @@ lex_id3 cont glaexts mod buf just_a_conid let start_new_lexeme = stepOverLexeme buf in + -- trace ("lex_id32 "{-++unpackFS lexeme-}) $ case expandWhile# is_ident start_new_lexeme of { buf1 -> if emptyLexeme buf1 then just_a_conid @@ -1007,8 +1017,10 @@ mk_var_token pk_str | otherwise = ITvarsym pk_str where (C# f) = _HEAD_ pk_str + -- tl = _TAIL_ pk_str mk_qvar_token m token = +-- trace ("mk_qvar ") $ case mk_var_token token of ITconid n -> ITqconid (m,n) ITvarid n -> ITqvarid (m,n) diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 49c0376..2a733a7 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -70,7 +70,16 @@ splitForConApp :: RdrNameHsType -> [RdrNameBangType] splitForConApp t ts = split t ts where split (HsAppTy t u) ts = split t (Unbanged u : ts) - +{- split (HsOpTy t1 t ty2) ts = + -- check that we've got a type constructor at the head + if occNameSpace t_occ /= tcClsName + then parseError + (showSDoc (text "not a constructor: (type pattern)`" <> + ppr t <> char '\'')) + else returnP (con, ts) + where t_occ = rdrNameOcc t + con = setRdrNameOcc t (setOccNameSpace t_occ dataName) +-} split (HsTyVar t) ts = -- check that we've got a type constructor at the head if occNameSpace t_occ /= tcClsName @@ -136,8 +145,12 @@ checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) checkDictTy (HsAppTy l r) args = checkDictTy l (r:args) checkDictTy _ _ = parseError "Illegal class assertion" +-- Put more comments! +-- Checks that the lhs of a datatype declaration +-- is of the form Context => T a b ... z checkDataHeader :: RdrNameHsType -> P (RdrNameContext, RdrName, [RdrNameHsTyVar]) + checkDataHeader (HsForAllTy Nothing cs t) = checkSimple t [] `thenP` \(c,ts) -> returnP (cs,c,map UserTyVar ts) @@ -145,17 +158,23 @@ checkDataHeader t = checkSimple t [] `thenP` \(c,ts) -> returnP ([],c,map UserTyVar ts) +-- Checks the type part of the lhs of a datatype declaration checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName])) checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a = checkSimple l (a:xs) -checkSimple (HsTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs) -checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration" +checkSimple (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs) + +checkSimple (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) [] + | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2 + = returnP (tycon,[t1,t2]) + +checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration" --------------------------------------------------------------------------- -- Checking Patterns. -- We parse patterns as expressions and check for valid patterns below, --- nverting the expression into a pattern at the same time. +-- converting the expression into a pattern at the same time. checkPattern :: RdrNameHsExpr -> P RdrNamePat checkPattern e = checkPat e [] @@ -204,6 +223,8 @@ checkPat e [] = case e of RecordCon c fs -> mapP checkPatField fs `thenP` \fs -> returnP (RecPatIn c fs) +-- Generics + HsType ty -> returnP (TypePatIn ty) _ -> patFail checkPat _ _ = patFail @@ -249,6 +270,7 @@ checkValSig other ty loc = parseError "Type signature given for an expressio -- A variable binding is parsed as an RdrNameFunMonoBind. -- See comments with HsBinds.MonoBinds +isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr]) isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op) = Just (op, True, (l:r:es)) isFunLhs (HsVar f) es | not (isRdrDataCon f) @@ -282,6 +304,7 @@ mkRecConstrOrUpdate _ _ -- it's external name will be "++". Too bad; it's important because we don't -- want z-encoding (e.g. names with z's in them shouldn't be doubled) -- (This is why we use occNameUserString.) + mkExtName :: Maybe ExtName -> RdrName -> ExtName mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm))) Nothing diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 122ab9a..9f7ef43 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.36 2000/09/22 15:56:13 simonpj Exp $ +$Id: Parser.y,v 1.37 2000/10/03 08:43:02 simonpj Exp $ Haskell grammar. @@ -14,6 +14,7 @@ module Parser ( parse ) where import HsSyn import HsPragmas import HsTypes ( mkHsTupCon ) +import HsPat ( InPat(..) ) import RdrHsSyn import Lex @@ -30,6 +31,7 @@ import Panic import GlaExts import FastString ( tailFS ) +import Outputable #include "HsVersions.h" } @@ -158,6 +160,8 @@ Conflicts: 14 shift/reduce '{' { ITocurly } -- special symbols '}' { ITccurly } + '{|' { ITocurlybar } + '|}' { ITccurlybar } vccurly { ITvccurly } -- virtual close curly (from layout) '[' { ITobrack } ']' { ITcbrack } @@ -328,13 +332,13 @@ topdecl :: { RdrBinding } | srcloc 'data' ctype '=' constrs deriving {% checkDataHeader $3 `thenP` \(cs,c,ts) -> returnP (RdrHsDecl (TyClD - (TyData DataType cs c ts (reverse $5) (length $5) $6 + (mkTyData DataType cs c ts (reverse $5) (length $5) $6 NoDataPragmas $1))) } | srcloc 'newtype' ctype '=' newconstr deriving {% checkDataHeader $3 `thenP` \(cs,c,ts) -> returnP (RdrHsDecl (TyClD - (TyData NewType cs c ts [$5] 1 $6 + (mkTyData NewType cs c ts [$5] 1 $6 NoDataPragmas $1))) } | srcloc 'class' ctype fds where @@ -486,7 +490,7 @@ sigtypes :: { [RdrNameHsType] } | sigtypes ',' sigtype { $3 : $1 } sigtype :: { RdrNameHsType } - : ctype { mkHsForAllTy Nothing [] $1 } + : ctype { (mkHsForAllTy Nothing [] $1) } sig_vars :: { [RdrName] } : sig_vars ',' var { $3 : $1 } @@ -499,16 +503,21 @@ sig_vars :: { [RdrName] } ctype :: { RdrNameHsType } : 'forall' tyvars '.' ctype { mkHsForAllTy (Just $2) [] $4 } | context type { mkHsForAllTy Nothing $1 $2 } - -- A type of form (context => type) is an *implicit* HsForAllTy + -- A type of form (context => type) is an *implicit* HsForAllTy | type { $1 } type :: { RdrNameHsType } - : btype '->' type { HsFunTy $1 $3 } + : gentype '->' type { HsFunTy $1 $3 } | ipvar '::' type { mkHsIParamTy $1 $3 } - | btype { $1 } + | gentype { $1 } + +gentype :: { RdrNameHsType } + : btype { $1 } +-- Generics + | atype tyconop atype { HsOpTy $1 $2 $3 } btype :: { RdrNameHsType } - : btype atype { HsAppTy $1 $2 } + : btype atype { (HsAppTy $1 $2) } | atype { $1 } atype :: { RdrNameHsType } @@ -517,7 +526,9 @@ atype :: { RdrNameHsType } | '(' type ',' types ')' { HsTupleTy (mkHsTupCon tcName Boxed ($2:$4)) ($2 : reverse $4) } | '(#' types '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) (reverse $2) } | '[' type ']' { HsListTy $2 } - | '(' ctype ')' { $2 } + | '(' ctype ')' { $2 } +-- Generics + | INTEGER { HsNumTy $1 } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b @@ -648,15 +659,16 @@ dclasses :: { [RdrName] } -} valdef :: { RdrBinding } - : infixexp srcloc opt_sig rhs {% checkValDef $1 $3 $4 $2 } - | infixexp srcloc '::' sigtype {% checkValSig $1 $4 $2 } + : infixexp srcloc opt_sig rhs {% (checkValDef $1 $3 $4 $2) } + | infixexp srcloc '::' sigtype {% (checkValSig $1 $4 $2) } | var ',' sig_vars srcloc '::' sigtype { foldr1 RdrAndBindings [ RdrSig (Sig n $6 $4) | n <- $1:$3 ] - } + } + rhs :: { RdrNameGRHSs } - : '=' srcloc exp wherebinds { GRHSs (unguardedRHS $3 $2) - $4 Nothing} + : '=' srcloc exp wherebinds { (GRHSs (unguardedRHS $3 $2) + $4 Nothing)} | gdrhs wherebinds { GRHSs (reverse $1) $2 Nothing } gdrhs :: { [RdrNameGRHS] } @@ -670,13 +682,14 @@ gdrh :: { RdrNameGRHS } -- Expressions exp :: { RdrNameHsExpr } - : infixexp '::' sigtype { ExprWithTySig $1 $3 } + : infixexp '::' sigtype { (ExprWithTySig $1 $3) } | infixexp 'with' dbinding { HsWith $1 $3 } | infixexp { $1 } infixexp :: { RdrNameHsExpr } : exp10 { $1 } - | infixexp qop exp10 { OpApp $1 $2 (panic "fixity") $3 } + | infixexp qop exp10 { (OpApp $1 (HsVar $2) + (panic "fixity") $3 )} exp10 :: { RdrNameHsExpr } : '\\' aexp aexps opt_asig '->' srcloc exp @@ -706,24 +719,29 @@ ccallid :: { FAST_STRING } | CONID { $1 } fexp :: { RdrNameHsExpr } - : fexp aexp { HsApp $1 $2 } + : fexp aexp { (HsApp $1 $2) } | aexp { $1 } aexps0 :: { [RdrNameHsExpr] } - : aexps { reverse $1 } + : aexps { (reverse $1) } aexps :: { [RdrNameHsExpr] } : aexps aexp { $2 : $1 } | {- empty -} { [] } aexp :: { RdrNameHsExpr } - : aexp '{' fbinds '}' {% mkRecConstrOrUpdate $1 (reverse $3) } - | aexp1 { $1 } + : var_or_con '{|' gentype '|}' { (HsApp $1 (HsType $3)) } + | aexp '{' fbinds '}' {% (mkRecConstrOrUpdate $1 + (reverse $3)) } + | aexp1 { $1 } + +var_or_con :: { RdrNameHsExpr } + : qvar { HsVar $1 } + | gcon { HsVar $1 } aexp1 :: { RdrNameHsExpr } - : qvar { HsVar $1 } - | ipvar { HsIPVar $1 } - | gcon { HsVar $1 } + : ipvar { HsIPVar $1 } + | var_or_con { $1 } | literal { HsLit $1 } | INTEGER { HsOverLit (mkHsIntegralLit $1) } | RATIONAL { HsOverLit (mkHsFractionalLit $1) } @@ -731,8 +749,8 @@ aexp1 :: { RdrNameHsExpr } | '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) Boxed} | '(#' texps '#)' { ExplicitTuple (reverse $2) Unboxed } | '[' list ']' { $2 } - | '(' infixexp qop ')' { SectionL $2 $3 } - | '(' qopm infixexp ')' { SectionR $2 $3 } + | '(' infixexp qop ')' { (SectionL $2 (HsVar $3)) } + | '(' qopm infixexp ')' { (SectionR $2 $3) } | qvar '@' aexp { EAsPat $1 $3 } | '_' { EWildPat } | '~' aexp1 { ELazyPat $2 } @@ -741,6 +759,7 @@ texps :: { [RdrNameHsExpr] } : texps ',' exp { $3 : $1 } | exp { [$1] } + ----------------------------------------------------------------------------- -- List expressions @@ -792,9 +811,9 @@ alts1 :: { [RdrNameMatch] } alt :: { RdrNameMatch } : infixexp opt_sig ralt wherebinds - {% checkPattern $1 `thenP` \p -> + {% (checkPattern $1 `thenP` \p -> returnP (Match [] [p] $2 - (GRHSs $3 $4 Nothing)) } + (GRHSs $3 $4 Nothing)) )} ralt :: { [RdrNameGRHS] } : '->' srcloc exp { [GRHS [ExprStmt $3 $2] $2] } @@ -927,9 +946,9 @@ op :: { RdrName } -- used in infix decls : varop { $1 } | conop { $1 } -qop :: { RdrNameHsExpr } -- used in sections - : qvarop { HsVar $1 } - | qconop { HsVar $1 } +qop :: { RdrName {-HsExpr-} } -- used in sections + : qvarop { $1 } + | qconop { $1 } qopm :: { RdrNameHsExpr } -- used in sections : qvaropm { HsVar $1 } @@ -1052,6 +1071,9 @@ modid :: { ModuleName } tycon :: { RdrName } : CONID { mkSrcUnqual tcClsName $1 } +tyconop :: { RdrName } + : CONSYM { mkSrcUnqual tcClsName $1 } + qtycon :: { RdrName } : tycon { $1 } | QCONID { mkSrcQual tcClsName $1 } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 75fa293..5af43d6 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -53,7 +53,7 @@ module RdrHsSyn ( extractHsTyRdrTyVars, extractHsTysRdrTyVars, extractPatsTyVars, extractRuleBndrsTyVars, - extractHsCtxtRdrTyVars, + extractHsCtxtRdrTyVars, extractGenericPatTyVars, mkHsOpApp, mkClassDecl, mkClassOpSig, mkConDecl, mkHsNegApp, mkHsIntegralLit, mkHsFractionalLit, mkNPlusKPatIn, @@ -67,7 +67,8 @@ module RdrHsSyn ( cvBinds, cvMonoBindsAndSigs, cvTopDecls, - cvValSig, cvClassOpSig, cvInstDeclSig + cvValSig, cvClassOpSig, cvInstDeclSig, + mkTyData ) where #include "HsVersions.h" @@ -76,8 +77,8 @@ import HsSyn -- Lots of it import CmdLineOpts ( opt_NoImplicitPrelude ) import HsPat ( collectSigTysFromPats ) import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, - mkSuperDictSelOcc, mkDefaultMethodOcc, - varName, dataName, tcName + mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1, + mkGenOcc2, varName, dataName, tcName ) import PrelNames ( pRELUDE_Name, mkTupNameStr ) import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, @@ -86,6 +87,8 @@ import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, import HsPragmas import List ( nub ) import BasicTypes ( Boxity(..), RecFlag(..) ) +import Class ( DefMeth (..) ) +import Outputable \end{code} @@ -183,6 +186,10 @@ extract_ty (HsUsgTy usg ty) acc = extract_ty ty acc extract_ty (HsUsgForAllTy uv ty) acc = extract_ty ty acc extract_ty (HsTyVar tv) acc = tv : acc extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc) +-- Generics +extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (HsNumTy num) acc = acc +-- Generics extract_ty (HsForAllTy (Just tvs) ctxt ty) acc = acc ++ (filter (`notElem` locals) $ @@ -196,6 +203,19 @@ extractPatsTyVars = filter isRdrTyVar . nub . extract_tys . collectSigTysFromPats + +extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName] +-- Get the type variables out of the type patterns in a bunch of +-- possibly-generic bindings in a class declaration +extractGenericPatTyVars binds + = filter isRdrTyVar (nub (get binds [])) + where + get (AndMonoBinds b1 b2) acc = get b1 (get b2 acc) + get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms + get other acc = acc + + get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc + get_m other acc = acc \end{code} @@ -215,7 +235,7 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. \begin{code} mkClassDecl cxt cname tyvars fds sigs mbinds prags loc - = ClassDecl cxt cname tyvars fds sigs mbinds prags tname dname dwname sc_sel_names loc + = ClassDecl cxt cname tyvars fds sigs mbinds prags new_names loc where cls_occ = rdrNameOcc cname data_occ = mkClassDataConOcc cls_occ @@ -231,11 +251,22 @@ mkClassDecl cxt cname tyvars fds sigs mbinds prags loc -- D_sc1, D_sc2 -- (We used to call them D_C, but now we can have two different -- superclasses both called C!) - -mkClassOpSig has_default_method op ty loc - = ClassOpSig op (Just (dm_rn, has_default_method)) ty loc + new_names = toClassDeclNameList (tname, dname, dwname, sc_sel_names) + +-- mkTyData :: ?? +mkTyData new_or_data context tname list_var list_con i maybe pragmas src = + let t_occ = rdrNameOcc tname + name1 = mkRdrUnqual (mkGenOcc1 t_occ) + name2 = mkRdrUnqual (mkGenOcc2 t_occ) + in TyData new_or_data context + tname list_var list_con i maybe pragmas src name1 name2 + +mkClassOpSig (DefMeth x) op ty loc + = ClassOpSig op (Just (DefMeth dm_rn)) ty loc where dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op)) +mkClassOpSig x op ty loc = + ClassOpSig op (Just x) ty loc mkConDecl cname ex_vars cxt details loc = ConDecl cname wkr_name ex_vars cxt details loc diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 728cb90..168d04c 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -8,12 +8,7 @@ module PrelInfo ( module PrelNames, module MkId, - builtinNames, -- Names of things whose *unique* must be known, but - -- that is all. If something is in here, you know that - -- if it's used at all then it's Name will be just as - -- it is here, unique and all. Includes all the - - + wiredInNames, -- Names of wired in things -- Primop RdrNames @@ -34,17 +29,18 @@ module PrelInfo ( #include "HsVersions.h" -- friends: -import MkId -- Ditto import PrelNames -- Prelude module names import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName ) import DataCon ( DataCon, dataConId, dataConWrapId ) -import TysPrim -- TYPES -import TysWiredIn +import MkId ( mkPrimOpId, wiredInIds ) +import MkId -- All of it, for re-export +import TysPrim ( primTyCons ) +import TysWiredIn ( wiredInTyCons ) -- others: import RdrName ( RdrName ) -import Name ( Name, mkKnownKeyGlobal, getName ) +import Name ( Name, getName ) import TyCon ( tyConDataConsIfAvailable, TyCon ) import Class ( Class, classKey ) import Type ( funTyCon ) @@ -63,21 +59,18 @@ We have two ``builtin name funs,'' one to look up @TyCons@ and @Classes@, the other to look up values. \begin{code} -builtinNames :: Bag Name -builtinNames - = unionManyBags - [ -- Wired in TyCons - unionManyBags (map getTyConNames wired_in_tycons) +wiredInNames :: [Name] +wiredInNames + = bagToList $ unionManyBags + [ -- Wired in TyCons + unionManyBags (map getTyConNames ([funTyCon] ++ primTyCons ++ wiredInTyCons)) -- Wired in Ids , listToBag (map getName wiredInIds) -- PrimOps , listToBag (map (getName . mkPrimOpId) allThePrimOps) - - -- Other names with magic keys - , listToBag (map mkKnownKeyGlobal knownKeyRdrNames) - ] + ] \end{code} @@ -126,60 +119,6 @@ minusH_RDR = primOpRdrName IntSubOp tagToEnumH_RDR = primOpRdrName TagToEnumOp \end{code} -%************************************************************************ -%* * -\subsection{Wired in TyCons} -%* * -%************************************************************************ - -\begin{code} -wired_in_tycons = [funTyCon] ++ - prim_tycons ++ - tuple_tycons ++ - unboxed_tuple_tycons ++ - data_tycons - -prim_tycons - = [ addrPrimTyCon - , arrayPrimTyCon - , byteArrayPrimTyCon - , charPrimTyCon - , doublePrimTyCon - , floatPrimTyCon - , intPrimTyCon - , int64PrimTyCon - , foreignObjPrimTyCon - , bcoPrimTyCon - , weakPrimTyCon - , mutableArrayPrimTyCon - , mutableByteArrayPrimTyCon - , mVarPrimTyCon - , mutVarPrimTyCon - , realWorldTyCon - , stablePtrPrimTyCon - , stableNamePrimTyCon - , statePrimTyCon - , threadIdPrimTyCon - , wordPrimTyCon - , word64PrimTyCon - ] - -tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..37] ] -unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..37] ] - -data_tycons - = [ addrTyCon - , boolTyCon - , charTyCon - , doubleTyCon - , floatTyCon - , intTyCon - , integerTyCon - , listTyCon - , wordTyCon - ] -\end{code} - %************************************************************************ %* * diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index b72f143..e1284ba 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -11,45 +11,16 @@ defined here so as to avod \begin{code} module PrelNames ( - Unique, Uniquable(..), hasKey, -- Re-exported for convenience - knownKeyRdrNames, - mkTupNameStr, mkTupConRdrName, - - ------------------------------------------------------------ - -- Prelude modules - pREL_GHC, pREL_BASE, pREL_ADDR, pREL_STABLE, - pREL_IO_BASE, pREL_PACK, pREL_ERR, pREL_NUM, pREL_FLOAT, pREL_REAL, - ------------------------------------------------------------ - -- Module names (both Prelude and otherwise) - pREL_GHC_Name, pRELUDE_Name, pREL_MAIN_Name, mAIN_Name, + ----------------------------------------------------------- + module PrelNames, -- A huge bunch of (a) RdrNames, e.g. intTyCon_RDR + -- (b) Uniques e.g. intTyConKey + -- So many that we export them all - ------------------------------------------------------------ - -- Original RdrNames for a few things - main_RDR, - deRefStablePtr_RDR, makeStablePtr_RDR, - ioTyCon_RDR, ioDataCon_RDR, bindIO_RDR, returnIO_RDR, - unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR, - eqClass_RDR, foldr_RDR, build_RDR, - ccallableClass_RDR, creturnableClass_RDR, - monadClass_RDR, enumClass_RDR, ordClass_RDR, - ratioDataCon_RDR, negate_RDR, assertErr_RDR, - plusInteger_RDR, timesInteger_RDR, eqString_RDR, - - -- Plus a whole lot more needed only in TcGenDeriv - eq_RDR, ne_RDR, not_RDR, compare_RDR, ge_RDR, le_RDR, gt_RDR, - ltTag_RDR, eqTag_RDR, gtTag_RDR, getTag_RDR, - and_RDR, true_RDR, false_RDR, - succ_RDR, pred_RDR, toEnum_RDR, fromEnum_RDR, - minBound_RDR, maxBound_RDR, - enumFrom_RDR, enumFromThen_RDR, enumFromTo_RDR, enumFromThenTo_RDR, - map_RDR, append_RDR, compose_RDR, - plus_RDR, times_RDR, mkInt_RDR, - error_RDR, - range_RDR, inRange_RDR, index_RDR, - readList___RDR, readList_RDR, readsPrec_RDR, lex_RDR, readParen_RDR, - showList_RDR, showList___RDR, showsPrec_RDR, showString_RDR, showSpace_RDR, showParen_RDR, + ----------------------------------------------------------- + knownKeyRdrNames, + mkTupNameStr, mkTupConRdrName, ------------------------------------------------------------ -- Goups of classes and types @@ -58,53 +29,7 @@ module PrelNames ( derivingOccurrences, -- For a given class C, this tells what other derivableClassKeys, -- things are needed as a result of a -- deriving(C) clause - numericTyKeys, cCallishTyKeys, - - ------------------------------------------------------------ - -- Keys - absentErrorIdKey, addrDataConKey, addrPrimTyConKey, addrTyConKey, - appendIdKey, arrayPrimTyConKey, assertIdKey, augmentIdKey, - bcoPrimTyConKey, bindIOIdKey, boolTyConKey, boundedClassKey, - boxedConKey, buildIdKey, byteArrayPrimTyConKey, byteArrayTyConKey, - cCallableClassKey, cReturnableClassKey, charDataConKey, - charPrimTyConKey, charTyConKey, concatIdKey, consDataConKey, - deRefStablePtrIdKey, doubleDataConKey, doublePrimTyConKey, - doubleTyConKey, enumClassKey, enumFromClassOpKey, - enumFromThenClassOpKey, enumFromThenToClassOpKey, - enumFromToClassOpKey, eqClassKey, eqClassOpKey, eqStringIdKey, - errorIdKey, falseDataConKey, failMClassOpKey, filterIdKey, - floatDataConKey, floatPrimTyConKey, floatTyConKey, floatingClassKey, - foldlIdKey, foldrIdKey, foreignObjDataConKey, foreignObjPrimTyConKey, - foreignObjTyConKey, fractionalClassKey, fromEnumClassOpKey, - fromIntClassOpKey, fromIntegerClassOpKey, fromRationalClassOpKey, - funTyConKey, functorClassKey, geClassOpKey, getTagIdKey, - intDataConKey, intPrimTyConKey, intTyConKey, int8TyConKey, - int16TyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey, - smallIntegerDataConKey, largeIntegerDataConKey, integerMinusOneIdKey, - integerPlusOneIdKey, integerPlusTwoIdKey, int2IntegerIdKey, - integerTyConKey, integerZeroIdKey, integralClassKey, - irrefutPatErrorIdKey, ixClassKey, listTyConKey, mainKey, - makeStablePtrIdKey, mapIdKey, minusClassOpKey, monadClassKey, - monadPlusClassKey, mutableArrayPrimTyConKey, - mutableByteArrayPrimTyConKey, mutableByteArrayTyConKey, - mutVarPrimTyConKey, nilDataConKey, noMethodBindingErrorIdKey, - nonExhaustiveGuardsErrorIdKey, numClassKey, anyBoxConKey, ordClassKey, - orderingTyConKey, otherwiseIdKey, parErrorIdKey, parIdKey, - patErrorIdKey, plusIntegerIdKey, ratioDataConKey, ratioTyConKey, - rationalTyConKey, readClassKey, realClassKey, realFloatClassKey, - realFracClassKey, realWorldPrimIdKey, realWorldTyConKey, - recConErrorIdKey, recSelErrIdKey, recUpdErrorIdKey, returnIOIdKey, - returnMClassOpKey, runSTRepIdKey, showClassKey, ioTyConKey, - ioDataConKey, stablePtrDataConKey, stablePtrPrimTyConKey, - stablePtrTyConKey, stableNameDataConKey, stableNamePrimTyConKey, - stableNameTyConKey, statePrimTyConKey, timesIntegerIdKey, typeConKey, - kindConKey, boxityConKey, mVarPrimTyConKey, thenMClassOpKey, - threadIdPrimTyConKey, toEnumClassOpKey, traceIdKey, trueDataConKey, - unboundKey, unboxedConKey, unpackCStringUtf8IdKey, - unpackCStringAppendIdKey, unpackCStringFoldrIdKey, unpackCStringIdKey, - unsafeCoerceIdKey, ushowListIdKey, weakPrimTyConKey, wordDataConKey, - wordPrimTyConKey, wordTyConKey, word8TyConKey, word16TyConKey, - word32TyConKey, word64PrimTyConKey, word64TyConKey, zipIdKey + numericTyKeys, cCallishTyKeys ) where @@ -132,7 +57,8 @@ import Panic ( panic ) %************************************************************************ This section tells what the compiler knows about the -assocation of names with uniques +assocation of names with uniques. These ones are the *non* wired-in ones. +The wired in ones are defined in TysWiredIn etc. \begin{code} knownKeyRdrNames :: [(RdrName, Unique)] @@ -323,32 +249,32 @@ to write them all down in one place. \begin{code} main_RDR = varQual mAIN_Name SLIT("main") -ioTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("IO") -ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO") -bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO") -returnIO_RDR = varQual pREL_IO_BASE_Name SLIT("returnIO") - +-- Stuff from PrelGHC +funTyCon_RDR = tcQual pREL_GHC_Name SLIT("(->)") +ccallableClass_RDR = clsQual pREL_GHC_Name SLIT("CCallable") +creturnableClass_RDR = clsQual pREL_GHC_Name SLIT("CReturnable") -rationalTyCon_RDR = tcQual pREL_REAL_Name SLIT("Rational") -ratioTyCon_RDR = tcQual pREL_REAL_Name SLIT("Ratio") -ratioDataCon_RDR = dataQual pREL_REAL_Name SLIT(":%") - -byteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("ByteArray") -mutableByteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray") - -foreignObjTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("ForeignObj") -bcoPrimTyCon_RDR = tcQual pREL_BASE_Name SLIT("BCO#") -stablePtrTyCon_RDR = tcQual pREL_STABLE_Name SLIT("StablePtr") -stablePtrDataCon_RDR = dataQual pREL_STABLE_Name SLIT("StablePtr") -deRefStablePtr_RDR = varQual pREL_STABLE_Name SLIT("deRefStablePtr") -makeStablePtr_RDR = varQual pREL_STABLE_Name SLIT("makeStablePtr") - --- Random PrelBase data types and constructors +-- PrelBase data types and constructors +charTyCon_RDR = tcQual pREL_BASE_Name SLIT("Char") +charDataCon_RDR = dataQual pREL_BASE_Name SLIT("C#") intTyCon_RDR = tcQual pREL_BASE_Name SLIT("Int") -orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering") mkInt_RDR = dataQual pREL_BASE_Name SLIT("I#") +orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering") +boolTyCon_RDR = tcQual pREL_BASE_Name SLIT("Bool") false_RDR = dataQual pREL_BASE_Name SLIT("False") true_RDR = dataQual pREL_BASE_Name SLIT("True") +listTyCon_RDR = tcQual pREL_BASE_Name SLIT("[]") +nil_RDR = dataQual pREL_BASE_Name SLIT("[]") +cons_RDR = dataQual pREL_BASE_Name SLIT(":") + +-- Generics +crossTyCon_RDR = tcQual pREL_BASE_Name SLIT(":*:") +crossDataCon_RDR = dataQual pREL_BASE_Name SLIT(":*:") +plusTyCon_RDR = tcQual pREL_BASE_Name SLIT(":+:") +inlDataCon_RDR = dataQual pREL_BASE_Name SLIT("Inl") +inrDataCon_RDR = dataQual pREL_BASE_Name SLIT("Inr") +genUnitTyCon_RDR = tcQual pREL_BASE_Name SLIT("Unit") +genUnitDataCon_RDR = dataQual pREL_BASE_Name SLIT("Unit") -- Random PrelBase functions otherwiseId_RDR = varQual pREL_BASE_Name SLIT("otherwise") @@ -369,20 +295,20 @@ unpackCStringFoldr_RDR = varQual pREL_BASE_Name SLIT("unpackFoldrCString#") unpackCStringUtf8_RDR = varQual pREL_BASE_Name SLIT("unpackCStringUtf8#") -- Classes Eq and Ord -eqClass_RDR = clsQual pREL_BASE_Name SLIT("Eq") -ordClass_RDR = clsQual pREL_BASE_Name SLIT("Ord") -eq_RDR = varQual pREL_BASE_Name SLIT("==") -ne_RDR = varQual pREL_BASE_Name SLIT("/=") -le_RDR = varQual pREL_BASE_Name SLIT("<=") -lt_RDR = varQual pREL_BASE_Name SLIT("<") -ge_RDR = varQual pREL_BASE_Name SLIT(">=") -gt_RDR = varQual pREL_BASE_Name SLIT(">") +eqClass_RDR = clsQual pREL_BASE_Name SLIT("Eq") +ordClass_RDR = clsQual pREL_BASE_Name SLIT("Ord") +eq_RDR = varQual pREL_BASE_Name SLIT("==") +ne_RDR = varQual pREL_BASE_Name SLIT("/=") +le_RDR = varQual pREL_BASE_Name SLIT("<=") +lt_RDR = varQual pREL_BASE_Name SLIT("<") +ge_RDR = varQual pREL_BASE_Name SLIT(">=") +gt_RDR = varQual pREL_BASE_Name SLIT(">") ltTag_RDR = dataQual pREL_BASE_Name SLIT("LT") eqTag_RDR = dataQual pREL_BASE_Name SLIT("EQ") gtTag_RDR = dataQual pREL_BASE_Name SLIT("GT") -max_RDR = varQual pREL_BASE_Name SLIT("max") -min_RDR = varQual pREL_BASE_Name SLIT("min") -compare_RDR = varQual pREL_BASE_Name SLIT("compare") +max_RDR = varQual pREL_BASE_Name SLIT("max") +min_RDR = varQual pREL_BASE_Name SLIT("min") +compare_RDR = varQual pREL_BASE_Name SLIT("compare") -- Class Monad monadClass_RDR = clsQual pREL_BASE_Name SLIT("Monad") @@ -392,7 +318,7 @@ returnM_RDR = varQual pREL_BASE_Name SLIT("return") failM_RDR = varQual pREL_BASE_Name SLIT("fail") -- Class Functor -functorClass_RDR = clsQual pREL_BASE_Name SLIT("Functor") +functorClass_RDR = clsQual pREL_BASE_Name SLIT("Functor") -- Class Show showClass_RDR = clsQual pREL_SHOW_Name SLIT("Show") @@ -403,7 +329,6 @@ showSpace_RDR = varQual pREL_SHOW_Name SLIT("showSpace") showString_RDR = varQual pREL_SHOW_Name SLIT("showString") showParen_RDR = varQual pREL_SHOW_Name SLIT("showParen") - -- Class Read readClass_RDR = clsQual pREL_READ_Name SLIT("Read") readsPrec_RDR = varQual pREL_READ_Name SLIT("readsPrec") @@ -413,7 +338,7 @@ lex_RDR = varQual pREL_READ_Name SLIT("lex") readList___RDR = varQual pREL_READ_Name SLIT("readList__") --- Class Num +-- Module PrelNum numClass_RDR = clsQual pREL_NUM_Name SLIT("Num") fromInt_RDR = varQual pREL_NUM_Name SLIT("fromInt") fromInteger_RDR = varQual pREL_NUM_Name SLIT("fromInteger") @@ -423,16 +348,27 @@ plus_RDR = varQual pREL_NUM_Name SLIT("+") times_RDR = varQual pREL_NUM_Name SLIT("*") plusInteger_RDR = varQual pREL_NUM_Name SLIT("plusInteger") timesInteger_RDR = varQual pREL_NUM_Name SLIT("timesInteger") +integerTyCon_RDR = tcQual pREL_NUM_Name SLIT("Integer") +smallIntegerDataCon_RDR = dataQual pREL_NUM_Name SLIT("S#") +largeIntegerDataCon_RDR = dataQual pREL_NUM_Name SLIT("J#") --- Other numberic classes -realClass_RDR = clsQual pREL_REAL_Name SLIT("Real") -integralClass_RDR = clsQual pREL_REAL_Name SLIT("Integral") -realFracClass_RDR = clsQual pREL_REAL_Name SLIT("RealFrac") -fractionalClass_RDR = clsQual pREL_REAL_Name SLIT("Fractional") -fromRational_RDR = varQual pREL_REAL_Name SLIT("fromRational") - -floatingClass_RDR = clsQual pREL_FLOAT_Name SLIT("Floating") -realFloatClass_RDR = clsQual pREL_FLOAT_Name SLIT("RealFloat") +-- PrelReal types and classes +rationalTyCon_RDR = tcQual pREL_REAL_Name SLIT("Rational") +ratioTyCon_RDR = tcQual pREL_REAL_Name SLIT("Ratio") +ratioDataCon_RDR = dataQual pREL_REAL_Name SLIT(":%") +realClass_RDR = clsQual pREL_REAL_Name SLIT("Real") +integralClass_RDR = clsQual pREL_REAL_Name SLIT("Integral") +realFracClass_RDR = clsQual pREL_REAL_Name SLIT("RealFrac") +fractionalClass_RDR = clsQual pREL_REAL_Name SLIT("Fractional") +fromRational_RDR = varQual pREL_REAL_Name SLIT("fromRational") + +-- PrelFloat classes +floatTyCon_RDR = tcQual pREL_FLOAT_Name SLIT("Float") +floatDataCon_RDR = dataQual pREL_FLOAT_Name SLIT("F#") +doubleTyCon_RDR = tcQual pREL_FLOAT_Name SLIT("Double") +doubleDataCon_RDR = dataQual pREL_FLOAT_Name SLIT("D#") +floatingClass_RDR = clsQual pREL_FLOAT_Name SLIT("Floating") +realFloatClass_RDR = clsQual pREL_FLOAT_Name SLIT("RealFloat") -- Class Ix ixClass_RDR = clsQual pREL_ARR_Name SLIT("Ix") @@ -440,10 +376,6 @@ range_RDR = varQual pREL_ARR_Name SLIT("range") index_RDR = varQual pREL_ARR_Name SLIT("index") inRange_RDR = varQual pREL_ARR_Name SLIT("inRange") --- Class CCallable and CReturnable -ccallableClass_RDR = clsQual pREL_GHC_Name SLIT("CCallable") -creturnableClass_RDR = clsQual pREL_GHC_Name SLIT("CReturnable") - -- Class Enum enumClass_RDR = clsQual pREL_ENUM_Name SLIT("Enum") succ_RDR = varQual pREL_ENUM_Name SLIT("succ") @@ -466,21 +398,48 @@ concat_RDR = varQual pREL_LIST_Name SLIT("concat") filter_RDR = varQual pREL_LIST_Name SLIT("filter") zip_RDR = varQual pREL_LIST_Name SLIT("zip") +-- IOBase things +ioTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("IO") +ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO") +bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO") +returnIO_RDR = varQual pREL_IO_BASE_Name SLIT("returnIO") + +-- Int, Word, and Addr things int8TyCon_RDR = tcQual iNT_Name SLIT("Int8") int16TyCon_RDR = tcQual iNT_Name SLIT("Int16") int32TyCon_RDR = tcQual iNT_Name SLIT("Int32") int64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Int64") -word8TyCon_RDR = tcQual wORD_Name SLIT("Word8") -word16TyCon_RDR = tcQual wORD_Name SLIT("Word16") -word32TyCon_RDR = tcQual wORD_Name SLIT("Word32") -word64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Word64") +wordTyCon_RDR = tcQual pREL_ADDR_Name SLIT("Word") +wordDataCon_RDR = dataQual pREL_ADDR_Name SLIT("W#") +word8TyCon_RDR = tcQual wORD_Name SLIT("Word8") +word16TyCon_RDR = tcQual wORD_Name SLIT("Word16") +word32TyCon_RDR = tcQual wORD_Name SLIT("Word32") +word64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Word64") + +addrTyCon_RDR = tcQual pREL_ADDR_Name SLIT("Addr") +addrDataCon_RDR = dataQual pREL_ADDR_Name SLIT("A#") + + +-- Byte array types +byteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("ByteArray") +mutableByteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray") + +-- Forign objects and weak pointers +foreignObjTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("ForeignObj") +foreignObjDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("ForeignObj") +bcoPrimTyCon_RDR = tcQual pREL_BASE_Name SLIT("BCO#") +stablePtrTyCon_RDR = tcQual pREL_STABLE_Name SLIT("StablePtr") +stablePtrDataCon_RDR = dataQual pREL_STABLE_Name SLIT("StablePtr") +deRefStablePtr_RDR = varQual pREL_STABLE_Name SLIT("deRefStablePtr") +makeStablePtr_RDR = varQual pREL_STABLE_Name SLIT("makeStablePtr") error_RDR = varQual pREL_ERR_Name SLIT("error") assert_RDR = varQual pREL_GHC_Name SLIT("assert") getTag_RDR = varQual pREL_GHC_Name SLIT("getTag#") assertErr_RDR = varQual pREL_ERR_Name SLIT("assertError") runSTRep_RDR = varQual pREL_ST_Name SLIT("runSTRep") + \end{code} @@ -590,6 +549,11 @@ boxityConKey = mkPreludeTyConUnique 68 typeConKey = mkPreludeTyConUnique 69 threadIdPrimTyConKey = mkPreludeTyConUnique 70 bcoPrimTyConKey = mkPreludeTyConUnique 71 + +-- Generic Type Constructors +crossTyConKey = mkPreludeTyConUnique 72 +plusTyConKey = mkPreludeTyConUnique 73 +genUnitTyConKey = mkPreludeTyConUnique 74 \end{code} %************************************************************************ @@ -616,6 +580,12 @@ stableNameDataConKey = mkPreludeDataConUnique 13 trueDataConKey = mkPreludeDataConUnique 14 wordDataConKey = mkPreludeDataConUnique 15 ioDataConKey = mkPreludeDataConUnique 16 + +-- Generic data constructors +crossDataConKey = mkPreludeDataConUnique 17 +inlDataConKey = mkPreludeDataConUnique 18 +inrDataConKey = mkPreludeDataConUnique 19 +genUnitDataConKey = mkPreludeDataConUnique 20 \end{code} %************************************************************************ @@ -703,6 +673,43 @@ runSTRepIdKey = mkPreludeMiscIdUnique 122 %************************************************************************ %* * +\subsection{Standard groups of types} +%* * +%************************************************************************ + +\begin{code} +numericTyKeys = + [ addrTyConKey + , wordTyConKey + , intTyConKey + , integerTyConKey + , doubleTyConKey + , floatTyConKey + ] + + -- Renamer always imports these data decls replete with constructors + -- so that desugarer can always see their constructors. Ugh! +cCallishTyKeys = + [ addrTyConKey + , wordTyConKey + , byteArrayTyConKey + , mutableByteArrayTyConKey + , foreignObjTyConKey + , stablePtrTyConKey + , int8TyConKey + , int16TyConKey + , int32TyConKey + , int64TyConKey + , word8TyConKey + , word16TyConKey + , word32TyConKey + , word64TyConKey + ] +\end{code} + + +%************************************************************************ +%* * \subsection[Class-std-groups]{Standard groups of Prelude classes} %* * %************************************************************************ @@ -782,15 +789,6 @@ fractionalClassKeys = -- the strictness analyser needs to know about numeric types -- (see SaAbsInt.lhs) -numericTyKeys = - [ addrTyConKey - , wordTyConKey - , intTyConKey - , integerTyConKey - , doubleTyConKey - , floatTyConKey - ] - needsDataDeclCtxtClassKeys = -- see comments in TcDeriv [ readClassKey ] @@ -800,25 +798,6 @@ cCallishClassKeys = , cReturnableClassKey ] - -- Renamer always imports these data decls replete with constructors - -- so that desugarer can always see their constructors. Ugh! -cCallishTyKeys = - [ addrTyConKey - , wordTyConKey - , byteArrayTyConKey - , mutableByteArrayTyConKey - , foreignObjTyConKey - , stablePtrTyConKey - , int8TyConKey - , int16TyConKey - , int32TyConKey - , int64TyConKey - , word8TyConKey - , word16TyConKey - , word32TyConKey - , word64TyConKey - ] - standardClassKeys = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys -- diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 45a1620..5e7b4a3 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -12,6 +12,8 @@ module TysPrim( alphaTy, betaTy, gammaTy, deltaTy, openAlphaTy, openAlphaTyVar, openAlphaTyVars, + primTyCons, + charPrimTyCon, charPrimTy, intPrimTyCon, intPrimTy, wordPrimTyCon, wordPrimTy, @@ -48,17 +50,59 @@ module TysPrim( import Var ( TyVar, mkSysTyVar ) import Name ( mkWiredInTyConName ) +import OccName ( mkSrcOccFS, tcName ) import PrimRep ( PrimRep(..), isFollowableRep ) import TyCon ( mkPrimTyCon, TyCon, ArgVrcs ) import Type ( Type, mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy, unboxedTypeKind, boxedTypeKind, openTypeKind, mkArrowKinds ) -import Unique ( mkAlphaTyVarUnique ) +import Unique ( Unique, mkAlphaTyVarUnique ) import PrelNames import Outputable \end{code} +%************************************************************************ +%* * +\subsection{Primitive type constructors} +%* * +%************************************************************************ + +\begin{code} +primTyCons :: [TyCon] +primTyCons + = [ addrPrimTyCon + , arrayPrimTyCon + , byteArrayPrimTyCon + , charPrimTyCon + , doublePrimTyCon + , floatPrimTyCon + , intPrimTyCon + , int64PrimTyCon + , foreignObjPrimTyCon + , bcoPrimTyCon + , weakPrimTyCon + , mutableArrayPrimTyCon + , mutableByteArrayPrimTyCon + , mVarPrimTyCon + , mutVarPrimTyCon + , realWorldTyCon + , stablePtrPrimTyCon + , stableNamePrimTyCon + , statePrimTyCon + , threadIdPrimTyCon + , wordPrimTyCon + , word64PrimTyCon + ] +\end{code} + + +%************************************************************************ +%* * +\subsection{Support code} +%* * +%************************************************************************ + \begin{code} alphaTyVars :: [TyVar] alphaTyVars = [ mkSysTyVar u boxedTypeKind @@ -94,6 +138,7 @@ vrcsZ = [vrcZero] vrcsZP = [vrcZero,vrcPos] \end{code} + %************************************************************************ %* * \subsection[TysPrim-basic]{Basic primitive types (@Char#@, @Int#@, etc.)} @@ -106,7 +151,7 @@ pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> ArgVrcs -> PrimRep -> pcPrimTyCon key str arity arg_vrcs rep = the_tycon where - name = mkWiredInTyConName key pREL_GHC str the_tycon + name = mkWiredInTyConName key pREL_GHC (mkSrcOccFS tcName str) the_tycon the_tycon = mkPrimTyCon name kind arity arg_vrcs rep kind = mkArrowKinds (take arity (repeat boxedTypeKind)) result_kind result_kind | isFollowableRep rep = boxedTypeKind -- Represented by a GC-ish ptr diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index dcad432..2db5050 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -11,6 +11,8 @@ types and operations.'' \begin{code} module TysWiredIn ( + wiredInTyCons, genericTyCons, + addrDataCon, addrTy, addrTyCon, @@ -53,6 +55,11 @@ module TysWiredIn ( unboxedSingletonTyCon, unboxedSingletonDataCon, unboxedPairTyCon, unboxedPairDataCon, + -- Generics + genUnitTyCon, genUnitDataCon, + plusTyCon, inrDataCon, inlDataCon, + crossTyCon, crossDataCon, + stablePtrTyCon, stringTy, trueDataCon, trueDataConId, @@ -76,6 +83,7 @@ module TysWiredIn ( #include "HsVersions.h" import {-# SOURCE #-} MkId( mkDataConId, mkDataConWrapId ) +import {-# SOURCE #-} Generics( mkTyConGenInfo ) -- friends: import PrelNames @@ -84,75 +92,120 @@ import TysPrim -- others: import Constants ( mAX_TUPLE_SIZE ) import Module ( Module, mkPrelModule ) -import Name ( mkWiredInTyConName, mkWiredInIdName, mkSrcOccFS, mkWorkerOcc, dataName ) +import Name ( mkWiredInTyConName, mkWiredInIdName, nameOccName ) +import OccName ( mkSrcOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 ) +import RdrName ( RdrName, mkPreludeQual, rdrNameOcc, rdrNameModule ) import DataCon ( DataCon, StrictnessMark(..), mkDataCon, dataConId ) import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, tyConDataCons, - mkAlgTyCon, mkSynTyCon, mkTupleTyCon, isUnLiftedTyCon + mkSynTyCon, mkTupleTyCon, + isUnLiftedTyCon, mkAlgTyConRep,tyConName ) -import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) + +import BasicTypes ( Arity, RecFlag(..), EP(..), Boxity(..), isBoxed ) + import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys, mkArrowKinds, boxedTypeKind, unboxedTypeKind, - mkFunTy, mkFunTys, - splitTyConApp_maybe, repType, + mkFunTy, mkFunTys, + splitTyConApp_maybe, repType, mkTyVarTy, TauType, ClassContext ) import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique ) import PrelNames import CmdLineOpts ( opt_GlasgowExts ) import Array +import Maybe ( fromJust ) +import FiniteMap ( lookupFM ) alpha_tyvar = [alphaTyVar] alpha_ty = [alphaTy] alpha_beta_tyvars = [alphaTyVar, betaTyVar] +\end{code} -pcRecDataTyCon, pcNonRecDataTyCon - :: Unique{-TyConKey-} -> Module -> FAST_STRING - -> [TyVar] -> ArgVrcs -> [DataCon] -> TyCon -pcRecDataTyCon = pcTyCon DataTyCon Recursive -pcNonRecDataTyCon = pcTyCon DataTyCon NonRecursive +%************************************************************************ +%* * +\subsection{Wired in type constructors} +%* * +%************************************************************************ -pcTyCon new_or_data is_rec key mod str tyvars argvrcs cons - = tycon - where - tycon = mkAlgTyCon name kind - tyvars - [] -- No context - argvrcs - cons - (length cons) - [] -- No derivings - new_or_data - is_rec +\begin{code} +wiredInTyCons :: [TyCon] +wiredInTyCons = data_tycons ++ tuple_tycons ++ unboxed_tuple_tycons + +data_tycons = genericTyCons ++ + [ addrTyCon + , boolTyCon + , charTyCon + , doubleTyCon + , floatTyCon + , intTyCon + , integerTyCon + , listTyCon + , wordTyCon + ] + +genericTyCons :: [TyCon] +genericTyCons = [ plusTyCon, crossTyCon, genUnitTyCon ] + + +tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..37] ] +unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..37] ] +\end{code} - name = mkWiredInTyConName key mod str tycon - kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind -pcSynTyCon key mod str kind arity tyvars expansion argvrcs -- this fun never used! +%************************************************************************ +%* * +\subsection{mkWiredInTyCon} +%* * +%************************************************************************ + +\begin{code} +pcNonRecDataTyCon = pcTyCon DataTyCon NonRecursive +pcRecDataTyCon = pcTyCon DataTyCon Recursive + +pcTyCon new_or_data is_rec key rdr_name tyvars argvrcs cons = tycon where - tycon = mkSynTyCon name kind arity tyvars expansion argvrcs - name = mkWiredInTyConName key mod str tycon - -pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING - -> [TyVar] -> ClassContext -> [TauType] -> TyCon -> DataCon + tycon = mkAlgTyConRep name kind + tyvars + [] -- No context + argvrcs + cons + (length cons) + [] -- No derivings + new_or_data + is_rec + gen_info + + mod = mkPrelModule (rdrNameModule rdr_name) + occ = rdrNameOcc rdr_name + name = mkWiredInTyConName key mod occ tycon + kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind + gen_info = mk_tc_gen_info mod key name tycon + +pcDataCon :: Unique -- DataConKey + -> RdrName -- Qualified + -> [TyVar] -> ClassContext -> [TauType] -> TyCon -> DataCon -- The unique is the first of two free uniques; --- the first is used for the datacon itself and the worker; +-- the first is used for the datacon itself and the worker; -- the second is used for the wrapper. -pcDataCon wrap_key mod str tyvars context arg_tys tycon + +pcDataCon wrap_key rdr_name tyvars context arg_tys tycon = data_con where - data_con = mkDataCon wrap_name - [ NotMarkedStrict | a <- arg_tys ] - [ {- no labelled fields -} ] - tyvars context [] [] arg_tys tycon work_id wrap_id + mod = mkPrelModule (rdrNameModule rdr_name) + wrap_occ = rdrNameOcc rdr_name + + data_con = mkDataCon wrap_name + [ NotMarkedStrict | a <- arg_tys ] + [ {- no labelled fields -} ] + tyvars context [] [] arg_tys tycon work_id wrap_id work_occ = mkWorkerOcc wrap_occ work_key = incrUnique wrap_key work_name = mkWiredInIdName work_key mod work_occ work_id work_id = mkDataConId work_name data_con - - wrap_occ = mkSrcOccFS dataName str + wrap_name = mkWiredInIdName wrap_key mod wrap_occ wrap_id wrap_id = mkDataConWrapId data_con \end{code} @@ -182,8 +235,8 @@ unboxedTupleArr = array (0,mAX_TUPLE_SIZE) [(i,mk_tuple Unboxed i) | i <- [0..mA mk_tuple :: Boxity -> Int -> (TyCon,DataCon) mk_tuple boxity arity = (tycon, tuple_con) where - tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity - tc_name = mkWiredInTyConName tc_uniq mod name_str tycon + tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info + tc_name = mkWiredInTyConName tc_uniq mod (mkSrcOccFS tcName name_str) tycon tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind res_kind | isBoxed boxity = boxedTypeKind | otherwise = unboxedTypeKind @@ -191,12 +244,27 @@ mk_tuple boxity arity = (tycon, tuple_con) tyvars | isBoxed boxity = take arity alphaTyVars | otherwise = take arity openAlphaTyVars - tuple_con = pcDataCon dc_uniq mod name_str tyvars [] tyvar_tys tycon + tuple_con = pcDataCon dc_uniq rdr_name tyvars [] tyvar_tys tycon tyvar_tys = mkTyVarTys tyvars (mod_name, name_str) = mkTupNameStr boxity arity + rdr_name = mkPreludeQual dataName mod_name name_str tc_uniq = mkTupleTyConUnique boxity arity dc_uniq = mkTupleDataConUnique boxity arity mod = mkPrelModule mod_name + gen_info = mk_tc_gen_info mod tc_uniq tc_name tycon + +mk_tc_gen_info mod tc_uniq tc_name tycon + = gen_info + where + tc_occ_name = nameOccName tc_name + occ_name1 = mkGenOcc1 tc_occ_name + occ_name2 = mkGenOcc2 tc_occ_name + fn1_key = incrUnique tc_uniq + fn2_key = incrUnique fn1_key + name1 = mkWiredInIdName fn1_key mod occ_name1 id1 + name2 = mkWiredInIdName fn2_key mod occ_name2 id2 + gen_info = mkTyConGenInfo tycon name1 name2 + Just (EP id1 id2) = gen_info unitTyCon = tupleTyCon Boxed 0 unitDataConId = dataConId (head (tyConDataCons unitTyCon)) @@ -235,8 +303,8 @@ voidTy = unitTy \begin{code} charTy = mkTyConTy charTyCon -charTyCon = pcNonRecDataTyCon charTyConKey pREL_BASE SLIT("Char") [] [] [charDataCon] -charDataCon = pcDataCon charDataConKey pREL_BASE SLIT("C#") [] [] [charPrimTy] charTyCon +charTyCon = pcNonRecDataTyCon charTyConKey charTyCon_RDR [] [] [charDataCon] +charDataCon = pcDataCon charDataConKey charDataCon_RDR [] [] [charPrimTy] charTyCon stringTy = mkListTy charTy -- convenience only \end{code} @@ -244,8 +312,8 @@ stringTy = mkListTy charTy -- convenience only \begin{code} intTy = mkTyConTy intTyCon -intTyCon = pcNonRecDataTyCon intTyConKey pREL_BASE SLIT("Int") [] [] [intDataCon] -intDataCon = pcDataCon intDataConKey pREL_BASE SLIT("I#") [] [] [intPrimTy] intTyCon +intTyCon = pcNonRecDataTyCon intTyConKey intTyCon_RDR [] [] [intDataCon] +intDataCon = pcDataCon intDataConKey mkInt_RDR [] [] [intPrimTy] intTyCon isIntTy :: Type -> Bool isIntTy = isTyCon intTyConKey @@ -255,15 +323,15 @@ isIntTy = isTyCon intTyConKey wordTy = mkTyConTy wordTyCon -wordTyCon = pcNonRecDataTyCon wordTyConKey pREL_ADDR SLIT("Word") [] [] [wordDataCon] -wordDataCon = pcDataCon wordDataConKey pREL_ADDR SLIT("W#") [] [] [wordPrimTy] wordTyCon +wordTyCon = pcNonRecDataTyCon wordTyConKey wordTyCon_RDR [] [] [wordDataCon] +wordDataCon = pcDataCon wordDataConKey wordDataCon_RDR [] [] [wordPrimTy] wordTyCon \end{code} \begin{code} addrTy = mkTyConTy addrTyCon -addrTyCon = pcNonRecDataTyCon addrTyConKey pREL_ADDR SLIT("Addr") [] [] [addrDataCon] -addrDataCon = pcDataCon addrDataConKey pREL_ADDR SLIT("A#") [] [] [addrPrimTy] addrTyCon +addrTyCon = pcNonRecDataTyCon addrTyConKey addrTyCon_RDR [] [] [addrDataCon] +addrDataCon = pcDataCon addrDataConKey addrDataCon_RDR [] [] [addrPrimTy] addrTyCon isAddrTy :: Type -> Bool isAddrTy = isTyCon addrTyConKey @@ -272,8 +340,8 @@ isAddrTy = isTyCon addrTyConKey \begin{code} floatTy = mkTyConTy floatTyCon -floatTyCon = pcNonRecDataTyCon floatTyConKey pREL_FLOAT SLIT("Float") [] [] [floatDataCon] -floatDataCon = pcDataCon floatDataConKey pREL_FLOAT SLIT("F#") [] [] [floatPrimTy] floatTyCon +floatTyCon = pcNonRecDataTyCon floatTyConKey floatTyCon_RDR [] [] [floatDataCon] +floatDataCon = pcDataCon floatDataConKey floatDataCon_RDR [] [] [floatPrimTy] floatTyCon isFloatTy :: Type -> Bool isFloatTy = isTyCon floatTyConKey @@ -285,27 +353,27 @@ doubleTy = mkTyConTy doubleTyCon isDoubleTy :: Type -> Bool isDoubleTy = isTyCon doubleTyConKey -doubleTyCon = pcNonRecDataTyCon doubleTyConKey pREL_FLOAT SLIT("Double") [] [] [doubleDataCon] -doubleDataCon = pcDataCon doubleDataConKey pREL_FLOAT SLIT("D#") [] [] [doublePrimTy] doubleTyCon +doubleTyCon = pcNonRecDataTyCon doubleTyConKey doubleTyCon_RDR [] [] [doubleDataCon] +doubleDataCon = pcDataCon doubleDataConKey doubleDataCon_RDR [] [] [doublePrimTy] doubleTyCon \end{code} \begin{code} stablePtrTyCon - = pcNonRecDataTyCon stablePtrTyConKey pREL_STABLE SLIT("StablePtr") + = pcNonRecDataTyCon stablePtrTyConKey stablePtrTyCon_RDR alpha_tyvar [(True,False)] [stablePtrDataCon] where stablePtrDataCon - = pcDataCon stablePtrDataConKey pREL_STABLE SLIT("StablePtr") + = pcDataCon stablePtrDataConKey stablePtrDataCon_RDR alpha_tyvar [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon \end{code} \begin{code} foreignObjTyCon - = pcNonRecDataTyCon foreignObjTyConKey pREL_IO_BASE SLIT("ForeignObj") + = pcNonRecDataTyCon foreignObjTyConKey foreignObjTyCon_RDR [] [] [foreignObjDataCon] where foreignObjDataCon - = pcDataCon foreignObjDataConKey pREL_IO_BASE SLIT("ForeignObj") + = pcDataCon foreignObjDataConKey foreignObjDataCon_RDR [] [] [foreignObjPrimTy] foreignObjTyCon isForeignObjTy :: Type -> Bool @@ -323,12 +391,12 @@ isForeignObjTy = isTyCon foreignObjTyConKey integerTy :: Type integerTy = mkTyConTy integerTyCon -integerTyCon = pcNonRecDataTyCon integerTyConKey pREL_NUM SLIT("Integer") +integerTyCon = pcNonRecDataTyCon integerTyConKey integerTyCon_RDR [] [] [smallIntegerDataCon, largeIntegerDataCon] -smallIntegerDataCon = pcDataCon smallIntegerDataConKey pREL_NUM SLIT("S#") +smallIntegerDataCon = pcDataCon smallIntegerDataConKey smallIntegerDataCon_RDR [] [] [intPrimTy] integerTyCon -largeIntegerDataCon = pcDataCon largeIntegerDataConKey pREL_NUM SLIT("J#") +largeIntegerDataCon = pcDataCon largeIntegerDataConKey largeIntegerDataCon_RDR [] [] [intPrimTy, byteArrayPrimTy] integerTyCon @@ -486,10 +554,10 @@ primitive counterpart. boolTy = mkTyConTy boolTyCon boolTyCon = pcTyCon EnumTyCon NonRecursive boolTyConKey - pREL_BASE SLIT("Bool") [] [] [falseDataCon, trueDataCon] + boolTyCon_RDR [] [] [falseDataCon, trueDataCon] -falseDataCon = pcDataCon falseDataConKey pREL_BASE SLIT("False") [] [] [] boolTyCon -trueDataCon = pcDataCon trueDataConKey pREL_BASE SLIT("True") [] [] [] boolTyCon +falseDataCon = pcDataCon falseDataConKey false_RDR [] [] [] boolTyCon +trueDataCon = pcDataCon trueDataConKey true_RDR [] [] [] boolTyCon falseDataConId = dataConId falseDataCon trueDataConId = dataConId trueDataCon @@ -516,11 +584,11 @@ mkListTy ty = mkTyConApp listTyCon [ty] alphaListTy = mkSigmaTy alpha_tyvar [] (mkTyConApp listTyCon alpha_ty) -listTyCon = pcRecDataTyCon listTyConKey pREL_BASE SLIT("[]") +listTyCon = pcRecDataTyCon listTyConKey listTyCon_RDR alpha_tyvar [(True,False)] [nilDataCon, consDataCon] -nilDataCon = pcDataCon nilDataConKey pREL_BASE SLIT("[]") alpha_tyvar [] [] listTyCon -consDataCon = pcDataCon consDataConKey pREL_BASE SLIT(":") +nilDataCon = pcDataCon nilDataConKey nil_RDR alpha_tyvar [] [] listTyCon +consDataCon = pcDataCon consDataConKey cons_RDR alpha_tyvar [] [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon -- Interesting: polymorphic recursion would help here. -- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy @@ -579,3 +647,43 @@ mkTupleTy boxity arity tys = mkTyConApp (tupleTyCon boxity arity) tys unitTy = mkTupleTy Boxed 0 [] \end{code} + +%************************************************************************ +%* * +\subsection{Wired In Type Constructors for Representation Types} +%* * +%************************************************************************ + +The following code defines the wired in datatypes cross, plus, unit +and c_of needed for the generic methods. + +Ok, so the basic story is that for each type constructor I need to +create 2 things - a TyCon and a DataCon and then we are basically +ok. There are going to be no arguments passed to these functions +because -well- there is nothing to pass to these functions. + +\begin{code} +crossTyCon :: TyCon +crossTyCon = pcNonRecDataTyCon crossTyConKey crossTyCon_RDR alpha_beta_tyvars [] [crossDataCon] + +crossDataCon :: DataCon +crossDataCon = pcDataCon crossDataConKey crossDataCon_RDR alpha_beta_tyvars [] [alphaTy, betaTy] crossTyCon + +plusTyCon :: TyCon +plusTyCon = pcNonRecDataTyCon plusTyConKey plusTyCon_RDR alpha_beta_tyvars [] [inlDataCon, inrDataCon] + +inlDataCon, inrDataCon :: DataCon +inlDataCon = pcDataCon inlDataConKey inlDataCon_RDR alpha_beta_tyvars [] [alphaTy] plusTyCon +inrDataCon = pcDataCon inrDataConKey inrDataCon_RDR alpha_beta_tyvars [] [betaTy] plusTyCon + +genUnitTyCon :: TyCon -- The "1" type constructor for generics +genUnitTyCon = pcNonRecDataTyCon genUnitTyConKey genUnitTyCon_RDR [] [] [genUnitDataCon] + +genUnitDataCon :: DataCon +genUnitDataCon = pcDataCon genUnitDataConKey genUnitDataCon_RDR [] [] [] genUnitTyCon +\end{code} + + + + + diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 1c22d06..66d9f9a 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -36,7 +36,7 @@ import Module ( Module ) import UniqSupply ( uniqFromSupply, splitUniqSupply, UniqSupply ) import Unique ( Unique ) import VarSet -import Util ( removeDups ) +import ListSetOps ( removeDups ) import Outputable infixr 9 `thenMM`, `thenMM_` diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 66f4589..0763ce4 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -64,6 +64,7 @@ import SrcLoc ( SrcLoc ) import CmdLineOpts ( opt_InPackage ) import Outputable import List ( insert ) +import Class ( DefMeth (..) ) import GlaExts import FastString ( tailFS ) @@ -163,6 +164,8 @@ import FastString ( tailFS ) '{' { ITocurly } -- special symbols '}' { ITccurly } + '{|' { ITocurlybar } -- special symbols + '|}' { ITccurlybar } -- special symbols '[' { ITobrack } ']' { ITcbrack } '(' { IToparen } @@ -332,8 +335,10 @@ csigs1 : { [] } | csig ';' csigs1 { $1 : $3 } csig :: { RdrNameSig } -csig : src_loc var_name '::' type { mkClassOpSig False $2 $4 $1 } - | src_loc var_name '=' '::' type { mkClassOpSig True $2 $5 $1 } +csig : src_loc var_name '::' type { mkClassOpSig NoDefMeth $2 $4 $1 } + | src_loc var_name '=' '::' type { mkClassOpSig (DefMeth (error "DefMeth") ) + $2 $5 $1 } + | src_loc var_name ';' '::' type { mkClassOpSig GenDefMeth $2 $5 $1 } -------------------------------------------------------------------------- @@ -363,9 +368,9 @@ decl : src_loc var_name '::' type maybe_idinfo | src_loc 'type' tc_name tv_bndrs '=' type { TyClD (TySynonym $3 $4 $6 $1) } | src_loc 'data' opt_decl_context tc_name tv_bndrs constrs - { TyClD (TyData DataType $3 $4 $5 $6 (length $6) Nothing noDataPragmas $1) } + { TyClD (mkTyData DataType $3 $4 $5 $6 (length $6) Nothing noDataPragmas $1) } | src_loc 'newtype' opt_decl_context tc_name tv_bndrs newtype_constr - { TyClD (TyData NewType $3 $4 $5 $6 1 Nothing noDataPragmas $1) } + { TyClD (mkTyData NewType $3 $4 $5 $6 1 Nothing noDataPragmas $1) } | src_loc 'class' opt_decl_context tc_name tv_bndrs fds csigs { TyClD (mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds noClassPragmas $1) } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index dcb7153..312456e 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -249,7 +249,7 @@ implicitFVs mod_name decls -- Virtually every program has error messages in it somewhere string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR] - get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _)) + get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _ _)) = concat (map get_deriv deriv_classes) get other = [] @@ -469,8 +469,9 @@ slurpDeferredDecls decls ASSERT( isEmptyFVs fvs ) returnRn decls1 -stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc)) - = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc)) +stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc name1 name2)) + = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc + name1 name2)) -- Nuke the context and constructors -- But retain the *number* of constructors! -- Also the tvs will have kinds on them. @@ -501,7 +502,7 @@ vars of the source program, and extracts from the decl the gate names. getGates source_fvs (SigD (IfaceSig _ ty _ _)) = extractHsTyNames ty -getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _ _)) +getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ )) = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) (hsTyVarNames tvs) `addOneToNameSet` cls) @@ -526,7 +527,7 @@ getGates source_fvs (TyClD (TySynonym tycon tvs ty _)) (hsTyVarNames tvs) -- A type synonym type constructor isn't a "gate" for instance decls -getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _)) +getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _ _)) = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) (hsTyVarNames tvs) `addOneToNameSet` tycon @@ -602,7 +603,7 @@ fixitiesFromLocalDecls gbl_env decls getFixities acc (FixD fix) = fix_decl acc fix - getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _)) + getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ )) = foldlRn fix_decl acc [sig | FixSig sig <- sigs] -- Get fixities from class decl sigs too. getFixities acc other_decl diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index e230762..9ec3657 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -28,14 +28,14 @@ import RnMonad import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn, lookupSigOccRn, - warnUnusedLocalBinds, mapFvRn, + warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV ) import CmdLineOpts ( opt_WarnMissingSigs ) import Digraph ( stronglyConnComp, SCC(..) ) import Name ( OccName, Name, nameOccName, mkUnboundName, isUnboundName ) import NameSet -import RdrName ( RdrName, rdrNameOcc ) +import RdrName ( RdrName, rdrNameOcc ) import BasicTypes ( RecFlag(..) ) import List ( partition ) import Bag ( bagToList ) @@ -180,7 +180,7 @@ rnTopMonoBinds mbinds sigs rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) -> returnRn (final_binds, bind_fvs `plusFV` sig_fvs) where - binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds)) + binder_rdr_names = collectMonoBinders mbinds \end{code} %************************************************************************ @@ -246,7 +246,7 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds warnUnusedLocalBinds unused_binders `thenRn_` returnRn (result, delListFromNameSet all_fvs new_mbinders) where - mbinders_w_srclocs = bagToList (collectMonoBinders mbinds) + mbinders_w_srclocs = collectLocatedMonoBinders mbinds \end{code} @@ -364,27 +364,40 @@ in many ways the @op@ in an instance decl is just like an occurrence, not a binder. \begin{code} -rnMethodBinds :: RdrNameMonoBinds -> RnMS (RenamedMonoBinds, FreeVars) +rnMethodBinds :: [Name] -- Names for generic type variables + -> RdrNameMonoBinds + -> RnMS (RenamedMonoBinds, FreeVars) -rnMethodBinds EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs) +rnMethodBinds gen_tyvars EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs) -rnMethodBinds (AndMonoBinds mb1 mb2) - = rnMethodBinds mb1 `thenRn` \ (mb1', fvs1) -> - rnMethodBinds mb2 `thenRn` \ (mb2', fvs2) -> +rnMethodBinds gen_tyvars (AndMonoBinds mb1 mb2) + = rnMethodBinds gen_tyvars mb1 `thenRn` \ (mb1', fvs1) -> + rnMethodBinds gen_tyvars mb2 `thenRn` \ (mb2', fvs2) -> returnRn (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2) -rnMethodBinds (FunMonoBind name inf matches locn) +rnMethodBinds gen_tyvars (FunMonoBind name inf matches locn) = pushSrcLocRn locn $ lookupGlobalOccRn name `thenRn` \ sel_name -> -- We use the selector name as the binder - mapFvRn rnMatch matches `thenRn` \ (new_matches, fvs) -> + mapFvRn rn_match matches `thenRn` \ (new_matches, fvs) -> mapRn_ (checkPrecMatch inf sel_name) new_matches `thenRn_` returnRn (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name) + where + -- Gruesome; bring into scope the correct members of the generic type variables + -- See comments in RnSource.rnDecl(ClassDecl) + rn_match match@(Match _ (TypePatIn ty : _) _ _) + = extendTyVarEnvFVRn gen_tvs (rnMatch match) + where + tvs = map rdrNameOcc (extractHsTyRdrNames ty) + gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] + + rn_match match = rnMatch match + -- Can't handle method pattern-bindings which bind multiple methods. -rnMethodBinds mbind@(PatMonoBind other_pat _ locn) +rnMethodBinds gen_tyvars mbind@(PatMonoBind other_pat _ locn) = pushSrcLocRn locn $ failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind) \end{code} @@ -496,7 +509,7 @@ renameSigs ok_sig sigs -- Doesn't seem worth much trouble to sort this. renameSig :: Sig RdrName -> RnMS (Sig Name, FreeVars) - +-- ClassOpSig is renamed elsewhere. renameSig (Sig v ty src_loc) = pushSrcLocRn src_loc $ lookupSigOccRn v `thenRn` \ new_v -> diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 620aa75..5239c53 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -30,10 +30,12 @@ import NameSet import OccName ( OccName, occNameUserString, occNameFlavour ) import Module ( ModuleName, moduleName, mkVanillaModule, pprModuleName ) import FiniteMap +import Unique ( Unique ) import UniqSupply import SrcLoc ( SrcLoc ) import Outputable -import Util ( removeDups, equivClasses, thenCmp, sortLt ) +import ListSetOps ( removeDups, equivClasses ) +import Util ( thenCmp, sortLt ) import List ( nub ) \end{code} @@ -344,42 +346,52 @@ unQualInScope env %********************************************************* \begin{code} +newLocalsRn :: (Unique -> OccName -> SrcLoc -> Name) + -> [(RdrName,SrcLoc)] + -> RnMS [Name] +newLocalsRn mk_name rdr_names_w_loc + = getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> + let + n = length rdr_names_w_loc + (us', us1) = splitUniqSupply us + uniqs = uniqsFromSupply n us1 + names = [ mk_name uniq (rdrNameOcc rdr_name) loc + | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs + ] + in + setNameSupplyRn (us', cache, ipcache) `thenRn_` + returnRn names + + bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [(RdrName,SrcLoc)] -> ([Name] -> RnMS a) -> RnMS a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope - = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` - - getModeRn `thenRn` \ mode -> + = getModeRn `thenRn` \ mode -> getLocalNameEnv `thenRn` \ name_env -> - -- Warn about shadowing, but only in source modules + -- Check for duplicate names + checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` + + -- Warn about shadowing, but only in source modules (case mode of SourceMode | opt_WarnNameShadowing -> mapRn_ (check_shadow name_env) rdr_names_w_loc other -> returnRn () ) `thenRn_` - getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> let - n = length rdr_names_w_loc - (us', us1) = splitUniqSupply us - uniqs = uniqsFromSupply n us1 - names = [ mk_name uniq (rdrNameOcc rdr_name) loc - | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs - ] mk_name = case mode of SourceMode -> mkLocalName InterfaceMode -> mkImportedLocalName -- Keep track of whether the name originally came from -- an interface file. in - setNameSupplyRn (us', cache, ipcache) `thenRn_` - + newLocalsRn mk_name rdr_names_w_loc `thenRn` \ names -> let - new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names) + new_local_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names) in - setLocalNameEnv new_name_env (enclosed_scope names) + setLocalNameEnv new_local_env (enclosed_scope names) where check_shadow name_env (rdr_name,loc) @@ -449,13 +461,11 @@ bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVa bindUVarRn = bindLocalRn ------------------------------------- -extendTyVarEnvFVRn :: [HsTyVarBndr Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) +extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) -- This tiresome function is used only in rnDecl on InstDecl extendTyVarEnvFVRn tyvars enclosed_scope - = bindLocalNames tyvar_names enclosed_scope `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs tyvar_names) - where - tyvar_names = hsTyVarNames tyvars + = bindLocalNames tyvars enclosed_scope `thenRn` \ (thing, fvs) -> + returnRn (thing, delListFromNameSet fvs tyvars) bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName] -> ([HsTyVarBndr Name] -> RnMS a) @@ -492,6 +502,18 @@ bindTyVarsFV2Rn doc_str rdr_names enclosed_scope enclosed_scope names tyvars `thenRn` \ (thing, fvs) -> returnRn (thing, delListFromNameSet fvs names) +bindNakedTyVarsFVRn :: SDoc -> [RdrName] + -> ([Name] -> RnMS (a, FreeVars)) + -> RnMS (a, FreeVars) +bindNakedTyVarsFVRn doc_str tyvar_names enclosed_scope + = getSrcLocRn `thenRn` \ loc -> + let + located_tyvars = [(tv, loc) | tv <- tyvar_names] + in + bindLocatedLocalsRn doc_str located_tyvars $ \ names -> + enclosed_scope names `thenRn` \ (thing, fvs) -> + returnRn (thing, delListFromNameSet fvs names) + ------------------------------------- checkDupOrQualNames, checkDupNames :: SDoc diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 6e71a32..992e5c1 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -45,8 +45,7 @@ import NameSet import UniqFM ( isNullUFM ) import FiniteMap ( elemFM ) import UniqSet ( emptyUniqSet ) -import Util ( removeDups ) -import ListSetOps ( unionLists ) +import ListSetOps ( unionLists, removeDups ) import Maybes ( maybeToBool ) import Outputable \end{code} @@ -145,6 +144,9 @@ rnPat (RecPatIn con rpats) = lookupOccRn con `thenRn` \ con' -> rnRpats rpats `thenRn` \ (rpats', fvs) -> returnRn (RecPatIn con' rpats', fvs `addOneFV` con') +rnPat (TypePatIn name) = + (rnHsType (text "type pattern") name) `thenRn` \ (name', fvs) -> + returnRn (TypePatIn name', fvs) \end{code} ************************************************************************ @@ -172,7 +174,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) doc_sig = text "a pattern type-signature" doc_pats = text "in a pattern match" in - bindTyVarsFVRn doc_sig (map UserTyVar forall_tyvars) $ \ sig_tyvars -> + bindNakedTyVarsFVRn doc_sig forall_tyvars $ \ sig_tyvars -> -- Note that we do a single bindLocalsRn for all the -- matches together, so that we spot the repeated variable in @@ -417,6 +419,11 @@ rnExpr (HsIf p b1 b2 src_loc) rnExpr b2 `thenRn` \ (b2', fvB2) -> returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2]) +rnExpr (HsType a) = + (rnHsType doc a) `thenRn` \ (t, fvT) -> returnRn (HsType t, fvT) + where doc = text "renaming a type pattern" + + rnExpr (ArithSeqIn seq) = lookupOrigName enumClass_RDR `thenRn` \ enum -> rn_seq seq `thenRn` \ (new_seq, fvs) -> diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 763816a..58e86b0 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -12,7 +12,7 @@ import HsSyn import HsPragmas ( InstancePragmas, GenPragmas, DataPragmas, ClassPragmas, ClassOpPragmas ) import TysWiredIn ( tupleTyCon, listTyCon, charTyCon ) -import Name ( Name, getName ) +import Name ( Name, getName, isTyVarName ) import NameSet import BasicTypes ( Boxity ) import Outputable @@ -71,24 +71,29 @@ listTyCon_name = getName listTyCon tupleTyCon_name :: Boxity -> Int -> Name tupleTyCon_name boxity n = getName (tupleTyCon boxity n) +extractHsTyVars :: RenamedHsType -> NameSet +extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x) + extractHsTyNames :: RenamedHsType -> NameSet extractHsTyNames ty = get ty where get (HsAppTy ty1 ty2) = get ty1 `unionNameSets` get ty2 - get (HsListTy ty) = unitNameSet listTyCon_name - `unionNameSets` get ty + get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` get ty get (HsTupleTy (HsTupCon n _) tys) = unitNameSet n `unionNameSets` extractHsTyNames_s tys get (HsFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2 get (HsPredTy p) = extractHsPredTyNames p get (HsUsgForAllTy uv ty) = get ty get (HsUsgTy u ty) = get ty + get (HsOpTy ty1 tycon ty2) = get ty1 `unionNameSets` get ty2 `unionNameSets` + unitNameSet tycon + get (HsNumTy n) = emptyNameSet get (HsTyVar tv) = unitNameSet tv get (HsForAllTy (Just tvs) ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty) `minusNameSet` - mkNameSet (hsTyVarNames tvs) + mkNameSet (hsTyVarNames tvs) get ty@(HsForAllTy Nothing _ _) = pprPanic "extractHsTyNames" (ppr ty) extractHsTyNames_s :: [RenamedHsType] -> NameSet @@ -97,11 +102,31 @@ extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet t extractHsCtxtTyNames :: RenamedContext -> NameSet extractHsCtxtTyNames ctxt = foldr (unionNameSets . extractHsPredTyNames) emptyNameSet ctxt --- You don't import or export implicit parameters, so don't mention --- the IP names +-- You don't import or export implicit parameters, +-- so don't mention the IP names extractHsPredTyNames (HsPClass cls tys) = unitNameSet cls `unionNameSets` extractHsTyNames_s tys extractHsPredTyNames (HsPIParam n ty) = extractHsTyNames ty \end{code} + +%************************************************************************ +%* * +\subsection{A few functions on generic defintions +%* * +%************************************************************************ + +These functions on generics are defined over RenamedMatches, which is +why they are here and not in HsMatches. + +\begin{code} +maybeGenericMatch :: RenamedMatch -> Maybe (RenamedHsType, RenamedMatch) + -- Tells whether a Match is for a generic definition + -- and extract the type from a generic match and put it at the front + +maybeGenericMatch (Match tvs (TypePatIn ty : pats) sig_ty grhss) + = Just (ty, Match tvs pats sig_ty grhss) + +maybeGenericMatch other_match = Nothing +\end{code} diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index ef23e33..bb13311 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -601,7 +601,7 @@ getNonWiredInDecl needed_name loadHomeInterface doc_str needed_name `thenRn` \ ifaces -> case lookupNameEnv (iDecls ifaces) needed_name of - Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _))) + Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _ _))) -- This case deals with deferred import of algebraic data types | not opt_NoPruneTyDecls @@ -1013,7 +1013,7 @@ getDeclBinders :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function -> RdrNameHsDecl -> RnM d (Maybe AvailInfo) -getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ _ src_loc)) +getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ _ src_loc _ _)) = new_name tycon src_loc `thenRn` \ tycon_name -> getConFieldNames new_name condecls `thenRn` \ sub_names -> returnRn (Just (AvailTC tycon_name (tycon_name : nub sub_names))) @@ -1024,7 +1024,7 @@ getDeclBinders new_name (TyClD (TySynonym tycon _ _ src_loc)) = new_name tycon src_loc `thenRn` \ tycon_name -> returnRn (Just (AvailTC tycon_name [tycon_name])) -getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ _ _ _ src_loc)) +getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ src_loc)) = new_name cname src_loc `thenRn` \ class_name -> -- Record the names for the class ops @@ -1089,10 +1089,11 @@ and the dict fun of an instance decl, because both of these have bindings of their own elsewhere. \begin{code} -getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ tname dname dwname snames src_loc)) - = sequenceRn [new_name n src_loc | n <- (tname : dname : dwname : snames)] +getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ names + src_loc)) + = sequenceRn [new_name n src_loc | n <- names] -getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _)) +getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _ _ _)) = sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons] getDeclSysBinders new_name other_decl diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 41d8960..c6f6c1e 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -39,13 +39,13 @@ import BasicTypes ( Version, defaultFixity ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, WarnMsg, Message ) -import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc, +import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc, RdrNameEnv, emptyRdrEnv, extendRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvToList, rdrEnvElts ) import Name ( Name, OccName, NamedThing(..), getSrcLoc, isLocallyDefinedName, nameModule, nameOccName, - decode, mkLocalName, mkUnboundName, + decode, mkLocalName, mkUnboundName, mkKnownKeyGlobal, NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList ) import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom, @@ -53,10 +53,10 @@ import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom, ) import NameSet import CmdLineOpts ( opt_D_dump_rn_trace, opt_HiMap ) -import PrelInfo ( builtinNames ) +import PrelInfo ( wiredInNames, knownKeyRdrNames ) import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) import Unique ( Unique ) -import FiniteMap ( FiniteMap, emptyFM, bagToFM ) +import FiniteMap ( FiniteMap, emptyFM, listToFM, plusFM ) import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) import UniqSupply import Outputable @@ -401,10 +401,13 @@ emptyIfaces = Ifaces { iImpModInfo = emptyFM, } builtins :: FiniteMap (ModuleName,OccName) Name -builtins = - bagToFM ( - mapBag (\ name -> ((moduleName (nameModule name), nameOccName name), name)) - builtinNames) +builtins = listToFM wired_in `plusFM` listToFM known_key + where + wired_in = [ ((moduleName (nameModule name), nameOccName name), name) + | name <- wiredInNames ] + + known_key = [ ((rdrNameModule rdr_name, rdrNameOcc rdr_name), mkKnownKeyGlobal rdr_name uniq) + | (rdr_name, uniq) <- knownKeyRdrNames ] \end{code} @renameSourceCode@ is used to rename stuff ``out-of-line''; diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index c0e9ad5..3607cd3 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -41,7 +41,8 @@ import NameSet ( elemNameSet, emptyNameSet ) import Outputable import Maybes ( maybeToBool, catMaybes, mapMaybe ) import UniqFM ( emptyUFM, listToUFM ) -import Util ( removeDups, sortLt ) +import ListSetOps ( removeDups ) +import Util ( sortLt ) import List ( partition ) \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 86a4f25..c99a24b 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -15,14 +15,14 @@ import HsTypes ( hsTyVarNames, pprHsContext ) import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr ) import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, extractRuleBndrsTyVars, extractHsTyRdrTyVars, - extractHsCtxtRdrTyVars + extractHsCtxtRdrTyVars, extractGenericPatTyVars ) import RnHsSyn import HsCore import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs ) import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName, - lookupOrigNames, lookupSysBinder, + lookupOrigNames, lookupSysBinder, newLocalsRn, bindLocalsFVRn, bindUVarRn, bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn, bindCoreLocalFVRn, bindCoreLocalsFVRn, bindLocalNames, @@ -33,9 +33,10 @@ import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName, import RnMonad import FunDeps ( oclose ) -import Class ( FunDep ) +import Class ( FunDep, DefMeth (..) ) import Name ( Name, OccName, nameOccName, NamedThing(..) ) import NameSet +import OccName ( mkDefaultMethodOcc, isTvOcc ) import FiniteMap ( elemFM ) import PrelInfo ( derivableClassKeys, cCallishClassKeys ) import PrelNames ( deRefStablePtr_RDR, makeStablePtr_RDR, @@ -49,7 +50,7 @@ import CmdLineOpts ( opt_GlasgowExts, opt_WarnUnusedMatches ) -- Warn of unused import Unique ( Uniquable(..) ) import ErrUtils ( Message ) import CStrings ( isCLabelString ) -import Util +import ListSetOps ( minusList, removeDupsEq ) \end{code} @rnDecl@ `renames' declarations. @@ -134,17 +135,19 @@ and then go over it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} -rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings pragmas src_loc)) +rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings pragmas src_loc gen_name1 gen_name2)) = pushSrcLocRn src_loc $ lookupTopBndrRn tycon `thenRn` \ tycon' -> bindTyVarsFVRn data_doc tyvars $ \ tyvars' -> rnContext data_doc context `thenRn` \ (context', cxt_fvs) -> checkDupOrQualNames data_doc con_names `thenRn_` mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) -> + lookupSysBinder gen_name1 `thenRn` \ name1' -> + lookupSysBinder gen_name2 `thenRn` \ name2' -> rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) -> ASSERT(isNoDataPragmas pragmas) returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' nconstrs - derivings' noDataPragmas src_loc), + derivings' noDataPragmas src_loc name1' name2'), cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs) where data_doc = text "the data type declaration for" <+> quotes (ppr tycon) @@ -165,7 +168,7 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc)) unquantify ty = ty rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas - tname dname dwname snames src_loc)) + names src_loc)) = pushSrcLocRn src_loc $ lookupTopBndrRn cname `thenRn` \ cname' -> @@ -177,10 +180,8 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas -- So the 'Imported' part of this call is not relevant. -- Unclean; but since these two are the only place this happens -- I can't work up the energy to do it more beautifully - lookupSysBinder tname `thenRn` \ tname' -> - lookupSysBinder dname `thenRn` \ dname' -> - lookupSysBinder dwname `thenRn` \ dwname' -> - mapRn lookupSysBinder snames `thenRn` \ snames' -> + + mapRn lookupSysBinder names `thenRn` \ names' -> -- Tyvars scope over bindings and context bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' -> @@ -189,23 +190,40 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas rnContext cls_doc context `thenRn` \ (context', cxt_fvs) -> -- Check the functional dependencies - rnFds cls_doc fds `thenRn` \ (fds', fds_fvs) -> + rnFds cls_doc fds `thenRn` \ (fds', fds_fvs) -> -- Check the signatures + -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). let - -- First process the class op sigs, then the fixity sigs. - (op_sigs, non_op_sigs) = partition isClassOpSig sigs + (op_sigs, non_op_sigs) = partition isClassOpSig sigs + sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs] in checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs `thenRn` \ (sigs', sig_fvs) -> let - binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ] + binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ] in renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ (non_ops', fix_fvs) -> -- Check the methods + -- The newLocals call is tiresome: given a generic class decl + -- class C a where + -- op :: a -> a + -- op {| x+y |} (Inl a) = ... + -- op {| x+y |} (Inr b) = ... + -- op {| a*b |} (a*b) = ... + -- we want to name both "x" tyvars with the same unique, so that they are + -- easy to group together in the typechecker. + -- Hence the + getLocalNameEnv `thenRn` \ name_env -> + let + meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds + gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds, + not (tv `elemFM` name_env)] + in checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_` - rnMethodBinds mbinds `thenRn` \ (mbinds', meth_fvs) -> + newLocalsRn mkLocalName gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars -> + rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) -> -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. @@ -214,8 +232,9 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas ASSERT(isNoClassPragmas pragmas) returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds' - NoClassPragmas tname' dname' dwname' snames' src_loc), + NoClassPragmas names' src_loc), sig_fvs `plusFV` + fix_fvs `plusFV` cxt_fvs `plusFV` fds_fvs `plusFV` @@ -227,9 +246,6 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas sig_doc = text "the signatures for class" <+> ppr cname meth_doc = text "the default-methods for class" <+> ppr cname - sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs] - meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds) - rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn) = pushSrcLocRn locn $ lookupTopBndrRn op `thenRn` \ op_name -> @@ -247,15 +263,18 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas (case maybe_dm_stuff of Nothing -> returnRn (Nothing, emptyFVs) -- Source-file class decl - Just (dm_rdr_name, explicit_dm) + Just (DefMeth dm_rdr_name) -> -- Imported class that has a default method decl -- See comments with tname, snames, above lookupSysBinder dm_rdr_name `thenRn` \ dm_name -> - returnRn (Just (dm_name, explicit_dm), - if explicit_dm then unitFV dm_name else emptyFVs) + returnRn (Just (DefMeth dm_name), unitFV dm_name) -- An imported class decl for a class decl that had an explicit default -- method, mentions, rather than defines, -- the default method, so we must arrange to pull it in + Just GenDefMeth + -> returnRn (Just GenDefMeth, emptyFVs) + Just NoDefMeth + -> returnRn (Just NoDefMeth, emptyFVs) ) `thenRn` \ (maybe_dm_stuff', dm_fvs) -> returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn, op_ty_fvs `plusFV` dm_fvs) @@ -283,11 +302,11 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)) -- Rename the bindings -- NB meth_names can be qualified! checkDupNames meth_doc meth_names `thenRn_` - extendTyVarEnvFVRn inst_tyvars ( - rnMethodBinds mbinds + extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) ( + rnMethodBinds [] mbinds ) `thenRn` \ (mbinds', meth_fvs) -> let - binders = map fst (bagToList (collectMonoBinders mbinds')) + binders = collectMonoBinders mbinds' binder_set = mkNameSet binders in -- Rename the prags and signatures. @@ -312,8 +331,8 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)) returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc), inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv) where - meth_doc = text "the bindings in an instance declaration" - meth_names = bagToList (collectMonoBinders mbinds) + meth_doc = text "the bindings in an instance declaration" + meth_names = collectLocatedMonoBinders mbinds \end{code} %********************************************************* @@ -561,6 +580,17 @@ rnHsType doc (HsTyVar tyvar) = lookupOccRn tyvar `thenRn` \ tyvar' -> returnRn (HsTyVar tyvar', unitFV tyvar') +rnHsType doc (HsOpTy ty1 opname ty2) + = lookupOccRn opname `thenRn` \ name' -> + rnHsType doc ty1 `thenRn` \ (ty1', fvs1) -> + rnHsType doc ty2 `thenRn` \ (ty2',fvs2) -> + returnRn (HsOpTy ty1' name' ty2', fvs1 `plusFV` fvs2 `addOneFV` name') + +rnHsType doc (HsNumTy i) + | i == 1 = returnRn (HsNumTy i, emptyFVs) + | otherwise = failWithRn (HsNumTy i, emptyFVs) + (ptext SLIT("Only unit numeric type pattern is valid")) + rnHsType doc (HsFunTy ty1 ty2) = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) -> -- Might find a for-all as the arg of a function type diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index eea1f86..ea737a1 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -233,7 +233,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec newTyVar boxedTypeKind `thenNF_Tc` \ alpha_tv -> let forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv) - binder_names = map fst (bagToList (collectMonoBinders mbind)) + binder_names = collectMonoBinders mbind poly_ids = map mk_dummy binder_names mk_dummy name = case maybeSig tc_ty_sigs name of Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature @@ -398,8 +398,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- at all. pat_binders :: [Name] - pat_binders = map fst $ bagToList $ collectMonoBinders $ - (justPatBindings mbind EmptyMonoBinds) + pat_binders = collectMonoBinders (justPatBindings mbind EmptyMonoBinds) in -- CHECK FOR UNBOXED BINDERS IN PATTERN BINDINGS mapTc (\id -> checkTc (not (idName id `elem` pat_binders diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index d4690c6..3ca78e9 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -5,7 +5,7 @@ \begin{code} module TcClassDcl ( tcClassDecl1, tcClassDecls2, mkImplicitClassBinds, - tcMethodBind, checkFromThisClass + tcMethodBind, badMethodErr ) where #include "HsVersions.h" @@ -13,12 +13,14 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2, mkImplicitClassBinds, import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..), HsExpr(..), HsLit(..), HsType(..), HsPred(..), mkSimpleMatch, andMonoBinds, andMonoBindList, - isClassDecl, isClassOpSig, isPragSig, collectMonoBinders + isClassDecl, isClassOpSig, isPragSig, + fromClassDeclNameList, tyClDeclName ) -import BasicTypes ( TopLevelFlag(..), RecFlag(..) ) +import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..), EP(..) ) import RnHsSyn ( RenamedTyClDecl, RenamedClassOpSig, RenamedMonoBinds, - RenamedContext, RenamedHsDecl, RenamedSig + RenamedContext, RenamedHsDecl, RenamedSig, + RenamedHsExpr, maybeGenericMatch ) import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) @@ -32,20 +34,27 @@ import TcMonoType ( tcHsSigType, tcClassContext, checkSigTyVars, sigCtxt, mkTcSi import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns ) import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcSigTyVars ) import TcMonad +import Generics ( mkGenericRhs, validGenericMethodType ) import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) +import Class ( classTyVars, classBigSig, classSelIds, classTyCon, Class, ClassOpItem, + DefMeth (..) ) import Bag ( bagToList ) -import Class ( classTyVars, classBigSig, classSelIds, classTyCon, Class, ClassOpItem ) -import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods ) +import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods, opt_PprStyle_Debug ) import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId ) import DataCon ( mkDataCon, notMarkedStrict ) import Id ( Id, idType, idName ) -import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) ) +import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..), mkSysLocalName, + NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts ) import NameSet ( NameSet, mkNameSet, elemNameSet, emptyNameSet ) import Outputable -import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkSigmaTy, mkClassPred ) +import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkSigmaTy, mkClassPred, + splitTyConApp_maybe, isTyVarTy + ) import Var ( TyVar ) import VarSet ( mkVarSet, emptyVarSet ) -import Maybes ( seqMaybe ) +import ErrUtils ( dumpIfSet ) +import Util ( count ) +import Maybes ( seqMaybe, maybeToBool, orElse ) \end{code} @@ -94,7 +103,7 @@ tcClassDecl1 :: ValueEnv -> RenamedTyClDecl -> TcM s (Name, TyThingDetails) tcClassDecl1 rec_env (ClassDecl context class_name tyvar_names fundeps class_sigs def_methods pragmas - tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc) + sys_names src_loc) = -- CHECK ARITY 1 FOR HASKELL 1.4 checkTc (opt_GlasgowExts || length tyvar_names == 1) (classArityErr class_name) `thenTc_` @@ -102,19 +111,22 @@ tcClassDecl1 rec_env -- LOOK THINGS UP IN THE ENVIRONMENT tcLookupTy class_name `thenTc` \ (AClass clas) -> let - tyvars = classTyVars clas - dm_bndrs_w_locs = bagToList (collectMonoBinders def_methods) - dm_bndr_set = mkNameSet (map fst dm_bndrs_w_locs) + tyvars = classTyVars clas + op_sigs = filter isClassOpSig class_sigs + op_names = [n | ClassOpSig n _ _ _ <- op_sigs] + (_, datacon_name, datacon_wkr_name, sc_sel_names) = fromClassDeclNameList sys_names in - tcExtendTyVarEnv tyvars $ + tcExtendTyVarEnv tyvars $ + + -- CHECK THAT THE DEFAULT BINDINGS ARE LEGAL + checkDefaultBinds clas op_names def_methods `thenTc` \ dm_info -> + checkGenericClassIsUnary clas dm_info `thenTc_` -- CHECK THE CONTEXT - tcSuperClasses class_name clas - context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) -> + tcSuperClasses clas context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) -> -- CHECK THE CLASS SIGNATURES, - mapTc (tcClassSig rec_env dm_bndr_set clas tyvars) - (filter isClassOpSig class_sigs) `thenTc` \ sig_stuff -> + mapTc (tcClassSig rec_env clas tyvars dm_info) op_sigs `thenTc` \ sig_stuff -> -- MAKE THE CLASS DETAILS let @@ -123,14 +135,14 @@ tcClassDecl1 rec_env dict_component_tys = sc_tys ++ op_tys dict_con = mkDataCon datacon_name - [notMarkedStrict | _ <- dict_component_tys] - [{- No labelled fields -}] - tyvars - [{-No context-}] - [{-No existential tyvars-}] [{-Or context-}] - dict_component_tys - (classTyCon clas) - dict_con_id dict_wrap_id + [notMarkedStrict | _ <- dict_component_tys] + [{- No labelled fields -}] + tyvars + [{-No context-}] + [{-No existential tyvars-}] [{-Or context-}] + dict_component_tys + (classTyCon clas) + dict_con_id dict_wrap_id dict_con_id = mkDataConId datacon_wkr_name dict_con dict_wrap_id = mkDataConWrapId dict_con @@ -139,13 +151,60 @@ tcClassDecl1 rec_env \end{code} \begin{code} -tcSuperClasses :: Name -> Class +checkDefaultBinds :: Class -> [Name] -> RenamedMonoBinds -> TcM s (NameEnv (DefMeth Name)) + -- Check default bindings + -- a) must be for a class op for this class + -- b) must be all generic or all non-generic + -- and return a mapping from class-op to DefMeth info + +checkDefaultBinds clas ops EmptyMonoBinds = returnTc emptyNameEnv + +checkDefaultBinds clas ops (AndMonoBinds b1 b2) + = checkDefaultBinds clas ops b1 `thenTc` \ dm_info1 -> + checkDefaultBinds clas ops b2 `thenTc` \ dm_info2 -> + returnTc (dm_info1 `plusNameEnv` dm_info2) + +checkDefaultBinds clas ops (FunMonoBind op _ matches loc) + = tcAddSrcLoc loc $ + + -- Check that the op is from this class + checkTc (op `elem` ops) (badMethodErr clas op) `thenTc_` + + -- Check that all the defns ar generic, or none are + checkTc (all_generic || none_generic) (mixedGenericErr op) `thenTc_` + + -- Make up the right dm_info + if all_generic then + returnTc (unitNameEnv op GenDefMeth) + else + -- An explicit non-generic default method + newDefaultMethodName op loc `thenNF_Tc` \ dm_name -> + returnTc (unitNameEnv op (DefMeth dm_name)) + + where + n_generic = count (maybeToBool . maybeGenericMatch) matches + none_generic = n_generic == 0 + all_generic = n_generic == length matches + +checkGenericClassIsUnary clas dm_info + = -- Check that if the class has generic methods, then the + -- class has only one parameter. We can't do generic + -- multi-parameter type classes! + checkTc (unary || no_generics) (genericMultiParamErr clas) + where + unary = length (classTyVars clas) == 1 + no_generics = null [() | GenDefMeth <- nameEnvElts dm_info] +\end{code} + + +\begin{code} +tcSuperClasses :: Class -> RenamedContext -- class context -> [Name] -- Names for superclass selectors -> TcM s (ClassContext, -- the superclass context [Id]) -- superclass selector Ids -tcSuperClasses class_name clas context sc_sel_names +tcSuperClasses clas context sc_sel_names = -- Check the context. -- The renamer has already checked that the context mentions -- only the type variable of the class decl. @@ -167,23 +226,27 @@ tcSuperClasses class_name clas context sc_sel_names where check_constraint sc@(HsPClass c tys) - = checkTc (all is_tyvar tys) (superClassErr class_name sc) + = checkTc (all is_tyvar tys) (superClassErr clas sc) is_tyvar (HsTyVar _) = True is_tyvar other = False -tcClassSig :: ValueEnv -- Knot tying only! - -> NameSet -- Names bound in the default-method bindings +tcClassSig :: ValueEnv -- Knot tying only! -> Class -- ...ditto... -> [TyVar] -- The class type variable, used for error check only + -> NameEnv (DefMeth Name) -- Info about default methods -> RenamedClassOpSig -> TcM s (Type, -- Type of the method ClassOpItem) -- Selector Id, default-method Id, True if explicit default binding +-- This warrants an explanation: we need to separate generic +-- default methods and default methods later on in the compiler +-- so we distinguish them in checkDefaultBinds, and pass this knowledge in the +-- Class.DefMeth data structure. -tcClassSig rec_env dm_bind_names clas clas_tyvars - (ClassOpSig op_name maybe_dm_stuff op_ty src_loc) +tcClassSig rec_env clas clas_tyvars dm_info + (ClassOpSig op_name maybe_dm op_ty src_loc) = tcAddSrcLoc src_loc $ -- Check the type signature. NB that the envt *already has* @@ -199,20 +262,22 @@ tcClassSig rec_env dm_bind_names clas clas_tyvars -- Build the selector id and default method id sel_id = mkDictSelId op_name clas + + dm_info_name = maybe_dm `orElse` lookupNameEnv dm_info op_name `orElse` NoDefMeth + + dm_info_id = case dm_info_name of + NoDefMeth -> NoDefMeth + GenDefMeth -> GenDefMeth + DefMeth dm_name -> DefMeth (tcAddImportedIdInfo rec_env dm_id) + where + dm_id = mkDefaultMethodId dm_name clas global_ty in - (case maybe_dm_stuff of - Nothing -> -- Source-file class declaration - newDefaultMethodName op_name src_loc `thenNF_Tc` \ dm_name -> - returnNF_Tc (mkDefaultMethodId dm_name clas global_ty, op_name `elemNameSet` dm_bind_names) - - Just (dm_name, explicit_dm) -> -- Interface-file class decl - let - dm_id = mkDefaultMethodId dm_name clas global_ty - in - returnNF_Tc (tcAddImportedIdInfo rec_env dm_id, explicit_dm) - ) `thenNF_Tc` \ (dm_id, explicit_dm) -> - - returnTc (local_ty, (sel_id, dm_id, explicit_dm)) + -- Check that for a generic method, the type of + -- the method is sufficiently simple + checkTc (dm_info_name /= GenDefMeth || validGenericMethodType local_ty) + (badGenericMethodType op_name op_ty) `thenTc_` + + returnTc (local_ty, (sel_id, dm_info_id)) \end{code} @@ -222,55 +287,8 @@ tcClassSig rec_env dm_bind_names clas clas_tyvars %* * %************************************************************************ -The purpose of pass 2 is -\begin{enumerate} -\item -to beat on the explicitly-provided default-method decls (if any), -using them to produce a complete set of default-method decls. -(Omitted ones elicit an error message.) -\item -to produce a definition for the selector function for each method +@mkImplicitClassBinds@ produces a binding for the selector function for each method and superclass dictionary. -\end{enumerate} - -Pass~2 only applies to locally-defined class declarations. - -The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to -each local class decl. - -\begin{code} -tcClassDecls2 :: [RenamedHsDecl] - -> NF_TcM s (LIE, TcMonoBinds) - -tcClassDecls2 decls - = foldr combine - (returnNF_Tc (emptyLIE, EmptyMonoBinds)) - [tcClassDecl2 cls_decl | TyClD cls_decl <- decls, isClassDecl cls_decl] - where - combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) -> - tc2 `thenNF_Tc` \ (lie2, binds2) -> - returnNF_Tc (lie1 `plusLIE` lie2, - binds1 `AndMonoBinds` binds2) -\end{code} - -@tcClassDecl2@ is the business end of things. - -\begin{code} -tcClassDecl2 :: RenamedTyClDecl -- The class declaration - -> NF_TcM s (LIE, TcMonoBinds) - -tcClassDecl2 (ClassDecl context class_name - tyvar_names _ class_sigs default_binds pragmas _ _ _ _ src_loc) - - | not (isLocallyDefined class_name) - = returnNF_Tc (emptyLIE, EmptyMonoBinds) - - | otherwise -- It is locally defined - = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ - tcAddSrcLoc src_loc $ - tcLookupTy class_name `thenNF_Tc` \ (AClass clas) -> - tcDefaultMethodBinds clas default_binds class_sigs -\end{code} \begin{code} mkImplicitClassBinds :: [Class] -> NF_TcM s ([Id], TcMonoBinds) @@ -289,6 +307,8 @@ mkImplicitClassBinds classes | otherwise = EmptyMonoBinds \end{code} + + %************************************************************************ %* * \subsection[Default methods]{Default methods} @@ -350,97 +370,113 @@ dfun.Foo.List dfoo_list \end{verbatim} +The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to +each local class decl. + \begin{code} -tcDefaultMethodBinds - :: Class - -> RenamedMonoBinds - -> [RenamedSig] - -> TcM s (LIE, TcMonoBinds) - -tcDefaultMethodBinds clas default_binds sigs - = -- Check that the default bindings come from this class - checkFromThisClass clas default_binds `thenNF_Tc_` - - -- Do each default method separately - -- For Hugs compatibility we make a default-method for every - -- class op, regardless of whether or not the programmer supplied an - -- explicit default decl for the class. GHC will actually never - -- call the default method for such operations, because it'll whip up - -- a more-informative default method at each instance decl. - mapAndUnzipTc tc_dm op_items `thenTc` \ (defm_binds, const_lies) -> +tcClassDecls2 :: [RenamedHsDecl] -> NF_TcM s (LIE, TcMonoBinds) - returnTc (plusLIEs const_lies, andMonoBindList defm_binds) +tcClassDecls2 decls + = foldr combine + (returnNF_Tc (emptyLIE, EmptyMonoBinds)) + [tcClassDecl2 cls_decl | TyClD cls_decl <- decls, + isClassDecl cls_decl, + isLocallyDefined (tyClDeclName cls_decl)] where - prags = filter isPragSig sigs + combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) -> + tc2 `thenNF_Tc` \ (lie2, binds2) -> + returnNF_Tc (lie1 `plusLIE` lie2, + binds1 `AndMonoBinds` binds2) +\end{code} - (tyvars, _, _, op_items) = classBigSig clas +@tcClassDecl2@ generates bindings for polymorphic default methods +(generic default methods have by now turned into instance declarations) - origin = ClassDeclOrigin +\begin{code} +tcClassDecl2 :: RenamedTyClDecl -- The class declaration + -> NF_TcM s (LIE, TcMonoBinds) + +tcClassDecl2 (ClassDecl context class_name + tyvar_names _ sigs default_binds pragmas _ src_loc) + = -- A locally defined class + recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ + tcAddSrcLoc src_loc $ + tcLookupTy class_name `thenNF_Tc` \ (AClass clas) -> + + -- We make a separate binding for each default method. + -- At one time I used a single AbsBinds for all of them, thus + -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... } + -- But that desugars into + -- ds = \d -> (..., ..., ...) + -- dm1 = \d -> case ds d of (a,b,c) -> a + -- And since ds is big, it doesn't get inlined, so we don't get good + -- default methods. Better to make separate AbsBinds for each + let + (tyvars, _, _, op_items) = classBigSig clas + prags = filter isPragSig sigs + tc_dm = tcDefMeth clas tyvars default_binds prags + in + mapAndUnzipTc tc_dm op_items `thenTc` \ (defm_binds, const_lies) -> - -- We make a separate binding for each default method. - -- At one time I used a single AbsBinds for all of them, thus - -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... } - -- But that desugars into - -- ds = \d -> (..., ..., ...) - -- dm1 = \d -> case ds d of (a,b,c) -> a - -- And since ds is big, it doesn't get inlined, so we don't get good - -- default methods. Better to make separate AbsBinds for each + returnTc (plusLIEs const_lies, andMonoBindList defm_binds) - tc_dm op_item@(_, dm_id, _) - = tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) -> - let - theta = [(mkClassPred clas inst_tys)] - in - newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) -> - let - avail_insts = this_dict - in - tcExtendTyVarEnvForMeths tyvars clas_tyvars ( - tcMethodBind clas origin clas_tyvars inst_tys theta - default_binds prags False - op_item - ) `thenTc` \ (defm_bind, insts_needed, (_, local_dm_id)) -> + +tcDefMeth clas tyvars binds_in prags (_, NoDefMeth) = returnTc (EmptyMonoBinds, emptyLIE) +tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnTc (EmptyMonoBinds, emptyLIE) + -- Generate code for polymorphic default methods only + -- (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 binds_in prags op_item@(_, DefMeth dm_id) + = tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) -> + let + theta = [(mkClassPred clas inst_tys)] + in + newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) -> + + tcExtendTyVarEnvForMeths tyvars clas_tyvars ( + tcMethodBind clas origin clas_tyvars inst_tys theta + binds_in prags False op_item + ) `thenTc` \ (defm_bind, insts_needed, (_, local_dm_id)) -> - tcAddErrCtxt (defltMethCtxt clas) $ + tcAddErrCtxt (defltMethCtxt clas) $ - -- tcMethodBind has checked that the class_tyvars havn't - -- been unified with each other or another type, but we must - -- still zonk them before passing them to tcSimplifyAndCheck - zonkTcSigTyVars clas_tyvars `thenNF_Tc` \ clas_tyvars' -> + -- tcMethodBind has checked that the class_tyvars havn't + -- been unified with each other or another type, but we must + -- still zonk them before passing them to tcSimplifyAndCheck + zonkTcSigTyVars clas_tyvars `thenNF_Tc` \ clas_tyvars' -> - -- Check the context - tcSimplifyAndCheck - (ptext SLIT("class") <+> ppr clas) - (mkVarSet clas_tyvars') - avail_insts - insts_needed `thenTc` \ (const_lie, dict_binds) -> + -- Check the context + tcSimplifyAndCheck + (ptext SLIT("class") <+> ppr clas) + (mkVarSet clas_tyvars') + this_dict + insts_needed `thenTc` \ (const_lie, dict_binds) -> - let - full_bind = AbsBinds - clas_tyvars' - [this_dict_id] - [(clas_tyvars', dm_id, local_dm_id)] - emptyNameSet -- No inlines (yet) - (dict_binds `andMonoBinds` defm_bind) - in - returnTc (full_bind, const_lie) -\end{code} - -\begin{code} -checkFromThisClass :: Class -> RenamedMonoBinds -> NF_TcM s () -checkFromThisClass clas mbinds - = mapNF_Tc check_from_this_class bndrs_w_locs `thenNF_Tc_` - returnNF_Tc () + let + full_bind = AbsBinds + clas_tyvars' + [this_dict_id] + [(clas_tyvars', dm_id, local_dm_id)] + emptyNameSet -- No inlines (yet) + (dict_binds `andMonoBinds` defm_bind) + in + returnTc (full_bind, const_lie) where - check_from_this_class (bndr, loc) - | nameOccName bndr `elem` sel_names = returnNF_Tc () - | otherwise = tcAddSrcLoc loc $ - addErrTc (badMethodErr bndr clas) - sel_names = map getOccName (classSelIds clas) - bndrs_w_locs = bagToList (collectMonoBinders mbinds) + origin = ClassDeclOrigin \end{code} + +%************************************************************************ +%* * +\subsection{Typechecking a method} +%* * +%************************************************************************ + @tcMethodBind@ is used to type-check both default-method and instance-decl method declarations. We must type-check methods one at a time, because their signatures may have different contexts and @@ -465,123 +501,164 @@ tcMethodBind -> TcM s (TcMonoBinds, LIE, (LIE, TcId)) tcMethodBind clas origin inst_tyvars inst_tys inst_theta - meth_binds prags is_inst_decl - (sel_id, dm_id, explicit_dm) - = tcGetSrcLoc `thenNF_Tc` \ loc -> - - newMethod origin sel_id inst_tys `thenNF_Tc` \ meth@(_, meth_id) -> - mkTcSig meth_id loc `thenNF_Tc` \ sig_info -> - - let - meth_name = idName meth_id - maybe_user_bind = find_bind meth_name meth_binds - - no_user_bind = case maybe_user_bind of {Nothing -> True; other -> False} - - meth_bind = case maybe_user_bind of - Just bind -> bind - Nothing -> mk_default_bind meth_name loc - - meth_prags = find_prags meth_name prags - in - - -- Warn if no method binding, only if -fwarn-missing-methods - warnTc (is_inst_decl && opt_WarnMissingMethods && no_user_bind && not explicit_dm) - (omittedMethodWarn sel_id clas) `thenNF_Tc_` - - -- Check the bindings; first add inst_tyvars to the envt - -- so that we don't quantify over them in nested places - -- The *caller* put the class/inst decl tyvars into the envt - tcExtendGlobalTyVars (mkVarSet inst_tyvars) ( - tcAddErrCtxt (methodCtxt sel_id) $ - tcBindWithSigs NotTopLevel meth_bind - [sig_info] meth_prags NonRecursive - ) `thenTc` \ (binds, insts, _) -> - - - tcExtendLocalValEnv [(meth_name, meth_id)] ( - tcSpecSigs meth_prags - ) `thenTc` \ (prag_binds1, prag_lie) -> - - -- The prag_lie for a SPECIALISE pragma will mention the function - -- itself, so we have to simplify them away right now lest they float - -- outwards! - bindInstsOfLocalFuns prag_lie [meth_id] `thenTc` \ (prag_lie', prag_binds2) -> - - - -- Now check that the instance type variables - -- (or, in the case of a class decl, the class tyvars) - -- have not been unified with anything in the environment - -- - -- We do this for each method independently to localise error messages - tcAddErrCtxtM (sigCtxt sig_msg inst_tyvars inst_theta (idType meth_id)) $ - checkSigTyVars inst_tyvars emptyVarSet `thenTc_` - - returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2, - insts `plusLIE` prag_lie', - meth) - where - sig_msg = ptext SLIT("When checking the expected type for class method") <+> ppr sel_name - - sel_name = idName sel_id - - -- The renamer just puts the selector ID as the binder in the method binding - -- but we must use the method name; so we substitute it here. Crude but simple. - find_bind meth_name (FunMonoBind op_name fix matches loc) - | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc) - find_bind meth_name (AndMonoBinds b1 b2) - = find_bind meth_name b1 `seqMaybe` find_bind meth_name b2 - find_bind meth_name other = Nothing -- Default case - - - -- Find the prags for this method, and replace the - -- selector name with the method name - find_prags meth_name [] = [] - find_prags meth_name (SpecSig name ty loc : prags) - | name == sel_name = SpecSig meth_name ty loc : find_prags meth_name prags - find_prags meth_name (InlineSig name phase loc : prags) - | name == sel_name = InlineSig meth_name phase loc : find_prags meth_name prags - find_prags meth_name (NoInlineSig name phase loc : prags) - | name == sel_name = NoInlineSig meth_name phase loc : find_prags meth_name prags - find_prags meth_name (prag:prags) = find_prags meth_name prags - - mk_default_bind local_meth_name loc - = FunMonoBind local_meth_name - False -- Not infix decl - [mkSimpleMatch [] (default_expr loc) Nothing loc] - loc - - default_expr loc - | explicit_dm = HsVar (getName dm_id) -- There's a default method - | otherwise = error_expr loc -- No default method - - error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) - (HsLit (HsString (_PK_ (error_msg loc)))) - - error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) + meth_binds prags is_inst_decl (sel_id, dm_info) + = tcGetSrcLoc `thenNF_Tc` \ loc -> + newMethod origin sel_id inst_tys `thenNF_Tc` \ meth@(_, meth_id) -> + mkTcSig meth_id loc `thenNF_Tc` \ sig_info -> + let + meth_name = idName meth_id + sig_msg = ptext SLIT("When checking the expected type for class method") <+> ppr sel_id + meth_prags = find_prags (idName sel_id) meth_name prags + in + -- Figure out what method binding to use + -- If the user suppplied one, use it, else construct a default one + (case find_bind (idName sel_id) meth_name meth_binds of + Just user_bind -> returnTc user_bind + Nothing -> mkDefMethRhs is_inst_decl clas inst_tys sel_id loc dm_info `thenTc` \ rhs -> + returnTc (FunMonoBind meth_name False -- Not infix decl + [mkSimpleMatch [] rhs Nothing loc] loc) + ) `thenTc` \ meth_bind -> + -- Check the bindings; first add inst_tyvars to the envt + -- so that we don't quantify over them in nested places + -- The *caller* put the class/inst decl tyvars into the envt + tcExtendGlobalTyVars (mkVarSet inst_tyvars) + (tcAddErrCtxt (methodCtxt sel_id) $ + tcBindWithSigs NotTopLevel meth_bind + [sig_info] meth_prags NonRecursive + ) `thenTc` \ (binds, insts, _) -> + + tcExtendLocalValEnv [(meth_name, meth_id)] + (tcSpecSigs meth_prags) `thenTc` \ (prag_binds1, prag_lie) -> + + -- The prag_lie for a SPECIALISE pragma will mention the function + -- itself, so we have to simplify them away right now lest they float + -- outwards! + bindInstsOfLocalFuns prag_lie [meth_id] `thenTc` \ (prag_lie', prag_binds2) -> + + -- Now check that the instance type variables + -- (or, in the case of a class decl, the class tyvars) + -- have not been unified with anything in the environment + -- + -- We do this for each method independently to localise error messages + tcAddErrCtxtM (sigCtxt sig_msg inst_tyvars inst_theta (idType meth_id)) $ + checkSigTyVars inst_tyvars emptyVarSet `thenTc_` + + returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2, + insts `plusLIE` prag_lie', + meth) + + -- The user didn't supply a method binding, + -- so we have to make up a default binding + -- The RHS of a default method depends on the default-method info +mkDefMethRhs is_inst_decl clas inst_tys sel_id loc (DefMeth dm_id) + = -- An polymorphic default method + returnTc (HsVar (idName dm_id)) + +mkDefMethRhs is_inst_decl clas inst_tys sel_id loc NoDefMeth + = -- No default method + -- Warn only if -fwarn-missing-methods + warnTc (is_inst_decl && opt_WarnMissingMethods) + (omittedMethodWarn sel_id clas) `thenNF_Tc_` + returnTc error_rhs + where + error_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) + (HsLit (HsString (_PK_ error_msg))) + error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) + + +mkDefMethRhs is_inst_decl clas inst_tys sel_id loc GenDefMeth + = -- A generic default method + -- If the method is defined generically, we can only do the job if the + -- instance declaration is for a single-parameter type class with + -- a type constructor applied to type arguments in the instance decl + -- (checkTc, so False provokes the error) + checkTc (not is_inst_decl || simple_inst) + (badGenericInstance sel_id clas) `thenTc_` + + ioToTc (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff) `thenNF_Tc_` + returnTc rhs + where + rhs = mkGenericRhs sel_id clas_tyvar tycon + + stuff = vcat [ppr clas <+> ppr inst_tys, + nest 4 (ppr sel_id <+> equals <+> ppr rhs)] + + -- The tycon is only used in the generic case, and in that + -- case we require that the instance decl is for a single-parameter + -- type class with type variable arguments: + -- instance (...) => C (T a b) + simple_inst = maybeToBool maybe_tycon + clas_tyvar = head (classTyVars clas) + Just tycon = maybe_tycon + maybe_tycon = case inst_tys of + [ty] -> case splitTyConApp_maybe ty of + Just (tycon, arg_tys) | all isTyVarTy arg_tys -> Just tycon + other -> Nothing + other -> Nothing +\end{code} + + +\begin{code} +-- The renamer just puts the selector ID as the binder in the method binding +-- but we must use the method name; so we substitute it here. Crude but simple. +find_bind sel_name meth_name (FunMonoBind op_name fix matches loc) + | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc) +find_bind sel_name meth_name (AndMonoBinds b1 b2) + = find_bind sel_name meth_name b1 `seqMaybe` find_bind sel_name meth_name b2 +find_bind sel_name meth_name other = Nothing -- Default case + + -- Find the prags for this method, and replace the + -- selector name with the method name +find_prags sel_name meth_name [] = [] +find_prags sel_name meth_name (SpecSig name ty loc : prags) + | name == sel_name = SpecSig meth_name ty loc : find_prags sel_name meth_name prags +find_prags sel_name meth_name (InlineSig name phase loc : prags) + | name == sel_name = InlineSig meth_name phase loc : find_prags sel_name meth_name prags +find_prags sel_name meth_name (NoInlineSig name phase loc : prags) + | name == sel_name = NoInlineSig meth_name phase loc : find_prags sel_name meth_name prags +find_prags sel_name meth_name (prag:prags) = find_prags sel_name meth_name prags \end{code} + Contexts and errors ~~~~~~~~~~~~~~~~~~~ \begin{code} classArityErr class_name = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name) -superClassErr class_name sc +superClassErr clas sc = ptext SLIT("Illegal superclass constraint") <+> quotes (ppr sc) - <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name) + <+> ptext SLIT("in declaration for class") <+> quotes (ppr clas) -defltMethCtxt class_name - = ptext SLIT("When checking the default methods for class") <+> quotes (ppr class_name) +defltMethCtxt clas + = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas) methodCtxt sel_id = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id) -badMethodErr bndr clas +badMethodErr clas op = hsep [ptext SLIT("Class"), quotes (ppr clas), - ptext SLIT("does not have a method"), quotes (ppr bndr)] + ptext SLIT("does not have a method"), quotes (ppr op)] omittedMethodWarn sel_id clas = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id), ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)] + +badGenericMethodType op op_ty + = hang (ptext SLIT("Generic method type is too complex")) + 4 (vcat [ppr op <+> dcolon <+> ppr op_ty, + ptext SLIT("You can only use type variables, arrows, and tuples")]) + +badGenericInstance sel_id clas + = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id), + ptext SLIT("because the instance declaration is not for a simple type (T a b c)"), + ptext SLIT("(where T is a derivable type constructor)"), + ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)] + +mixedGenericErr op + = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op) + +genericMultiParamErr clas + = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+> + ptext SLIT("cannot have generic methods") \end{code} diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 4d21ace..59f1e2f 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -10,7 +10,7 @@ module TcDeriv ( tcDeriving ) where #include "HsVersions.h" -import HsSyn ( HsBinds(..), MonoBinds(..), collectMonoBinders ) +import HsSyn ( HsBinds(..), MonoBinds(..), collectLocatedMonoBinders ) import RdrHsSyn ( RdrNameMonoBinds ) import RnHsSyn ( RenamedHsBinds ) import CmdLineOpts ( opt_D_dump_deriv ) @@ -18,7 +18,7 @@ import CmdLineOpts ( opt_D_dump_deriv ) import TcMonad import TcEnv ( InstEnv, getEnvTyCons, tcSetInstEnv, newDFunName ) import TcGenDeriv -- Deriv stuff -import TcInstUtil ( InstInfo(..), buildInstanceEnv ) +import TcInstUtil ( InstInfo(..), pprInstInfo, instInfoClass, simpleInstInfoTyCon, buildInstanceEnv ) import TcSimplify ( tcSimplifyThetas ) import RnBinds ( rnMethodBinds, rnTopMonoBinds ) @@ -51,7 +51,8 @@ import TysWiredIn ( voidTy ) import Var ( TyVar ) import PrelNames import Bag ( bagToList ) -import Util ( zipWithEqual, sortLt, removeDups, assoc, thenCmp ) +import Util ( zipWithEqual, sortLt, thenCmp ) +import ListSetOps ( removeDups, assoc ) import Outputable \end{code} @@ -217,7 +218,7 @@ tcDeriving mod fixs rn_name_supply inst_decl_infos_in extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list method_binds_s = map (gen_bind fixs) new_inst_infos - mbinders = bagToList (collectMonoBinders extra_mbinds) + mbinders = collectLocatedMonoBinders extra_mbinds -- Rename to get RenamedBinds. -- The only tricky bit is that the extra_binds must scope over the @@ -239,13 +240,8 @@ tcDeriving mod fixs rn_name_supply inst_decl_infos_in where ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc ddump_deriving inst_infos extra_binds - = vcat (map pp_info inst_infos) $$ ppr extra_binds + = vcat (map pprInstInfo inst_infos) $$ ppr extra_binds where - pp_info (InstInfo clas tvs [ty] inst_decl_theta _ mbinds _ _) - = ppr (mkSigmaTy tvs inst_decl_theta' (mkDictTy clas [ty])) - $$ - ppr mbinds - where inst_decl_theta' = classesToPreds inst_decl_theta -- Paste the dfun id and method binds into the InstInfo gen_inst_info (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ locn _, meth_binds) @@ -256,7 +252,7 @@ tcDeriving mod fixs rn_name_supply inst_decl_infos_in returnNF_Tc (InstInfo clas tyvars tys inst_decl_theta dfun_id meth_binds locn []) - rn_meths meths = rnMethodBinds meths `thenRn` \ (meths', _) -> returnRn meths' + rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths' -- Ignore the free vars returned \end{code} @@ -460,7 +456,7 @@ add_solns inst_infos_in eqns solns mk_deriv_inst_info (clas, tycon, tyvars, _) theta = InstInfo clas tyvars [mkTyConApp tycon (mkTyVarTys tyvars)] - theta + theta' dummy_dfun_id (my_panic "binds") (getSrcLoc tycon) (my_panic "upragmas") @@ -552,10 +548,10 @@ the renamer. What a great hack! -- (paired with class name, as we need that when generating dict -- names.) gen_bind :: FixityEnv -> InstInfo -> RdrNameMonoBinds -gen_bind fixities (InstInfo clas _ [ty] _ _ _ _ _) - | not from_here = EmptyMonoBinds - | clas `hasKey` showClassKey = gen_Show_binds fixities tycon - | clas `hasKey` readClassKey = gen_Read_binds fixities tycon +gen_bind fixities inst + | not (isLocallyDefined tycon) = EmptyMonoBinds + | clas `hasKey` showClassKey = gen_Show_binds fixities tycon + | clas `hasKey` readClassKey = gen_Read_binds fixities tycon | otherwise = assoc "gen_bind:bad derived class" [(eqClassKey, gen_Eq_binds) @@ -567,8 +563,8 @@ gen_bind fixities (InstInfo clas _ [ty] _ _ _ _ _) (classKey clas) tycon where - from_here = isLocallyDefined tycon - (tycon,_,_) = splitAlgTyConApp ty + clas = instInfoClass inst + tycon = simpleInstInfoTyCon inst \end{code} @@ -615,11 +611,9 @@ gen_taggery_Names inst_infos foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far -> foldlTc do_tag2con names_so_far tycons_of_interest where - all_CTs = [ (c, get_tycon ty) | (InstInfo c _ [ty] _ _ _ _ _) <- inst_infos ] + all_CTs = [ (instInfoClass info, simpleInstInfoTyCon info) | info <- inst_infos ] - get_tycon ty = case splitAlgTyConApp ty of { (tc, _, _) -> tc } - - all_tycons = map snd all_CTs + all_tycons = map snd all_CTs (tycons_of_interest, _) = removeDups compare all_tycons do_con2tag acc_Names tycon diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index b1f993e..bde67ba 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -398,7 +398,10 @@ tcLookupValue name Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> returnNF_Tc (lookupWithDefaultUFM ve def name) where - def = pprPanic "tcLookupValue:" (ppr name) + wired_in = case maybeWiredInIdName name of + Just id -> True + Nothing -> False + def = pprPanic "tcLookupValue:" (ppr name <+> ppr wired_in) tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id) tcLookupValueMaybe name diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 5db09d1..134ce6e 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -4,57 +4,79 @@ \section[TcInstDecls]{Typechecking instance declarations} \begin{code} -module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where +module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), InstDecl(..), + +import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances, opt_D_dump_deriv ) + +import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), - andMonoBindList + andMonoBindList, collectMonoBinders, isClassDecl ) -import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl ) +import HsTypes ( HsType (..), HsTyVarBndr(..), toHsTyVar ) +import HsPat ( InPat (..) ) +import HsMatches ( Match (..) ) +import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, extractHsTyVars ) import TcHsSyn ( TcMonoBinds, mkHsConApp ) - import TcBinds ( tcSpecSigs ) -import TcClassDcl ( tcMethodBind, checkFromThisClass ) -import TcMonad +import TcClassDcl ( tcMethodBind, badMethodErr ) +import TcMonad import RnMonad ( RnNameSupply, FixityEnv ) import Inst ( InstOrigin(..), newDicts, newClassDicts, LIE, emptyLIE, plusLIE, plusLIEs ) import TcDeriv ( tcDeriving ) -import TcEnv ( ValueEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths, - tcAddImportedIdInfo, tcInstId, newDFunName +import TcEnv ( ValueEnv, tcExtendGlobalValEnv, + tcExtendTyVarEnvForMeths, TyThing (..), + tcAddImportedIdInfo, tcInstId, tcLookupTy, + newDFunName, tcExtendTyVarEnv ) -import TcInstUtil ( InstInfo(..), classDataCon ) -import TcMonoType ( tcHsSigType ) +import TcInstUtil ( InstInfo(..), pprInstInfo, classDataCon, simpleInstInfoTyCon, simpleInstInfoTy ) +import TcMonoType ( tcTyVars, tcHsSigType, tcHsType, kcHsSigType ) import TcSimplify ( tcSimplifyAndCheck ) import TcType ( zonkTcSigTyVars ) import Bag ( emptyBag, unitBag, unionBags, unionManyBags, - foldBag, Bag + foldBag, Bag, listToBag ) -import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances ) -import Class ( classBigSig ) +import Class ( Class, DefMeth(..), classBigSig ) import Var ( idName, idType ) import Maybes ( maybeToBool, expectJust ) import MkId ( mkDictFunId ) +import Generics ( validGenericInstanceType ) import Module ( Module ) import Name ( isLocallyDefined ) -import NameSet ( emptyNameSet ) +import NameSet ( emptyNameSet, nameSetToList ) import PrelInfo ( eRROR_ID ) -import PprType ( pprConstraint ) +import PprType ( pprConstraint, pprPred ) import TyCon ( isSynTyCon, tyConDerivings ) import Type ( mkTyVarTys, splitSigmaTy, isTyVarTy, splitTyConApp_maybe, splitDictTy_maybe, - splitAlgTyConApp_maybe, - classesToPreds, classesOfPreds, - unUsgTy, tyVarsOfTypes + splitAlgTyConApp_maybe, classesToPreds, classesOfPreds, + unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy, + getClassTys_maybe ) -import Subst ( mkTopTyVarSubst, substClasses ) +import Subst ( mkTopTyVarSubst, substClasses, substTheta ) import VarSet ( mkVarSet, varSetElems ) -import TysWiredIn ( isFFIArgumentTy, isFFIResultTy ) +import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIResultTy ) import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey ) +import Name ( Name, NameEnv, extendNameEnv_C, emptyNameEnv, + plusNameEnv_C, nameEnvElts ) +import FiniteMap ( mapFM ) +import SrcLoc ( SrcLoc ) +import RnHsSyn -- ( RenamedMonoBinds ) +import VarSet ( varSetElems ) +import UniqFM ( mapUFM ) +import Unique ( Uniquable(..) ) +import BasicTypes ( NewOrData(..) ) +import ErrUtils ( dumpIfSet ) +import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc, + assocElts, extendAssoc_C, + equivClassesByUniq, minusList + ) +import List ( intersect, (\\) ) import Outputable \end{code} @@ -131,6 +153,15 @@ Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn, and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm. \end{enumerate} + +%************************************************************************ +%* * +\subsection{Extracting instance decls} +%* * +%************************************************************************ + +Gather up the instance declarations from their various sources + \begin{code} tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids -> [RenamedHsDecl] @@ -141,26 +172,36 @@ tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids RenamedHsBinds) tcInstDecls1 unf_env decls mod fixs rn_name_supply - = -- Do the ordinary instance declarations + = -- (1) Do the ordinary instance declarations mapNF_Tc (tcInstDecl1 mod unf_env) [inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags -> let decl_inst_info = unionManyBags inst_info_bags in - -- Handle "derived" instances; note that we only do derivings + -- (2) Instances from "deriving" clauses; note that we only do derivings -- for things in this module; we ignore deriving decls from -- interfaces! - tcDeriving mod fixs rn_name_supply decl_inst_info - `thenTc` \ (deriv_inst_info, deriv_binds) -> + tcDeriving mod fixs rn_name_supply decl_inst_info `thenTc` \ (deriv_inst_info, deriv_binds) -> + + -- (3) Instances from generic class declarations + mapTc (getGenericInstances mod) + [cl_decl | TyClD cl_decl <- decls, isClassDecl cl_decl] `thenTc` \ cls_inst_info -> let - full_inst_info = deriv_inst_info `unionBags` decl_inst_info + generic_insts = concat cls_inst_info + full_inst_info = deriv_inst_info `unionBags` + unionManyBags inst_info_bags `unionBags` + (listToBag generic_insts) in - returnTc (full_inst_info, deriv_binds) + ioToTc (dumpIfSet opt_D_dump_deriv "Generic instances" + (vcat (map pprInstInfo generic_insts))) `thenNF_Tc_` + (returnTc (full_inst_info, deriv_binds)) +\end{code} +\begin{code} tcInstDecl1 :: Module -> ValueEnv -> RenamedInstDecl -> NF_TcM s (Bag InstInfo) - +-- Deal with a single instance declaration tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc) = -- Prime error recovery, set source location recoverNF_Tc (returnNF_Tc emptyBag) $ @@ -170,7 +211,6 @@ tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc) tcHsSigType poly_ty `thenTc` \ poly_ty' -> let (tyvars, theta, dict_ty) = splitSigmaTy poly_ty' - constr = classesOfPreds theta (clas, inst_tys) = case splitDictTy_maybe dict_ty of Just ct -> ct Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty) @@ -185,21 +225,143 @@ tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc) -- contain something illegal in normal Haskell, notably -- instance CCallable [Char] scrutiniseInstanceHead clas inst_tys `thenNF_Tc_` - mapNF_Tc scrutiniseInstanceConstraint constr `thenNF_Tc_` + mapNF_Tc scrutiniseInstanceConstraint theta `thenNF_Tc_` -- Make the dfun id and return it newDFunName mod clas inst_tys src_loc `thenNF_Tc` \ dfun_name -> - returnNF_Tc (mkDictFunId dfun_name clas tyvars inst_tys constr) + returnNF_Tc (mkDictFunId dfun_name clas tyvars inst_tys theta) Just dfun_name -> -- An interface-file instance declaration -- Make the dfun id and add info from interface file let - dfun_id = mkDictFunId dfun_name clas tyvars inst_tys constr + dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta in returnNF_Tc (tcAddImportedIdInfo unf_env dfun_id) ) `thenNF_Tc` \ dfun_id -> - returnTc (unitBag (InstInfo clas tyvars inst_tys constr dfun_id binds src_loc uprags)) + returnTc (unitBag (InstInfo clas tyvars inst_tys theta dfun_id binds src_loc uprags)) +\end{code} + + +%************************************************************************ +%* * +\subsection{Extracting generic instance declaration from class declarations} +%* * +%************************************************************************ + +@getGenericInstances@ extracts the generic instance declarations from a class +declaration. For exmaple + + class C a where + op :: a -> a + + op{ x+y } (Inl v) = ... + op{ x+y } (Inr v) = ... + op{ x*y } (v :*: w) = ... + op{ 1 } Unit = ... + +gives rise to the instance declarations + + instance C (x+y) where + op (Inl v) = ... + op (Inr v) = ... + + instance C (x*y) where + op (v :*: w) = ... + + instance C 1 where + op Unit = ... + + +\begin{code} +getGenericInstances :: Module -> RenamedTyClDecl -> TcM s [InstInfo] +getGenericInstances mod decl@(ClassDecl context class_name tyvar_names + fundeps class_sigs def_methods pragmas + name_list loc) + | null groups + = returnTc [] -- The comon case + + | otherwise + = recoverNF_Tc (returnNF_Tc []) $ + tcAddDeclCtxt decl $ + tcLookupTy class_name `thenTc` \ (AClass clas) -> + + -- Make an InstInfo out of each group + mapTc (mkGenericInstance mod clas loc) groups `thenTc` \ inst_infos -> + + -- Check that there is only one InstInfo for each type constructor + -- The main way this can fail is if you write + -- f {| a+b |} ... = ... + -- f {| x+y |} ... = ... + -- Then at this point we'll have an InstInfo for each + let + bad_groups = [group | group <- equivClassesByUniq get_uniq inst_infos, + length group > 1] + get_uniq inst = getUnique (simpleInstInfoTyCon inst) + in + mapTc (addErrTc . dupGenericInsts) bad_groups `thenTc_` + + -- Check that there is an InstInfo for each generic type constructor + let + missing = genericTyCons `minusList` map simpleInstInfoTyCon inst_infos + in + checkTc (null missing) (missingGenericInstances missing) `thenTc_` + + returnTc inst_infos + + where + -- Group the declarations by type pattern + groups :: [(RenamedHsType, RenamedMonoBinds)] + groups = assocElts (getGenericBinds def_methods) + + +--------------------------------- +getGenericBinds :: RenamedMonoBinds -> Assoc RenamedHsType RenamedMonoBinds + -- Takes a group of method bindings, finds the generic ones, and returns + -- them in finite map indexed by the type parameter in the definition. + +getGenericBinds EmptyMonoBinds = emptyAssoc +getGenericBinds (AndMonoBinds m1 m2) + = plusAssoc_C AndMonoBinds (getGenericBinds m1) (getGenericBinds m2) + +getGenericBinds (FunMonoBind id infixop matches loc) + = mapAssoc wrap (foldr add emptyAssoc matches) + where + add match env = case maybeGenericMatch match of + Nothing -> env + Just (ty, match') -> extendAssoc_C (++) env (ty, [match']) + + wrap ms = FunMonoBind id infixop ms loc + +--------------------------------- +mkGenericInstance :: Module -> Class -> SrcLoc + -> (RenamedHsType, RenamedMonoBinds) + -> TcM s InstInfo + +mkGenericInstance mod clas loc (hs_ty, binds) + -- Make a generic instance declaration + -- For example: instance (C a, C b) => C (a+b) where { binds } + + = -- Extract the universally quantified type variables + tcTyVars (nameSetToList (extractHsTyVars hs_ty)) + (kcHsSigType hs_ty) `thenTc` \ tyvars -> + tcExtendTyVarEnv tyvars $ + + -- Type-check the instance type, and check its form + tcHsSigType hs_ty `thenTc` \ inst_ty -> + checkTc (validGenericInstanceType inst_ty) + (badGenericInstanceType binds) `thenTc_` + + -- Make the dictionary function. + newDFunName mod clas [inst_ty] loc `thenNF_Tc` \ dfun_name -> + let + inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars] + inst_tys = [inst_ty] + dfun_id = mkDictFunId dfun_name clas tyvars inst_tys inst_theta + in + + returnTc (InstInfo clas tyvars inst_tys inst_theta dfun_id binds loc []) + -- The "[]" means "no pragmas" \end{code} @@ -222,7 +384,6 @@ tcInstDecls2 inst_decls binds1 `AndMonoBinds` binds2) \end{code} - ======= New documentation starts here (Sept 92) ============== The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines @@ -304,39 +465,42 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ tcAddSrcLoc locn $ - -- Check that all the method bindings come from this class - checkFromThisClass clas monobinds `thenNF_Tc_` - -- Instantiate the instance decl with tc-style type variables tcInstId dfun_id `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') -> let - (clas, inst_tys') = expectJust "tcInstDecl2" (splitDictTy_maybe dict_ty') - - origin = InstanceDeclOrigin + (clas, inst_tys') = expectJust "tcInstDecl2" (splitDictTy_maybe dict_ty') + origin = InstanceDeclOrigin (class_tyvars, sc_theta, _, op_items) = classBigSig clas - dm_ids = [dm_id | (_, dm_id, _) <- op_items] + dm_ids = [dm_id | (_, DefMeth dm_id) <- op_items] + sel_names = [idName sel_id | (sel_id, _) <- op_items] -- Instantiate the theta found in the original instance decl - inst_decl_theta' = substClasses (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars')) - inst_decl_theta + inst_decl_theta' = substTheta (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars')) + inst_decl_theta - -- Instantiate the super-class context with inst_tys + -- Instantiate the super-class context with inst_tys sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta + + -- Find any definitions in monobinds that aren't from the class + bad_bndrs = collectMonoBinders monobinds `minusList` sel_names in + -- Check that all the method bindings come from this class + mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_` + -- Create dictionary Ids from the specified instance contexts. - newClassDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) -> - newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) -> - newClassDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) -> - newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> + newClassDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) -> + newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) -> + newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) -> + newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' ( tcExtendGlobalValEnv dm_ids ( -- Default-method Ids may be mentioned in synthesised RHSs mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys' - (classesToPreds inst_decl_theta') + inst_decl_theta' monobinds uprags True) op_items )) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) -> @@ -469,10 +633,16 @@ compiled elsewhere). In these cases, we let them go through anyway. We can also have instances for functions: @instance Foo (a -> b) ...@. \begin{code} -scrutiniseInstanceConstraint (clas, tys) - | all isTyVarTy tys - || opt_AllowUndecidableInstances = returnNF_Tc () - | otherwise = addErrTc (instConstraintErr clas tys) +scrutiniseInstanceConstraint pred + | opt_AllowUndecidableInstances + = returnNF_Tc () + + | Just (clas,tys) <- getClassTys_maybe pred, + all isTyVarTy tys + = returnNF_Tc () + + | otherwise + = addErrTc (instConstraintErr pred) scrutiniseInstanceHead clas inst_taus | -- CCALL CHECK @@ -532,13 +702,52 @@ ccallable_type ty = isFFIArgumentTy False {- Not safe call -} ty creturnable_type ty = isFFIResultTy ty \end{code} + +%************************************************************************ +%* * +\subsection{Error messages} +%* * +%************************************************************************ + +\begin{code} +tcAddDeclCtxt decl thing_inside + = tcAddSrcLoc loc $ + tcAddErrCtxt ctxt $ + thing_inside + where + (name, loc, thing) + = case decl of + (ClassDecl _ name _ _ _ _ _ _ loc) -> (name, loc, "class") + (TySynonym name _ _ loc) -> (name, loc, "type synonym") + (TyData NewType _ name _ _ _ _ _ loc _ _) -> (name, loc, "newtype") + (TyData DataType _ name _ _ _ _ _ loc _ _) -> (name, loc, "data type") + + ctxt = hsep [ptext SLIT("In the"), text thing, + ptext SLIT("declaration for"), quotes (ppr name)] +\end{code} + \begin{code} -instConstraintErr clas tys +instConstraintErr pred = hang (ptext SLIT("Illegal constraint") <+> - quotes (pprConstraint clas tys) <+> + quotes (pprPred pred) <+> ptext SLIT("in instance context")) 4 (ptext SLIT("(Instance contexts must constrain only type variables)")) +badGenericInstanceType binds + = vcat [ptext SLIT("Illegal type pattern in the generic bindings"), + nest 4 (ppr binds)] + +missingGenericInstances missing + = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing + + + +dupGenericInsts inst_infos + = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"), + nest 4 (vcat (map (ppr . simpleInstInfoTy) inst_infos)), + ptext SLIT("All the type patterns for a generic type constructor must be identical") + ] + instTypeErr clas tys msg = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys), nest 4 (parens msg) diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index 0dc6ab9..bc1814e 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -9,12 +9,14 @@ The bits common to TcInstDcls and TcDeriv. module TcInstUtil ( InstInfo(..), buildInstanceEnv, - classDataCon + instInfoClass, simpleInstInfoTy, simpleInstInfoTyCon, classDataCon, + pprInstInfo ) where #include "HsVersions.h" import RnHsSyn ( RenamedMonoBinds, RenamedSig ) +import HsTypes ( toHsType ) import CmdLineOpts ( opt_AllowOverlappingInstances ) import TcMonad @@ -23,13 +25,13 @@ import Bag ( bagToList, Bag ) import Class ( Class ) import Var ( TyVar, Id, idName ) import Maybes ( MaybeErr(..) ) -import Name ( getSrcLoc, nameModule, isLocallyDefined ) +import Name ( getSrcLoc, nameModule, isLocallyDefined, toRdrName ) import SrcLoc ( SrcLoc ) -import Type ( Type, ClassContext ) +import Type ( Type, ThetaType, splitTyConApp_maybe, mkSigmaTy, mkDictTy ) import PprType ( pprConstraint ) import Class ( classTyCon ) import DataCon ( DataCon ) -import TyCon ( tyConDataCons ) +import TyCon ( TyCon, tyConDataCons ) import Outputable \end{code} @@ -41,13 +43,30 @@ data InstInfo Class -- Class, k [TyVar] -- Type variables, tvs [Type] -- The types at which the class is being instantiated - ClassContext -- inst_decl_theta: the original context, c, from the + ThetaType -- inst_decl_theta: the original context, c, from the -- instance declaration. It constrains (some of) -- the TyVars above Id -- The dfun id RenamedMonoBinds -- Bindings, b SrcLoc -- Source location assoc'd with this instance's defn [RenamedSig] -- User pragmas recorded for generating specialised instances + +pprInstInfo (InstInfo clas tvs tys inst_decl_theta _ mbinds _ _) + = vcat [ptext SLIT("InstInfo:") <+> ppr (mkSigmaTy tvs inst_decl_theta (mkDictTy clas tys)), + nest 4 (ppr mbinds)] + +instInfoClass :: InstInfo -> Class +instInfoClass (InstInfo clas _ _ _ _ _ _ _) = clas + +simpleInstInfoTy :: InstInfo -> Type +simpleInstInfoTy (InstInfo _ _ [ty] _ _ _ _ _) = ty + +simpleInstInfoTyCon :: InstInfo -> TyCon + -- Gets the type constructor for a simple instance declaration, + -- i.e. one of the form instance (...) => C (T a b c) where ... +simpleInstInfoTyCon inst + = case splitTyConApp_maybe (simpleInstInfoTy inst) of + Just (tycon, _) -> tycon \end{code} @@ -75,7 +94,8 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of \begin{code} buildInstanceEnv :: Bag InstInfo -> NF_TcM s InstEnv -buildInstanceEnv info = foldrNF_Tc addClassInstance emptyInstEnv (bagToList info) +buildInstanceEnv info = --pprTrace "BuildInstanceEnv" (ppr info) + foldrNF_Tc addClassInstance emptyInstEnv (bagToList info) \end{code} @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@ diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 658c3e8..35ffec3 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -19,7 +19,7 @@ import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt ) import TcHsSyn ( TcMatch, TcGRHSs, TcStmt ) import TcMonad -import TcMonoType ( kcHsSigType, kcTyVarScope, newSigTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt ) +import TcMonoType ( kcHsSigType, tcTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt ) import Inst ( LIE, plusLIE, emptyLIE, plusLIEs ) import TcEnv ( tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars ) import TcPat ( tcPat, tcPatBndr_NoSigs, polyPatSig ) @@ -138,11 +138,10 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt -- If there are sig tvs we must be careful *not* to use -- expected_ty right away, else we'll unify with tyvars free -- in the envt. So invent a fresh tyvar and use that instead - newTyVarTy openTypeKind `thenNF_Tc` \ tyvar_ty -> + newTyVarTy openTypeKind `thenNF_Tc` \ tyvar_ty -> -- Extend the tyvar env and check the match itself - kcTyVarScope sig_tvs (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tv_kinds -> - newSigTyVars sig_tv_kinds `thenNF_Tc` \ sig_tyvars -> + tcTyVars sig_tvs (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tyvars -> tcExtendTyVarEnv sig_tyvars (tc_match tyvar_ty) `thenTc` \ (pat_ids, match_and_lie) -> -- Check that the scoped type variables from the patterns diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 1478dc9..4be703c 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -39,14 +39,17 @@ import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import TcTyDecls ( mkImplicitDataBinds ) +import CoreUnfold ( unfoldingTemplate ) +import Type ( funResultTy, splitForAllTys ) import RnMonad ( RnNameSupply, FixityEnv ) import Bag ( isEmptyBag ) import ErrUtils ( printErrorsAndWarnings, dumpIfSet ) -import Id ( idType, idName ) +import Id ( idType, idName, idUnfolding ) import Module ( pprModuleName, mkThisModule ) import Name ( nameOccName, isLocallyDefined, isGlobalName, toRdrName, nameEnvElts, ) +import TyCon ( TyCon, isDataTyCon, tyConName, tyConGenInfo ) import OccName ( isSysOcc ) import TyCon ( TyCon, isClassTyCon ) import Class ( Class ) @@ -54,8 +57,10 @@ import PrelNames ( mAIN_Name, mainKey ) import UniqSupply ( UniqSupply ) import Maybes ( maybeToBool ) import Util +import BasicTypes ( EP(..) ) import Bag ( Bag, isEmptyBag ) import Outputable + \end{code} Outside-world interface: @@ -97,31 +102,6 @@ typecheckModule us rn_name_supply fixity_env mod else Nothing) -dump_tc results - = ppr (tc_binds results) $$ pp_rules (tc_rules results) - -dump_sigs results -- Print type signatures - = -- Convert to HsType so that we get source-language style printing - -- And sort by RdrName - vcat $ map ppr_sig $ sortLt lt_sig $ - [(toRdrName id, toHsType (idType id)) | id <- nameEnvElts (tc_env results), - want_sig id - ] - where - lt_sig (n1,_) (n2,_) = n1 < n2 - ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t - - want_sig id | opt_PprStyle_Debug = True - | otherwise = isLocallyDefined n && - isGlobalName n && - not (isSysOcc (nameOccName n)) - where - n = idName id - -pp_rules [] = empty -pp_rules rs = vcat [ptext SLIT("{-# RULES"), - nest 4 (vcat (map ppr rs)), - ptext SLIT("#-}")] \end{code} The internal monster: @@ -145,10 +125,9 @@ tcModule rn_name_supply fixities -- Type-check the type and class decls tcTyAndClassDecls unf_env decls `thenTc` \ env -> - - -- Typecheck the instance decls, includes deriving tcSetEnv env $ + -- Typecheck the instance decls, includes deriving tcInstDecls1 unf_env decls (mkThisModule mod_name) fixities rn_name_supply `thenTc` \ (inst_info, deriv_binds) -> @@ -290,3 +269,60 @@ noMainErr ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))] \end{code} + +%************************************************************************ +%* * +\subsection{Dumping output} +%* * +%************************************************************************ + +\begin{code} +dump_tc results + = vcat [ppr (tc_binds results), + pp_rules (tc_rules results), + ppr_gen_tycons (tc_tycons results) + ] + +dump_sigs results -- Print type signatures + = -- Convert to HsType so that we get source-language style printing + -- And sort by RdrName + vcat $ map ppr_sig $ sortLt lt_sig $ + [(toRdrName id, toHsType (idType id)) | id <- nameEnvElts (tc_env results), + want_sig id + ] + where + lt_sig (n1,_) (n2,_) = n1 < n2 + ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t + + want_sig id | opt_PprStyle_Debug = True + | otherwise = isLocallyDefined n && + isGlobalName n && + not (isSysOcc (nameOccName n)) + where + n = idName id + +ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"), + vcat (map ppr_gen_tycon (filter isLocallyDefined tcs)), + ptext SLIT("#-}") + ] + +-- x&y are now Id's, not CoreExpr's +ppr_gen_tycon tycon + | Just ep <- tyConGenInfo tycon + = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep) + + | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable") + +ppr_ep (EP from to) + = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau), + ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)), + ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to)) + ] + where + (_,from_tau) = splitForAllTys (idType from) + +pp_rules [] = empty +pp_rules rs = vcat [ptext SLIT("{-# RULES"), + nest 4 (vcat (map ppr rs)), + ptext SLIT("#-}")] +\end{code} diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index e23f703..89f6c5b 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -10,7 +10,7 @@ module TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, -- Kind checking kcHsTyVar, kcHsTyVars, mkTyClTyVars, kcHsType, kcHsSigType, kcHsBoxedSigType, kcHsContext, - kcTyVarScope, newSigTyVars, mkImmutTyVars, + tcTyVars, tcHsTyVars, mkImmutTyVars, TcSigInfo(..), tcTySig, mkTcSig, maybeSig, checkSigTyVars, sigCtxt, sigPatCtxt @@ -55,15 +55,16 @@ import Var ( TyVar, mkTyVar, tyVarKind, mkNamedUVar ) import VarEnv import VarSet import ErrUtils ( Message ) -import TyCon ( TyCon, isSynTyCon, tyConArity, tyConKind ) +import TyCon ( TyCon, isSynTyCon, tyConArity, tyConKind, tyConName ) import Class ( ClassContext, classArity, classTyCon ) import Name ( Name, isLocallyDefined ) -import TysWiredIn ( mkListTy, mkTupleTy ) +import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon ) import UniqFM ( elemUFM ) import BasicTypes ( Boxity(..) ) import SrcLoc ( SrcLoc ) import Util ( mapAccumL, isSingleton ) import Outputable + \end{code} @@ -90,7 +91,7 @@ To do step 1, we proceed thus: 1b. Apply the kind checker 1c. Zonk the resulting kinds -The kind checker is passed to kcTyVarScope as an argument. +The kind checker is passed to tcHsTyVars as an argument. For example, when we find (forall a m. m a -> m a) @@ -98,7 +99,7 @@ we bind a,m to kind varibles and kind-check (m a -> m a). This makes a get kind *, and m get kind *->*. Now we typecheck (m a -> m a) in an environment that binds a and m suitably. -The kind checker passed to kcTyVarScope needs to look at enough to +The kind checker passed to tcHsTyVars needs to look at enough to establish the kind of the tyvar: * For a group of type and class decls, it's just the group, not the rest of the program @@ -116,22 +117,33 @@ But equally valid would be a::(*->*)-> *, b::*->* \begin{code} -kcTyVarScope :: [HsTyVarBndr Name] - -> TcM s a -- The kind checker - -> TcM s [(Name,Kind)] - -- Do a kind check to find out the kinds of the type variables - -- Then return a bunch of name-kind pairs, from which to - -- construct the type variables. We don't return the tyvars - -- themselves because sometimes we want mutable ones and - -- sometimes we want immutable ones. - -kcTyVarScope [] kind_check = returnTc [] +tcHsTyVars :: [HsTyVarBndr Name] + -> TcM s a -- The kind checker + -> ([TyVar] -> TcM s b) + -> TcM s b + +tcHsTyVars [] kind_check thing_inside = thing_inside [] -- A useful short cut for a common case! -kcTyVarScope tv_names kind_check +tcHsTyVars tv_names kind_check thing_inside = kcHsTyVars tv_names `thenNF_Tc` \ tv_names_w_kinds -> tcExtendKindEnv tv_names_w_kinds kind_check `thenTc_` - zonkKindEnv tv_names_w_kinds + zonkKindEnv tv_names_w_kinds `thenNF_Tc` \ tvs_w_kinds -> + let + tyvars = mkImmutTyVars tvs_w_kinds + in + tcExtendTyVarEnv tyvars (thing_inside tyvars) + +tcTyVars :: [Name] + -> TcM s a -- The kind checker + -> TcM s [TyVar] +tcTyVars [] kind_check = returnTc [] + +tcTyVars tv_names kind_check + = mapNF_Tc newNamedKindVar tv_names `thenTc` \ kind_env -> + tcExtendKindEnv kind_env kind_check `thenTc_` + zonkKindEnv kind_env `thenNF_Tc` \ tvs_w_kinds -> + listNF_Tc [tcNewSigTyVar name kind | (name,kind) <- tvs_w_kinds] \end{code} @@ -139,12 +151,14 @@ kcTyVarScope tv_names kind_check kcHsTyVar :: HsTyVarBndr name -> NF_TcM s (name, TcKind) kcHsTyVars :: [HsTyVarBndr name] -> NF_TcM s [(name, TcKind)] -kcHsTyVar (UserTyVar name) = newKindVar `thenNF_Tc` \ kind -> - returnNF_Tc (name, kind) +kcHsTyVar (UserTyVar name) = newNamedKindVar name kcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (name, kind) kcHsTyVars tvs = mapNF_Tc kcHsTyVar tvs +newNamedKindVar name = newKindVar `thenNF_Tc` \ kind -> + returnNF_Tc (name, kind) + --------------------------- kcBoxedType :: RenamedHsType -> TcM s () -- The type ty must be a *boxed* *type* @@ -169,14 +183,7 @@ kcHsBoxedSigType = kcBoxedType --------------------------- kcHsType :: RenamedHsType -> TcM s TcKind -kcHsType (HsTyVar name) - = tcLookupTy name `thenTc` \ thing -> - case thing of - ATyVar tv -> returnTc (tyVarKind tv) - ATyCon tc -> returnTc (tyConKind tc) - AThing k -> returnTc k - other -> failWithTc (wrongThingErr "type" thing name) - +kcHsType (HsTyVar name) = kcTyVar name kcHsType (HsUsgTy _ ty) = kcHsType ty kcHsType (HsUsgForAllTy _ ty) = kcHsType ty @@ -198,27 +205,27 @@ kcHsType (HsFunTy ty1 ty2) kcFunResType ty2 `thenTc_` returnTc boxedTypeKind +kcHsType ty@(HsOpTy ty1 op ty2) + = kcTyVar op `thenTc` \ op_kind -> + kcHsType ty1 `thenTc` \ ty1_kind -> + kcHsType ty2 `thenTc` \ ty2_kind -> + tcAddErrCtxt (appKindCtxt (ppr ty)) $ + kcAppKind op_kind ty1_kind `thenTc` \ op_kind' -> + kcAppKind op_kind' ty2_kind + kcHsType (HsPredTy pred) = kcHsPred pred `thenTc_` returnTc boxedTypeKind kcHsType ty@(HsAppTy ty1 ty2) - = kcHsType ty1 `thenTc` \ tc_kind -> - kcHsType ty2 `thenTc` \ arg_kind -> - + = kcHsType ty1 `thenTc` \ tc_kind -> + kcHsType ty2 `thenTc` \ arg_kind -> tcAddErrCtxt (appKindCtxt (ppr ty)) $ - case splitFunTy_maybe tc_kind of - Just (arg_kind', res_kind) - -> unifyKind arg_kind arg_kind' `thenTc_` - returnTc res_kind - - Nothing -> newKindVar `thenNF_Tc` \ res_kind -> - unifyKind tc_kind (mkArrowKind arg_kind res_kind) `thenTc_` - returnTc res_kind + kcAppKind tc_kind arg_kind kcHsType (HsForAllTy (Just tv_names) context ty) - = kcHsTyVars tv_names `thenNF_Tc` \ kind_env -> - tcExtendKindEnv kind_env $ + = kcHsTyVars tv_names `thenNF_Tc` \ kind_env -> + tcExtendKindEnv kind_env $ kcHsContext context `thenTc_` -- Context behaves like a function type @@ -232,6 +239,16 @@ kcHsType (HsForAllTy (Just tv_names) context ty) kcFunResType ty `thenTc_` returnTc boxedTypeKind +--------------------------- +kcTyVar name + = tcLookupTy name `thenTc` \ thing -> + case thing of + ATyVar tv -> returnTc (tyVarKind tv) + ATyCon tc -> returnTc (tyConKind tc) + AThing k -> returnTc k + other -> failWithTc (wrongThingErr "type" thing name) + +--------------------------- kcFunResType :: RenamedHsType -> TcM s TcKind -- The only place an unboxed tuple type is allowed -- is at the right hand end of an arrow @@ -241,6 +258,17 @@ kcFunResType (HsTupleTy (HsTupCon _ Unboxed) tys) kcFunResType ty = kcHsType ty +--------------------------- +kcAppKind fun_kind arg_kind + = case splitFunTy_maybe fun_kind of + Just (arg_kind', res_kind) + -> unifyKind arg_kind arg_kind' `thenTc_` + returnTc res_kind + + Nothing -> newKindVar `thenNF_Tc` \ res_kind -> + unifyKind fun_kind (mkArrowKind arg_kind res_kind) `thenTc_` + returnTc res_kind + --------------------------- kcHsContext ctxt = mapTc_ kcHsPred ctxt @@ -316,6 +344,15 @@ tcHsType (HsFunTy ty1 ty2) tcHsType ty2 `thenTc` \ tau_ty2 -> returnTc (mkFunTy tau_ty1 tau_ty2) +tcHsType (HsNumTy n) + = ASSERT(n== 1) + returnTc (mkTyConApp genUnitTyCon []) + +tcHsType (HsOpTy ty1 op ty2) = + tcHsType ty1 `thenTc` \ tau_ty1 -> + tcHsType ty2 `thenTc` \ tau_ty2 -> + tc_fun_type op [tau_ty1,tau_ty2] + tcHsType (HsAppTy ty1 ty2) = tc_app ty1 [ty2] @@ -343,81 +380,88 @@ tcHsType (HsUsgForAllTy uv_name ty) returnTc (mkUsForAllTy uv tc_ty) tcHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty) - = kcTyVarScope tv_names - (kcHsContext ctxt `thenTc_` kcFunResType ty) `thenTc` \ tv_kinds -> - let - forall_tyvars = mkImmutTyVars tv_kinds - in - tcExtendTyVarEnv forall_tyvars $ - tcContext ctxt `thenTc` \ theta -> - tcHsType ty `thenTc` \ tau -> - let - -- Check for ambiguity - -- forall V. P => tau - -- is ambiguous if P contains generic variables - -- (i.e. one of the Vs) that are not mentioned in tau - -- - -- However, we need to take account of functional dependencies - -- when we speak of 'mentioned in tau'. Example: - -- class C a b | a -> b where ... - -- Then the type - -- forall x y. (C x y) => x - -- is not ambiguous because x is mentioned and x determines y - -- - -- NOTE: In addition, GHC insists that at least one type variable - -- in each constraint is in V. So we disallow a type like - -- forall a. Eq b => b -> b - -- even in a scope where b is in scope. - -- This is the is_free test below. - - tau_vars = tyVarsOfType tau - fds = instFunDepsOfTheta theta - tvFundep = tyVarFunDep fds - extended_tau_vars = oclose tvFundep tau_vars - is_ambig ct_var = (ct_var `elem` forall_tyvars) && - not (ct_var `elemUFM` extended_tau_vars) - is_free ct_var = not (ct_var `elem` forall_tyvars) - - check_pred pred = checkTc (not any_ambig) (ambigErr pred full_ty) `thenTc_` - checkTc (not all_free) (freeErr pred full_ty) - where - ct_vars = varSetElems (tyVarsOfPred pred) - any_ambig = is_source_polytype && any is_ambig ct_vars - all_free = all is_free ct_vars - - -- Check ambiguity only for source-program types, not - -- for types coming from inteface files. The latter can - -- legitimately have ambiguous types. Example - -- class S a where s :: a -> (Int,Int) - -- instance S Char where s _ = (1,1) - -- f:: S a => [a] -> Int -> (Int,Int) - -- f (_::[a]) x = (a*x,b) - -- where (a,b) = s (undefined::a) - -- Here the worker for f gets the type - -- fw :: forall a. S a => Int -> (# Int, Int #) - -- - -- If the list of tv_names is empty, we have a monotype, - -- and then we don't need to check for ambiguity either, - -- because the test can't fail (see is_ambig). - is_source_polytype = case tv_names of - (UserTyVar _ : _) -> True - other -> False + = let + kind_check = kcHsContext ctxt `thenTc_` kcFunResType ty in - mapTc check_pred theta `thenTc_` - returnTc (mkSigmaTy forall_tyvars theta tau) + tcHsTyVars tv_names kind_check $ \ tyvars -> + tcContext ctxt `thenTc` \ theta -> + tcHsType ty `thenTc` \ tau -> + checkAmbiguity full_ty tyvars theta tau `thenTc_` + returnTc (mkSigmaTy tyvars theta tau) + + -- Check for ambiguity + -- forall V. P => tau + -- is ambiguous if P contains generic variables + -- (i.e. one of the Vs) that are not mentioned in tau + -- + -- However, we need to take account of functional dependencies + -- when we speak of 'mentioned in tau'. Example: + -- class C a b | a -> b where ... + -- Then the type + -- forall x y. (C x y) => x + -- is not ambiguous because x is mentioned and x determines y + -- + -- NOTE: In addition, GHC insists that at least one type variable + -- in each constraint is in V. So we disallow a type like + -- forall a. Eq b => b -> b + -- even in a scope where b is in scope. + -- This is the is_free test below. + +checkAmbiguity full_ty forall_tyvars theta tau + = mapTc check_pred theta + where + tau_vars = tyVarsOfType tau + fds = instFunDepsOfTheta theta + tvFundep = tyVarFunDep fds + extended_tau_vars = oclose tvFundep tau_vars + + is_ambig ct_var = (ct_var `elem` forall_tyvars) && + not (ct_var `elemUFM` extended_tau_vars) + is_free ct_var = not (ct_var `elem` forall_tyvars) + + check_pred pred = checkTc (not any_ambig) (ambigErr pred full_ty) `thenTc_` + checkTc (not all_free) (freeErr pred full_ty) + where + ct_vars = varSetElems (tyVarsOfPred pred) + all_free = all is_free ct_vars + any_ambig = is_source_polytype && any is_ambig ct_vars + + -- Notes on the 'is_source_polytype' test above + -- Check ambiguity only for source-program types, not + -- for types coming from inteface files. The latter can + -- legitimately have ambiguous types. Example + -- class S a where s :: a -> (Int,Int) + -- instance S Char where s _ = (1,1) + -- f:: S a => [a] -> Int -> (Int,Int) + -- f (_::[a]) x = (a*x,b) + -- where (a,b) = s (undefined::a) + -- Here the worker for f gets the type + -- fw :: forall a. S a => Int -> (# Int, Int #) + -- + -- If the list of tv_names is empty, we have a monotype, + -- and then we don't need to check for ambiguity either, + -- because the test can't fail (see is_ambig). + is_source_polytype + = case full_ty of + HsForAllTy (Just (UserTyVar _ : _)) _ _ -> True + other -> False \end{code} Help functions for type applications ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} +tc_app :: RenamedHsType -> [RenamedHsType] -> TcM s Type tc_app (HsAppTy ty1 ty2) tys = tc_app ty1 (ty2:tys) tc_app ty tys = tcAddErrCtxt (appKindCtxt pp_app) $ mapTc tcHsType tys `thenTc` \ arg_tys -> - tc_fun_type ty arg_tys + case ty of + HsTyVar fun -> tc_fun_type fun arg_tys + other -> tcHsType ty `thenTc` \ fun_ty -> + returnNF_Tc (mkAppTys fun_ty arg_tys) where pp_app = ppr ty <+> sep (map pprParendHsType tys) @@ -425,7 +469,7 @@ tc_app ty tys -- But not quite; for synonyms it checks the correct arity, and builds a SynTy -- hence the rather strange functionality. -tc_fun_type (HsTyVar name) arg_tys +tc_fun_type name arg_tys = tcLookupTy name `thenTc` \ thing -> case thing of ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys) @@ -447,10 +491,6 @@ tc_fun_type (HsTyVar name) arg_tys n_args = length arg_tys other -> failWithTc (wrongThingErr "type constructor" thing name) - -tc_fun_type ty arg_tys - = tcHsType ty `thenTc` \ fun_ty -> - returnNF_Tc (mkAppTys fun_ty arg_tys) \end{code} @@ -495,10 +535,7 @@ tcClassAssertion ccall_ok assn@(HsPIParam name ty) \begin{code} mkImmutTyVars :: [(Name,Kind)] -> [TyVar] -newSigTyVars :: [(Name,Kind)] -> NF_TcM s [TcTyVar] - mkImmutTyVars pairs = [mkTyVar name kind | (name, kind) <- pairs] -newSigTyVars pairs = listNF_Tc [tcNewSigTyVar name kind | (name,kind) <- pairs] mkTyClTyVars :: Kind -- Kind of the tycon or class -> [HsTyVarBndr Name] diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 9a44d8d..a867a8c 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -104,6 +104,9 @@ tcPat :: (Name -> TcType -> TcM s TcId) -- How to construct a suitable (monomorp %************************************************************************ \begin{code} +tcPat tc_bndr pat@(TypePatIn ty) pat_ty + = failWithTc (badTypePat pat) + tcPat tc_bndr (VarPatIn name) pat_ty = tc_bndr name pat_ty `thenTc` \ bndr_id -> returnTc (VarPat bndr_id, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE) @@ -441,5 +444,7 @@ polyPatSig :: TcType -> SDoc polyPatSig sig_ty = hang (ptext SLIT("Illegal polymorphic type signature in pattern:")) 4 (ppr sig_ty) + +badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat \end{code} diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index c58a6f7..622decc 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -16,7 +16,7 @@ import TcMonad import TcSimplify ( tcSimplifyToDicts, tcSimplifyAndCheck ) import TcType ( zonkTcTypes, zonkTcTyVarToTyVar, newTyVarTy ) import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar ) -import TcMonoType ( kcTyVarScope, kcHsSigType, tcHsSigType, newSigTyVars, checkSigTyVars ) +import TcMonoType ( kcHsSigType, tcHsSigType, tcTyVars, checkSigTyVars ) import TcExpr ( tcExpr ) import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv ) import Inst ( LIE, emptyLIE, plusLIEs, instToId ) @@ -51,11 +51,8 @@ tcRule (HsRule name sig_tvs vars lhs rhs src_loc) newTyVarTy openTypeKind `thenNF_Tc` \ rule_ty -> -- Deal with the tyvars mentioned in signatures - -- Yuk to the UserTyVar - kcTyVarScope (map UserTyVar sig_tvs) - (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tv_kinds -> - newSigTyVars sig_tv_kinds `thenNF_Tc` \ sig_tyvars -> - tcExtendTyVarEnv sig_tyvars ( + tcTyVars sig_tvs (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tyvars -> + tcExtendTyVarEnv sig_tyvars ( -- Ditto forall'd variables mapNF_Tc new_id vars `thenNF_Tc` \ ids -> @@ -65,8 +62,8 @@ tcRule (HsRule name sig_tvs vars lhs rhs src_loc) tcExpr lhs rule_ty `thenTc` \ (lhs', lhs_lie) -> tcExpr rhs rule_ty `thenTc` \ (rhs', rhs_lie) -> - returnTc (ids, lhs', rhs', lhs_lie, rhs_lie) - ) `thenTc` \ (ids, lhs', rhs', lhs_lie, rhs_lie) -> + returnTc (sig_tyvars, ids, lhs', rhs', lhs_lie, rhs_lie) + ) `thenTc` \ (sig_tyvars, ids, lhs', rhs', lhs_lie, rhs_lie) -> -- Check that LHS has no overloading at all tcSimplifyToDicts lhs_lie `thenTc` \ (lhs_dicts, lhs_binds) -> diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index fc9757f..3acc71c 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -163,7 +163,8 @@ import VarSet import FiniteMap import CmdLineOpts ( opt_GlasgowExts ) import Outputable -import Util +import ListSetOps ( equivClasses ) +import Util ( zipEqual, mapAccumL ) import List ( partition ) import Maybe ( fromJust ) import Maybes ( maybeToBool ) diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index f0518d3..c9699c9 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -29,10 +29,11 @@ import TcMonoType ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClT import TcType ( TcKind, newKindVar, zonkKindEnv ) import TcUnify ( unifyKind ) +import TcInstDcls ( tcAddDeclCtxt ) import Type ( Kind, mkArrowKind, boxedTypeKind, zipFunTys ) import Variance ( calcTyConArgVrcs ) import Class ( Class, mkClass, classTyCon ) -import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..), mkSynTyCon, mkAlgTyCon, mkClassTyCon ) +import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..), mkSynTyCon, mkAlgTyConRep, mkClassTyCon ) import DataCon ( isNullaryDataCon ) import Var ( varName ) import FiniteMap @@ -46,6 +47,8 @@ import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, uniqSetToList ) import ErrUtils ( Message ) import Unique ( Unique, Uniquable(..) ) +import HsDecls ( fromClassDeclNameList ) +import Generics ( mkTyConGenInfo ) \end{code} @@ -78,7 +81,6 @@ tcGroups unf_env (group:groups) Dealing with a group ~~~~~~~~~~~~~~~~~~~~ - Consider a mutually-recursive group, binding a type constructor T and a class C. @@ -156,8 +158,6 @@ tcGroup unf_env scc AcyclicSCC decl -> [decl] CyclicSCC decls -> decls -tcTyClDecl1 :: ValueEnv -> RenamedTyClDecl -> TcM s (Name, TyThingDetails) - tcTyClDecl1 unf_env decl = tcAddDeclCtxt decl $ if isClassDecl decl then @@ -180,11 +180,11 @@ getInitialKind (TySynonym name tyvars _ _) newKindVar `thenNF_Tc` \ result_kind -> returnNF_Tc (name, mk_kind arg_kinds result_kind) -getInitialKind (TyData _ _ name tyvars _ _ _ _ _) +getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _ _) = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds -> returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind) -getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ _ _ _ _) +getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ _ ) = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds -> returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind) @@ -220,7 +220,7 @@ kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc) kcHsType rhs `thenTc` \ rhs_kind -> unifyKind result_kind rhs_kind -kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ _ loc) +kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ _ loc _ _) = tcAddDeclCtxt decl $ kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind -> kcHsContext context `thenTc_` @@ -234,7 +234,7 @@ kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ _ loc) kcTyClDecl decl@(ClassDecl context class_name hs_tyvars fundeps class_sigs - _ _ _ _ _ _ loc) + _ _ _ loc) = tcAddDeclCtxt decl $ kcTyClDeclBody class_name hs_tyvars $ \ result_kind -> kcHsContext context `thenTc_` @@ -283,13 +283,14 @@ buildTyConOrClass is_rec kenv rec_vrcs rec_details argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon buildTyConOrClass is_rec kenv rec_vrcs rec_details - (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ _ src_loc) + (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ _ src_loc name1 name2) = (tycon_name, ATyCon tycon) where - tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs + tycon = mkAlgTyConRep tycon_name tycon_kind tyvars ctxt argvrcs data_cons nconstrs derived_classes - flavour is_rec + flavour is_rec gen_info + gen_info = mkTyConGenInfo tycon name1 name2 DataTyDetails ctxt data_cons derived_classes = lookupNameEnv_NF rec_details tycon_name @@ -304,10 +305,11 @@ buildTyConOrClass is_rec kenv rec_vrcs rec_details buildTyConOrClass is_rec kenv rec_vrcs rec_details (ClassDecl context class_name - tyvar_names fundeps class_sigs def_methods pragmas - tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc) + tyvar_names fundeps class_sigs def_methods pragmas + name_list src_loc) = (class_name, AClass clas) where + (tycon_name, _, _, _) = fromClassDeclNameList name_list clas = mkClass class_name tyvars fds sc_theta sc_sel_ids op_items tycon @@ -386,7 +388,7 @@ Edges in Type/Class decls mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique]) -mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _ _) +mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _) = Just (decl, getUnique name, map getUnique (catMaybes (map get_clas ctxt))) mk_cls_edges other_decl = Nothing @@ -394,7 +396,7 @@ mk_cls_edges other_decl ---------------------------------------------------- mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique]) -mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _) +mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _ _ _) = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` get_cons condecls `unionUniqSets` get_deriv derivs)) @@ -402,7 +404,7 @@ mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _) mk_edges decl@(TySynonym name _ rhs _) = (decl, getUnique name, uniqSetToList (get_ty rhs)) -mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _ _ _ _) +mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _) = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` get_sigs sigs)) @@ -467,23 +469,6 @@ set_name name = unitUniqSet (getUnique name) %************************************************************************ \begin{code} -tcAddDeclCtxt decl thing_inside - = tcAddSrcLoc loc $ - tcAddErrCtxt ctxt $ - thing_inside - where - (name, loc, thing) - = case decl of - (ClassDecl _ name _ _ _ _ _ _ _ _ _ loc) -> (name, loc, "class") - (TySynonym name _ _ loc) -> (name, loc, "type synonym") - (TyData NewType _ name _ _ _ _ _ loc) -> (name, loc, "newtype") - (TyData DataType _ name _ _ _ _ _ loc) -> (name, loc, "data type") - - ctxt = hsep [ptext SLIT("In the"), text thing, - ptext SLIT("declaration for"), quotes (ppr name)] -\end{code} - -\begin{code} typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message typeCycleErr syn_cycles diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 16d1845..2281538 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -20,8 +20,8 @@ import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext ) import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) import BasicTypes ( NewOrData(..) ) -import TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, kcTyVarScope, tcClassContext, - kcHsContext, kcHsSigType, mkImmutTyVars +import TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, tcHsTyVars, tcClassContext, + kcHsContext, kcHsSigType ) import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcLookupValueByKey, TyThing(..), TyThingDetails(..) ) import TcMonad @@ -37,7 +37,7 @@ import Var ( Id, TyVar ) import Name ( Name, isLocallyDefined, NamedThing(..) ) import Outputable import TyCon ( TyCon, isSynTyCon, isNewTyCon, - tyConDataConsIfAvailable, tyConTyVars + tyConDataConsIfAvailable, tyConTyVars, tyConGenIds ) import Type ( tyVarsOfTypes, splitFunTy, applyTys, mkTyConApp, mkTyVarTys, mkForAllTys, @@ -46,7 +46,7 @@ import Type ( tyVarsOfTypes, splitFunTy, applyTys, import TysWiredIn ( unitTy ) import VarSet ( intersectVarSet, isEmptyVarSet ) import PrelNames ( unpackCStringIdKey, unpackCStringUtf8IdKey ) -import Util ( equivClasses ) +import ListSetOps ( equivClasses ) \end{code} %************************************************************************ @@ -75,7 +75,7 @@ tcTyDecl1 (TySynonym tycon_name tyvar_names rhs src_loc) returnTc (tycon_name, SynTyDetails rhs_ty) -tcTyDecl1 (TyData new_or_data context tycon_name _ con_decls _ derivings _ src_loc) +tcTyDecl1 (TyData new_or_data context tycon_name _ con_decls _ derivings _ src_loc name1 name2) = tcLookupTy tycon_name `thenNF_Tc` \ (ATyCon tycon) -> let tyvars = tyConTyVars tycon @@ -142,11 +142,7 @@ tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ClassContext -> RenamedConDecl -> tcConDecl new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc) = tcAddSrcLoc src_loc $ - kcTyVarScope ex_tvs (kcConDetails ex_ctxt details) `thenTc` \ ex_tv_kinds -> - let - ex_tyvars = mkImmutTyVars ex_tv_kinds - in - tcExtendTyVarEnv ex_tyvars $ + tcHsTyVars ex_tvs (kcConDetails ex_ctxt details) $ \ ex_tyvars -> tcClassContext ex_ctxt `thenTc` \ ex_theta -> case details of VanillaCon btys -> tc_datacon ex_tyvars ex_theta btys @@ -231,8 +227,8 @@ mkImplicitDataBinds (tycon : tycons) mkImplicitDataBinds_one tycon = mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids -> let - unf_ids = sel_ids ++ data_con_wrapper_ids - all_ids = map dataConId data_cons ++ unf_ids + unf_ids = sel_ids ++ data_con_wrapper_ids ++ gen_ids + all_ids = map dataConId data_cons ++ unf_ids -- For the locally-defined things -- we need to turn the unfoldings inside the selector Ids into bindings, @@ -245,7 +241,7 @@ mkImplicitDataBinds_one tycon data_cons = tyConDataConsIfAvailable tycon -- Abstract types mean we don't bring the -- data cons into scope, which should be fine - + gen_ids = tyConGenIds tycon data_con_wrapper_ids = map dataConWrapId data_cons fields = [ (con, field) | con <- data_cons, diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 02585be..6a4680f 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -57,7 +57,7 @@ import PrimRep ( PrimRep(VoidRep) ) import Var ( TyVar, tyVarKind, tyVarName, isTyVar, isMutTyVar, mkTyVar ) -- others: -import TcMonad +import TcMonad -- TcType, amongst others import TysWiredIn ( voidTy ) import Name ( Name, NamedThing(..), setNameUnique, mkSysLocalName, diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index b3e47e4..d7d8146 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -6,6 +6,7 @@ \begin{code} module Class ( Class, ClassOpItem, ClassPred, ClassContext, FunDep, + DefMeth (..), mkClass, classTyVars, classArity, classKey, className, classSelIds, classTyCon, @@ -58,10 +59,14 @@ type ClassContext = [ClassPred] type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where ... -- Here fun-deps are [([a,b],[c]), ([a,c],[b])] -type ClassOpItem = (Id, -- Selector function; contains unfolding - Id, -- Default methods - Bool) -- True <=> an explicit default method was - -- supplied in the class decl +type ClassOpItem = (Id, DefMeth Id) + -- Selector function; contains unfolding + -- Default-method info + +data DefMeth id = NoDefMeth -- No default method + | DefMeth id -- A polymorphic default method (named id) + | GenDefMeth -- A generic default method + deriving Eq \end{code} The @mkClass@ function fills in the indirect superclasses. @@ -100,7 +105,7 @@ classArity clas = length (classTyVars clas) -- Could memoise this classSelIds (Class {classSCSels = sc_sels, classOpStuff = op_stuff}) - = sc_sels ++ [op_sel | (op_sel, _, _) <- op_stuff] + = sc_sels ++ [op_sel | (op_sel, _) <- op_stuff] classTvsFds c = (classTyVars c, classFunDeps c) diff --git a/ghc/compiler/types/Generics.hi-boot-5 b/ghc/compiler/types/Generics.hi-boot-5 new file mode 100644 index 0000000..3a9ab2c --- /dev/null +++ b/ghc/compiler/types/Generics.hi-boot-5 @@ -0,0 +1,4 @@ +__interface Generics 1 0 where +__export Generics mkTyConGenInfo ; + +1 mkTyConGenInfo :: TyCon.TyCon -> Name.Name -> Name.Name -> PrelMaybe.Maybe (BasicTypes.EP Var.Id) ; diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs new file mode 100644 index 0000000..9be3138 --- /dev/null +++ b/ghc/compiler/types/Generics.lhs @@ -0,0 +1,478 @@ +\begin{code} +module Generics ( mkTyConGenInfo, mkGenericRhs, + validGenericInstanceType, validGenericMethodType + ) where + + +import CmdLineOpts ( opt_GlasgowExts ) +import RnHsSyn ( RenamedHsExpr ) +import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch ) + +import Type ( Type, isUnLiftedType, applyTys, tyVarsOfType, tyVarsOfTypes, + mkTyVarTys, mkForAllTys, mkTyConApp, splitFunTys, + mkFunTy, funResultTy, isTyVarTy, splitForAllTys, + splitSigmaTy, getTyVar, splitTyConApp_maybe, funTyCon + ) + +import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId ) + +import TyCon ( TyCon, tyConTyVars, tyConDataConsIfAvailable, + tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon + ) +import Name ( Name, mkSysLocalName ) +import CoreSyn ( mkLams, Expr(..), CoreExpr, AltCon(..), Note(..), + mkConApp, Alt, Bind (..), mkTyApps, mkVarApps ) +import BasicTypes ( RecFlag(..), EP(..), Boxity(..) ) +import Var ( TyVar ) +import VarSet ( isEmptyVarSet ) +import Id ( Id, mkTemplateLocal, mkTemplateLocals, idType, idName, + mkTemplateLocalsNum, mkVanillaId, mkId + ) +import TysWiredIn ( genericTyCons, + genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon, + inlDataCon, crossTyCon, crossDataCon + ) +import IdInfo ( vanillaIdInfo, setUnfoldingInfo ) +import CoreUnfold ( mkTopUnfolding ) + +import Unique ( Uniquable(..), mkBuiltinUnique ) +import SrcLoc ( mkBuiltinSrcLoc ) +import Maybes ( maybeToBool, expectJust ) +import Outputable + +#include "HsVersions.h" +\end{code} + +Roadmap of what's where in the Generics work. +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Parser +No real checks. + +RnSource.rnHsType + Checks that HsNumTy has a "1" in it. + +TcInstDcls.mkGenericInstance: + Checks for invalid type patterns, such as f {| Int |} + +TcClassDcl.tcClassSig + Checks for a method type that is too complicated; + e.g. has for-alls or lists in it + We could lift this restriction + +TcClassDecl.mkDefMethRhs + Checks that the instance type is simple, in an instance decl + where we let the compiler fill in a generic method. + e.g. instance C (T Int) + is not valid if C has generic methods. + +TcClassDecl.checkGenericClassIsUnary + Checks that we don't have generic methods in a multi-parameter class + +TcClassDecl.checkDefaultBinds + Checks that all the equations for a method in a class decl + are generic, or all are non-generic + + + +Checking that the type constructors which are present in Generic +patterns (not Unit, this is done differently) is done in mk_inst_info +(TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that +HsOpTy is tied to Generic definitions which is not a very good design +feature, indeed a bug. However, the check is easy to move from +tcHsType back to mk_inst_info and everything will be fine. Also see +bug #5. + +Generics.lhs + +Making generic information to put into a tycon. Constructs the +representation type, which, I think, are not used later. Perhaps it is +worth removing them from the GI datatype. Although it does get used in +the construction of conversion functions (internally). + +TyCon.lhs + +Just stores generic information, accessible by tyConGenInfo or tyConGenIds. + +TysWiredIn.lhs + +Defines generic and other type and data constructors. + +This is sadly incomplete, but will be added to. + + +Bugs & shortcomings of existing implementation: +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +2. Another pretty big bug I dscovered at the last minute when I was +testing the code is that at the moment the type variable of the class +is scoped over the entire declaration, including the patterns. For +instance, if I have the following code, + +class Er a where + ... + er {| Plus a b |} (Inl x) (Inl y) = er x y + er {| Plus a b |} (Inr x) (Inr y) = er x y + er {| Plus a b |} _ _ = False + +and I print out the types of the generic patterns, I get the +following. Note that all the variable names for "a" are the same, +while for "b" they are all different. + +check_ty + [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-}, + std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-}, + std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}] + +This is a bug as if I change the code to + + er {| Plus c b |} (Inl x) (Inl y) = er x y + +all the names come out to be different. + +Thus, all the types (Plus a b) come out to be different, so I cannot +compare them and test whether they are all the same and thus cannot +return an error if the type variables are different. + +Temporary fix/hack. I am not checking for this, I just assume they are +the same, see line "check_ty = True" in TcInstDecls. When we resolve +the issue with variables, though - I assume that we will make them to +be the same in all the type patterns, jus uncomment the check and +everything should work smoothly. + +Hence, I have also left the rather silly construction of: +* extracting all the type variables from all the types +* putting them *all* into the environment +* typechecking all the types +* selecting one of them and using it as the instance_ty. + +(the alternative is to make sure that all the types are the same, +taking one, extracting its variables, putting them into the environment, +type checking it, using it as the instance_ty) + +6. What happens if we do not supply all of the generic patterns? At +the moment, the compiler crashes with an error message "Non-exhaustive +patterns in a generic declaration" + + +What has not been addressed: +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Contexts. In the generated instance declarations for the 3 primitive +type constructors, we need contexts. It is unclear what those should +be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b) + +Type application. We have type application in expressions +(essentially) on the lhs of an equation. Do we want to allow it on the +RHS? + +Scoping of type variables in a generic definition. At the moment, (see +TcInstDecls) we extract the type variables inside the type patterns +and add them to the environment. See my bug #2 above. This seems pretty +important. + + + +%************************************************************************ +%* * +\subsection{Getting the representation type out} +%* * +%************************************************************************ + +\begin{code} +validGenericInstanceType :: Type -> Bool + -- Checks for validity of the type pattern in a generic + -- declaration. It's ok to have + -- f {| a + b |} ... + -- but it's not OK to have + -- f {| a + Int |} + +validGenericInstanceType inst_ty + = case splitTyConApp_maybe inst_ty of + Just (tycon, tys) -> all isTyVarTy tys && tycon `elem` genericTyCons + Nothing -> False + +validGenericMethodType :: Type -> Bool + -- At the moment we only allow method types built from + -- * type variables + -- * function arrow + -- * boxed tuples + -- * an arbitrary type not involving the class type variables +validGenericMethodType ty = valid ty + +valid ty + | isTyVarTy ty = True + | not (null arg_tys) = all valid arg_tys && valid res_ty + | no_tyvars_in_ty = True + | otherwise = isBoxedTupleTyCon tc && all valid tys + where + (arg_tys, res_ty) = splitFunTys ty + no_tyvars_in_ty = isEmptyVarSet (tyVarsOfType ty) + Just (tc,tys) = splitTyConApp_maybe ty +\end{code} + + +%************************************************************************ +%* * +\subsection{Generating representation types} +%* * +%************************************************************************ + +\begin{code} +mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id) +-- mkTyConGenInfo is called twice +-- once from TysWiredIn for Tuples +-- once the typechecker TcTyDecls +-- to generate generic types and conversion functions for all datatypes. +-- +-- Must only be called with an algebraic type. +-- +-- The two names are the names constructed by the renamer +-- for the fromT and toT conversion functions. + +mkTyConGenInfo tycon from_name to_name + | not opt_GlasgowExts + = Nothing + + | null datacons -- Abstractly imported types don't have + = Nothing -- to/from operations, (and should not need them) + + -- If any of the constructor has an unboxed type as argument + -- then we can't build the embedding-projection pair, because + -- it relies on instantiating *polymorphic* sum and product types + -- at the argument types of the constructors + | any (any isUnLiftedType . dataConOrigArgTys) datacons + = Nothing + + | otherwise + = Just (EP { fromEP = mkId from_name from_ty from_id_info, + toEP = mkId to_name to_ty to_id_info }) + where + tyvars = tyConTyVars tycon -- [a, b, c] + datacons = tyConDataConsIfAvailable tycon -- [C, D] + tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c + tyvar_tys = mkTyVarTys tyvars + + from_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn + to_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn + + from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty) + to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty) + + (from_fn, to_fn, rep_ty) + | isNewTyCon tycon + = ( mkLams tyvars $ Lam x $ Note (Coerce newrep_ty tycon_ty) (Var x), + Var (dataConWrapId the_datacon), + newrep_ty ) + + | otherwise + = ( mkLams tyvars $ Lam x $ Case (Var x) x from_alts, + mkLams tyvars $ Lam rep_var to_inner, + idType rep_var ) + + -- x :: T a b c + x = mkTemplateLocal 1 tycon_ty + + ---------------------- + -- Newtypes only + [the_datacon] = datacons + newrep_ty = applyTys (expectJust "mkGenTyConInfo" (newTyConRep tycon)) tyvar_tys + + ---------------------- + -- Non-newtypes only + -- Recurse over the sum first + -- The "2" is the first free unique + (from_alts, to_inner, rep_var) = mk_sum_stuff 2 tyvars datacons + + + +---------------------------------------------------- +-- Dealing with sums +---------------------------------------------------- +mk_sum_stuff :: Int -- Base for generating unique names + -> [TyVar] -- Type variables over which the tycon is abstracted + -> [DataCon] -- The data constructors + -> ([Alt Id], CoreExpr, Id) + +-- 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 i tyvars [datacon] + = ([from_alt], to_body_fn app_exp, rep_var) + where + types = dataConOrigArgTys datacon + datacon_vars = mkTemplateLocalsNum i types + new_i = i + length types + app_exp = mkVarApps (Var (dataConId datacon)) (tyvars ++ datacon_vars) + from_alt = (DataAlt datacon, datacon_vars, from_alt_rhs) + + (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff new_i datacon_vars + +mk_sum_stuff i tyvars datacons + = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts, + Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body), + (DataAlt inrDataCon, [r_rep_var], r_to_body)], + rep_var) + where + (l_datacons, r_datacons) = splitInHalf datacons + (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff (i+2) tyvars l_datacons + (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff (i+2) tyvars r_datacons + rep_tys = [idType l_rep_var, idType r_rep_var] + rep_ty = mkTyConApp plusTyCon rep_tys + rep_var = mkTemplateLocal i rep_ty + + wrap :: DataCon -> [Alt Id] -> [Alt Id] + -- Wrap an application of the Inl or Inr constructor round each alternative + wrap datacon alts + = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts] + where + datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys + + +-- This constructs the c_of datatype from a DataCon and a Type +-- The identity function at the moment. +cOfConstr :: DataCon -> Type -> Type +cOfConstr y z = z + + +---------------------------------------------------- +-- Dealing with products +---------------------------------------------------- +mk_prod_stuff :: Int -- Base for unique names + -> [Id] -- arg-ids; args of the original user-defined constructor + -- They are bound enclosing from_rhs + -- Please bind these in the to_body_fn + -> (Int, -- Depleted unique-name supply + CoreExpr, -- from-rhs: puts together the representation from the arg_ids + CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation + Id) -- The rep-id; please bind this to the representation + +-- For example: +-- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c), +-- \x -> case abc of { a :*: bc -> +-- case bc of { b :*: c -> +-- x, +-- abc ) + +-- We need to use different uqiques in the branches +-- because the returned to_body_fns are nested. +-- Hence the returned unqique-name supply + +mk_prod_stuff i [] -- Unit case + = (i, + Var (dataConWrapId genUnitDataCon), + \x -> x, + mkTemplateLocal i (mkTyConApp genUnitTyCon [])) + +mk_prod_stuff i [arg_var] -- Singleton case + = (i, Var arg_var, \x -> x, arg_var) + +mk_prod_stuff i arg_vars -- Two or more + = (r_i, + mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]), + \x -> Case (Var rep_var) rep_var + [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))], + rep_var) + where + (l_arg_vars, r_arg_vars) = splitInHalf arg_vars + (l_i, l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff (i+1) l_arg_vars + (r_i, r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff l_i r_arg_vars + rep_var = mkTemplateLocal i (mkTyConApp crossTyCon rep_tys) + rep_tys = [idType l_rep_var, idType r_rep_var] +\end{code} + +A little utility function + +\begin{code} +splitInHalf :: [a] -> ([a],[a]) +splitInHalf list = (left, right) + where + half = length list `div` 2 + left = take half list + right = drop half list +\end{code} + +%************************************************************************ +%* * +\subsection{Generating the RHS of a generic default method} +%* * +%************************************************************************ + +Generating the Generic default method. Uses the bimaps to generate the +actual method. All of this is rather incomplete, but it would be nice +to make even this work. + +\begin{code} +mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr +mkGenericRhs sel_id tyvar tycon + = HsApp (toEP bimap) (HsVar (idName sel_id)) + where + -- Initialising the "Environment" with the from/to functions + -- on the datatype (actually tycon) in question + Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed + ep = EP (HsVar (idName from)) (HsVar (idName to)) + + -- Takes out the ForAll and the Class rstrictions in front of the + -- type of the method. + (_,_,op_ty) = splitSigmaTy (idType sel_id) + + -- Now we probably have a tycon in front + -- of us, quite probably a FunTyCon. + bimap = generate_bimap (tyvar, ep) op_ty + +-- EP is the environment of to/from bimaps, but as we only have one type +-- variable at the moment, there is only one EP. + +------------------- +generate_bimap :: (TyVar, EP RenamedHsExpr) -> Type -> EP RenamedHsExpr +-- Top level case - splitting the TyCon. +generate_bimap (tv,ep) ty | isTyVarTy ty = ASSERT( getTyVar "Generics.generate_bimap" ty == tv) ep + | otherwise = bimapApp (tv,ep) (splitTyConApp_maybe ty) + +------------------- +bimapApp :: (TyVar, EP RenamedHsExpr) -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr +bimapApp ep Nothing = panic "TcClassDecl: Type Application!" +bimapApp ep (Just (tycon, ty_args)) + | tycon == funTyCon = bimapArrow arg_eps + | isBoxedTupleTyCon tycon = bimapTuple arg_eps + | otherwise = -- Otherwise validGenericMethodType will + -- have checked that the type is a constant type + ASSERT( isEmptyVarSet (tyVarsOfTypes ty_args) ) + EP idexpr idexpr + where + arg_eps = map (generate_bimap ep) ty_args + +------------------- +bimapArrow [ep1, ep2] + = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body, + toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body } + where + from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2)) + to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2)) + +------------------- +bimapTuple eps + = EP { fromEP = mk_hs_lam [tuple_pat] from_body, + toEP = mk_hs_lam [tuple_pat] to_body } + where + names = take (length eps) genericNames + tuple_pat = TuplePatIn (map VarPatIn names) Boxed + eps_w_names = eps `zip` names + to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed + from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed + +------------------- +genericNames :: [Name] +genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]] +(g1:g2:g3:_) = genericNames + +mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body Nothing mkBuiltinSrcLoc)) +idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3) +\end{code} diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index b878694..c4cbcd5 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -13,7 +13,7 @@ module TyCon( isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, isRecursiveTyCon, newTyConRep, - mkAlgTyCon, + mkAlgTyConRep, --mkAlgTyCon, mkClassTyCon, mkFunTyCon, mkPrimTyCon, @@ -24,6 +24,7 @@ module TyCon( setTyConName, + tyConName, tyConKind, tyConUnique, tyConTyVars, @@ -39,7 +40,10 @@ module TyCon( maybeTyConSingleCon, - matchesTyCon + matchesTyCon, + + -- Generics + tyConGenIds, tyConGenInfo ) where #include "HsVersions.h" @@ -50,9 +54,11 @@ import {-# SOURCE #-} TypeRep ( Type, Kind, SuperKind ) import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon ) + import Class ( Class, ClassContext ) -import Var ( TyVar ) -import BasicTypes ( Arity, NewOrData(..), RecFlag(..), Boxity(..), isBoxed ) +import Var ( TyVar, Id ) +import BasicTypes ( Arity, NewOrData(..), RecFlag(..), Boxity(..), + isBoxed, EP(..) ) import Name ( Name, nameUnique, NamedThing(getName) ) import PrelNames ( Unique, Uniquable(..), anyBoxConKey ) import PrimRep ( PrimRep(..), isFollowableRep ) @@ -110,6 +116,11 @@ data TyCon algTyConRec :: RecFlag, -- Tells whether the data type is part of -- a mutually-recursive group or not + genInfo :: Maybe (EP Id), -- Convert T <-> Tring + -- Some TyCons don't have it; + -- e.g. the TyCon for a Class dictionary, + -- and TyCons with unboxed arguments + algTyConClass :: Bool -- True if this tycon comes from a class declaration } @@ -131,7 +142,8 @@ data TyCon tyConArity :: Arity, tyConBoxed :: Boxity, tyConTyVars :: [TyVar], - dataCon :: DataCon + dataCon :: DataCon, + genInfo :: Maybe (EP Id) -- Generic type and conv funs } | SynTyCon { @@ -216,8 +228,23 @@ mkFunTyCon name kind tyConKind = kind, tyConArity = 2 } - -mkAlgTyCon name kind tyvars theta argvrcs cons ncons derivs flavour rec + +tyConGenInfo :: TyCon -> Maybe (EP Id) +tyConGenInfo (AlgTyCon { genInfo = info }) = info +tyConGenInfo (TupleTyCon { genInfo = info }) = info +tyConGenInfo other = Nothing + +tyConGenIds :: TyCon -> [Id] +-- Returns the generic-programming Ids; these Ids need bindings +tyConGenIds tycon = case tyConGenInfo tycon of + Nothing -> [] + Just (EP from to) -> [from,to] + +-- This is the making of a TyCon. Just the same as the old mkAlgTyCon, +-- but now you also have to pass in the generic information about the type +-- constructor - you can get hold of it easily (see Generics module) +mkAlgTyConRep name kind tyvars theta argvrcs cons ncons derivs flavour rec + gen_info = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -231,7 +258,8 @@ mkAlgTyCon name kind tyvars theta argvrcs cons ncons derivs flavour rec algTyConDerivings = derivs, algTyConClass = False, algTyConFlavour = flavour, - algTyConRec = rec + algTyConRec = rec, + genInfo = gen_info } mkClassTyCon name kind tyvars argvrcs con clas flavour @@ -248,11 +276,12 @@ mkClassTyCon name kind tyvars argvrcs con clas flavour algTyConDerivings = [], algTyConClass = True, algTyConFlavour = flavour, - algTyConRec = NonRecursive + algTyConRec = NonRecursive, + genInfo = Nothing } -mkTupleTyCon name kind arity tyvars con boxed +mkTupleTyCon name kind arity tyvars con boxed gen_info = TupleTyCon { tyConUnique = nameUnique name, tyConName = name, @@ -260,7 +289,8 @@ mkTupleTyCon name kind arity tyvars con boxed tyConArity = arity, tyConBoxed = boxed, tyConTyVars = tyvars, - dataCon = con + dataCon = con, + genInfo = gen_info } mkPrimTyCon name kind arity arg_vrcs rep @@ -285,6 +315,7 @@ mkSynTyCon name kind arity tyvars rhs argvrcs } setTyConName tc name = tc {tyConName = name, tyConUnique = nameUnique name} + \end{code} \begin{code} @@ -459,7 +490,7 @@ instance Uniquable TyCon where getUnique tc = tyConUnique tc instance Outputable TyCon where - ppr tc = ppr (getName tc) + ppr tc = ppr (getName tc) instance NamedThing TyCon where getName = tyConName @@ -486,3 +517,6 @@ matchesTyCon tc1 tc2 = uniq1 == uniq2 || uniq1 == anyBoxConKey uniq1 = tyConUnique tc1 uniq2 = tyConUnique tc2 \end{code} + + + diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index aad3228..ef37be2 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -737,6 +737,7 @@ splitRhoTy ty = split ty ty [] split orig_ty ty ts = (reverse ts, orig_ty) \end{code} + isSigmaType returns true of any qualified type. It doesn't *necessarily* have any foralls. E.g. f :: (?x::Int) => Int -> Int @@ -811,8 +812,8 @@ typeKind (ForAllTy tv ty) = typeKind ty Free variables of a type ~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tyVarsOfType :: Type -> TyVarSet +tyVarsOfType :: Type -> TyVarSet tyVarsOfType (TyVarTy tv) = unitVarSet tv tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index 53e282c..6e29873 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -30,6 +30,7 @@ import VarSet import Name ( Name, Provenance(..), ExportFlag(..), mkWiredInTyConName, mkGlobalName, mkKindOccFS, tcName, ) +import OccName ( mkSrcOccFS, tcName ) import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon, ) @@ -297,7 +298,7 @@ mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds We define a few wired-in type constructors here to avoid module knots \begin{code} -funTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("(->)") funTyCon +funTyConName = mkWiredInTyConName funTyConKey pREL_GHC (mkSrcOccFS tcName SLIT("(->)")) funTyCon funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] boxedTypeKind) \end{code} diff --git a/ghc/compiler/utils/ListSetOps.lhs b/ghc/compiler/utils/ListSetOps.lhs index 3b42040..db43da5 100644 --- a/ghc/compiler/utils/ListSetOps.lhs +++ b/ghc/compiler/utils/ListSetOps.lhs @@ -5,28 +5,220 @@ \begin{code} module ListSetOps ( - unionLists, - --UNUSED: intersectLists, - minusList + unionLists, minusList, + + -- Association lists + Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, + emptyAssoc, unitAssoc, mapAssoc, plusAssoc_C, extendAssoc_C, + mkLookupFun, assocElts, + + -- Duplicate handling + hasNoDups, runs, removeDups, removeDupsEq, + equivClasses, equivClassesByUniq ) where #include "HsVersions.h" -import Util ( isn'tIn ) +import Outputable +import Unique ( Unique ) +import UniqFM ( eltsUFM, emptyUFM, addToUFM_C ) +import Util ( isn'tIn, isIn, mapAccumR, sortLt ) import List ( union ) \end{code} + +%************************************************************************ +%* * +\subsection{Treating lists as sets} +%* * +%************************************************************************ + \begin{code} unionLists :: (Eq a) => [a] -> [a] -> [a] unionLists = union \end{code} Everything in the first list that is not in the second list: + \begin{code} minusList :: (Eq a) => [a] -> [a] -> [a] minusList xs ys = [ x | x <- xs, x `not_elem` ys] where not_elem = isn'tIn "minusList" +\end{code} + + +%************************************************************************ +%* * +\subsection[Utils-assoc]{Association lists} +%* * +%************************************************************************ + +Inefficient finite maps based on association lists and equality. + +\begin{code} +type Assoc a b = [(a,b)] -- A finite mapping based on equality and association lists + +emptyAssoc :: Assoc a b +unitAssoc :: a -> b -> Assoc a b +assocElts :: Assoc a b -> [(a,b)] +assoc :: (Eq a) => String -> Assoc a b -> a -> b +assocDefault :: (Eq a) => b -> Assoc a b -> a -> b +assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b +assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b +assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b +mapAssoc :: (b -> c) -> Assoc a b -> Assoc a c +extendAssoc_C :: (Eq a) => (b -> b -> b) -> Assoc a b -> (a,b) -> Assoc a b +plusAssoc_C :: (Eq a) => (b -> b -> b) -> Assoc a b -> Assoc a b -> Assoc a b + -- combining fn takes (old->new->result) + +emptyAssoc = [] +unitAssoc a b = [(a,b)] +assocElts xs = xs + +assocDefaultUsing eq deflt ((k,v) : rest) key + | k `eq` key = v + | otherwise = assocDefaultUsing eq deflt rest key + +assocDefaultUsing eq deflt [] key = deflt +assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key +assocDefault deflt list key = assocDefaultUsing (==) deflt list key +assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key + +assocMaybe alist key + = lookup alist + where + lookup [] = Nothing + lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest + +mapAssoc f alist = [(key, f val) | (key,val) <- alist] + +plusAssoc_C combine [] new = new -- Shortcut for common case +plusAssoc_C combine old new = foldl (extendAssoc_C combine) old new + +extendAssoc_C combine old_list (new_key, new_val) + = go old_list + where + go [] = [(new_key, new_val)] + go ((old_key, old_val) : old_list) + | new_key == old_key = ((old_key, old_val `combine` new_val) : old_list) + | otherwise = (old_key, old_val) : go old_list \end{code} + + +@mkLookupFun eq alist@ is a function which looks up +its argument in the association list @alist@, returning a Maybe type. +@mkLookupFunDef@ is similar except that it is given a value to return +on failure. + +\begin{code} +mkLookupFun :: (key -> key -> Bool) -- Equality predicate + -> [(key,val)] -- The assoc list + -> key -- The key + -> Maybe val -- The corresponding value + +mkLookupFun eq alist s + = case [a | (s',a) <- alist, s' `eq` s] of + [] -> Nothing + (a:_) -> Just a +\end{code} + + +%************************************************************************ +%* * +\subsection[Utils-dups]{Duplicate-handling} +%* * +%************************************************************************ + +\begin{code} +hasNoDups :: (Eq a) => [a] -> Bool + +hasNoDups xs = f [] xs + where + f seen_so_far [] = True + f seen_so_far (x:xs) = if x `is_elem` seen_so_far then + False + else + f (x:seen_so_far) xs + + is_elem = isIn "hasNoDups" +\end{code} + +\begin{code} +equivClasses :: (a -> a -> Ordering) -- Comparison + -> [a] + -> [[a]] + +equivClasses cmp stuff@[] = [] +equivClasses cmp stuff@[item] = [stuff] +equivClasses cmp items + = runs eq (sortLt lt items) + where + eq a b = case cmp a b of { EQ -> True; _ -> False } + lt a b = case cmp a b of { LT -> True; _ -> False } +\end{code} + +The first cases in @equivClasses@ above are just to cut to the point +more quickly... + +@runs@ groups a list into a list of lists, each sublist being a run of +identical elements of the input list. It is passed a predicate @p@ which +tells when two elements are equal. + +\begin{code} +runs :: (a -> a -> Bool) -- Equality + -> [a] + -> [[a]] + +runs p [] = [] +runs p (x:xs) = case (span (p x) xs) of + (first, rest) -> (x:first) : (runs p rest) +\end{code} + +\begin{code} +removeDups :: (a -> a -> Ordering) -- Comparison function + -> [a] + -> ([a], -- List with no duplicates + [[a]]) -- List of duplicate groups. One representative from + -- each group appears in the first result + +removeDups cmp [] = ([], []) +removeDups cmp [x] = ([x],[]) +removeDups cmp xs + = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') -> + (xs', dups) } + where + collect_dups dups_so_far [x] = (dups_so_far, x) + collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x) + +removeDupsEq :: Eq a => [a] -> ([a], [[a]]) +-- Same, but with only equality +-- It's worst case quadratic, but we only use it on short lists +removeDupsEq [] = ([], []) +removeDupsEq (x:xs) | x `elem` xs = (ys, (x : filter (== x) xs) : zs) + where + (ys,zs) = removeDupsEq (filter (/= x) xs) +removeDupsEq (x:xs) | otherwise = (x:ys, zs) + where + (ys,zs) = removeDupsEq xs +\end{code} + + +\begin{code} +equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]] + -- NB: it's *very* important that if we have the input list [a,b,c], + -- where a,b,c all have the same unique, then we get back the list + -- [a,b,c] + -- not + -- [c,b,a] + -- Hence the use of foldr, plus the reversed-args tack_on below +equivClassesByUniq get_uniq xs + = eltsUFM (foldr add emptyUFM xs) + where + add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a] + tack_on old new = new++old +\end{code} + + diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs index 6dd9251..abaf1c1 100644 --- a/ghc/compiler/utils/Maybes.lhs +++ b/ghc/compiler/utils/Maybes.lhs @@ -15,9 +15,6 @@ module Maybes ( expectJust, maybeToBool, - assocMaybe, - mkLookupFun, mkLookupFunDef, - failMaB, failMaybe, seqMaybe, @@ -118,49 +115,6 @@ orElse :: Maybe a -> a -> a Nothing `orElse` y = y \end{code} -Lookup functions -~~~~~~~~~~~~~~~~ - -@assocMaybe@ looks up in an assocation list, returning -@Nothing@ if it fails. - -\begin{code} -assocMaybe :: (Eq a) => [(a,b)] -> a -> Maybe b - -assocMaybe alist key - = lookup alist - where - lookup [] = Nothing - lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest -\end{code} - -@mkLookupFun eq alist@ is a function which looks up -its argument in the association list @alist@, returning a Maybe type. -@mkLookupFunDef@ is similar except that it is given a value to return -on failure. - -\begin{code} -mkLookupFun :: (key -> key -> Bool) -- Equality predicate - -> [(key,val)] -- The assoc list - -> key -- The key - -> Maybe val -- The corresponding value - -mkLookupFun eq alist s - = case [a | (s',a) <- alist, s' `eq` s] of - [] -> Nothing - (a:_) -> Just a - -mkLookupFunDef :: (key -> key -> Bool) -- Equality predicate - -> [(key,val)] -- The assoc list - -> val -- Value to return on failure - -> key -- The key - -> val -- The corresponding value - -mkLookupFunDef eq alist deflt s - = case [a | (s',a) <- alist, s' `eq` s] of - [] -> deflt - (a:_) -> a -\end{code} %************************************************************************ %* * diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 2bb567d..50587e2 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -24,12 +24,6 @@ module Util ( -- for-loop nTimes, - -- association lists - assoc, assocUsing, assocDefault, assocDefaultUsing, - - -- duplicate handling - hasNoDups, equivClasses, runs, removeDups, removeDupsEq, equivClassesByUniq, - -- sorting IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA) sortLt, @@ -275,126 +269,6 @@ isn'tIn msg x ys %************************************************************************ %* * -\subsection[Utils-assoc]{Association lists} -%* * -%************************************************************************ - -See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@. - -\begin{code} -assoc :: (Eq a) => String -> [(a, b)] -> a -> b -assocDefault :: (Eq a) => b -> [(a, b)] -> a -> b -assocUsing :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b -assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b - -assocDefaultUsing eq deflt ((k,v) : rest) key - | k `eq` key = v - | otherwise = assocDefaultUsing eq deflt rest key - -assocDefaultUsing eq deflt [] key = deflt - -assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key -assocDefault deflt list key = assocDefaultUsing (==) deflt list key -assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key -\end{code} - -%************************************************************************ -%* * -\subsection[Utils-dups]{Duplicate-handling} -%* * -%************************************************************************ - -\begin{code} -hasNoDups :: (Eq a) => [a] -> Bool - -hasNoDups xs = f [] xs - where - f seen_so_far [] = True - f seen_so_far (x:xs) = if x `is_elem` seen_so_far then - False - else - f (x:seen_so_far) xs - - is_elem = isIn "hasNoDups" -\end{code} - -\begin{code} -equivClasses :: (a -> a -> Ordering) -- Comparison - -> [a] - -> [[a]] - -equivClasses cmp stuff@[] = [] -equivClasses cmp stuff@[item] = [stuff] -equivClasses cmp items - = runs eq (sortLt lt items) - where - eq a b = case cmp a b of { EQ -> True; _ -> False } - lt a b = case cmp a b of { LT -> True; _ -> False } -\end{code} - -The first cases in @equivClasses@ above are just to cut to the point -more quickly... - -@runs@ groups a list into a list of lists, each sublist being a run of -identical elements of the input list. It is passed a predicate @p@ which -tells when two elements are equal. - -\begin{code} -runs :: (a -> a -> Bool) -- Equality - -> [a] - -> [[a]] - -runs p [] = [] -runs p (x:xs) = case (span (p x) xs) of - (first, rest) -> (x:first) : (runs p rest) -\end{code} - -\begin{code} -removeDups :: (a -> a -> Ordering) -- Comparison function - -> [a] - -> ([a], -- List with no duplicates - [[a]]) -- List of duplicate groups. One representative from - -- each group appears in the first result - -removeDups cmp [] = ([], []) -removeDups cmp [x] = ([x],[]) -removeDups cmp xs - = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') -> - (xs', dups) } - where - collect_dups dups_so_far [x] = (dups_so_far, x) - collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x) - -removeDupsEq :: Eq a => [a] -> ([a], [[a]]) --- Same, but with only equality --- It's worst case quadratic, but we only use it on short lists -removeDupsEq [] = ([], []) -removeDupsEq (x:xs) | x `elem` xs = (ys, (x : filter (== x) xs) : zs) - where - (ys,zs) = removeDupsEq (filter (/= x) xs) -removeDupsEq (x:xs) | otherwise = (x:ys, zs) - where - (ys,zs) = removeDupsEq xs -\end{code} - - -\begin{code} -equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]] - -- NB: it's *very* important that if we have the input list [a,b,c], - -- where a,b,c all have the same unique, then we get back the list - -- [a,b,c] - -- not - -- [c,b,a] - -- Hence the use of foldr, plus the reversed-args tack_on below -equivClassesByUniq get_uniq xs - = eltsUFM (foldr add emptyUFM xs) - where - add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a] - tack_on old new = new++old -\end{code} - -%************************************************************************ -%* * \subsection[Utils-sorting]{Sorting} %* * %************************************************************************ diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs index f1e7c55..4c0bcbe 100644 --- a/ghc/lib/std/PrelBase.lhs +++ b/ghc/lib/std/PrelBase.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelBase.lhs,v 1.38 2000/09/26 16:45:34 simonpj Exp $ +% $Id: PrelBase.lhs,v 1.39 2000/10/03 08:43:05 simonpj Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -561,6 +561,19 @@ instance CReturnable () -- Why, exactly? %********************************************************* %* * +\subsection{Generics} +%* * +%********************************************************* + +\begin{code} +data Unit = Unit +data a :+: b = Inl a | Inr b +data a :*: b = a :*: b +\end{code} + + +%********************************************************* +%* * \subsection{Numeric primops} %* * %*********************************************************