Repository : ssh://[email protected]/ghc On branch : type-nats-simple Link : http://ghc.haskell.org/trac/ghc/changeset/500a7f7e671e8e0c62d51e855cd3ddec3471811a/ghc
>--------------------------------------------------------------- commit 500a7f7e671e8e0c62d51e855cd3ddec3471811a Author: Iavor S. Diatchki <[email protected]> Date: Wed Sep 4 11:55:09 2013 -0700 Fixup how we create the wired-in names for type-level function tycons. Now they are all declared in TcTypeNats, because they contain the actual tycons, which are delcared there. >--------------------------------------------------------------- 500a7f7e671e8e0c62d51e855cd3ddec3471811a compiler/prelude/PrelNames.lhs | 11 +---------- compiler/prelude/TysWiredIn.lhs | 2 ++ compiler/typecheck/TcRnDriver.lhs | 1 + compiler/typecheck/TcTypeNats.hs | 26 ++++++++++++++++++-------- 4 files changed, 22 insertions(+), 18 deletions(-) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 3e5384b..24558f0 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -289,10 +289,6 @@ basicKnownKeyNames -- Type-level naturals singIClassName, - typeNatLeqClassName, - typeNatAddTyFamName, - typeNatMulTyFamName, - typeNatExpTyFamName, -- Implicit parameters ipClassName, @@ -1120,13 +1116,8 @@ randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey -- Type-level naturals -singIClassName, typeNatLeqClassName, - typeNatAddTyFamName, typeNatMulTyFamName, typeNatExpTyFamName :: Name +singIClassName :: Name singIClassName = clsQual gHC_TYPELITS (fsLit "SingI") singIClassNameKey -typeNatLeqClassName = clsQual gHC_TYPELITS (fsLit "<=") typeNatLeqClassNameKey -typeNatAddTyFamName = tcQual gHC_TYPELITS (fsLit "+") typeNatAddTyFamNameKey -typeNatMulTyFamName = tcQual gHC_TYPELITS (fsLit "*") typeNatMulTyFamNameKey -typeNatExpTyFamName = tcQual gHC_TYPELITS (fsLit "^") typeNatExpTyFamNameKey -- Implicit parameters ipClassName :: Name diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 5ec290a..0a39228 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -68,6 +68,8 @@ module TysWiredIn ( -- * Equality predicates eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon, + mkWiredInTyConName -- This is used in TcTypeNats to define the + -- built-in functions for evaluation. ) where #include "HsVersions.h" diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index b5bf4a7..5df26a2 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -774,6 +774,7 @@ checkBootTyCon tc1 tc2 = eqClosedFamilyAx ax1 ax2 eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) = eqTypeX env t1 t2 + eqSynRhs (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2 eqSynRhs _ _ = False in roles1 == roles2 && diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs index 7356e67..7f5c8a6 100644 --- a/compiler/typecheck/TcTypeNats.hs +++ b/compiler/typecheck/TcTypeNats.hs @@ -11,14 +11,15 @@ import CoAxiom ( CoAxiomRule(..) ) import Name ( Name, mkWiredInName, BuiltInSyntax(..) ) import OccName ( mkOccName, tcName ) import Unique ( mkAxiomRuleUnique ) -import TysWiredIn ( typeNatKind ) +import TysWiredIn ( typeNatKind, mkWiredInTyConName ) import TysPrim ( tyVarList, mkArrowKinds ) -import PrelNames ( gHC_PRIM - , typeNatAddTyFamName - , typeNatMulTyFamName - , typeNatExpTyFamName +import PrelNames ( gHC_PRIM, gHC_TYPELITS + , typeNatAddTyFamNameKey + , typeNatMulTyFamNameKey + , typeNatExpTyFamNameKey ) import FamInst(TcBuiltInSynFamily(..),trivialBuiltInFamily) +import FastString ( fsLit ) typeNatTyThings :: [TyThing] @@ -37,28 +38,37 @@ typeNatTyCons = map ATyCon ] typeNatAddTyCon :: TyCon -typeNatAddTyCon = mkTypeNatFunTyCon2 typeNatAddTyFamName +typeNatAddTyCon = mkTypeNatFunTyCon2 name TcBuiltInSynFamily { sfMatchFam = matchFamAdd , sfInteractTop = interactTopAdd , sfInteractInert = sfInteractInert trivialBuiltInFamily } + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "+") + typeNatAddTyFamNameKey typeNatAddTyCon typeNatMulTyCon :: TyCon -typeNatMulTyCon = mkTypeNatFunTyCon2 typeNatMulTyFamName +typeNatMulTyCon = mkTypeNatFunTyCon2 name TcBuiltInSynFamily { sfMatchFam = matchFamMul , sfInteractTop = interactTopMul , sfInteractInert = sfInteractInert trivialBuiltInFamily } + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "*") + typeNatMulTyFamNameKey typeNatMulTyCon typeNatExpTyCon :: TyCon -typeNatExpTyCon = mkTypeNatFunTyCon2 typeNatExpTyFamName +typeNatExpTyCon = mkTypeNatFunTyCon2 name TcBuiltInSynFamily { sfMatchFam = matchFamExp , sfInteractTop = interactTopExp , sfInteractInert = sfInteractInert trivialBuiltInFamily } + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "*") + typeNatExpTyFamNameKey typeNatExpTyCon -- Make a binary built-in constructor of kind: Nat -> Nat -> Nat mkTypeNatFunTyCon2 :: Name -> TcBuiltInSynFamily -> TyCon _______________________________________________ ghc-commits mailing list [email protected] http://www.haskell.org/mailman/listinfo/ghc-commits
