diff options
83 files changed, 1947 insertions, 1705 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index cf1bf58e9d..682317b2f3 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -46,7 +46,7 @@ module BasicTypes( Boxity(..), isBoxed, - TupleSort(..), tupleSortBoxity, boxityNormalTupleSort, + TupleSort(..), tupleSortBoxity, boxityTupleSort, tupleParens, -- ** The OneShotInfo type @@ -94,7 +94,7 @@ module BasicTypes( import FastString import Outputable import SrcLoc ( Located,unLoc ) - +import StaticFlags( opt_PprStyle_Debug ) import Data.Data hiding (Fixity) import Data.Function (on) import GHC.Exts (Any) @@ -573,19 +573,20 @@ data TupleSort deriving( Eq, Data, Typeable ) tupleSortBoxity :: TupleSort -> Boxity -tupleSortBoxity BoxedTuple = Boxed -tupleSortBoxity UnboxedTuple = Unboxed +tupleSortBoxity BoxedTuple = Boxed +tupleSortBoxity UnboxedTuple = Unboxed tupleSortBoxity ConstraintTuple = Boxed -boxityNormalTupleSort :: Boxity -> TupleSort -boxityNormalTupleSort Boxed = BoxedTuple -boxityNormalTupleSort Unboxed = UnboxedTuple +boxityTupleSort :: Boxity -> TupleSort +boxityTupleSort Boxed = BoxedTuple +boxityTupleSort Unboxed = UnboxedTuple tupleParens :: TupleSort -> SDoc -> SDoc tupleParens BoxedTuple p = parens p -tupleParens ConstraintTuple p = parens p -- The user can't write fact tuples - -- directly, we overload the (,,) syntax -tupleParens UnboxedTuple p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") +tupleParens UnboxedTuple p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") +tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) + | opt_PprStyle_Debug = ptext (sLit "(%") <+> p <+> ptext (sLit "%)") + | otherwise = parens p {- ************************************************************************ diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 46d79d8f81..79c14726cd 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -1015,7 +1015,6 @@ dataConCannotMatch tys con -- TODO: could gather equalities from superclasses too predEqs pred = case classifyPredType pred of EqPred NomEq ty1 ty2 -> [(ty1, ty2)] - TuplePred ts -> concatMap predEqs ts _ -> [] {- diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs index 094347a4fa..4ebeecaacc 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs @@ -32,7 +32,7 @@ module RdrName ( nameRdrName, getRdrName, -- ** Destruction - rdrNameOcc, rdrNameSpace, setRdrNameSpace, demoteRdrName, + rdrNameOcc, rdrNameSpace, demoteRdrName, isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, @@ -153,32 +153,6 @@ rdrNameOcc (Exact name) = nameOccName name rdrNameSpace :: RdrName -> NameSpace rdrNameSpace = occNameSpace . rdrNameOcc -setRdrNameSpace :: RdrName -> NameSpace -> RdrName --- ^ This rather gruesome function is used mainly by the parser. --- When parsing: --- --- > data T a = T | T1 Int --- --- we parse the data constructors as /types/ because of parser ambiguities, --- so then we need to change the /type constr/ to a /data constr/ --- --- The exact-name case /can/ occur when parsing: --- --- > data [] a = [] | a : [a] --- --- For the exact-name case we return an original name. -setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) -setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) -setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) -setRdrNameSpace (Exact n) ns - | isExternalName n - = Orig (nameModule n) occ - | otherwise -- This can happen when quoting and then splicing a fixity - -- declaration for a type - = Exact $ mkSystemNameAt (nameUnique n) occ (nameSrcSpan n) - where - occ = setOccNameSpace ns (nameOccName n) - -- demoteRdrName lowers the NameSpace of RdrName. -- see Note [Demotion] in OccName demoteRdrName :: RdrName -> Maybe RdrName diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs index ecff80fec8..70600d8d11 100644 --- a/compiler/basicTypes/Unique.hs +++ b/compiler/basicTypes/Unique.hs @@ -43,6 +43,7 @@ module Unique ( mkAlphaTyVarUnique, mkPrimOpIdUnique, mkTupleTyConUnique, mkTupleDataConUnique, + mkCTupleTyConUnique, mkPreludeMiscIdUnique, mkPreludeDataConUnique, mkPreludeTyConUnique, mkPreludeClassUnique, mkPArrDataConUnique, @@ -283,25 +284,25 @@ Allocation of unique supply characters: mkAlphaTyVarUnique :: Int -> Unique mkPreludeClassUnique :: Int -> Unique mkPreludeTyConUnique :: Int -> Unique -mkTupleTyConUnique :: TupleSort -> Int -> Unique -mkPreludeDataConUnique :: Int -> Unique -mkTupleDataConUnique :: TupleSort -> Int -> Unique +mkTupleTyConUnique :: Boxity -> Arity -> Unique +mkCTupleTyConUnique :: Arity -> Unique +mkPreludeDataConUnique :: Arity -> Unique +mkTupleDataConUnique :: Boxity -> Arity -> Unique mkPrimOpIdUnique :: Int -> Unique mkPreludeMiscIdUnique :: Int -> Unique mkPArrDataConUnique :: Int -> Unique -mkAlphaTyVarUnique i = mkUnique '1' i - -mkPreludeClassUnique i = mkUnique '2' i +mkAlphaTyVarUnique i = mkUnique '1' i +mkPreludeClassUnique i = mkUnique '2' i -- Prelude type constructors occupy *three* slots. -- The first is for the tycon itself; the latter two -- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info. -mkPreludeTyConUnique i = mkUnique '3' (3*i) -mkTupleTyConUnique BoxedTuple a = mkUnique '4' (3*a) -mkTupleTyConUnique UnboxedTuple a = mkUnique '5' (3*a) -mkTupleTyConUnique ConstraintTuple a = mkUnique 'k' (3*a) +mkPreludeTyConUnique i = mkUnique '3' (3*i) +mkTupleTyConUnique Boxed a = mkUnique '4' (3*a) +mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a) +mkCTupleTyConUnique a = mkUnique 'k' (3*a) -- Data constructor keys occupy *two* slots. The first is used for the -- data constructor itself and its wrapper function (the function that @@ -309,10 +310,9 @@ mkTupleTyConUnique ConstraintTuple a = mkUnique 'k' (3*a) -- used for the worker function (the function that builds the constructor -- representation). -mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic -mkTupleDataConUnique BoxedTuple a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels) -mkTupleDataConUnique UnboxedTuple a = mkUnique '8' (2*a) -mkTupleDataConUnique ConstraintTuple a = mkUnique 'h' (2*a) +mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic +mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels) +mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a) mkPrimOpIdUnique op = mkUnique '9' op mkPreludeMiscIdUnique i = mkUnique '0' i diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index ec0bb5e225..13285a5b3c 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -1570,7 +1570,7 @@ lookupIdInScope id oneTupleDataConId :: Id -- Should not happen -oneTupleDataConId = dataConWorkId (tupleCon BoxedTuple 1) +oneTupleDataConId = dataConWorkId (tupleDataCon Boxed 1) checkBndrIdInScope :: Var -> Var -> LintM () checkBndrIdInScope binder id diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs index 6905641f56..3b76aef36d 100644 --- a/compiler/coreSyn/MkCore.hs +++ b/compiler/coreSyn/MkCore.hs @@ -379,7 +379,7 @@ mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) mkCoreTup :: [CoreExpr] -> CoreExpr mkCoreTup [] = Var unitDataConId mkCoreTup [c] = c -mkCoreTup cs = mkConApp (tupleCon BoxedTuple (length cs)) +mkCoreTup cs = mkConApp (tupleDataCon Boxed (length cs)) (map (Type . exprType) cs ++ cs) -- | Build a big tuple holding the specified variables @@ -484,7 +484,7 @@ mkSmallTupleSelector [var] should_be_the_same_var _ scrut mkSmallTupleSelector vars the_var scrut_var scrut = ASSERT( notNull vars ) Case scrut scrut_var (idType the_var) - [(DataAlt (tupleCon BoxedTuple (length vars)), vars, Var the_var)] + [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)] -- | A generalization of 'mkTupleSelector', allowing the body -- of the case to be an arbitrary expression. @@ -537,7 +537,8 @@ mkSmallTupleCase [var] body _scrut_var scrut = bindNonRec var scrut body mkSmallTupleCase vars body scrut_var scrut -- One branch no refinement? - = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon BoxedTuple (length vars)), vars, body)] + = Case scrut scrut_var (exprType body) + [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)] {- ************************************************************************ diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs index 24abf1828a..ecea85021c 100644 --- a/compiler/coreSyn/PprCore.hs +++ b/compiler/coreSyn/PprCore.hs @@ -131,7 +131,7 @@ ppr_expr add_par expr@(App {}) let pp_args = sep (map pprArg args) val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples - pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args)) + pp_tup_args = pprWithCommas pprCoreExpr val_args in case fun of Var f -> case isDataConWorkId_maybe f of @@ -230,7 +230,7 @@ pprCoreAlt (con, args, rhs) ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc ppr_case_pat (DataAlt dc) args | Just sort <- tyConTuple_maybe tc - = tupleParens sort (hsep (punctuate comma (map ppr_bndr args))) + = tupleParens sort (pprWithCommas ppr_bndr args) where ppr_bndr = pprBndr CaseBind tc = dataConTyCon dc diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 3d855d4407..af72f74312 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -722,7 +722,7 @@ tidy_pat (PArrPat ps ty) [ty] tidy_pat (TuplePat ps boxity tys) - = unLoc $ mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) + = unLoc $ mkPrefixConPat (tupleDataCon boxity arity) (map tidy_lpat ps) tys where arity = length ps diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 55cd7d2ac3..44795b9dfa 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -152,7 +152,7 @@ coreCaseTuple uniqs scrut_var vars body coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr coreCasePair scrut_var var1 var2 body = Case (Var scrut_var) scrut_var (exprType body) - [(DataAlt (tupleCon BoxedTuple 2), [var1, var2], body)] + [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)] mkCorePairTy :: Type -> Type -> Type mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 8e56fb5f7d..f67ffacdc4 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -40,19 +40,18 @@ import Digraph import PrelNames import TysPrim ( mkProxyPrimTy ) -import TyCon ( isTupleTyCon, tyConDataCons_maybe - , tyConName, isPromotedTyCon, isPromotedDataCon, tyConKind ) +import TyCon import TcEvidence import TcType import Type import Kind (returnsConstraintKind) import Coercion hiding (substCo) -import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon, mkListTy +import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy , mkBoxedTupleTy, stringTy ) import Id import MkId(proxyHashId) import Class -import DataCon ( dataConTyCon, dataConWorkId ) +import DataCon ( dataConTyCon ) import Name import MkId ( seqId ) import IdInfo ( IdDetails(..) ) @@ -70,7 +69,6 @@ import BasicTypes hiding ( TopLevel ) import DynFlags import FastString import ErrUtils( MsgDoc ) -import ListSetOps( getNth ) import Util import Control.Monad( when ) import MonadUtils @@ -853,23 +851,6 @@ dsEvTerm (EvCast tm co) dsEvTerm (EvDFunApp df tys tms) = return (Var df `mkTyApps` tys `mkApps` (map Var tms)) dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions] dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox - -dsEvTerm (EvTupleSel tm n) - = do { tup <- dsEvTerm tm - ; let scrut_ty = exprType tup - (tc, tys) = splitTyConApp scrut_ty - Just [dc] = tyConDataCons_maybe tc - xs = mkTemplateLocals tys - the_x = getNth xs n - ; ASSERT( isTupleTyCon tc ) - return $ - Case tup (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] } - -dsEvTerm (EvTupleMk tms) - = return (Var (dataConWorkId dc) `mkTyApps` map idType tms `mkApps` map Var tms) - where - dc = tupleCon ConstraintTuple (length tms) - dsEvTerm (EvSuperClass d n) = do { d' <- dsEvTerm d ; let (cls, tys) = getClassPredTys (exprType d') diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs index 5c5fde0b14..90121a0f5f 100644 --- a/compiler/deSugar/DsCCall.hs +++ b/compiler/deSugar/DsCCall.hs @@ -226,7 +226,7 @@ boxResult result_ty _ -> [] return_result state anss - = mkCoreConApps (tupleCon UnboxedTuple (2 + length extra_result_tys)) + = mkCoreConApps (tupleDataCon Unboxed (2 + length extra_result_tys)) (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys) ++ (state : anss)) @@ -290,9 +290,9 @@ mk_alt return_result (Just prim_res_ty, wrap_result) let the_rhs = return_result (Var state_id) (wrap_result (Var result_id) : map Var as) - ccall_res_ty = mkTyConApp (tupleTyCon UnboxedTuple arity) + ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity) (realWorldStatePrimTy : ls) - the_alt = ( DataAlt (tupleCon UnboxedTuple arity) + the_alt = ( DataAlt (tupleDataCon Unboxed arity) , (state_id : args_ids) , the_rhs ) diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 78a6d11632..37c927dddd 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -23,7 +23,6 @@ import DsMonad import Name import NameEnv import FamInstEnv( topNormaliseType ) - import DsMeta import HsSyn @@ -293,7 +292,7 @@ dsExpr (ExplicitTuple tup_args boxity) -- The reverse is because foldM goes left-to-right ; return $ mkCoreLams lam_vars $ - mkCoreConApps (tupleCon (boxityNormalTupleSort boxity) (length tup_args)) + mkCoreConApps (tupleDataCon boxity (length tup_args)) (map (Type . exprType) args ++ args) } dsExpr (HsSCC _ cc expr@(L loc _)) = do @@ -428,7 +427,7 @@ dsExpr (HsStatic expr@(L loc _)) = do , srcLocCol $ realSrcSpanStart r ) _ -> (0, 0) - srcLoc = mkCoreConApps (tupleCon BoxedTuple 2) + srcLoc = mkCoreConApps (tupleDataCon Boxed 2) [ Type intTy , Type intTy , mkIntExprInt dflags line, mkIntExprInt dflags col ] diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 9eb37a9c1e..34ef0e808e 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -15,15 +15,7 @@ -- a Royal Pain (triggers other recompilation). ----------------------------------------------------------------------------- -module DsMeta( dsBracket, - templateHaskellNames, qTyConName, nameTyConName, - liftName, liftStringName, expQTyConName, patQTyConName, - decQTyConName, decsQTyConName, typeQTyConName, - decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName, - quoteExpName, quotePatName, quoteDecName, quoteTypeName, - tExpTyConName, tExpDataConName, unTypeName, unTypeQName, - unsafeTExpCoerceName - ) where +module DsMeta( dsBracket ) where #include "HsVersions.h" @@ -41,11 +33,12 @@ import PrelNames -- OccName.varName we do this by removing varName from the import of -- OccName above, making a qualified instance of OccName and using -- OccNameAlias.varName where varName ws previously used in this file. -import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName, dataName ) +import qualified OccName( isDataOcc, isVarOcc, isTcOcc ) import Module import Id import Name hiding( isVarOcc, isTcOcc, varName, tcName ) +import THNames import NameEnv import TcType import TyCon @@ -2095,830 +2088,3 @@ notHandled what doc = failWithDs msg 2 doc --- %************************************************************************ --- %* * --- The known-key names for Template Haskell --- %* * --- %************************************************************************ - --- To add a name, do three things --- --- 1) Allocate a key --- 2) Make a "Name" --- 3) Add the name to knownKeyNames - -templateHaskellNames :: [Name] --- The names that are implicitly mentioned by ``bracket'' --- Should stay in sync with the import list of DsMeta - -templateHaskellNames = [ - returnQName, bindQName, sequenceQName, newNameName, liftName, - mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, - liftStringName, - unTypeName, - unTypeQName, - unsafeTExpCoerceName, - - -- Lit - charLName, stringLName, integerLName, intPrimLName, wordPrimLName, - floatPrimLName, doublePrimLName, rationalLName, - -- Pat - litPName, varPName, tupPName, unboxedTupPName, - conPName, tildePName, bangPName, infixPName, - asPName, wildPName, recPName, listPName, sigPName, viewPName, - -- FieldPat - fieldPatName, - -- Match - matchName, - -- Clause - clauseName, - -- Exp - varEName, conEName, litEName, appEName, infixEName, - infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName, - tupEName, unboxedTupEName, - condEName, multiIfEName, letEName, caseEName, doEName, compEName, - fromEName, fromThenEName, fromToEName, fromThenToEName, - listEName, sigEName, recConEName, recUpdEName, staticEName, - -- FieldExp - fieldExpName, - -- Body - guardedBName, normalBName, - -- Guard - normalGEName, patGEName, - -- Stmt - bindSName, letSName, noBindSName, parSName, - -- Dec - funDName, valDName, dataDName, newtypeDName, tySynDName, - classDName, instanceDName, standaloneDerivDName, sigDName, forImpDName, - pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, - pragRuleDName, pragAnnDName, defaultSigDName, - familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, - tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, - infixLDName, infixRDName, infixNDName, - roleAnnotDName, - -- Cxt - cxtName, - -- Strict - isStrictName, notStrictName, unpackedName, - -- Con - normalCName, recCName, infixCName, forallCName, - -- StrictType - strictTypeName, - -- VarStrictType - varStrictTypeName, - -- Type - forallTName, varTName, conTName, appTName, equalityTName, - tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName, - promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, - -- TyLit - numTyLitName, strTyLitName, - -- TyVarBndr - plainTVName, kindedTVName, - -- Role - nominalRName, representationalRName, phantomRName, inferRName, - -- Kind - varKName, conKName, tupleKName, arrowKName, listKName, appKName, - starKName, constraintKName, - -- Callconv - cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName, - -- Safety - unsafeName, - safeName, - interruptibleName, - -- Inline - noInlineDataConName, inlineDataConName, inlinableDataConName, - -- RuleMatch - conLikeDataConName, funLikeDataConName, - -- Phases - allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName, - -- TExp - tExpDataConName, - -- RuleBndr - ruleVarName, typedRuleVarName, - -- FunDep - funDepName, - -- FamFlavour - typeFamName, dataFamName, - -- TySynEqn - tySynEqnName, - -- AnnTarget - valueAnnotationName, typeAnnotationName, moduleAnnotationName, - - -- And the tycons - qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName, - clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName, - stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName, - varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, - typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, - patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, - predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName, - roleTyConName, tExpTyConName, - - -- Quasiquoting - quoteDecName, quoteTypeName, quoteExpName, quotePatName] - -thSyn, thLib, qqLib :: Module -thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax") -thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib") -qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") - -mkTHModule :: FastString -> Module -mkTHModule m = mkModule thPackageKey (mkModuleNameFS m) - -libFun, libTc, thFun, thTc, thCon, qqFun :: FastString -> Unique -> Name -libFun = mk_known_key_name OccName.varName thLib -libTc = mk_known_key_name OccName.tcName thLib -thFun = mk_known_key_name OccName.varName thSyn -thTc = mk_known_key_name OccName.tcName thSyn -thCon = mk_known_key_name OccName.dataName thSyn -qqFun = mk_known_key_name OccName.varName qqLib - --------------------- TH.Syntax ----------------------- -qTyConName, nameTyConName, fieldExpTyConName, patTyConName, - fieldPatTyConName, expTyConName, decTyConName, typeTyConName, - tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName, - predTyConName, tExpTyConName :: Name -qTyConName = thTc (fsLit "Q") qTyConKey -nameTyConName = thTc (fsLit "Name") nameTyConKey -fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey -patTyConName = thTc (fsLit "Pat") patTyConKey -fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey -expTyConName = thTc (fsLit "Exp") expTyConKey -decTyConName = thTc (fsLit "Dec") decTyConKey -typeTyConName = thTc (fsLit "Type") typeTyConKey -tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey -matchTyConName = thTc (fsLit "Match") matchTyConKey -clauseTyConName = thTc (fsLit "Clause") clauseTyConKey -funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey -predTyConName = thTc (fsLit "Pred") predTyConKey -tExpTyConName = thTc (fsLit "TExp") tExpTyConKey - -returnQName, bindQName, sequenceQName, newNameName, liftName, - mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, - mkNameLName, liftStringName, unTypeName, unTypeQName, - unsafeTExpCoerceName :: Name -returnQName = thFun (fsLit "returnQ") returnQIdKey -bindQName = thFun (fsLit "bindQ") bindQIdKey -sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey -newNameName = thFun (fsLit "newName") newNameIdKey -liftName = thFun (fsLit "lift") liftIdKey -liftStringName = thFun (fsLit "liftString") liftStringIdKey -mkNameName = thFun (fsLit "mkName") mkNameIdKey -mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey -mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey -mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey -mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey -unTypeName = thFun (fsLit "unType") unTypeIdKey -unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey -unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey - - --------------------- TH.Lib ----------------------- --- data Lit = ... -charLName, stringLName, integerLName, intPrimLName, wordPrimLName, - floatPrimLName, doublePrimLName, rationalLName :: Name -charLName = libFun (fsLit "charL") charLIdKey -stringLName = libFun (fsLit "stringL") stringLIdKey -integerLName = libFun (fsLit "integerL") integerLIdKey -intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey -wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey -floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey -doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey -rationalLName = libFun (fsLit "rationalL") rationalLIdKey - --- data Pat = ... -litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName, - asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name -litPName = libFun (fsLit "litP") litPIdKey -varPName = libFun (fsLit "varP") varPIdKey -tupPName = libFun (fsLit "tupP") tupPIdKey -unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey -conPName = libFun (fsLit "conP") conPIdKey -infixPName = libFun (fsLit "infixP") infixPIdKey -tildePName = libFun (fsLit "tildeP") tildePIdKey -bangPName = libFun (fsLit "bangP") bangPIdKey -asPName = libFun (fsLit "asP") asPIdKey -wildPName = libFun (fsLit "wildP") wildPIdKey -recPName = libFun (fsLit "recP") recPIdKey -listPName = libFun (fsLit "listP") listPIdKey -sigPName = libFun (fsLit "sigP") sigPIdKey -viewPName = libFun (fsLit "viewP") viewPIdKey - --- type FieldPat = ... -fieldPatName :: Name -fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey - --- data Match = ... -matchName :: Name -matchName = libFun (fsLit "match") matchIdKey - --- data Clause = ... -clauseName :: Name -clauseName = libFun (fsLit "clause") clauseIdKey - --- data Exp = ... -varEName, conEName, litEName, appEName, infixEName, infixAppName, - sectionLName, sectionRName, lamEName, lamCaseEName, tupEName, - unboxedTupEName, condEName, multiIfEName, letEName, caseEName, - doEName, compEName, staticEName :: Name -varEName = libFun (fsLit "varE") varEIdKey -conEName = libFun (fsLit "conE") conEIdKey -litEName = libFun (fsLit "litE") litEIdKey -appEName = libFun (fsLit "appE") appEIdKey -infixEName = libFun (fsLit "infixE") infixEIdKey -infixAppName = libFun (fsLit "infixApp") infixAppIdKey -sectionLName = libFun (fsLit "sectionL") sectionLIdKey -sectionRName = libFun (fsLit "sectionR") sectionRIdKey -lamEName = libFun (fsLit "lamE") lamEIdKey -lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey -tupEName = libFun (fsLit "tupE") tupEIdKey -unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey -condEName = libFun (fsLit "condE") condEIdKey -multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey -letEName = libFun (fsLit "letE") letEIdKey -caseEName = libFun (fsLit "caseE") caseEIdKey -doEName = libFun (fsLit "doE") doEIdKey -compEName = libFun (fsLit "compE") compEIdKey --- ArithSeq skips a level -fromEName, fromThenEName, fromToEName, fromThenToEName :: Name -fromEName = libFun (fsLit "fromE") fromEIdKey -fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey -fromToEName = libFun (fsLit "fromToE") fromToEIdKey -fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey --- end ArithSeq -listEName, sigEName, recConEName, recUpdEName :: Name -listEName = libFun (fsLit "listE") listEIdKey -sigEName = libFun (fsLit "sigE") sigEIdKey -recConEName = libFun (fsLit "recConE") recConEIdKey -recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey -staticEName = libFun (fsLit "staticE") staticEIdKey - --- type FieldExp = ... -fieldExpName :: Name -fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey - --- data Body = ... -guardedBName, normalBName :: Name -guardedBName = libFun (fsLit "guardedB") guardedBIdKey -normalBName = libFun (fsLit "normalB") normalBIdKey - --- data Guard = ... -normalGEName, patGEName :: Name -normalGEName = libFun (fsLit "normalGE") normalGEIdKey -patGEName = libFun (fsLit "patGE") patGEIdKey - --- data Stmt = ... -bindSName, letSName, noBindSName, parSName :: Name -bindSName = libFun (fsLit "bindS") bindSIdKey -letSName = libFun (fsLit "letS") letSIdKey -noBindSName = libFun (fsLit "noBindS") noBindSIdKey -parSName = libFun (fsLit "parS") parSIdKey - --- data Dec = ... -funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, - instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, - pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName, - familyNoKindDName, standaloneDerivDName, defaultSigDName, - familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName, - closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, - infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name -funDName = libFun (fsLit "funD") funDIdKey -valDName = libFun (fsLit "valD") valDIdKey -dataDName = libFun (fsLit "dataD") dataDIdKey -newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey -tySynDName = libFun (fsLit "tySynD") tySynDIdKey -classDName = libFun (fsLit "classD") classDIdKey -instanceDName = libFun (fsLit "instanceD") instanceDIdKey -standaloneDerivDName - = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey -sigDName = libFun (fsLit "sigD") sigDIdKey -defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey -forImpDName = libFun (fsLit "forImpD") forImpDIdKey -pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey -pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey -pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey -pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey -pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey -pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey -familyNoKindDName = libFun (fsLit "familyNoKindD") familyNoKindDIdKey -familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey -dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey -newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey -tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey -closedTypeFamilyKindDName - = libFun (fsLit "closedTypeFamilyKindD") closedTypeFamilyKindDIdKey -closedTypeFamilyNoKindDName - = libFun (fsLit "closedTypeFamilyNoKindD") closedTypeFamilyNoKindDIdKey -infixLDName = libFun (fsLit "infixLD") infixLDIdKey -infixRDName = libFun (fsLit "infixRD") infixRDIdKey -infixNDName = libFun (fsLit "infixND") infixNDIdKey -roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey - --- type Ctxt = ... -cxtName :: Name -cxtName = libFun (fsLit "cxt") cxtIdKey - --- data Strict = ... -isStrictName, notStrictName, unpackedName :: Name -isStrictName = libFun (fsLit "isStrict") isStrictKey -notStrictName = libFun (fsLit "notStrict") notStrictKey -unpackedName = libFun (fsLit "unpacked") unpackedKey - --- data Con = ... -normalCName, recCName, infixCName, forallCName :: Name -normalCName = libFun (fsLit "normalC") normalCIdKey -recCName = libFun (fsLit "recC") recCIdKey -infixCName = libFun (fsLit "infixC") infixCIdKey -forallCName = libFun (fsLit "forallC") forallCIdKey - --- type StrictType = ... -strictTypeName :: Name -strictTypeName = libFun (fsLit "strictType") strictTKey - --- type VarStrictType = ... -varStrictTypeName :: Name -varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey - --- data Type = ... -forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName, - listTName, appTName, sigTName, equalityTName, litTName, - promotedTName, promotedTupleTName, - promotedNilTName, promotedConsTName :: Name -forallTName = libFun (fsLit "forallT") forallTIdKey -varTName = libFun (fsLit "varT") varTIdKey -conTName = libFun (fsLit "conT") conTIdKey -tupleTName = libFun (fsLit "tupleT") tupleTIdKey -unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey -arrowTName = libFun (fsLit "arrowT") arrowTIdKey -listTName = libFun (fsLit "listT") listTIdKey -appTName = libFun (fsLit "appT") appTIdKey -sigTName = libFun (fsLit "sigT") sigTIdKey -equalityTName = libFun (fsLit "equalityT") equalityTIdKey -litTName = libFun (fsLit "litT") litTIdKey -promotedTName = libFun (fsLit "promotedT") promotedTIdKey -promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey -promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey -promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey - --- data TyLit = ... -numTyLitName, strTyLitName :: Name -numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey -strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey - --- data TyVarBndr = ... -plainTVName, kindedTVName :: Name -plainTVName = libFun (fsLit "plainTV") plainTVIdKey -kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey - --- data Role = ... -nominalRName, representationalRName, phantomRName, inferRName :: Name -nominalRName = libFun (fsLit "nominalR") nominalRIdKey -representationalRName = libFun (fsLit "representationalR") representationalRIdKey -phantomRName = libFun (fsLit "phantomR") phantomRIdKey -inferRName = libFun (fsLit "inferR") inferRIdKey - --- data Kind = ... -varKName, conKName, tupleKName, arrowKName, listKName, appKName, - starKName, constraintKName :: Name -varKName = libFun (fsLit "varK") varKIdKey -conKName = libFun (fsLit "conK") conKIdKey -tupleKName = libFun (fsLit "tupleK") tupleKIdKey -arrowKName = libFun (fsLit "arrowK") arrowKIdKey -listKName = libFun (fsLit "listK") listKIdKey -appKName = libFun (fsLit "appK") appKIdKey -starKName = libFun (fsLit "starK") starKIdKey -constraintKName = libFun (fsLit "constraintK") constraintKIdKey - --- data Callconv = ... -cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name -cCallName = libFun (fsLit "cCall") cCallIdKey -stdCallName = libFun (fsLit "stdCall") stdCallIdKey -cApiCallName = libFun (fsLit "cApi") cApiCallIdKey -primCallName = libFun (fsLit "prim") primCallIdKey -javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey - --- data Safety = ... -unsafeName, safeName, interruptibleName :: Name -unsafeName = libFun (fsLit "unsafe") unsafeIdKey -safeName = libFun (fsLit "safe") safeIdKey -interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey - --- data Inline = ... -noInlineDataConName, inlineDataConName, inlinableDataConName :: Name -noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey -inlineDataConName = thCon (fsLit "Inline") inlineDataConKey -inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey - --- data RuleMatch = ... -conLikeDataConName, funLikeDataConName :: Name -conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey -funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey - --- data Phases = ... -allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name -allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey -fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey -beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey - --- newtype TExp a = ... -tExpDataConName :: Name -tExpDataConName = thCon (fsLit "TExp") tExpDataConKey - --- data RuleBndr = ... -ruleVarName, typedRuleVarName :: Name -ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey -typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey - --- data FunDep = ... -funDepName :: Name -funDepName = libFun (fsLit "funDep") funDepIdKey - --- data FamFlavour = ... -typeFamName, dataFamName :: Name -typeFamName = libFun (fsLit "typeFam") typeFamIdKey -dataFamName = libFun (fsLit "dataFam") dataFamIdKey - --- data TySynEqn = ... -tySynEqnName :: Name -tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey - --- data AnnTarget = ... -valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name -valueAnnotationName = libFun (fsLit "valueAnnotation") valueAnnotationIdKey -typeAnnotationName = libFun (fsLit "typeAnnotation") typeAnnotationIdKey -moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey - -matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName, - decQTyConName, conQTyConName, strictTypeQTyConName, - varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName, - patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName, - ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName :: Name -matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey -clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey -expQTyConName = libTc (fsLit "ExpQ") expQTyConKey -stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey -decQTyConName = libTc (fsLit "DecQ") decQTyConKey -decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec] -conQTyConName = libTc (fsLit "ConQ") conQTyConKey -strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey -varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey -typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey -fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey -patQTyConName = libTc (fsLit "PatQ") patQTyConKey -fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey -predQTyConName = libTc (fsLit "PredQ") predQTyConKey -ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey -tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey -roleTyConName = libTc (fsLit "Role") roleTyConKey - --- quasiquoting -quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name -quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey -quotePatName = qqFun (fsLit "quotePat") quotePatKey -quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey -quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey - --- TyConUniques available: 200-299 --- Check in PrelNames if you want to change this - -expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, - decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey, - stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey, - decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey, - fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, - fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, - predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey, - roleTyConKey, tExpTyConKey :: Unique -expTyConKey = mkPreludeTyConUnique 200 -matchTyConKey = mkPreludeTyConUnique 201 -clauseTyConKey = mkPreludeTyConUnique 202 -qTyConKey = mkPreludeTyConUnique 203 -expQTyConKey = mkPreludeTyConUnique 204 -decQTyConKey = mkPreludeTyConUnique 205 -patTyConKey = mkPreludeTyConUnique 206 -matchQTyConKey = mkPreludeTyConUnique 207 -clauseQTyConKey = mkPreludeTyConUnique 208 -stmtQTyConKey = mkPreludeTyConUnique 209 -conQTyConKey = mkPreludeTyConUnique 210 -typeQTyConKey = mkPreludeTyConUnique 211 -typeTyConKey = mkPreludeTyConUnique 212 -decTyConKey = mkPreludeTyConUnique 213 -varStrictTypeQTyConKey = mkPreludeTyConUnique 214 -strictTypeQTyConKey = mkPreludeTyConUnique 215 -fieldExpTyConKey = mkPreludeTyConUnique 216 -fieldPatTyConKey = mkPreludeTyConUnique 217 -nameTyConKey = mkPreludeTyConUnique 218 -patQTyConKey = mkPreludeTyConUnique 219 -fieldPatQTyConKey = mkPreludeTyConUnique 220 -fieldExpQTyConKey = mkPreludeTyConUnique 221 -funDepTyConKey = mkPreludeTyConUnique 222 -predTyConKey = mkPreludeTyConUnique 223 -predQTyConKey = mkPreludeTyConUnique 224 -tyVarBndrTyConKey = mkPreludeTyConUnique 225 -decsQTyConKey = mkPreludeTyConUnique 226 -ruleBndrQTyConKey = mkPreludeTyConUnique 227 -tySynEqnQTyConKey = mkPreludeTyConUnique 228 -roleTyConKey = mkPreludeTyConUnique 229 -tExpTyConKey = mkPreludeTyConUnique 230 - --- IdUniques available: 200-499 --- If you want to change this, make sure you check in PrelNames - -returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, - mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, - mkNameLIdKey, unTypeIdKey, unTypeQIdKey, unsafeTExpCoerceIdKey :: Unique -returnQIdKey = mkPreludeMiscIdUnique 200 -bindQIdKey = mkPreludeMiscIdUnique 201 -sequenceQIdKey = mkPreludeMiscIdUnique 202 -liftIdKey = mkPreludeMiscIdUnique 203 -newNameIdKey = mkPreludeMiscIdUnique 204 -mkNameIdKey = mkPreludeMiscIdUnique 205 -mkNameG_vIdKey = mkPreludeMiscIdUnique 206 -mkNameG_dIdKey = mkPreludeMiscIdUnique 207 -mkNameG_tcIdKey = mkPreludeMiscIdUnique 208 -mkNameLIdKey = mkPreludeMiscIdUnique 209 -unTypeIdKey = mkPreludeMiscIdUnique 210 -unTypeQIdKey = mkPreludeMiscIdUnique 211 -unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 212 - - --- data Lit = ... -charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey, - floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique -charLIdKey = mkPreludeMiscIdUnique 220 -stringLIdKey = mkPreludeMiscIdUnique 221 -integerLIdKey = mkPreludeMiscIdUnique 222 -intPrimLIdKey = mkPreludeMiscIdUnique 223 -wordPrimLIdKey = mkPreludeMiscIdUnique 224 -floatPrimLIdKey = mkPreludeMiscIdUnique 225 -doublePrimLIdKey = mkPreludeMiscIdUnique 226 -rationalLIdKey = mkPreludeMiscIdUnique 227 - -liftStringIdKey :: Unique -liftStringIdKey = mkPreludeMiscIdUnique 228 - --- data Pat = ... -litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, - asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique -litPIdKey = mkPreludeMiscIdUnique 240 -varPIdKey = mkPreludeMiscIdUnique 241 -tupPIdKey = mkPreludeMiscIdUnique 242 -unboxedTupPIdKey = mkPreludeMiscIdUnique 243 -conPIdKey = mkPreludeMiscIdUnique 244 -infixPIdKey = mkPreludeMiscIdUnique 245 -tildePIdKey = mkPreludeMiscIdUnique 246 -bangPIdKey = mkPreludeMiscIdUnique 247 -asPIdKey = mkPreludeMiscIdUnique 248 -wildPIdKey = mkPreludeMiscIdUnique 249 -recPIdKey = mkPreludeMiscIdUnique 250 -listPIdKey = mkPreludeMiscIdUnique 251 -sigPIdKey = mkPreludeMiscIdUnique 252 -viewPIdKey = mkPreludeMiscIdUnique 253 - --- type FieldPat = ... -fieldPatIdKey :: Unique -fieldPatIdKey = mkPreludeMiscIdUnique 260 - --- data Match = ... -matchIdKey :: Unique -matchIdKey = mkPreludeMiscIdUnique 261 - --- data Clause = ... -clauseIdKey :: Unique -clauseIdKey = mkPreludeMiscIdUnique 262 - - --- data Exp = ... -varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey, - sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey, - unboxedTupEIdKey, condEIdKey, multiIfEIdKey, - letEIdKey, caseEIdKey, doEIdKey, compEIdKey, - fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, - listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey :: Unique -varEIdKey = mkPreludeMiscIdUnique 270 -conEIdKey = mkPreludeMiscIdUnique 271 -litEIdKey = mkPreludeMiscIdUnique 272 -appEIdKey = mkPreludeMiscIdUnique 273 -infixEIdKey = mkPreludeMiscIdUnique 274 -infixAppIdKey = mkPreludeMiscIdUnique 275 -sectionLIdKey = mkPreludeMiscIdUnique 276 -sectionRIdKey = mkPreludeMiscIdUnique 277 -lamEIdKey = mkPreludeMiscIdUnique 278 -lamCaseEIdKey = mkPreludeMiscIdUnique 279 -tupEIdKey = mkPreludeMiscIdUnique 280 -unboxedTupEIdKey = mkPreludeMiscIdUnique 281 -condEIdKey = mkPreludeMiscIdUnique 282 -multiIfEIdKey = mkPreludeMiscIdUnique 283 -letEIdKey = mkPreludeMiscIdUnique 284 -caseEIdKey = mkPreludeMiscIdUnique 285 -doEIdKey = mkPreludeMiscIdUnique 286 -compEIdKey = mkPreludeMiscIdUnique 287 -fromEIdKey = mkPreludeMiscIdUnique 288 -fromThenEIdKey = mkPreludeMiscIdUnique 289 -fromToEIdKey = mkPreludeMiscIdUnique 290 -fromThenToEIdKey = mkPreludeMiscIdUnique 291 -listEIdKey = mkPreludeMiscIdUnique 292 -sigEIdKey = mkPreludeMiscIdUnique 293 -recConEIdKey = mkPreludeMiscIdUnique 294 -recUpdEIdKey = mkPreludeMiscIdUnique 295 -staticEIdKey = mkPreludeMiscIdUnique 296 - --- type FieldExp = ... -fieldExpIdKey :: Unique -fieldExpIdKey = mkPreludeMiscIdUnique 310 - --- data Body = ... -guardedBIdKey, normalBIdKey :: Unique -guardedBIdKey = mkPreludeMiscIdUnique 311 -normalBIdKey = mkPreludeMiscIdUnique 312 - --- data Guard = ... -normalGEIdKey, patGEIdKey :: Unique -normalGEIdKey = mkPreludeMiscIdUnique 313 -patGEIdKey = mkPreludeMiscIdUnique 314 - --- data Stmt = ... -bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique -bindSIdKey = mkPreludeMiscIdUnique 320 -letSIdKey = mkPreludeMiscIdUnique 321 -noBindSIdKey = mkPreludeMiscIdUnique 322 -parSIdKey = mkPreludeMiscIdUnique 323 - --- data Dec = ... -funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, - classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, - pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey, - pragAnnDIdKey, familyNoKindDIdKey, familyKindDIdKey, defaultSigDIdKey, - dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivDIdKey, - closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey, - infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey :: Unique -funDIdKey = mkPreludeMiscIdUnique 330 -valDIdKey = mkPreludeMiscIdUnique 331 -dataDIdKey = mkPreludeMiscIdUnique 332 -newtypeDIdKey = mkPreludeMiscIdUnique 333 -tySynDIdKey = mkPreludeMiscIdUnique 334 -classDIdKey = mkPreludeMiscIdUnique 335 -instanceDIdKey = mkPreludeMiscIdUnique 336 -sigDIdKey = mkPreludeMiscIdUnique 337 -forImpDIdKey = mkPreludeMiscIdUnique 338 -pragInlDIdKey = mkPreludeMiscIdUnique 339 -pragSpecDIdKey = mkPreludeMiscIdUnique 340 -pragSpecInlDIdKey = mkPreludeMiscIdUnique 341 -pragSpecInstDIdKey = mkPreludeMiscIdUnique 342 -pragRuleDIdKey = mkPreludeMiscIdUnique 343 -pragAnnDIdKey = mkPreludeMiscIdUnique 344 -familyNoKindDIdKey = mkPreludeMiscIdUnique 345 -familyKindDIdKey = mkPreludeMiscIdUnique 346 -dataInstDIdKey = mkPreludeMiscIdUnique 347 -newtypeInstDIdKey = mkPreludeMiscIdUnique 348 -tySynInstDIdKey = mkPreludeMiscIdUnique 349 -closedTypeFamilyKindDIdKey = mkPreludeMiscIdUnique 350 -closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 351 -infixLDIdKey = mkPreludeMiscIdUnique 352 -infixRDIdKey = mkPreludeMiscIdUnique 353 -infixNDIdKey = mkPreludeMiscIdUnique 354 -roleAnnotDIdKey = mkPreludeMiscIdUnique 355 -standaloneDerivDIdKey = mkPreludeMiscIdUnique 356 -defaultSigDIdKey = mkPreludeMiscIdUnique 357 - --- type Cxt = ... -cxtIdKey :: Unique -cxtIdKey = mkPreludeMiscIdUnique 360 - --- data Strict = ... -isStrictKey, notStrictKey, unpackedKey :: Unique -isStrictKey = mkPreludeMiscIdUnique 363 -notStrictKey = mkPreludeMiscIdUnique 364 -unpackedKey = mkPreludeMiscIdUnique 365 - --- data Con = ... -normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique -normalCIdKey = mkPreludeMiscIdUnique 370 -recCIdKey = mkPreludeMiscIdUnique 371 -infixCIdKey = mkPreludeMiscIdUnique 372 -forallCIdKey = mkPreludeMiscIdUnique 373 - --- type StrictType = ... -strictTKey :: Unique -strictTKey = mkPreludeMiscIdUnique 374 - --- type VarStrictType = ... -varStrictTKey :: Unique -varStrictTKey = mkPreludeMiscIdUnique 375 - --- data Type = ... -forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey, - listTIdKey, appTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, - promotedTIdKey, promotedTupleTIdKey, - promotedNilTIdKey, promotedConsTIdKey :: Unique -forallTIdKey = mkPreludeMiscIdUnique 380 -varTIdKey = mkPreludeMiscIdUnique 381 -conTIdKey = mkPreludeMiscIdUnique 382 -tupleTIdKey = mkPreludeMiscIdUnique 383 -unboxedTupleTIdKey = mkPreludeMiscIdUnique 384 -arrowTIdKey = mkPreludeMiscIdUnique 385 -listTIdKey = mkPreludeMiscIdUnique 386 -appTIdKey = mkPreludeMiscIdUnique 387 -sigTIdKey = mkPreludeMiscIdUnique 388 -equalityTIdKey = mkPreludeMiscIdUnique 389 -litTIdKey = mkPreludeMiscIdUnique 390 -promotedTIdKey = mkPreludeMiscIdUnique 391 -promotedTupleTIdKey = mkPreludeMiscIdUnique 392 -promotedNilTIdKey = mkPreludeMiscIdUnique 393 -promotedConsTIdKey = mkPreludeMiscIdUnique 394 - --- data TyLit = ... -numTyLitIdKey, strTyLitIdKey :: Unique -numTyLitIdKey = mkPreludeMiscIdUnique 395 -strTyLitIdKey = mkPreludeMiscIdUnique 396 - --- data TyVarBndr = ... -plainTVIdKey, kindedTVIdKey :: Unique -plainTVIdKey = mkPreludeMiscIdUnique 397 -kindedTVIdKey = mkPreludeMiscIdUnique 398 - --- data Role = ... -nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique -nominalRIdKey = mkPreludeMiscIdUnique 400 -representationalRIdKey = mkPreludeMiscIdUnique 401 -phantomRIdKey = mkPreludeMiscIdUnique 402 -inferRIdKey = mkPreludeMiscIdUnique 403 - --- data Kind = ... -varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey, - starKIdKey, constraintKIdKey :: Unique -varKIdKey = mkPreludeMiscIdUnique 404 -conKIdKey = mkPreludeMiscIdUnique 405 -tupleKIdKey = mkPreludeMiscIdUnique 406 -arrowKIdKey = mkPreludeMiscIdUnique 407 -listKIdKey = mkPreludeMiscIdUnique 408 -appKIdKey = mkPreludeMiscIdUnique 409 -starKIdKey = mkPreludeMiscIdUnique 410 -constraintKIdKey = mkPreludeMiscIdUnique 411 - --- data Callconv = ... -cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey, - javaScriptCallIdKey :: Unique -cCallIdKey = mkPreludeMiscIdUnique 420 -stdCallIdKey = mkPreludeMiscIdUnique 421 -cApiCallIdKey = mkPreludeMiscIdUnique 422 -primCallIdKey = mkPreludeMiscIdUnique 423 -javaScriptCallIdKey = mkPreludeMiscIdUnique 424 - --- data Safety = ... -unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique -unsafeIdKey = mkPreludeMiscIdUnique 430 -safeIdKey = mkPreludeMiscIdUnique 431 -interruptibleIdKey = mkPreludeMiscIdUnique 432 - --- data Inline = ... -noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique -noInlineDataConKey = mkPreludeDataConUnique 40 -inlineDataConKey = mkPreludeDataConUnique 41 -inlinableDataConKey = mkPreludeDataConUnique 42 - --- data RuleMatch = ... -conLikeDataConKey, funLikeDataConKey :: Unique -conLikeDataConKey = mkPreludeDataConUnique 43 -funLikeDataConKey = mkPreludeDataConUnique 44 - --- data Phases = ... -allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique -allPhasesDataConKey = mkPreludeDataConUnique 45 -fromPhaseDataConKey = mkPreludeDataConUnique 46 -beforePhaseDataConKey = mkPreludeDataConUnique 47 - --- newtype TExp a = ... -tExpDataConKey :: Unique -tExpDataConKey = mkPreludeDataConUnique 48 - --- data FunDep = ... -funDepIdKey :: Unique -funDepIdKey = mkPreludeMiscIdUnique 440 - --- data FamFlavour = ... -typeFamIdKey, dataFamIdKey :: Unique -typeFamIdKey = mkPreludeMiscIdUnique 450 -dataFamIdKey = mkPreludeMiscIdUnique 451 - --- data TySynEqn = ... -tySynEqnIdKey :: Unique -tySynEqnIdKey = mkPreludeMiscIdUnique 460 - --- quasiquoting -quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique -quoteExpKey = mkPreludeMiscIdUnique 470 -quotePatKey = mkPreludeMiscIdUnique 471 -quoteDecKey = mkPreludeMiscIdUnique 472 -quoteTypeKey = mkPreludeMiscIdUnique 473 - --- data RuleBndr = ... -ruleVarIdKey, typedRuleVarIdKey :: Unique -ruleVarIdKey = mkPreludeMiscIdUnique 480 -typedRuleVarIdKey = mkPreludeMiscIdUnique 481 - --- data AnnTarget = ... -valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique -valueAnnotationIdKey = mkPreludeMiscIdUnique 490 -typeAnnotationIdKey = mkPreludeMiscIdUnique 491 -moduleAnnotationIdKey = mkPreludeMiscIdUnique 492 diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index c8e30f18a7..5840578942 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -43,7 +43,7 @@ import Maybes import Util import Name import Outputable -import BasicTypes ( boxityNormalTupleSort, isGenerated ) +import BasicTypes ( isGenerated ) import FastString import Control.Monad( when ) @@ -568,7 +568,7 @@ tidy1 _ (TuplePat pats boxity tys) = return (idDsWrapper, unLoc tuple_ConPat) where arity = length pats - tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats tys + tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys -- LitPats: we *might* be able to replace these w/ a simpler form tidy1 _ (LitPat lit) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 09c252b3df..4934d18c5a 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -164,7 +164,6 @@ Library IdInfo Lexeme Literal - DsMeta Llvm Llvm.AbsSyn Llvm.MetaData @@ -422,6 +421,8 @@ Library TcSplice Class Coercion + DsMeta + THNames FamInstEnv FunDeps InstEnv diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 56efbb8fad..b95d05322f 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -48,7 +48,7 @@ import Name import VarEnv import Util import VarSet -import BasicTypes ( TupleSort(UnboxedTuple) ) +import BasicTypes ( Boxity(..) ) import TysPrim import PrelNames import TysWiredIn @@ -832,8 +832,9 @@ extractSubTerms recurse clos = liftM thirdOf3 . go 0 (nonPtrs clos) let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws return (ptr_i, ws1, Prim ty ws0) - unboxedTupleTerm ty terms = Term ty (Right (tupleCon UnboxedTuple (length terms))) - (error "unboxedTupleTerm: no HValue for unboxed tuple") terms + unboxedTupleTerm ty terms + = Term ty (Right (tupleDataCon Unboxed (length terms))) + (error "unboxedTupleTerm: no HValue for unboxed tuple") terms -- Fast, breadth-first Type reconstruction diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 031a340a0b..20cb234dbd 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -993,14 +993,14 @@ cvtTypeKind ty_str ty | n == 1 -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) | otherwise - -> mk_apps (HsTyVar (getRdrName (tupleTyCon BoxedTuple n))) tys' + -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys' UnboxedTupleT n | length tys' == n -- Saturated -> if n==1 then return (head tys') -- Singleton tuples treated -- like nothing (ie just parens) else returnL (HsTupleTy HsUnboxedTuple tys') | otherwise - -> mk_apps (HsTyVar (getRdrName (tupleTyCon UnboxedTuple n))) tys' + -> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys' ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y') | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys' diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index efefd17e4a..e9171a4f66 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -636,8 +636,7 @@ ppr_expr (SectionR op expr) pp_infixly v = sep [pprInfixOcc v, pp_expr] ppr_expr (ExplicitTuple exprs boxity) - = tupleParens (boxityNormalTupleSort boxity) - (fcat (ppr_tup_args $ map unLoc exprs)) + = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) where ppr_tup_args [] = [] ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 6cde90854d..5d74edf2e0 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -302,17 +302,24 @@ pprParendPat p | hsPatNeedsParens p = parens (pprPat p) | otherwise = pprPat p pprPat :: (OutputableBndr name) => Pat name -> SDoc -pprPat (VarPat var) = pprPatBndr var -pprPat (WildPat _) = char '_' -pprPat (LazyPat pat) = char '~' <> pprParendLPat pat -pprPat (BangPat pat) = char '!' <> pprParendLPat pat -pprPat (AsPat name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat] -pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] -pprPat (ParPat pat) = parens (ppr pat) +pprPat (VarPat var) = pprPatBndr var +pprPat (WildPat _) = char '_' +pprPat (LazyPat pat) = char '~' <> pprParendLPat pat +pprPat (BangPat pat) = char '!' <> pprParendLPat pat +pprPat (AsPat name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat] +pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] +pprPat (ParPat pat) = parens (ppr pat) +pprPat (LitPat s) = ppr s +pprPat (NPat l Nothing _) = ppr l +pprPat (NPat l (Just _) _) = char '-' <> ppr l +pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k] +pprPat (SplicePat splice) = pprSplice splice +pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co +pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (ListPat pats _ _) = brackets (interpp'SP pats) -pprPat (PArrPat pats _) = paBrackets (interpp'SP pats) -pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats) - +pprPat (PArrPat pats _) = paBrackets (interpp'SP pats) +pprPat (TuplePat pats bx _) = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) pprPat (ConPatIn con details) = pprUserCon (unLoc con) details pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, pat_binds = binds, pat_args = details }) @@ -325,14 +332,6 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, <+> pprConArgs details else pprUserCon (unLoc con) details -pprPat (LitPat s) = ppr s -pprPat (NPat l Nothing _) = ppr l -pprPat (NPat l (Just _) _) = char '-' <> ppr l -pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k] -pprPat (SplicePat splice) = pprSplice splice -pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co -pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty -pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty pprUserCon :: (OutputableBndr con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index ebd3bd4847..caa83013e0 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -825,7 +825,7 @@ ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty TyConPrec ty ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds ppr_mono_ty _ (HsTyVar name) = pprPrefixOcc name ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2 -ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys) +ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys) where std_con = case con of HsUnboxedTuple -> UnboxedTuple _ -> BoxedTuple diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index e99ad4d547..9d3ef75bec 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -24,7 +24,7 @@ import TcRnMonad import TyCon import ConLike import DataCon (dataConName, dataConWorkId, dataConTyCon) -import PrelInfo (wiredInThings, basicKnownKeyNames) +import PrelInfo ( knownKeyNames ) import Id (idName, isDataConWorkId_maybe) import TysWiredIn import IfaceEnv @@ -303,14 +303,11 @@ serialiseName bh name _ = do knownKeyNamesMap :: UniqFM Name knownKeyNamesMap = listToUFM_Directly [(nameUnique n, n) | n <- knownKeyNames] - where - knownKeyNames :: [Name] - knownKeyNames = map getName wiredInThings ++ basicKnownKeyNames -- See Note [Symbol table representation of names] putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO () -putName _dict BinSymbolTable{ +putName _dict BinSymbolTable{ bin_symtab_map = symtab_map_ref, bin_symtab_next = symtab_next } bh name | name `elemUFM` knownKeyNamesMap @@ -349,7 +346,7 @@ putTupleName_ bh tc tup_sort thing_tag sort_tag = case tup_sort of BoxedTuple -> 0 UnboxedTuple -> 1 - ConstraintTuple -> 2 + ConstraintTuple -> pprPanic "putTupleName:ConstraintTuple" (ppr tc) -- See Note [Symbol table representation of names] getSymtabName :: NameCacheUpdater @@ -370,11 +367,10 @@ getSymtabName _ncu _dict symtab bh = do 2 -> idName (dataConWorkId dc) _ -> pprPanic "getSymtabName:unknown tuple thing" (ppr i) where - dc = tupleCon sort arity + dc = tupleDataCon sort arity sort = case (i .&. 0x30000000) `shiftR` 28 of - 0 -> BoxedTuple - 1 -> UnboxedTuple - 2 -> ConstraintTuple + 0 -> Boxed + 1 -> Unboxed _ -> pprPanic "getSymtabName:unknown tuple sort" (ppr i) thing_tag = (i .&. 0x0CFFFFFF) `shiftR` 26 arity = fromIntegral (i .&. 0x03FFFFFF) diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index 6e14700cfa..b6db5dc9ee 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -21,6 +21,7 @@ module BuildTyCl ( import IfaceEnv import FamInstEnv( FamInstEnvs ) +import TysWiredIn( isCTupleTyConName ) import DataCon import PatSyn import Var @@ -282,6 +283,9 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec ; rhs <- if use_newtype then mkNewTyConRhs tycon_name rec_tycon dict_con + else if isCTupleTyConName tycon_name + then return (TupleTyCon { data_con = dict_con + , tup_sort = ConstraintTuple }) else return (mkDataTyConRhs [dict_con]) ; let { clas_kind = mkPiKinds tvs constraintKind diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 0838cb8468..c5aa1a521b 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -911,7 +911,7 @@ pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceCoercion co pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) -pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (interpp'SP as) +pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as) pprIfaceExpr add_par i@(IfaceLam _ _) = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow, @@ -1136,11 +1136,10 @@ freeNamesIfTcArgs ITC_Nil = emptyNameSet freeNamesIfType :: IfaceType -> NameSet freeNamesIfType (IfaceTyVar _) = emptyNameSet freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t -freeNamesIfType (IfaceTyConApp tc ts) = - freeNamesIfTc tc &&& freeNamesIfTcArgs ts +freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfTcArgs ts +freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfTcArgs ts freeNamesIfType (IfaceLitTy _) = emptyNameSet -freeNamesIfType (IfaceForAllTy tv t) = - freeNamesIfTvBndr tv &&& freeNamesIfType t +freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTvBndr tv &&& freeNamesIfType t freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index dc3c5c5039..6dfff6e4e5 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -10,7 +10,8 @@ This module defines interface types and binders module IfaceType ( IfExtName, IfLclName, - IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoercion(..), + IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), + IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyLit(..), IfaceTcArgs(..), IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, IfaceTvBndr, IfaceIdBndr, @@ -44,12 +45,12 @@ module IfaceType ( #include "HsVersions.h" import Coercion -import DataCon ( dataConTyCon ) +import DataCon ( isTupleDataCon ) import TcType import DynFlags import TypeRep import Unique( hasKey ) -import Util ( filterOut, lengthIs, zipWithEqual ) +import Util ( filterOut, zipWithEqual ) import TyCon hiding ( pprPromotionQuote ) import CoAxiom import Id @@ -99,13 +100,19 @@ type IfaceKind = IfaceType data IfaceType -- A kind of universal type, used for types and kinds = IfaceTyVar IfLclName -- Type/coercion variable only, not tycon + | IfaceLitTy IfaceTyLit | IfaceAppTy IfaceType IfaceType | IfaceFunTy IfaceType IfaceType | IfaceDFunTy IfaceType IfaceType | IfaceForAllTy IfaceTvBndr IfaceType + | IfaceTyConApp IfaceTyCon IfaceTcArgs -- Not necessarily saturated - -- Includes newtypes, synonyms, tuples - | IfaceLitTy IfaceTyLit + -- Includes newtypes, synonyms + + | IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp) + TupleSort IfaceTyConInfo -- A bit like IfaceTyCon + IfaceTcArgs -- arity = length args + -- For promoted data cons, the kind args are omitted type IfacePredType = IfaceType type IfaceContext = [IfacePredType] @@ -128,10 +135,14 @@ data IfaceTcArgs -- coercion constructors, the lot. -- We have to tag them in order to pretty print them -- properly. -data IfaceTyCon - = IfaceTc { ifaceTyConName :: IfExtName } - | IfacePromotedDataCon { ifaceTyConName :: IfExtName } - | IfacePromotedTyCon { ifaceTyConName :: IfExtName } +data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName + , ifaceTyConInfo :: IfaceTyConInfo } + +data IfaceTyConInfo -- Used to guide pretty-printing + -- and to disambiguate D from 'D (they share a name) + = NoIfaceTyConInfo + | IfacePromotedDataCon + | IfacePromotedTyCon data IfaceCoercion = IfaceReflCo Role IfaceType @@ -207,8 +218,9 @@ ifTyVarsOfType ty IfaceForAllTy (var,t) ty -> delOneFromUniqSet (ifTyVarsOfType ty) var `unionUniqSets` ifTyVarsOfType t - IfaceTyConApp _ args -> ifTyVarsOfArgs args - IfaceLitTy _ -> emptyUniqSet + IfaceTyConApp _ args -> ifTyVarsOfArgs args + IfaceTupleTy _ _ args -> ifTyVarsOfArgs args + IfaceLitTy _ -> emptyUniqSet ifTyVarsOfArgs :: IfaceTcArgs -> UniqSet IfLclName ifTyVarsOfArgs args = argv emptyUniqSet args @@ -238,6 +250,7 @@ substIfaceType env ty go (IfaceDFunTy t1 t2) = IfaceDFunTy (go t1) (go t2) go ty@(IfaceLitTy {}) = ty go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys) + go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceTcArgs env tys) go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty) substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs @@ -304,18 +317,6 @@ we want ************************************************************************ * * - Functions over IFaceTyCon -* * -************************************************************************ --} - ---isPromotedIfaceTyCon :: IfaceTyCon -> Bool ---isPromotedIfaceTyCon (IfacePromotedTyCon _) = True ---isPromotedIfaceTyCon _ = False - -{- -************************************************************************ -* * Pretty-printing * * ************************************************************************ @@ -395,6 +396,7 @@ pprParendIfaceType = ppr_ty TyConPrec ppr_ty :: TyPrec -> IfaceType -> SDoc ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar ppr_ty ctxt_prec (IfaceTyConApp tc tys) = sdocWithDynFlags (pprTyTcApp ctxt_prec tc tys) +ppr_ty _ (IfaceTupleTy s i tys) = pprTuple s i tys ppr_ty _ (IfaceLitTy n) = ppr_tylit n -- Function types ppr_ty ctxt_prec (IfaceFunTy ty1 ty2) @@ -521,10 +523,6 @@ ppr_iface_tc_app pp _ tc [ty] n = ifaceTyConName tc ppr_iface_tc_app pp ctxt_prec tc tys - | Just (tup_sort, tup_args) <- is_tuple - = pprPromotionQuote tc <> - tupleParens tup_sort (sep (punctuate comma (map (pp TopPrec) tup_args))) - | not (isSymOcc (nameOccName tc_name)) = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys) @@ -540,22 +538,10 @@ ppr_iface_tc_app pp ctxt_prec tc tys where tc_name = ifaceTyConName tc - is_tuple = case wiredInNameTyThing_maybe tc_name of - Just (ATyCon tc) - | Just sort <- tyConTuple_maybe tc - , tyConArity tc == length tys - -> Just (sort, tys) - - | Just dc <- isPromotedDataCon_maybe tc - , let dc_tc = dataConTyCon dc - , Just tup_sort <- tyConTuple_maybe dc_tc - , let arity = tyConArity dc_tc - ty_args = drop arity tys - , ty_args `lengthIs` arity - -> Just (tup_sort, ty_args) - - _ -> Nothing - +pprTuple :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> SDoc +pprTuple sort info args + = pprPromotionQuoteI info <> + tupleParens sort (pprWithCommas pprIfaceType (tcArgsIfaceTypes args)) ppr_tylit :: IfaceTyLit -> SDoc ppr_tylit (IfaceNumTyLit n) = integer n @@ -635,27 +621,34 @@ instance Outputable IfaceTyCon where ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) pprPromotionQuote :: IfaceTyCon -> SDoc -pprPromotionQuote (IfacePromotedDataCon _ ) = char '\'' -pprPromotionQuote (IfacePromotedTyCon _) = ifPprDebug (char '\'') -pprPromotionQuote _ = empty +pprPromotionQuote tc = pprPromotionQuoteI (ifaceTyConInfo tc) + +pprPromotionQuoteI :: IfaceTyConInfo -> SDoc +pprPromotionQuoteI NoIfaceTyConInfo = empty +pprPromotionQuoteI IfacePromotedDataCon = char '\'' +pprPromotionQuoteI IfacePromotedTyCon = ifPprDebug (char '\'') instance Outputable IfaceCoercion where ppr = pprIfaceCoercion instance Binary IfaceTyCon where - put_ bh tc = - case tc of - IfaceTc n -> putByte bh 0 >> put_ bh n - IfacePromotedDataCon n -> putByte bh 1 >> put_ bh n - IfacePromotedTyCon n -> putByte bh 2 >> put_ bh n + put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i + + get bh = do n <- get bh + i <- get bh + return (IfaceTyCon n i) + +instance Binary IfaceTyConInfo where + put_ bh NoIfaceTyConInfo = putByte bh 0 + put_ bh IfacePromotedDataCon = putByte bh 1 + put_ bh IfacePromotedTyCon = putByte bh 2 get bh = - do tc <- getByte bh - case tc of - 0 -> get bh >>= return . IfaceTc - 1 -> get bh >>= return . IfacePromotedDataCon - 2 -> get bh >>= return . IfacePromotedTyCon - _ -> panic ("get IfaceTyCon " ++ show tc) + do i <- getByte bh + case i of + 0 -> return NoIfaceTyConInfo + 1 -> return IfacePromotedDataCon + _ -> return IfacePromotedTyCon instance Outputable IfaceTyLit where ppr = ppr_tylit @@ -729,9 +722,10 @@ instance Binary IfaceType where put_ bh ah put_ bh (IfaceTyConApp tc tys) = do { putByte bh 5; put_ bh tc; put_ bh tys } - + put_ bh (IfaceTupleTy s i tys) + = do { putByte bh 6; put_ bh s; put_ bh i; put_ bh tys } put_ bh (IfaceLitTy n) - = do { putByte bh 30; put_ bh n } + = do { putByte bh 7; put_ bh n } get bh = do h <- getByte bh @@ -752,6 +746,8 @@ instance Binary IfaceType where return (IfaceDFunTy ag ah) 5 -> do { tc <- get bh; tys <- get bh ; return (IfaceTyConApp tc tys) } + 6 -> do { s <- get bh; i <- get bh; tys <- get bh + ; return (IfaceTupleTy s i tys) } 30 -> do n <- get bh return (IfaceLitTy n) @@ -904,12 +900,32 @@ toIfaceType :: Type -> IfaceType -- Synonyms are retained in the interface type toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv) toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n) +toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) toIfaceType (FunTy t1 t2) | isPredTy t1 = IfaceDFunTy (toIfaceType t1) (toIfaceType t2) | otherwise = IfaceFunTy (toIfaceType t1) (toIfaceType t2) -toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgs tc tys) -toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n) -toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) + +toIfaceType (TyConApp tc tys) -- Look for the three sorts of saturated tuple + | Just sort <- tyConTuple_maybe tc + , n_tys == arity + = IfaceTupleTy sort NoIfaceTyConInfo (toIfaceTcArgs tc tys) + + | Just tc' <- isPromotedTyCon_maybe tc + , Just sort <- tyConTuple_maybe tc' + , n_tys == arity + = IfaceTupleTy sort IfacePromotedTyCon (toIfaceTcArgs tc tys) + + | Just dc <- isPromotedDataCon_maybe tc + , isTupleDataCon dc + , n_tys == 2*arity + = IfaceTupleTy BoxedTuple IfacePromotedDataCon (toIfaceTcArgs tc (drop arity tys)) + + | otherwise + = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgs tc tys) + where + arity = tyConArity tc + n_tys = length tys toIfaceTyVar :: TyVar -> FastString toIfaceTyVar = occNameFS . getOccName @@ -920,13 +936,17 @@ toIfaceCoVar = occNameFS . getOccName ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTyCon tc - | isPromotedDataCon tc = IfacePromotedDataCon tc_name - | isPromotedTyCon tc = IfacePromotedTyCon tc_name - | otherwise = IfaceTc tc_name - where tc_name = tyConName tc + = IfaceTyCon tc_name info + where + tc_name = tyConName tc + info | isPromotedDataCon tc = IfacePromotedDataCon + | isPromotedTyCon tc = IfacePromotedTyCon + | otherwise = NoIfaceTyConInfo toIfaceTyCon_name :: Name -> IfaceTyCon -toIfaceTyCon_name = IfaceTc +toIfaceTyCon_name n = IfaceTyCon n NoIfaceTyConInfo + -- Used for the "rough-match" tycon stuff, + -- where pretty-printing is not an issue toIfaceTyLit :: TyLit -> IfaceTyLit toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 1beae57cc7..2553643525 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -49,7 +49,7 @@ import DataCon import PrelNames import TysWiredIn import TysPrim ( superKindTyConName ) -import BasicTypes ( strongLoopBreaker ) +import BasicTypes ( strongLoopBreaker, Arity, TupleSort(..), Boxity(..) ) import Literal import qualified Var import VarEnv @@ -643,7 +643,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd -- or, even if it is (module loop, perhaps) -- we'll just leave it in the non-local set where - -- This function *must* mirror exactly what Rules.topFreeName does + -- This function *must* mirror exactly what Rules.roughTopNames does -- We could have stored the ru_rough field in the iface file -- but that would be redundant, I think. -- The only wrinkle is that we must not be deceived by @@ -652,6 +652,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd -- to write them out in coreRuleToIfaceRule ifTopFreeName :: IfaceExpr -> Maybe Name ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc) + ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (tcArgsIfaceTypes ts))) ifTopFreeName (IfaceApp f _) = ifTopFreeName f ifTopFreeName (IfaceExt n) = Just n ifTopFreeName _ = Nothing @@ -805,7 +806,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo -- name is not a tycon => internal inconsistency Just _ -> notATyConErr -- tycon is external - Nothing -> tcIfaceTyCon (IfaceTc name) + Nothing -> tcIfaceTyConByName name } notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name) @@ -824,6 +825,7 @@ tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceT tcIfaceType (IfaceLitTy l) = do { l1 <- tcIfaceTyLit l; return (LitTy l1) } tcIfaceType (IfaceFunTy t1 t2) = tcIfaceTypeFun t1 t2 tcIfaceType (IfaceDFunTy t1 t2) = tcIfaceTypeFun t1 t2 +tcIfaceType (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc ; tks' <- tcIfaceTcArgs tks ; return (mkTyConApp tc' tks') } @@ -842,6 +844,34 @@ tcIfaceKind k = tcIfaceType k tcIfaceKindFun :: IfaceKind -> IfaceKind -> IfL Type tcIfaceKindFun t1 t2 = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') } +tcIfaceTupleTy :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> IfL Type +tcIfaceTupleTy sort info args + = do { args' <- tcIfaceTcArgs args + ; let arity = length args' + ; base_tc <- tcTupleTyCon sort arity + ; case info of + NoIfaceTyConInfo + -> return (mkTyConApp base_tc args') + + IfacePromotedTyCon + | Just tc <- promotableTyCon_maybe base_tc + -> return (mkTyConApp tc args') + | otherwise + -> panic "tcIfaceTupleTy" (ppr base_tc) + + IfacePromotedDataCon + -> do { let tc = promoteDataCon (tyConSingleDataCon base_tc) + kind_args = map typeKind args' + ; return (mkTyConApp tc (kind_args ++ args')) } } + +tcTupleTyCon :: TupleSort -> Arity -> IfL TyCon +tcTupleTyCon sort arity + = case sort of + ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity) + ; return (tyThingTyCon thing) } + BoxedTuple -> return (tupleTyCon Boxed arity) + UnboxedTuple -> return (tupleTyCon Unboxed arity) + tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type] tcIfaceTcArgs args = case args of @@ -942,15 +972,15 @@ tcIfaceExpr (IfaceFCall cc ty) = do dflags <- getDynFlags return (Var (mkFCallId dflags u cc ty')) -tcIfaceExpr (IfaceTuple boxity args) = do - args' <- mapM tcIfaceExpr args - -- Put the missing type arguments back in - let con_args = map (Type . exprType) args' ++ args' - return (mkApps (Var con_id) con_args) +tcIfaceExpr (IfaceTuple sort args) + = do { args' <- mapM tcIfaceExpr args + ; tc <- tcTupleTyCon sort arity + ; let con_args = map (Type . exprType) args' ++ args' + -- Put the missing type arguments back in + con_id = dataConWorkId (tyConSingleDataCon tc) + ; return (mkApps (Var con_id) con_args) } where arity = length args - con_id = dataConWorkId (tupleCon boxity arity) - tcIfaceExpr (IfaceLam (bndr, os) body) = bindIfaceBndr bndr $ \bndr' -> @@ -1059,7 +1089,7 @@ tcIfaceLit :: Literal -> IfL Literal -- so tcIfaceLit just fills in the type. -- See Note [Integer literals] in Literal tcIfaceLit (LitInteger i _) - = do t <- tcIfaceTyCon (IfaceTc integerTyConName) + = do t <- tcIfaceTyConByName integerTyConName return (mkLitInteger i (mkTyConTy t)) tcIfaceLit lit = return lit @@ -1237,6 +1267,7 @@ tcIfaceGlobal name -- sure the instances and RULES of this thing (particularly TyCon) are loaded -- Imagine: f :: Double -> Double = do { ifCheckWiredInThing thing; return thing } + | otherwise = do { env <- getGblEnv ; case if_rec_types env of { -- Note [Tying the knot] @@ -1279,20 +1310,25 @@ tcIfaceGlobal name -- Because if M.hs also has M.hs-boot, M.T will *already be* in the HPT, but in its -- emasculated form (e.g. lacking data constructors). +tcIfaceTyConByName :: IfExtName -> IfL TyCon +tcIfaceTyConByName name + = do { thing <- tcIfaceGlobal name + ; return (tyThingTyCon thing) } + tcIfaceTyCon :: IfaceTyCon -> IfL TyCon -tcIfaceTyCon itc - = do { - ; thing <- tcIfaceGlobal (ifaceTyConName itc) - ; case itc of - IfaceTc _ -> return $ tyThingTyCon thing - IfacePromotedDataCon _ -> return $ promoteDataCon $ tyThingDataCon thing - IfacePromotedTyCon name -> - let ktycon tc - | isSuperKind (tyConKind tc) = return tc - | Just prom_tc <- promotableTyCon_maybe tc = return prom_tc - | otherwise = pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) - in ktycon (tyThingTyCon thing) - } +tcIfaceTyCon (IfaceTyCon name info) + = do { thing <- tcIfaceGlobal name + ; case info of + NoIfaceTyConInfo -> return (tyThingTyCon thing) + IfacePromotedDataCon -> return (promoteDataCon (tyThingDataCon thing)) + -- Same Name as its underlying DataCon + IfacePromotedTyCon -> return (promote_tc (tyThingTyCon thing)) } + -- Same Name as its underlying TyCon + where + promote_tc tc + | Just prom_tc <- promotableTyCon_maybe tc = prom_tc + | isSuperKind (tyConKind tc) = tc + | otherwise = pprPanic "tcIfaceTyCon" (ppr name $$ ppr tc) tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name diff --git a/compiler/main/Constants.hs b/compiler/main/Constants.hs index 0f23fc242e..22bd4e6e02 100644 --- a/compiler/main/Constants.hs +++ b/compiler/main/Constants.hs @@ -17,6 +17,9 @@ mAX_TUPLE_SIZE :: Int mAX_TUPLE_SIZE = 62 -- Should really match the number -- of decls in Data.Tuple +mAX_CTUPLE_SIZE :: Int -- Constraint tuples +mAX_CTUPLE_SIZE = 8 -- Should match the number of decls in GHC.Classes + -- | Default maximum depth for both class instance search and type family -- reduction. See also Trac #5395. mAX_REDUCTION_DEPTH :: Int diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 0acbdff8a5..47d4515a14 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -101,7 +101,6 @@ import ConLike import GHC.Exts #endif -import DsMeta ( templateHaskellNames ) import Module import Packages import RdrName @@ -192,12 +191,6 @@ newHscEnv dflags = do hsc_type_env_var = Nothing } -knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, -knownKeyNames = -- where templateHaskellNames are defined - map getName wiredInThings - ++ basicKnownKeyNames - ++ templateHaskellNames - -- ----------------------------------------------------------------------------- getWarnings :: Hsc WarningMessages diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index eb2aa0c276..7ffa6b6a05 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -80,7 +80,7 @@ import TcEvidence ( emptyTcEvBinds ) -- compiler/prelude import ForeignCall import TysPrim ( liftedTypeKindTyConName, eqPrimTyCon ) -import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, +import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, unboxedUnitTyCon, unboxedUnitDataCon, listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) @@ -728,10 +728,9 @@ qcname_ext :: { Located RdrName } -- Variable or data constructor | 'type' qcname {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2))) [mj AnnType $1,mj AnnVal $2] } --- Cannot pull into qcname_ext, as qcname is also used in expression. -qcname :: { Located RdrName } -- Variable or data constructor +qcname :: { Located RdrName } -- Variable or type constructor : qvar { $1 } - | qcon { $1 } + | oqtycon { $1 } ----------------------------------------------------------------------------- -- Import Declarations @@ -2277,8 +2276,9 @@ aexp1 :: { LHsExpr RdrName } | aexp2 { $1 } aexp2 :: { LHsExpr RdrName } - : ipvar { sL1 $1 (HsIPVar $! unLoc $1) } - | qcname { sL1 $1 (HsVar $! unLoc $1) } + : qvar { sL1 $1 (HsVar $! unLoc $1) } + | qcon { sL1 $1 (HsVar $! unLoc $1) } + | ipvar { sL1 $1 (HsIPVar $! unLoc $1) } | literal { sL1 $1 (HsLit $! unLoc $1) } -- This will enable overloaded strings permanently. Normally the renamer turns HsString -- into HsOverLit when -foverloaded-strings is on. @@ -2803,10 +2803,10 @@ con_list : con { sL1 $1 [$1] } sysdcon_nolist :: { Located DataCon } -- Wired in data constructors : '(' ')' {% ams (sLL $1 $> unitDataCon) [mop $1,mcp $2] } - | '(' commas ')' {% ams (sLL $1 $> $ tupleCon BoxedTuple (snd $2 + 1)) + | '(' commas ')' {% ams (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1)) (mop $1:mcp $3:(mcommas (fst $2))) } | '(#' '#)' {% ams (sLL $1 $> $ unboxedUnitDataCon) [mo $1,mc $2] } - | '(#' commas '#)' {% ams (sLL $1 $> $ tupleCon UnboxedTuple (snd $2 + 1)) + | '(#' commas '#)' {% ams (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1)) (mo $1:mc $3:(mcommas (fst $2))) } sysdcon :: { Located DataCon } @@ -2840,10 +2840,10 @@ gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tu ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit tuples : oqtycon { $1 } - | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon BoxedTuple + | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Boxed (snd $2 + 1))) (mop $1:mcp $3:(mcommas (fst $2))) } - | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon UnboxedTuple + | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Unboxed (snd $2 + 1))) (mo $1:mc $3:(mcommas (fst $2))) } | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index f0dc1ea433..39589fe72c 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -21,6 +21,7 @@ module RdrHsSyn ( mkPatSynMatchGroup, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp mkTyClD, mkInstD, + setRdrNameSpace, cvBindGroup, cvBindsAndSigs, @@ -65,24 +66,24 @@ module RdrHsSyn ( import HsSyn -- Lots of it import Class ( FunDep ) +import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) +import DataCon ( DataCon, dataConTyCon ) +import ConLike ( ConLike(..) ) import CoAxiom ( Role, fsFromRole ) -import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, - isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace, - rdrNameSpace ) -import OccName ( tcClsName, isVarNameSpace ) -import Name ( Name ) -import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, - InlinePragma(..), InlineSpec(..), Origin(..), - SourceText ) +import RdrName +import Name +import BasicTypes import TcEvidence ( idHsWrapper ) import Lexer -import TysWiredIn ( unitTyCon, unitDataCon ) +import Type ( TyThing(..) ) +import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon, + nilDataConName, nilDataConKey, + listTyConName, listTyConKey ) import ForeignCall -import OccName ( srcDataName, varName, isDataOcc, isTcOcc, - occNameString ) import PrelNames ( forall_tv_RDR, allNameStrings ) import DynFlags import SrcLoc +import Unique ( hasKey ) import OrdList ( OrdList, fromOL ) import Bag ( emptyBag, consBag ) import Outputable @@ -137,7 +138,7 @@ mkClassDecl :: SrcSpan mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls ; let cxt = fromMaybe (noLoc []) mcxt - ; (cls, tparams,ann) <- checkTyClHdr tycl_hdr + ; (cls, tparams,ann) <- checkTyClHdr True tycl_hdr ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan -- Partial type signatures are not allowed in a class definition ; checkNoPartialSigs sigs cls @@ -271,7 +272,7 @@ mkTyData :: SrcSpan -> Maybe (Located [LHsType RdrName]) -> P (LTyClDecl RdrName) mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv - = do { (tc, tparams,ann) <- checkTyClHdr tycl_hdr + = do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv @@ -306,7 +307,7 @@ mkTySynonym :: SrcSpan -> LHsType RdrName -- RHS -> P (LTyClDecl RdrName) mkTySynonym loc lhs rhs - = do { (tc, tparams,ann) <- checkTyClHdr lhs + = do { (tc, tparams,ann) <- checkTyClHdr False lhs ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (ptext (sLit "type")) equalsDots tc tparams ; let err = text "In type synonym" <+> quotes (ppr tc) <> @@ -319,7 +320,7 @@ mkTyFamInstEqn :: LHsType RdrName -> LHsType RdrName -> P (TyFamInstEqn RdrName,[AddAnn]) mkTyFamInstEqn lhs rhs - = do { (tc, tparams,ann) <- checkTyClHdr lhs + = do { (tc, tparams,ann) <- checkTyClHdr False lhs ; let err xhs = hang (text "In type family instance equation of" <+> quotes (ppr tc) <> colon) 2 (ppr xhs) @@ -339,7 +340,7 @@ mkDataFamInst :: SrcSpan -> Maybe (Located [LHsType RdrName]) -> P (LInstDecl RdrName) mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv - = do { (tc, tparams,ann) <- checkTyClHdr tycl_hdr + = do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataFamInstD ( @@ -359,7 +360,7 @@ mkFamDecl :: SrcSpan -> Maybe (LHsKind RdrName) -- Optional kind signature -> P (LTyClDecl RdrName) mkFamDecl loc info lhs ksig - = do { (tc, tparams,ann) <- checkTyClHdr lhs + = do { (tc, tparams,ann) <- checkTyClHdr False lhs ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams ; return (L loc (FamDecl (FamilyDecl { fdInfo = info, fdLName = tc @@ -545,9 +546,9 @@ splitCon ty split (L _ (HsAppTy t u)) ts = split t (u : ts) split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc return (data_con, mk_rest ts) - split (L l (HsTupleTy _ [])) [] = return (L l (getRdrName unitDataCon), PrefixCon []) - -- See Note [Unit tuples] in HsTypes - split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty) + split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) [] + = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts) + split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty) mk_rest [L l (HsRecTy flds)] = RecCon (L l flds) mk_rest ts = PrefixCon ts @@ -662,6 +663,91 @@ tyConToDataCon loc tc = text "Perhaps you intended to use ExistentialQuantification" | otherwise = empty +setRdrNameSpace :: RdrName -> NameSpace -> RdrName +-- ^ This rather gruesome function is used mainly by the parser. +-- When parsing: +-- +-- > data T a = T | T1 Int +-- +-- we parse the data constructors as /types/ because of parser ambiguities, +-- so then we need to change the /type constr/ to a /data constr/ +-- +-- The exact-name case /can/ occur when parsing: +-- +-- > data [] a = [] | a : [a] +-- +-- For the exact-name case we return an original name. +setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) +setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) +setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) +setRdrNameSpace (Exact n) ns + | Just thing <- wiredInNameTyThing_maybe n + = setWiredInNameSpace thing ns + -- Preserve Exact Names for wired-in things, + -- notably tuples and lists + + | isExternalName n + = Orig (nameModule n) occ + + | otherwise -- This can happen when quoting and then + -- splicing a fixity declaration for a type + = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)) + where + occ = setOccNameSpace ns (nameOccName n) + +setWiredInNameSpace :: TyThing -> NameSpace -> RdrName +setWiredInNameSpace (ATyCon tc) ns + | isDataConNameSpace ns + = ty_con_data_con tc + | isTcClsNameSpace ns + = Exact (getName tc) -- No-op + +setWiredInNameSpace (AConLike (RealDataCon dc)) ns + | isTcClsNameSpace ns + = data_con_ty_con dc + | isDataConNameSpace ns + = Exact (getName dc) -- No-op + +setWiredInNameSpace thing ns + = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing) + +ty_con_data_con :: TyCon -> RdrName +ty_con_data_con tc + | isTupleTyCon tc + , Just dc <- tyConSingleDataCon_maybe tc + = Exact (getName dc) + + | tc `hasKey` listTyConKey + = Exact nilDataConName + + | otherwise -- See Note [setRdrNameSpace for wired-in names] + = Unqual (setOccNameSpace srcDataName (getOccName tc)) + +data_con_ty_con :: DataCon -> RdrName +data_con_ty_con dc + | let tc = dataConTyCon dc + , isTupleTyCon tc + = Exact (getName tc) + + | dc `hasKey` nilDataConKey + = Exact listTyConName + + | otherwise -- See Note [setRdrNameSpace for wired-in names] + = Unqual (setOccNameSpace tcClsName (getOccName dc)) + + +{- Note [setRdrNameSpace for wired-in names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC.Types, which declares (:), we have + infixr 5 : +The ambiguity about which ":" is meant is resolved by parsing it as a +data constructor, but then using dataTcOccs to try the type constructor too; +and that in turn calls setRdrNameSpace to change the name-space of ":" to +tcClsName. There isn't a corresponding ":" type constructor, but it's painful +to make setRdrNameSpace partial, so we just make an Unqual name instead. It +really doesn't matter! +-} + -- | Note [Sorting out the result type] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- In a GADT declaration which is not a record, we put the whole constr @@ -738,7 +824,9 @@ checkRecordSyntax lr@(L loc r) (text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r) -checkTyClHdr :: LHsType RdrName +checkTyClHdr :: Bool -- True <=> class header + -- False <=> type header + -> LHsType RdrName -> P (Located RdrName, -- the head symbol (type or class name) [LHsType RdrName], -- parameters of head symbol [AddAnn]) -- API Annotation for HsParTy when stripping parens @@ -746,22 +834,28 @@ checkTyClHdr :: LHsType RdrName -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) -- Int :*: Bool into (:*:, [Int, Bool]) -- returning the pieces -checkTyClHdr ty +checkTyClHdr is_cls ty = goL ty [] [] where goL (L l ty) acc ann = go l ty acc ann go l (HsTyVar tc) acc ann - | isRdrTc tc = return (L l tc, acc, ann) + | isRdrTc tc = return (L l tc, acc, ann) go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc ann - | isRdrTc tc = return (ltc, t1:t2:acc, ann) + | isRdrTc tc = return (ltc, t1:t2:acc, ann) go l (HsParTy ty) acc ann = goL ty acc (ann ++ mkParensApiAnn l) go _ (HsAppTy t1 t2) acc ann = goL t1 (t2:acc) ann - go l (HsTupleTy _ []) [] ann = return (L l (getRdrName unitTyCon), [],ann) - -- See Note [Unit tuples] in HsTypes - go l _ _ _ - = parseErrorSDoc l (text "Malformed head of type or class declaration:" - <+> ppr ty) + + go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann + = return (L l (nameRdrName tup_name), ts, ann) + where + arity = length ts + tup_name | is_cls = cTupleTyConName arity + | otherwise = getName (tupleTyCon Boxed arity) + -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?) + go l _ _ _ + = parseErrorSDoc l (text "Malformed head of type or class declaration:" + <+> ppr ty) checkContext :: LHsType RdrName -> P (LHsContext RdrName) checkContext (L l orig_t) @@ -1481,14 +1575,12 @@ mkModuleImpExp n@(L l name) subs = case subs of ImpExpAbs | isVarNameSpace (rdrNameSpace name) -> IEVar n - | otherwise -> IEThingAbs (L l nameT) - ImpExpAll -> IEThingAll (L l nameT) - ImpExpList xs -> IEThingWith (L l nameT) xs - - where - nameT = setRdrNameSpace name tcClsName + | otherwise -> IEThingAbs (L l name) + ImpExpAll -> IEThingAll (L l name) + ImpExpList xs -> IEThingWith (L l name) xs -mkTypeImpExp :: Located RdrName -> P (Located RdrName) +mkTypeImpExp :: Located RdrName -- TcCls or Var name space + -> P (Located RdrName) mkTypeImpExp name = do allowed <- extension explicitNamespacesEnabled if allowed diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs index 2303a8edd3..4d1cd9af95 100644 --- a/compiler/prelude/PrelInfo.hs +++ b/compiler/prelude/PrelInfo.hs @@ -10,7 +10,7 @@ module PrelInfo ( primOpRules, builtinRules, ghcPrimExports, - wiredInThings, basicKnownKeyNames, + wiredInThings, knownKeyNames, primOpId, -- Random other things @@ -30,6 +30,7 @@ import PrimOp import DataCon import Id import MkId +import Name( Name, getName ) import TysPrim import TysWiredIn import HscTypes @@ -38,12 +39,31 @@ import TyCon import Util import {-# SOURCE #-} TcTypeNats ( typeNatTyCons ) +#ifdef GHCI +import THNames +#endif + import Data.Array -{- -************************************************************************ + +{- ********************************************************************* +* * + Known key things +* * +********************************************************************* -} + +knownKeyNames :: [Name] +knownKeyNames + = map getName wiredInThings + ++ cTupleTyConNames + ++ basicKnownKeyNames +#ifdef GHCI + ++ templateHaskellNames +#endif + +{- ********************************************************************* * * -\subsection[builtinNameInfo]{Lookup built-in names} + Wired in things * * ************************************************************************ diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 113dfdc507..ded9583c62 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -121,7 +121,6 @@ import Module import OccName import RdrName import Unique -import BasicTypes import Name import SrcLoc import FastString @@ -520,19 +519,6 @@ mkMainModule_ m = mkModule mainPackageKey m {- ************************************************************************ * * -\subsection{Constructing the names of tuples -* * -************************************************************************ --} - -mkTupleModule :: TupleSort -> Module -mkTupleModule BoxedTuple = gHC_TUPLE -mkTupleModule ConstraintTuple = gHC_TUPLE -mkTupleModule UnboxedTuple = gHC_PRIM - -{- -************************************************************************ -* * RdrNames * * ************************************************************************ @@ -1572,9 +1558,6 @@ typeRepTyConKey = mkPreludeTyConUnique 183 #include "primop-vector-uniques.hs-incl" -unitTyConKey :: Unique -unitTyConKey = mkTupleTyConUnique BoxedTuple 0 - {- ************************************************************************ * * diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index 5c6b70072b..1ab8543afc 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -907,7 +907,7 @@ seqRule :: RuleM CoreExpr seqRule = do [ty_a, Type ty_s, a, s] <- getArgs guard $ exprIsHNF a - return $ mkConApp (tupleCon UnboxedTuple 2) + return $ mkConApp (tupleDataCon Unboxed 2) [Type (mkStatePrimTy ty_s), ty_a, s, a] -- spark# :: forall a s . a -> State# s -> (# State# s, a #) @@ -1224,7 +1224,7 @@ match_Integer_divop_both divop _ id_unf _ [xl,yl] , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 , (r,s) <- x `divop` y - = Just $ mkConApp (tupleCon UnboxedTuple 2) + = Just $ mkConApp (tupleDataCon Unboxed 2) [Type t, Type t, Lit (LitInteger r t), @@ -1300,7 +1300,7 @@ match_decodeDouble _ id_unf fn [xl] FunTy _ (TyConApp _ [integerTy, intHashTy]) -> case decodeFloat (fromRational x :: Double) of (y, z) -> - Just $ mkConApp (tupleCon UnboxedTuple 2) + Just $ mkConApp (tupleDataCon Unboxed 2) [Type integerTy, Type intHashTy, Lit (LitInteger y integerTy), diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs index de6d49b96a..dbeade27bc 100644 --- a/compiler/prelude/PrimOp.hs +++ b/compiler/prelude/PrimOp.hs @@ -34,7 +34,7 @@ import OccName ( OccName, pprOccName, mkVarOccFS ) import TyCon ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) ) import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon, typePrimRep ) -import BasicTypes ( Arity, Fixity(..), FixityDirection(..), TupleSort(..) ) +import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..) ) import ForeignCall ( CLabelString ) import Unique ( Unique, mkPrimOpIdUnique ) import Outputable diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs new file mode 100644 index 0000000000..5ccfaeb3e8 --- /dev/null +++ b/compiler/prelude/THNames.hs @@ -0,0 +1,836 @@ +-- %************************************************************************ +-- %* * +-- The known-key names for Template Haskell +-- %* * +-- %************************************************************************ + +module THNames where + +import PrelNames( mk_known_key_name ) +import Module( Module, mkModuleNameFS, mkModule, thPackageKey ) +import Name( Name ) +import OccName( tcName, dataName, varName ) +import Unique +import FastString + +-- To add a name, do three things +-- +-- 1) Allocate a key +-- 2) Make a "Name" +-- 3) Add the name to knownKeyNames + +templateHaskellNames :: [Name] +-- The names that are implicitly mentioned by ``bracket'' +-- Should stay in sync with the import list of DsMeta + +templateHaskellNames = [ + returnQName, bindQName, sequenceQName, newNameName, liftName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, + liftStringName, + unTypeName, + unTypeQName, + unsafeTExpCoerceName, + + -- Lit + charLName, stringLName, integerLName, intPrimLName, wordPrimLName, + floatPrimLName, doublePrimLName, rationalLName, + -- Pat + litPName, varPName, tupPName, unboxedTupPName, + conPName, tildePName, bangPName, infixPName, + asPName, wildPName, recPName, listPName, sigPName, viewPName, + -- FieldPat + fieldPatName, + -- Match + matchName, + -- Clause + clauseName, + -- Exp + varEName, conEName, litEName, appEName, infixEName, + infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName, + tupEName, unboxedTupEName, + condEName, multiIfEName, letEName, caseEName, doEName, compEName, + fromEName, fromThenEName, fromToEName, fromThenToEName, + listEName, sigEName, recConEName, recUpdEName, staticEName, + -- FieldExp + fieldExpName, + -- Body + guardedBName, normalBName, + -- Guard + normalGEName, patGEName, + -- Stmt + bindSName, letSName, noBindSName, parSName, + -- Dec + funDName, valDName, dataDName, newtypeDName, tySynDName, + classDName, instanceDName, standaloneDerivDName, sigDName, forImpDName, + pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, + pragRuleDName, pragAnnDName, defaultSigDName, + familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, + tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, + infixLDName, infixRDName, infixNDName, + roleAnnotDName, + -- Cxt + cxtName, + -- Strict + isStrictName, notStrictName, unpackedName, + -- Con + normalCName, recCName, infixCName, forallCName, + -- StrictType + strictTypeName, + -- VarStrictType + varStrictTypeName, + -- Type + forallTName, varTName, conTName, appTName, equalityTName, + tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName, + promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, + -- TyLit + numTyLitName, strTyLitName, + -- TyVarBndr + plainTVName, kindedTVName, + -- Role + nominalRName, representationalRName, phantomRName, inferRName, + -- Kind + varKName, conKName, tupleKName, arrowKName, listKName, appKName, + starKName, constraintKName, + -- Callconv + cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName, + -- Safety + unsafeName, + safeName, + interruptibleName, + -- Inline + noInlineDataConName, inlineDataConName, inlinableDataConName, + -- RuleMatch + conLikeDataConName, funLikeDataConName, + -- Phases + allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName, + -- TExp + tExpDataConName, + -- RuleBndr + ruleVarName, typedRuleVarName, + -- FunDep + funDepName, + -- FamFlavour + typeFamName, dataFamName, + -- TySynEqn + tySynEqnName, + -- AnnTarget + valueAnnotationName, typeAnnotationName, moduleAnnotationName, + + -- And the tycons + qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName, + clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName, + stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName, + varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, + typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, + patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, + predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName, + roleTyConName, tExpTyConName, + + -- Quasiquoting + quoteDecName, quoteTypeName, quoteExpName, quotePatName] + +thSyn, thLib, qqLib :: Module +thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax") +thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib") +qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") + +mkTHModule :: FastString -> Module +mkTHModule m = mkModule thPackageKey (mkModuleNameFS m) + +libFun, libTc, thFun, thTc, thCon, qqFun :: FastString -> Unique -> Name +libFun = mk_known_key_name OccName.varName thLib +libTc = mk_known_key_name OccName.tcName thLib +thFun = mk_known_key_name OccName.varName thSyn +thTc = mk_known_key_name OccName.tcName thSyn +thCon = mk_known_key_name OccName.dataName thSyn +qqFun = mk_known_key_name OccName.varName qqLib + +-------------------- TH.Syntax ----------------------- +qTyConName, nameTyConName, fieldExpTyConName, patTyConName, + fieldPatTyConName, expTyConName, decTyConName, typeTyConName, + tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName, + predTyConName, tExpTyConName :: Name +qTyConName = thTc (fsLit "Q") qTyConKey +nameTyConName = thTc (fsLit "Name") nameTyConKey +fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey +patTyConName = thTc (fsLit "Pat") patTyConKey +fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey +expTyConName = thTc (fsLit "Exp") expTyConKey +decTyConName = thTc (fsLit "Dec") decTyConKey +typeTyConName = thTc (fsLit "Type") typeTyConKey +tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey +matchTyConName = thTc (fsLit "Match") matchTyConKey +clauseTyConName = thTc (fsLit "Clause") clauseTyConKey +funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey +predTyConName = thTc (fsLit "Pred") predTyConKey +tExpTyConName = thTc (fsLit "TExp") tExpTyConKey + +returnQName, bindQName, sequenceQName, newNameName, liftName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, + mkNameLName, liftStringName, unTypeName, unTypeQName, + unsafeTExpCoerceName :: Name +returnQName = thFun (fsLit "returnQ") returnQIdKey +bindQName = thFun (fsLit "bindQ") bindQIdKey +sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey +newNameName = thFun (fsLit "newName") newNameIdKey +liftName = thFun (fsLit "lift") liftIdKey +liftStringName = thFun (fsLit "liftString") liftStringIdKey +mkNameName = thFun (fsLit "mkName") mkNameIdKey +mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey +mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey +mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey +mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey +unTypeName = thFun (fsLit "unType") unTypeIdKey +unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey +unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey + + +-------------------- TH.Lib ----------------------- +-- data Lit = ... +charLName, stringLName, integerLName, intPrimLName, wordPrimLName, + floatPrimLName, doublePrimLName, rationalLName :: Name +charLName = libFun (fsLit "charL") charLIdKey +stringLName = libFun (fsLit "stringL") stringLIdKey +integerLName = libFun (fsLit "integerL") integerLIdKey +intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey +wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey +floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey +doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey +rationalLName = libFun (fsLit "rationalL") rationalLIdKey + +-- data Pat = ... +litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName, + asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name +litPName = libFun (fsLit "litP") litPIdKey +varPName = libFun (fsLit "varP") varPIdKey +tupPName = libFun (fsLit "tupP") tupPIdKey +unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey +conPName = libFun (fsLit "conP") conPIdKey +infixPName = libFun (fsLit "infixP") infixPIdKey +tildePName = libFun (fsLit "tildeP") tildePIdKey +bangPName = libFun (fsLit "bangP") bangPIdKey +asPName = libFun (fsLit "asP") asPIdKey +wildPName = libFun (fsLit "wildP") wildPIdKey +recPName = libFun (fsLit "recP") recPIdKey +listPName = libFun (fsLit "listP") listPIdKey +sigPName = libFun (fsLit "sigP") sigPIdKey +viewPName = libFun (fsLit "viewP") viewPIdKey + +-- type FieldPat = ... +fieldPatName :: Name +fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey + +-- data Match = ... +matchName :: Name +matchName = libFun (fsLit "match") matchIdKey + +-- data Clause = ... +clauseName :: Name +clauseName = libFun (fsLit "clause") clauseIdKey + +-- data Exp = ... +varEName, conEName, litEName, appEName, infixEName, infixAppName, + sectionLName, sectionRName, lamEName, lamCaseEName, tupEName, + unboxedTupEName, condEName, multiIfEName, letEName, caseEName, + doEName, compEName, staticEName :: Name +varEName = libFun (fsLit "varE") varEIdKey +conEName = libFun (fsLit "conE") conEIdKey +litEName = libFun (fsLit "litE") litEIdKey +appEName = libFun (fsLit "appE") appEIdKey +infixEName = libFun (fsLit "infixE") infixEIdKey +infixAppName = libFun (fsLit "infixApp") infixAppIdKey +sectionLName = libFun (fsLit "sectionL") sectionLIdKey +sectionRName = libFun (fsLit "sectionR") sectionRIdKey +lamEName = libFun (fsLit "lamE") lamEIdKey +lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey +tupEName = libFun (fsLit "tupE") tupEIdKey +unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey +condEName = libFun (fsLit "condE") condEIdKey +multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey +letEName = libFun (fsLit "letE") letEIdKey +caseEName = libFun (fsLit "caseE") caseEIdKey +doEName = libFun (fsLit "doE") doEIdKey +compEName = libFun (fsLit "compE") compEIdKey +-- ArithSeq skips a level +fromEName, fromThenEName, fromToEName, fromThenToEName :: Name +fromEName = libFun (fsLit "fromE") fromEIdKey +fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey +fromToEName = libFun (fsLit "fromToE") fromToEIdKey +fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey +-- end ArithSeq +listEName, sigEName, recConEName, recUpdEName :: Name +listEName = libFun (fsLit "listE") listEIdKey +sigEName = libFun (fsLit "sigE") sigEIdKey +recConEName = libFun (fsLit "recConE") recConEIdKey +recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey +staticEName = libFun (fsLit "staticE") staticEIdKey + +-- type FieldExp = ... +fieldExpName :: Name +fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey + +-- data Body = ... +guardedBName, normalBName :: Name +guardedBName = libFun (fsLit "guardedB") guardedBIdKey +normalBName = libFun (fsLit "normalB") normalBIdKey + +-- data Guard = ... +normalGEName, patGEName :: Name +normalGEName = libFun (fsLit "normalGE") normalGEIdKey +patGEName = libFun (fsLit "patGE") patGEIdKey + +-- data Stmt = ... +bindSName, letSName, noBindSName, parSName :: Name +bindSName = libFun (fsLit "bindS") bindSIdKey +letSName = libFun (fsLit "letS") letSIdKey +noBindSName = libFun (fsLit "noBindS") noBindSIdKey +parSName = libFun (fsLit "parS") parSIdKey + +-- data Dec = ... +funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, + instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, + pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName, + familyNoKindDName, standaloneDerivDName, defaultSigDName, + familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName, + closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, + infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name +funDName = libFun (fsLit "funD") funDIdKey +valDName = libFun (fsLit "valD") valDIdKey +dataDName = libFun (fsLit "dataD") dataDIdKey +newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey +tySynDName = libFun (fsLit "tySynD") tySynDIdKey +classDName = libFun (fsLit "classD") classDIdKey +instanceDName = libFun (fsLit "instanceD") instanceDIdKey +standaloneDerivDName + = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey +sigDName = libFun (fsLit "sigD") sigDIdKey +defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey +forImpDName = libFun (fsLit "forImpD") forImpDIdKey +pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey +pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey +pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey +pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey +pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey +pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey +familyNoKindDName = libFun (fsLit "familyNoKindD") familyNoKindDIdKey +familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey +dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey +newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey +tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey +closedTypeFamilyKindDName + = libFun (fsLit "closedTypeFamilyKindD") closedTypeFamilyKindDIdKey +closedTypeFamilyNoKindDName + = libFun (fsLit "closedTypeFamilyNoKindD") closedTypeFamilyNoKindDIdKey +infixLDName = libFun (fsLit "infixLD") infixLDIdKey +infixRDName = libFun (fsLit "infixRD") infixRDIdKey +infixNDName = libFun (fsLit "infixND") infixNDIdKey +roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey + +-- type Ctxt = ... +cxtName :: Name +cxtName = libFun (fsLit "cxt") cxtIdKey + +-- data Strict = ... +isStrictName, notStrictName, unpackedName :: Name +isStrictName = libFun (fsLit "isStrict") isStrictKey +notStrictName = libFun (fsLit "notStrict") notStrictKey +unpackedName = libFun (fsLit "unpacked") unpackedKey + +-- data Con = ... +normalCName, recCName, infixCName, forallCName :: Name +normalCName = libFun (fsLit "normalC") normalCIdKey +recCName = libFun (fsLit "recC") recCIdKey +infixCName = libFun (fsLit "infixC") infixCIdKey +forallCName = libFun (fsLit "forallC") forallCIdKey + +-- type StrictType = ... +strictTypeName :: Name +strictTypeName = libFun (fsLit "strictType") strictTKey + +-- type VarStrictType = ... +varStrictTypeName :: Name +varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey + +-- data Type = ... +forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName, + listTName, appTName, sigTName, equalityTName, litTName, + promotedTName, promotedTupleTName, + promotedNilTName, promotedConsTName :: Name +forallTName = libFun (fsLit "forallT") forallTIdKey +varTName = libFun (fsLit "varT") varTIdKey +conTName = libFun (fsLit "conT") conTIdKey +tupleTName = libFun (fsLit "tupleT") tupleTIdKey +unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey +arrowTName = libFun (fsLit "arrowT") arrowTIdKey +listTName = libFun (fsLit "listT") listTIdKey +appTName = libFun (fsLit "appT") appTIdKey +sigTName = libFun (fsLit "sigT") sigTIdKey +equalityTName = libFun (fsLit "equalityT") equalityTIdKey +litTName = libFun (fsLit "litT") litTIdKey +promotedTName = libFun (fsLit "promotedT") promotedTIdKey +promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey +promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey +promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey + +-- data TyLit = ... +numTyLitName, strTyLitName :: Name +numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey +strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey + +-- data TyVarBndr = ... +plainTVName, kindedTVName :: Name +plainTVName = libFun (fsLit "plainTV") plainTVIdKey +kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey + +-- data Role = ... +nominalRName, representationalRName, phantomRName, inferRName :: Name +nominalRName = libFun (fsLit "nominalR") nominalRIdKey +representationalRName = libFun (fsLit "representationalR") representationalRIdKey +phantomRName = libFun (fsLit "phantomR") phantomRIdKey +inferRName = libFun (fsLit "inferR") inferRIdKey + +-- data Kind = ... +varKName, conKName, tupleKName, arrowKName, listKName, appKName, + starKName, constraintKName :: Name +varKName = libFun (fsLit "varK") varKIdKey +conKName = libFun (fsLit "conK") conKIdKey +tupleKName = libFun (fsLit "tupleK") tupleKIdKey +arrowKName = libFun (fsLit "arrowK") arrowKIdKey +listKName = libFun (fsLit "listK") listKIdKey +appKName = libFun (fsLit "appK") appKIdKey +starKName = libFun (fsLit "starK") starKIdKey +constraintKName = libFun (fsLit "constraintK") constraintKIdKey + +-- data Callconv = ... +cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name +cCallName = libFun (fsLit "cCall") cCallIdKey +stdCallName = libFun (fsLit "stdCall") stdCallIdKey +cApiCallName = libFun (fsLit "cApi") cApiCallIdKey +primCallName = libFun (fsLit "prim") primCallIdKey +javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey + +-- data Safety = ... +unsafeName, safeName, interruptibleName :: Name +unsafeName = libFun (fsLit "unsafe") unsafeIdKey +safeName = libFun (fsLit "safe") safeIdKey +interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey + +-- data Inline = ... +noInlineDataConName, inlineDataConName, inlinableDataConName :: Name +noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey +inlineDataConName = thCon (fsLit "Inline") inlineDataConKey +inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey + +-- data RuleMatch = ... +conLikeDataConName, funLikeDataConName :: Name +conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey +funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey + +-- data Phases = ... +allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name +allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey +fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey +beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey + +-- newtype TExp a = ... +tExpDataConName :: Name +tExpDataConName = thCon (fsLit "TExp") tExpDataConKey + +-- data RuleBndr = ... +ruleVarName, typedRuleVarName :: Name +ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey +typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey + +-- data FunDep = ... +funDepName :: Name +funDepName = libFun (fsLit "funDep") funDepIdKey + +-- data FamFlavour = ... +typeFamName, dataFamName :: Name +typeFamName = libFun (fsLit "typeFam") typeFamIdKey +dataFamName = libFun (fsLit "dataFam") dataFamIdKey + +-- data TySynEqn = ... +tySynEqnName :: Name +tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey + +-- data AnnTarget = ... +valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name +valueAnnotationName = libFun (fsLit "valueAnnotation") valueAnnotationIdKey +typeAnnotationName = libFun (fsLit "typeAnnotation") typeAnnotationIdKey +moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey + +matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName, + decQTyConName, conQTyConName, strictTypeQTyConName, + varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName, + patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName, + ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName :: Name +matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey +clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey +expQTyConName = libTc (fsLit "ExpQ") expQTyConKey +stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey +decQTyConName = libTc (fsLit "DecQ") decQTyConKey +decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec] +conQTyConName = libTc (fsLit "ConQ") conQTyConKey +strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey +varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey +typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey +fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey +patQTyConName = libTc (fsLit "PatQ") patQTyConKey +fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey +predQTyConName = libTc (fsLit "PredQ") predQTyConKey +ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey +tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey +roleTyConName = libTc (fsLit "Role") roleTyConKey + +-- quasiquoting +quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name +quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey +quotePatName = qqFun (fsLit "quotePat") quotePatKey +quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey +quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey + +-- TyConUniques available: 200-299 +-- Check in PrelNames if you want to change this + +expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, + decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey, + stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey, + decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey, + fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, + fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, + predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey, + roleTyConKey, tExpTyConKey :: Unique +expTyConKey = mkPreludeTyConUnique 200 +matchTyConKey = mkPreludeTyConUnique 201 +clauseTyConKey = mkPreludeTyConUnique 202 +qTyConKey = mkPreludeTyConUnique 203 +expQTyConKey = mkPreludeTyConUnique 204 +decQTyConKey = mkPreludeTyConUnique 205 +patTyConKey = mkPreludeTyConUnique 206 +matchQTyConKey = mkPreludeTyConUnique 207 +clauseQTyConKey = mkPreludeTyConUnique 208 +stmtQTyConKey = mkPreludeTyConUnique 209 +conQTyConKey = mkPreludeTyConUnique 210 +typeQTyConKey = mkPreludeTyConUnique 211 +typeTyConKey = mkPreludeTyConUnique 212 +decTyConKey = mkPreludeTyConUnique 213 +varStrictTypeQTyConKey = mkPreludeTyConUnique 214 +strictTypeQTyConKey = mkPreludeTyConUnique 215 +fieldExpTyConKey = mkPreludeTyConUnique 216 +fieldPatTyConKey = mkPreludeTyConUnique 217 +nameTyConKey = mkPreludeTyConUnique 218 +patQTyConKey = mkPreludeTyConUnique 219 +fieldPatQTyConKey = mkPreludeTyConUnique 220 +fieldExpQTyConKey = mkPreludeTyConUnique 221 +funDepTyConKey = mkPreludeTyConUnique 222 +predTyConKey = mkPreludeTyConUnique 223 +predQTyConKey = mkPreludeTyConUnique 224 +tyVarBndrTyConKey = mkPreludeTyConUnique 225 +decsQTyConKey = mkPreludeTyConUnique 226 +ruleBndrQTyConKey = mkPreludeTyConUnique 227 +tySynEqnQTyConKey = mkPreludeTyConUnique 228 +roleTyConKey = mkPreludeTyConUnique 229 +tExpTyConKey = mkPreludeTyConUnique 230 + +-- IdUniques available: 200-499 +-- If you want to change this, make sure you check in PrelNames + +returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, + mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, + mkNameLIdKey, unTypeIdKey, unTypeQIdKey, unsafeTExpCoerceIdKey :: Unique +returnQIdKey = mkPreludeMiscIdUnique 200 +bindQIdKey = mkPreludeMiscIdUnique 201 +sequenceQIdKey = mkPreludeMiscIdUnique 202 +liftIdKey = mkPreludeMiscIdUnique 203 +newNameIdKey = mkPreludeMiscIdUnique 204 +mkNameIdKey = mkPreludeMiscIdUnique 205 +mkNameG_vIdKey = mkPreludeMiscIdUnique 206 +mkNameG_dIdKey = mkPreludeMiscIdUnique 207 +mkNameG_tcIdKey = mkPreludeMiscIdUnique 208 +mkNameLIdKey = mkPreludeMiscIdUnique 209 +unTypeIdKey = mkPreludeMiscIdUnique 210 +unTypeQIdKey = mkPreludeMiscIdUnique 211 +unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 212 + + +-- data Lit = ... +charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey, + floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique +charLIdKey = mkPreludeMiscIdUnique 220 +stringLIdKey = mkPreludeMiscIdUnique 221 +integerLIdKey = mkPreludeMiscIdUnique 222 +intPrimLIdKey = mkPreludeMiscIdUnique 223 +wordPrimLIdKey = mkPreludeMiscIdUnique 224 +floatPrimLIdKey = mkPreludeMiscIdUnique 225 +doublePrimLIdKey = mkPreludeMiscIdUnique 226 +rationalLIdKey = mkPreludeMiscIdUnique 227 + +liftStringIdKey :: Unique +liftStringIdKey = mkPreludeMiscIdUnique 228 + +-- data Pat = ... +litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, + asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique +litPIdKey = mkPreludeMiscIdUnique 240 +varPIdKey = mkPreludeMiscIdUnique 241 +tupPIdKey = mkPreludeMiscIdUnique 242 +unboxedTupPIdKey = mkPreludeMiscIdUnique 243 +conPIdKey = mkPreludeMiscIdUnique 244 +infixPIdKey = mkPreludeMiscIdUnique 245 +tildePIdKey = mkPreludeMiscIdUnique 246 +bangPIdKey = mkPreludeMiscIdUnique 247 +asPIdKey = mkPreludeMiscIdUnique 248 +wildPIdKey = mkPreludeMiscIdUnique 249 +recPIdKey = mkPreludeMiscIdUnique 250 +listPIdKey = mkPreludeMiscIdUnique 251 +sigPIdKey = mkPreludeMiscIdUnique 252 +viewPIdKey = mkPreludeMiscIdUnique 253 + +-- type FieldPat = ... +fieldPatIdKey :: Unique +fieldPatIdKey = mkPreludeMiscIdUnique 260 + +-- data Match = ... +matchIdKey :: Unique +matchIdKey = mkPreludeMiscIdUnique 261 + +-- data Clause = ... +clauseIdKey :: Unique +clauseIdKey = mkPreludeMiscIdUnique 262 + + +-- data Exp = ... +varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey, + sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey, + unboxedTupEIdKey, condEIdKey, multiIfEIdKey, + letEIdKey, caseEIdKey, doEIdKey, compEIdKey, + fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, + listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey :: Unique +varEIdKey = mkPreludeMiscIdUnique 270 +conEIdKey = mkPreludeMiscIdUnique 271 +litEIdKey = mkPreludeMiscIdUnique 272 +appEIdKey = mkPreludeMiscIdUnique 273 +infixEIdKey = mkPreludeMiscIdUnique 274 +infixAppIdKey = mkPreludeMiscIdUnique 275 +sectionLIdKey = mkPreludeMiscIdUnique 276 +sectionRIdKey = mkPreludeMiscIdUnique 277 +lamEIdKey = mkPreludeMiscIdUnique 278 +lamCaseEIdKey = mkPreludeMiscIdUnique 279 +tupEIdKey = mkPreludeMiscIdUnique 280 +unboxedTupEIdKey = mkPreludeMiscIdUnique 281 +condEIdKey = mkPreludeMiscIdUnique 282 +multiIfEIdKey = mkPreludeMiscIdUnique 283 +letEIdKey = mkPreludeMiscIdUnique 284 +caseEIdKey = mkPreludeMiscIdUnique 285 +doEIdKey = mkPreludeMiscIdUnique 286 +compEIdKey = mkPreludeMiscIdUnique 287 +fromEIdKey = mkPreludeMiscIdUnique 288 +fromThenEIdKey = mkPreludeMiscIdUnique 289 +fromToEIdKey = mkPreludeMiscIdUnique 290 +fromThenToEIdKey = mkPreludeMiscIdUnique 291 +listEIdKey = mkPreludeMiscIdUnique 292 +sigEIdKey = mkPreludeMiscIdUnique 293 +recConEIdKey = mkPreludeMiscIdUnique 294 +recUpdEIdKey = mkPreludeMiscIdUnique 295 +staticEIdKey = mkPreludeMiscIdUnique 296 + +-- type FieldExp = ... +fieldExpIdKey :: Unique +fieldExpIdKey = mkPreludeMiscIdUnique 310 + +-- data Body = ... +guardedBIdKey, normalBIdKey :: Unique +guardedBIdKey = mkPreludeMiscIdUnique 311 +normalBIdKey = mkPreludeMiscIdUnique 312 + +-- data Guard = ... +normalGEIdKey, patGEIdKey :: Unique +normalGEIdKey = mkPreludeMiscIdUnique 313 +patGEIdKey = mkPreludeMiscIdUnique 314 + +-- data Stmt = ... +bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique +bindSIdKey = mkPreludeMiscIdUnique 320 +letSIdKey = mkPreludeMiscIdUnique 321 +noBindSIdKey = mkPreludeMiscIdUnique 322 +parSIdKey = mkPreludeMiscIdUnique 323 + +-- data Dec = ... +funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, + classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, + pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey, + pragAnnDIdKey, familyNoKindDIdKey, familyKindDIdKey, defaultSigDIdKey, + dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivDIdKey, + closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey, + infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey :: Unique +funDIdKey = mkPreludeMiscIdUnique 330 +valDIdKey = mkPreludeMiscIdUnique 331 +dataDIdKey = mkPreludeMiscIdUnique 332 +newtypeDIdKey = mkPreludeMiscIdUnique 333 +tySynDIdKey = mkPreludeMiscIdUnique 334 +classDIdKey = mkPreludeMiscIdUnique 335 +instanceDIdKey = mkPreludeMiscIdUnique 336 +sigDIdKey = mkPreludeMiscIdUnique 337 +forImpDIdKey = mkPreludeMiscIdUnique 338 +pragInlDIdKey = mkPreludeMiscIdUnique 339 +pragSpecDIdKey = mkPreludeMiscIdUnique 340 +pragSpecInlDIdKey = mkPreludeMiscIdUnique 341 +pragSpecInstDIdKey = mkPreludeMiscIdUnique 342 +pragRuleDIdKey = mkPreludeMiscIdUnique 343 +pragAnnDIdKey = mkPreludeMiscIdUnique 344 +familyNoKindDIdKey = mkPreludeMiscIdUnique 345 +familyKindDIdKey = mkPreludeMiscIdUnique 346 +dataInstDIdKey = mkPreludeMiscIdUnique 347 +newtypeInstDIdKey = mkPreludeMiscIdUnique 348 +tySynInstDIdKey = mkPreludeMiscIdUnique 349 +closedTypeFamilyKindDIdKey = mkPreludeMiscIdUnique 350 +closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 351 +infixLDIdKey = mkPreludeMiscIdUnique 352 +infixRDIdKey = mkPreludeMiscIdUnique 353 +infixNDIdKey = mkPreludeMiscIdUnique 354 +roleAnnotDIdKey = mkPreludeMiscIdUnique 355 +standaloneDerivDIdKey = mkPreludeMiscIdUnique 356 +defaultSigDIdKey = mkPreludeMiscIdUnique 357 + +-- type Cxt = ... +cxtIdKey :: Unique +cxtIdKey = mkPreludeMiscIdUnique 360 + +-- data Strict = ... +isStrictKey, notStrictKey, unpackedKey :: Unique +isStrictKey = mkPreludeMiscIdUnique 363 +notStrictKey = mkPreludeMiscIdUnique 364 +unpackedKey = mkPreludeMiscIdUnique 365 + +-- data Con = ... +normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique +normalCIdKey = mkPreludeMiscIdUnique 370 +recCIdKey = mkPreludeMiscIdUnique 371 +infixCIdKey = mkPreludeMiscIdUnique 372 +forallCIdKey = mkPreludeMiscIdUnique 373 + +-- type StrictType = ... +strictTKey :: Unique +strictTKey = mkPreludeMiscIdUnique 374 + +-- type VarStrictType = ... +varStrictTKey :: Unique +varStrictTKey = mkPreludeMiscIdUnique 375 + +-- data Type = ... +forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey, + listTIdKey, appTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, + promotedTIdKey, promotedTupleTIdKey, + promotedNilTIdKey, promotedConsTIdKey :: Unique +forallTIdKey = mkPreludeMiscIdUnique 380 +varTIdKey = mkPreludeMiscIdUnique 381 +conTIdKey = mkPreludeMiscIdUnique 382 +tupleTIdKey = mkPreludeMiscIdUnique 383 +unboxedTupleTIdKey = mkPreludeMiscIdUnique 384 +arrowTIdKey = mkPreludeMiscIdUnique 385 +listTIdKey = mkPreludeMiscIdUnique 386 +appTIdKey = mkPreludeMiscIdUnique 387 +sigTIdKey = mkPreludeMiscIdUnique 388 +equalityTIdKey = mkPreludeMiscIdUnique 389 +litTIdKey = mkPreludeMiscIdUnique 390 +promotedTIdKey = mkPreludeMiscIdUnique 391 +promotedTupleTIdKey = mkPreludeMiscIdUnique 392 +promotedNilTIdKey = mkPreludeMiscIdUnique 393 +promotedConsTIdKey = mkPreludeMiscIdUnique 394 + +-- data TyLit = ... +numTyLitIdKey, strTyLitIdKey :: Unique +numTyLitIdKey = mkPreludeMiscIdUnique 395 +strTyLitIdKey = mkPreludeMiscIdUnique 396 + +-- data TyVarBndr = ... +plainTVIdKey, kindedTVIdKey :: Unique +plainTVIdKey = mkPreludeMiscIdUnique 397 +kindedTVIdKey = mkPreludeMiscIdUnique 398 + +-- data Role = ... +nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique +nominalRIdKey = mkPreludeMiscIdUnique 400 +representationalRIdKey = mkPreludeMiscIdUnique 401 +phantomRIdKey = mkPreludeMiscIdUnique 402 +inferRIdKey = mkPreludeMiscIdUnique 403 + +-- data Kind = ... +varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey, + starKIdKey, constraintKIdKey :: Unique +varKIdKey = mkPreludeMiscIdUnique 404 +conKIdKey = mkPreludeMiscIdUnique 405 +tupleKIdKey = mkPreludeMiscIdUnique 406 +arrowKIdKey = mkPreludeMiscIdUnique 407 +listKIdKey = mkPreludeMiscIdUnique 408 +appKIdKey = mkPreludeMiscIdUnique 409 +starKIdKey = mkPreludeMiscIdUnique 410 +constraintKIdKey = mkPreludeMiscIdUnique 411 + +-- data Callconv = ... +cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey, + javaScriptCallIdKey :: Unique +cCallIdKey = mkPreludeMiscIdUnique 420 +stdCallIdKey = mkPreludeMiscIdUnique 421 +cApiCallIdKey = mkPreludeMiscIdUnique 422 +primCallIdKey = mkPreludeMiscIdUnique 423 +javaScriptCallIdKey = mkPreludeMiscIdUnique 424 + +-- data Safety = ... +unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique +unsafeIdKey = mkPreludeMiscIdUnique 430 +safeIdKey = mkPreludeMiscIdUnique 431 +interruptibleIdKey = mkPreludeMiscIdUnique 432 + +-- data Inline = ... +noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique +noInlineDataConKey = mkPreludeDataConUnique 40 +inlineDataConKey = mkPreludeDataConUnique 41 +inlinableDataConKey = mkPreludeDataConUnique 42 + +-- data RuleMatch = ... +conLikeDataConKey, funLikeDataConKey :: Unique +conLikeDataConKey = mkPreludeDataConUnique 43 +funLikeDataConKey = mkPreludeDataConUnique 44 + +-- data Phases = ... +allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique +allPhasesDataConKey = mkPreludeDataConUnique 45 +fromPhaseDataConKey = mkPreludeDataConUnique 46 +beforePhaseDataConKey = mkPreludeDataConUnique 47 + +-- newtype TExp a = ... +tExpDataConKey :: Unique +tExpDataConKey = mkPreludeDataConUnique 48 + +-- data FunDep = ... +funDepIdKey :: Unique +funDepIdKey = mkPreludeMiscIdUnique 440 + +-- data FamFlavour = ... +typeFamIdKey, dataFamIdKey :: Unique +typeFamIdKey = mkPreludeMiscIdUnique 450 +dataFamIdKey = mkPreludeMiscIdUnique 451 + +-- data TySynEqn = ... +tySynEqnIdKey :: Unique +tySynEqnIdKey = mkPreludeMiscIdUnique 460 + +-- quasiquoting +quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique +quoteExpKey = mkPreludeMiscIdUnique 470 +quotePatKey = mkPreludeMiscIdUnique 471 +quoteDecKey = mkPreludeMiscIdUnique 472 +quoteTypeKey = mkPreludeMiscIdUnique 473 + +-- data RuleBndr = ... +ruleVarIdKey, typedRuleVarIdKey :: Unique +ruleVarIdKey = mkPreludeMiscIdUnique 480 +typedRuleVarIdKey = mkPreludeMiscIdUnique 481 + +-- data AnnTarget = ... +valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique +valueAnnotationIdKey = mkPreludeMiscIdUnique 490 +typeAnnotationIdKey = mkPreludeMiscIdUnique 491 +moduleAnnotationIdKey = mkPreludeMiscIdUnique 492 diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 6c2ffb7417..34c1838997 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -43,21 +43,22 @@ module TysWiredIn ( wordTyCon, wordDataCon, wordTyConName, wordTy, -- * List - listTyCon, nilDataCon, nilDataConName, consDataCon, consDataConName, - listTyCon_RDR, consDataCon_RDR, listTyConName, + listTyCon, listTyCon_RDR, listTyConName, listTyConKey, + nilDataCon, nilDataConName, nilDataConKey, + consDataCon_RDR, consDataCon, consDataConName, + mkListTy, mkPromotedListTy, -- * Tuples mkTupleTy, mkBoxedTupleTy, - tupleTyCon, tupleCon, + tupleTyCon, tupleDataCon, tupleTyConName, promotedTupleTyCon, promotedTupleDataCon, - unitTyCon, unitDataCon, unitDataConId, pairTyCon, + unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, + pairTyCon, unboxedUnitTyCon, unboxedUnitDataCon, unboxedSingletonTyCon, unboxedSingletonDataCon, unboxedPairTyCon, unboxedPairDataCon, - - -- * Unit - unitTy, + cTupleTyConName, cTupleTyConNames, isCTupleTyConName, -- * Kinds typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind, @@ -84,7 +85,7 @@ import PrelNames import TysPrim -- others: -import Constants ( mAX_TUPLE_SIZE ) +import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import Module ( Module ) import Type ( mkTyConApp ) import DataCon @@ -95,11 +96,14 @@ import Class ( Class, mkClass ) import TypeRep import RdrName import Name -import BasicTypes ( TupleSort(..), tupleSortBoxity, - Arity, RecFlag(..), Boxity(..) ) +import NameSet ( NameSet, mkNameSet, elemNameSet ) +import BasicTypes ( Arity, RecFlag(..), Boxity(..), + TupleSort(..) ) import ForeignCall -import Unique ( incrUnique, mkTupleTyConUnique, - mkTupleDataConUnique, mkPArrDataConUnique ) +import Unique ( incrUnique, + mkTupleTyConUnique, mkTupleDataConUnique, + mkCTupleTyConUnique, mkPArrDataConUnique ) +import SrcLoc ( noSrcSpan ) import Data.Array import FastString import Outputable @@ -319,14 +323,39 @@ typeSymbolKind = TyConApp (promoteTyCon typeSymbolKindCon) [] Note [How tuples work] See also Note [Known-key names] in PrelNames ~~~~~~~~~~~~~~~~~~~~~~ * There are three families of tuple TyCons and corresponding - DataCons, (boxed, unboxed, and constraint tuples), expressed by the - type BasicTypes.TupleSort. - -* DataCons (and workers etc) for BoxedTuple and ConstraintTuple have - - distinct Uniques - - the same OccName - Using the same OccName means (hack!) that a single copy of the - runtime library code (info tables etc) works for both. + DataCons, expressed by the type BasicTypes.TupleSort: + data TupleSort = BoxedTuple | UnboxedTuple | ConstraintTuple + +* All three families are AlgTyCons, whose AlgTyConRhs is TupleTyCon + +* BoxedTuples + - A wired-in type + - Data type declarations in GHC.Tuple + - The data constructors really have an info table + +* UnboxedTuples + - A wired-in type + - Have a pretend DataCon, defined in GHC.Prim, + but no actual declaration and no info table + +* ConstraintTuples + - Are known-key rather than wired-in. Reason: it's awkward to + have all the superclass selectors wired-in. + - Declared as classes in GHC.Classes, e.g. + class (c1,c2) => (c1,c2) + - Given constraints: the superclasses automatically become available + - Wanted constraints: there is a built-in instance + instance (c1,c2) => (c1,c2) + - Currently just go up to 16; beyond that + you have to use manual nesting + - Their OccNames look like (%,,,%), so they can easily be + distinguished from term tuples. But (following Haskell) we + pretty-print saturated constraint tuples with round parens; see + BasicTypes.tupleParens. + +* In quite a lot of places things are restrcted just to + BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish + E.g. tupleTyCon has a Boxity argument * When looking up an OccName in the original-name cache (IfaceEnv.lookupOrigNameCache), we spot the tuple OccName to make sure @@ -340,140 +369,164 @@ isBuiltInOcc_maybe :: OccName -> Maybe Name -- map to wired-in Names with BuiltInSyntax isBuiltInOcc_maybe occ = case occNameString occ of - "[]" -> choose_ns listTyCon nilDataCon + "[]" -> choose_ns listTyConName nilDataConName ":" -> Just consDataConName "[::]" -> Just parrTyConName - "(##)" -> choose_ns unboxedUnitTyCon unboxedUnitDataCon - "()" -> choose_ns unitTyCon unitDataCon - '(':'#':',':rest -> parse_tuple UnboxedTuple 2 rest - '(':',':rest -> parse_tuple BoxedTuple 2 rest + "()" -> tup_name Boxed 0 + "(##)" -> tup_name Unboxed 0 + '(':',':rest -> parse_tuple Boxed 2 rest + '(':'#':',':rest -> parse_tuple Unboxed 2 rest _other -> Nothing where ns = occNameSpace occ parse_tuple sort n rest | (',' : rest2) <- rest = parse_tuple sort (n+1) rest2 - | tail_matches sort rest = choose_ns (tupleTyCon sort n) - (tupleCon sort n) + | tail_matches sort rest = tup_name sort n | otherwise = Nothing - tail_matches BoxedTuple ")" = True - tail_matches UnboxedTuple "#)" = True - tail_matches _ _ = False + tail_matches Boxed ")" = True + tail_matches Unboxed "#)" = True + tail_matches _ _ = False + + tup_name boxity arity + = choose_ns (getName (tupleTyCon boxity arity)) + (getName (tupleDataCon boxity arity)) choose_ns tc dc - | isTcClsNameSpace ns = Just (getName tc) - | isDataConNameSpace ns = Just (getName dc) - | otherwise = Just (getName (dataConWorkId dc)) + | isTcClsNameSpace ns = Just tc + | isDataConNameSpace ns = Just dc + | otherwise = pprPanic "tup_name" (ppr occ) -mkTupleOcc :: NameSpace -> TupleSort -> Arity -> OccName +mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName mkTupleOcc ns sort ar = mkOccName ns str where -- No need to cache these, the caching is done in mk_tuple str = case sort of - UnboxedTuple -> '(' : '#' : commas ++ "#)" - BoxedTuple -> '(' : commas ++ ")" - ConstraintTuple -> '(' : commas ++ ")" + Unboxed -> '(' : '#' : commas ++ "#)" + Boxed -> '(' : commas ++ ")" + + commas = take (ar-1) (repeat ',') +mkCTupleOcc :: NameSpace -> Arity -> OccName +mkCTupleOcc ns ar = mkOccName ns str + where + str = "(%" ++ commas ++ "%)" commas = take (ar-1) (repeat ',') - -- Cute hack: we reuse the standard tuple OccNames (and hence code) - -- for fact tuples, but give them different Uniques so they are not equal. - -- - -- You might think that this will go wrong because isBuiltInOcc_maybe won't - -- be able to tell the difference between boxed tuples and constraint tuples. BUT: - -- 1. Constraint tuples never occur directly in user code, so it doesn't matter - -- that we can't detect them in Orig OccNames originating from the user - -- programs (or those built by setRdrNameSpace used on an Exact tuple Name) - -- 2. Interface files have a special representation for tuple *occurrences* - -- in IfaceTyCons, their workers (in IfaceSyn) and their DataCons (in case - -- alternatives). Thus we don't rely on the OccName to figure out what kind - -- of tuple an occurrence was trying to use in these situations. - -- 3. We *don't* represent tuple data type declarations specially, so those - -- are still turned into wired-in names via isBuiltInOcc_maybe. But that's OK - -- because we don't actually need to declare constraint tuples thanks to this hack. - -- - -- So basically any OccName like (,,) flowing to isBuiltInOcc_maybe will always - -- refer to the standard boxed tuple. Cool :-) - - -tupleTyCon :: TupleSort -> Arity -> TyCon +cTupleTyConName :: Arity -> Name +cTupleTyConName arity + = mkExternalName (mkCTupleTyConUnique arity) gHC_CLASSES + (mkCTupleOcc tcName arity) noSrcSpan + -- The corresponding DataCon does not have a known-key name + +cTupleTyConNames :: [Name] +cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE]) + +cTupleTyConNameSet :: NameSet +cTupleTyConNameSet = mkNameSet cTupleTyConNames + +isCTupleTyConName :: Name -> Bool +isCTupleTyConName n + = ASSERT2( isExternalName n, ppr n ) + nameModule n == gHC_CLASSES + && n `elemNameSet` cTupleTyConNameSet + +tupleTyCon :: Boxity -> Arity -> TyCon tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially -tupleTyCon BoxedTuple i = fst (boxedTupleArr ! i) -tupleTyCon UnboxedTuple i = fst (unboxedTupleArr ! i) -tupleTyCon ConstraintTuple i = fst (factTupleArr ! i) +tupleTyCon Boxed i = fst (boxedTupleArr ! i) +tupleTyCon Unboxed i = fst (unboxedTupleArr ! i) + +tupleTyConName :: TupleSort -> Arity -> Name +tupleTyConName ConstraintTuple a = cTupleTyConName a +tupleTyConName BoxedTuple a = tyConName (tupleTyCon Boxed a) +tupleTyConName UnboxedTuple a = tyConName (tupleTyCon Unboxed a) -promotedTupleTyCon :: TupleSort -> Arity -> TyCon -promotedTupleTyCon sort i = promoteTyCon (tupleTyCon sort i) +promotedTupleTyCon :: Boxity -> Arity -> TyCon +promotedTupleTyCon boxity i = promoteTyCon (tupleTyCon boxity i) -promotedTupleDataCon :: TupleSort -> Arity -> TyCon -promotedTupleDataCon sort i = promoteDataCon (tupleCon sort i) +promotedTupleDataCon :: Boxity -> Arity -> TyCon +promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i) -tupleCon :: TupleSort -> Arity -> DataCon -tupleCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially -tupleCon BoxedTuple i = snd (boxedTupleArr ! i) -tupleCon UnboxedTuple i = snd (unboxedTupleArr ! i) -tupleCon ConstraintTuple i = snd (factTupleArr ! i) +tupleDataCon :: Boxity -> Arity -> DataCon +tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially +tupleDataCon Boxed i = snd (boxedTupleArr ! i) +tupleDataCon Unboxed i = snd (unboxedTupleArr ! i) -boxedTupleArr, unboxedTupleArr, factTupleArr :: Array Int (TyCon,DataCon) -boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple BoxedTuple i | i <- [0..mAX_TUPLE_SIZE]] -unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple UnboxedTuple i | i <- [0..mAX_TUPLE_SIZE]] -factTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple ConstraintTuple i | i <- [0..mAX_TUPLE_SIZE]] +boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) +boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]] +unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] -mk_tuple :: TupleSort -> Int -> (TyCon,DataCon) -mk_tuple sort arity = (tycon, tuple_con) +mk_tuple :: Boxity -> Int -> (TyCon,DataCon) +mk_tuple boxity arity = (tycon, tuple_con) where - tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con sort prom_tc - prom_tc = case sort of - BoxedTuple -> Just (mkPromotedTyCon tycon (promoteKind tc_kind)) - UnboxedTuple -> Nothing - ConstraintTuple -> Nothing - - modu = mkTupleModule sort - tc_name = mkWiredInName modu (mkTupleOcc tcName sort arity) tc_uniq + tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con + tup_sort + prom_tc NoParentTyCon + + tup_sort = case boxity of + Boxed -> BoxedTuple + Unboxed -> UnboxedTuple + + prom_tc = case boxity of + Boxed -> Just (mkPromotedTyCon tycon (promoteKind tc_kind)) + Unboxed -> Nothing + + modu = case boxity of + Boxed -> gHC_TUPLE + Unboxed -> gHC_PRIM + + tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq (ATyCon tycon) BuiltInSyntax tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind - res_kind = case sort of - BoxedTuple -> liftedTypeKind - UnboxedTuple -> unliftedTypeKind - ConstraintTuple -> constraintKind - tyvars = take arity $ case sort of - BoxedTuple -> alphaTyVars - UnboxedTuple -> openAlphaTyVars - ConstraintTuple -> tyVarList constraintKind + res_kind = case boxity of + Boxed -> liftedTypeKind + Unboxed -> unliftedTypeKind + + tyvars = take arity $ case boxity of + Boxed -> alphaTyVars + Unboxed -> openAlphaTyVars tuple_con = pcDataCon dc_name tyvars tyvar_tys tycon tyvar_tys = mkTyVarTys tyvars - dc_name = mkWiredInName modu (mkTupleOcc dataName sort arity) dc_uniq + dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq (AConLike (RealDataCon tuple_con)) BuiltInSyntax - tc_uniq = mkTupleTyConUnique sort arity - dc_uniq = mkTupleDataConUnique sort arity + tc_uniq = mkTupleTyConUnique boxity arity + dc_uniq = mkTupleDataConUnique boxity arity unitTyCon :: TyCon -unitTyCon = tupleTyCon BoxedTuple 0 +unitTyCon = tupleTyCon Boxed 0 + +unitTyConKey :: Unique +unitTyConKey = getUnique unitTyCon + unitDataCon :: DataCon unitDataCon = head (tyConDataCons unitTyCon) + unitDataConId :: Id unitDataConId = dataConWorkId unitDataCon pairTyCon :: TyCon -pairTyCon = tupleTyCon BoxedTuple 2 +pairTyCon = tupleTyCon Boxed 2 unboxedUnitTyCon :: TyCon -unboxedUnitTyCon = tupleTyCon UnboxedTuple 0 +unboxedUnitTyCon = tupleTyCon Unboxed 0 + unboxedUnitDataCon :: DataCon -unboxedUnitDataCon = tupleCon UnboxedTuple 0 +unboxedUnitDataCon = tupleDataCon Unboxed 0 unboxedSingletonTyCon :: TyCon -unboxedSingletonTyCon = tupleTyCon UnboxedTuple 1 +unboxedSingletonTyCon = tupleTyCon Unboxed 1 + unboxedSingletonDataCon :: DataCon -unboxedSingletonDataCon = tupleCon UnboxedTuple 1 +unboxedSingletonDataCon = tupleDataCon Unboxed 1 unboxedPairTyCon :: TyCon -unboxedPairTyCon = tupleTyCon UnboxedTuple 2 +unboxedPairTyCon = tupleTyCon Unboxed 2 + unboxedPairDataCon :: DataCon -unboxedPairDataCon = tupleCon UnboxedTuple 2 +unboxedPairDataCon = tupleDataCon Unboxed 2 {- ************************************************************************ @@ -754,17 +807,17 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}. \end{itemize} -} -mkTupleTy :: TupleSort -> [Type] -> Type +mkTupleTy :: Boxity -> [Type] -> Type -- Special case for *boxed* 1-tuples, which are represented by the type itself -mkTupleTy sort [ty] | Boxed <- tupleSortBoxity sort = ty -mkTupleTy sort tys = mkTyConApp (tupleTyCon sort (length tys)) tys +mkTupleTy Boxed [ty] = ty +mkTupleTy boxity tys = mkTyConApp (tupleTyCon boxity (length tys)) tys -- | Build the type of a small tuple that holds the specified type of thing mkBoxedTupleTy :: [Type] -> Type -mkBoxedTupleTy tys = mkTupleTy BoxedTuple tys +mkBoxedTupleTy tys = mkTupleTy Boxed tys unitTy :: Type -unitTy = mkTupleTy BoxedTuple [] +unitTy = mkTupleTy Boxed [] {- ************************************************************************ diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 0794412051..28da6cb413 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -53,6 +53,7 @@ import RdrName import HscTypes import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage ) import TcRnMonad +import RdrHsSyn ( setRdrNameSpace ) import Id ( isRecordSelector ) import Name import NameSet diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 036d6520fb..00381b3567 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -32,6 +32,7 @@ import NameSet import Avail import HscTypes import RdrName +import RdrHsSyn ( setRdrNameSpace ) import Outputable import Maybes import SrcLoc @@ -652,10 +653,14 @@ Then M's export_avails are (recall the AvailTC invariant from Avails.hs) C(C,T), T(T,T1,T2,T3) Notice that T appears *twice*, once as a child and once as a parent. From this we construct the imp_occ_env - C -> (C, C(C,T), Nothing + C -> (C, C(C,T), Nothing) T -> (T, T(T,T1,T2,T3), Just C) T1 -> (T1, T(T1,T2,T3), Nothing) -- similarly T2,T3 +If we say + import M( T(T1,T2) ) +then we get *two* Avails: C(T), T(T1,T2) + Note that the imp_occ_env will have entries for data constructors too, although we never look up data constructors. -} @@ -763,19 +768,30 @@ filterImports ifaces decl_spec (Just (want_hiding, L l import_items)) return ([(IEVar (L l name), trimAvail avail name)], []) IEThingAll (L l tc) -> do - (name, avail@(AvailTC name2 subs), mb_parent) <- lookup_name tc - let warns | null (drop 1 subs) = [DodgyImport tc] - | not (is_qual decl_spec) = [MissingImportList] - | otherwise = [] + (name, avail, mb_parent) <- lookup_name tc + let warns = case avail of + Avail {} -- e.g. f(..) + -> [DodgyImport tc] + + AvailTC _ subs + | null (drop 1 subs) -- e.g. T(..) where T is a synonym + -> [DodgyImport tc] + + | not (is_qual decl_spec) -- e.g. import M( T(..) ) + -> [MissingImportList] + + | otherwise + -> [] + + renamed_ie = IEThingAll (L l name) + sub_avails = case avail of + Avail {} -> [] + AvailTC name2 subs -> [(renamed_ie, AvailTC name2 (subs \\ [name]))] case mb_parent of - -- non-associated ty/cls - Nothing -> return ([(IEThingAll (L l name), avail)], warns) - -- associated ty - Just parent -> return ([(IEThingAll (L l name), - AvailTC name2 (subs \\ [name])), - (IEThingAll (L l name), - AvailTC parent [name])], - warns) + Nothing -> return ([(renamed_ie, avail)], warns) + -- non-associated ty/cls + Just parent -> return ((renamed_ie, AvailTC parent [name]) : sub_avails, warns) + -- associated type IEThingAbs (L l tc) | want_hiding -- hiding ( C ) diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index 5d12720e2c..737dcc9584 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -37,15 +37,15 @@ import {-# SOURCE #-} RnExpr ( rnLExpr ) import PrelNames ( isUnboundName ) import TcEnv ( checkWellStaged ) -import DsMeta ( liftName ) +import THNames ( liftName ) #ifdef GHCI import ErrUtils ( dumpIfSet_dyn_printer ) -import DsMeta ( decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) import TcEnv ( tcMetaTy ) import Hooks import Var ( Id ) -import DsMeta ( quoteExpName, quotePatName, quoteDecName, quoteTypeName ) +import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeName + , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) import Util import {-# SOURCE #-} TcExpr ( tcMonoExpr ) diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs index 0fc6ccf226..f3d592f49c 100644 --- a/compiler/simplStg/UnariseStg.hs +++ b/compiler/simplStg/UnariseStg.hs @@ -59,7 +59,7 @@ import BasicTypes type UnariseEnv = VarEnv [Id] ubxTupleId0 :: Id -ubxTupleId0 = dataConWorkId (tupleCon UnboxedTuple 0) +ubxTupleId0 = dataConWorkId (tupleDataCon Unboxed 0) unarise :: UniqSupply -> [StgBinding] -> [StgBinding] unarise us binds = zipWith (\us -> unariseBinding us init_env) (listSplitUniqSupply us) binds @@ -88,7 +88,7 @@ unariseExpr _ rho (StgApp f args) , UbxTupleRep tys <- repType (idType f) = -- Particularly important where (##) is concerned -- See Note [Nullary unboxed tuple] - StgConApp (tupleCon UnboxedTuple (length tys)) + StgConApp (tupleDataCon Unboxed (length tys)) (map StgVarArg (unariseId rho f)) | otherwise @@ -98,7 +98,7 @@ unariseExpr _ _ (StgLit l) = StgLit l unariseExpr _ rho (StgConApp dc args) - | isUnboxedTupleCon dc = StgConApp (tupleCon UnboxedTuple (length args')) args' + | isUnboxedTupleCon dc = StgConApp (tupleDataCon Unboxed (length args')) args' | otherwise = StgConApp dc args' where args' = unariseArgs rho args @@ -139,14 +139,14 @@ unariseAlts us rho alt_ty _ (UnaryRep _) alts = (alt_ty, zipWith (\us alt -> unariseAlt us rho alt) (listSplitUniqSupply us) alts) unariseAlts us rho _ bndr (UbxTupleRep tys) ((DEFAULT, [], [], e) : _) - = (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys, uses, unariseExpr us2' rho' e)]) + = (UbxTupAlt n, [(DataAlt (tupleDataCon Unboxed n), ys, uses, unariseExpr us2' rho' e)]) where (us2', rho', ys) = unariseIdBinder us rho bndr uses = replicate (length ys) (not (isDeadBinder bndr)) n = length tys unariseAlts us rho _ bndr (UbxTupleRep _) [(DataAlt _, ys, uses, e)] - = (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys', uses', unariseExpr us2' rho'' e)]) + = (UbxTupAlt n, [(DataAlt (tupleDataCon Unboxed n), ys', uses', unariseExpr us2' rho'' e)]) where (us2', rho', ys', uses') = unariseUsedIdBinders us rho ys uses rho'' = extendVarEnv rho' bndr ys' diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index de1bf08a31..61633f9834 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -1725,8 +1725,7 @@ mkCallUDs' env f args type_determines_value pred -- See Note [Type determines value] = case classifyPredType pred of - ClassPred cls _ -> not (isIPClass cls) - TuplePred ps -> all type_determines_value ps + ClassPred cls _ -> not (isIPClass cls) -- Superclasses can't be IPs EqPred {} -> True IrredPred {} -> True -- Things like (D []) where D is a -- Constraint-ranged family; Trac #7785 diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs index 8c96afadd6..304a3cbacb 100644 --- a/compiler/stranal/WwLib.hs +++ b/compiler/stranal/WwLib.hs @@ -24,11 +24,11 @@ import Demand import MkCore ( mkRuntimeErrorApp, aBSENT_ERROR_ID ) import MkId ( voidArgId, voidPrimId ) import TysPrim ( voidPrimTy ) -import TysWiredIn ( tupleCon ) +import TysWiredIn ( tupleDataCon ) import Type import Coercion hiding ( substTy, substTyVarBndr ) import FamInstEnv -import BasicTypes ( TupleSort(..), OneShotInfo(..), worstOneShot ) +import BasicTypes ( Boxity(..), OneShotInfo(..), worstOneShot ) import Literal ( absentLiteralOf ) import TyCon import UniqSupply @@ -643,7 +643,7 @@ mkWWcpr_help (data_con, inst_tys, arg_tys, co) -- Worker: case ( ...body... ) of C a b -> (# a, b #) = do { (work_uniq : uniqs) <- getUniquesM ; let (wrap_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : arg_tys) - ubx_tup_con = tupleCon UnboxedTuple (length arg_tys) + ubx_tup_con = tupleDataCon Unboxed (length arg_tys) ubx_tup_ty = exprType ubx_tup_app ubx_tup_app = mkConApp2 ubx_tup_con arg_tys args con_app = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs index 53ecb48cc7..3e07f6b07c 100644 --- a/compiler/typecheck/FunDeps.hs +++ b/compiler/typecheck/FunDeps.hs @@ -23,6 +23,7 @@ import Name import Var import Class import Type +import TcType( immSuperClasses ) import Unify import InstEnv import VarSet @@ -445,32 +446,29 @@ oclose :: [PredType] -> TyVarSet -> TyVarSet -- See Note [The liberal coverage condition] oclose preds fixed_tvs | null tv_fds = fixed_tvs -- Fast escape hatch for common case. - | otherwise = loop fixed_tvs + | otherwise = transCloVarSet extend fixed_tvs where - loop fixed_tvs - | new_fixed_tvs `subVarSet` fixed_tvs = fixed_tvs - | otherwise = loop new_fixed_tvs - where new_fixed_tvs = foldl extend fixed_tvs tv_fds - - extend fixed_tvs (ls,rs) - | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` rs - | otherwise = fixed_tvs + extend fixed_tvs = foldl add fixed_tvs tv_fds + where + add fixed_tvs (ls,rs) + | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` rs + | otherwise = fixed_tvs tv_fds :: [(TyVarSet,TyVarSet)] tv_fds = [ (tyVarsOfTypes xs, tyVarsOfTypes ys) - | (xs, ys) <- concatMap determined preds - ] + | (xs, ys) <- concatMap determined preds ] determined :: PredType -> [([Type],[Type])] determined pred = case classifyPredType pred of - ClassPred cls tys -> - do let (cls_tvs, cls_fds) = classTvsFds cls - fd <- cls_fds - return (instFD fd cls_tvs tys) EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])] - TuplePred ts -> concatMap determined ts - _ -> [] + ClassPred cls tys -> local_fds ++ concatMap determined superclasses + where + local_fds = [ instFD fd cls_tvs tys + | fd <- cls_fds ] + (cls_tvs, cls_fds) = classTvsFds cls + superclasses = immSuperClasses cls tys + _ -> [] {- ************************************************************************ diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 78a53fba39..1383bdd909 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -173,42 +173,11 @@ canEvNC ev canClassNC ev cls tys EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2) canEqNC ev eq_rel ty1 ty2 - TuplePred tys -> do traceTcS "canEvNC:tup" (ppr tys) - canTuple ev tys IrredPred {} -> do traceTcS "canEvNC:irred" (ppr (ctEvPred ev)) canIrred ev {- ************************************************************************ * * -* Tuple Canonicalization -* * -************************************************************************ --} - -canTuple :: CtEvidence -> [PredType] -> TcS (StopOrContinue Ct) -canTuple ev preds - | CtWanted { ctev_evar = evar, ctev_loc = loc } <- ev - = do { new_evars <- mapM (newWantedEvVar loc) preds - ; setWantedEvBind evar (EvTupleMk (map (ctEvId . fst) new_evars)) - ; emitWorkNC (freshGoals new_evars) - -- Note the "NC": these are fresh goals, not necessarily canonical - ; stopWith ev "Decomposed tuple constraint" } - - | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev - = do { given_evs <- newGivenEvVars loc (mkEvTupleSelectors (EvId evar) preds) - ; emitWorkNC given_evs - ; stopWith ev "Decomposed tuple constraint" } - - | CtDerived { ctev_loc = loc } <- ev - = do { mapM_ (emitNewDerived loc) preds - ; stopWith ev "Decomposed tuple constraint" } - - | otherwise = panic "canTuple" - - -{- -************************************************************************ -* * * Class Canonicalization * * ************************************************************************ @@ -384,7 +353,6 @@ canIrred old_ev do { -- Re-classify, in case flattening has improved its shape ; case classifyPredType (ctEvPred new_ev) of ClassPred cls tys -> canClassNC new_ev cls tys - TuplePred tys -> canTuple new_ev tys EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2 _ -> continueWith $ CIrredEvCan { cc_ev = new_ev } } } diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 88c88bdc53..a4c4703ec3 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -320,8 +320,6 @@ reportWanteds ctxt (WC { wc_simple = simples, wc_insol = insols, wc_impl = impli ; (_, leftovers) <- tryReporters ctxt2' reporters (insols2 ++ tidy_simples) ; MASSERT2( null leftovers, ppr leftovers ) - -- TuplePreds should have been expanded away by the constraint - -- simplifier, so they shouldn't show up at this point -- All the Derived ones have been filtered out of simples -- by the constraint solver. This is ok; we don't want -- to report unsolved Derived goals as errors diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index 6dd01f9f1f..6e026941f8 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -14,7 +14,7 @@ module TcEvidence ( EvBindMap(..), emptyEvBindMap, extendEvBinds, lookupEvBind, evBindMapBinds, foldEvBindMap, EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, - EvTerm(..), mkEvCast, evVarsOfTerm, mkEvTupleSelectors, mkEvScSelectors, + EvTerm(..), mkEvCast, evVarsOfTerm, mkEvScSelectors, EvLit(..), evTermCoercion, EvCallStack(..), EvTypeable(..), @@ -712,10 +712,6 @@ data EvTerm | EvDFunApp DFunId -- Dictionary instance application [Type] [EvId] - | EvTupleSel EvTerm Int -- n'th component of the tuple, 0-indexed - - | EvTupleMk [EvId] -- tuple built from this stuff - | EvDelayedError Type FastString -- Used with Opt_DeferTypeErrors -- See Note [Deferring coercion errors to runtime] -- in TcSimplify @@ -975,11 +971,6 @@ mkEvCast ev lco isTcReflCo lco = ev | otherwise = EvCast ev lco -mkEvTupleSelectors :: EvTerm -> [TcPredType] -> [(TcPredType, EvTerm)] -mkEvTupleSelectors ev preds = zipWith mk_pr preds [0..] - where - mk_pr pred i = (pred, EvTupleSel ev i) - mkEvScSelectors :: EvTerm -> Class -> [TcType] -> [(TcPredType, EvTerm)] mkEvScSelectors ev cls tys = zipWith mk_pr (immSuperClasses cls tys) [0..] @@ -1006,10 +997,8 @@ evVarsOfTerm :: EvTerm -> VarSet evVarsOfTerm (EvId v) = unitVarSet v evVarsOfTerm (EvCoercion co) = coVarsOfTcCo co evVarsOfTerm (EvDFunApp _ _ evs) = mkVarSet evs -evVarsOfTerm (EvTupleSel ev _) = evVarsOfTerm ev evVarsOfTerm (EvSuperClass v _) = evVarsOfTerm v evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo co -evVarsOfTerm (EvTupleMk evs) = mkVarSet evs evVarsOfTerm (EvDelayedError _ _) = emptyVarSet evVarsOfTerm (EvLit _) = emptyVarSet evVarsOfTerm (EvCallStack cs) = evVarsOfCallStack cs @@ -1089,8 +1078,6 @@ instance Outputable EvTerm where ppr (EvId v) = ppr v ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co - ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n)) - ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] ppr (EvLit l) = ppr l diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 155cdb42be..a9622588a0 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -16,7 +16,7 @@ module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, #include "HsVersions.h" import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) -import DsMeta( liftStringName, liftName ) +import THNames( liftStringName, liftName ) import HsSyn import TcHsSyn @@ -373,7 +373,7 @@ tcExpr (SectionL arg1 op) res_ty tcExpr (ExplicitTuple tup_args boxity) res_ty | all tupArgPresent tup_args - = do { let tup_tc = tupleTyCon (boxityNormalTupleSort boxity) (length tup_args) + = do { let tup_tc = tupleTyCon boxity (length tup_args) ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty ; tup_args1 <- tcTupArgs tup_args arg_tys ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } @@ -383,7 +383,7 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty do { let kind = case boxity of { Boxed -> liftedTypeKind ; Unboxed -> openTypeKind } arity = length tup_args - tup_tc = tupleTyCon (boxityNormalTupleSort boxity) arity + tup_tc = tupleTyCon boxity arity ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind ; let actual_res_ty @@ -1273,14 +1273,14 @@ checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var)) -- just going to flag an error for now ; lift <- if isStringTy id_ty then - do { sid <- tcLookupId DsMeta.liftStringName + do { sid <- tcLookupId THNames.liftStringName -- See Note [Lifting strings] ; return (HsVar sid) } else setConstraintVar lie_var $ -- Put the 'lift' constraint into the right LIE newMethodFromName (OccurrenceOf (idName id)) - DsMeta.liftName id_ty + THNames.liftName id_ty -- Update the pending splices ; ps <- readMutVar ps_var diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index d18e6edb60..d30c1ca3b1 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -1608,7 +1608,7 @@ data FFoldType a -- Describes how to fold over a Type in a functor like way , ft_var :: a -- The variable itself , ft_co_var :: a -- The variable itself, contravariantly , ft_fun :: a -> a -> a -- Function type - , ft_tup :: TupleSort -> [a] -> a -- Tuple type + , ft_tup :: TyCon -> [a] -> a -- Tuple type , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument , ft_bad_app :: a -- Type app, variable other than in last argument , ft_forall :: TcTyVar -> a -> a -- Forall type @@ -1644,8 +1644,7 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar | not (or xcs) = (caseTrivial, False) -- Variable does not occur -- At this point we know that xrs, xcs is not empty, -- and at least one xr is True - | Just sort <- tyConTuple_maybe con - = (caseTuple sort xrs, True) + | isTupleTyCon con = (caseTuple con xrs, True) | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty | Just (fun_ty, _) <- splitAppTy_maybe ty -- T (..no var..) ty = (caseTyApp fun_ty (last xrs), True) @@ -1716,11 +1715,11 @@ mkSimpleConMatch fold extra_pats con insides = do -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a] -> m (LMatch RdrName (LHsExpr RdrName))) - -> TupleSort -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName) -mkSimpleTupleCase match_for_con sort insides x = do - let con = tupleCon sort (length insides) - match <- match_for_con [] con insides - return $ nlHsCase x [match] + -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName) +mkSimpleTupleCase match_for_con tc insides x + = do { let data_con = tyConSingleDataCon tc + ; match <- match_for_con [] data_con insides + ; return $ nlHsCase x [match] } {- ************************************************************************ diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 80dd175e3c..02d993f70c 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -90,7 +90,7 @@ hsPatType (ViewPat _ _ ty) = ty hsPatType (ListPat _ ty Nothing) = mkListTy ty hsPatType (ListPat _ _ (Just (ty,_))) = ty hsPatType (PArrPat _ ty) = mkPArrTy ty -hsPatType (TuplePat _ bx tys) = mkTupleTy (boxityNormalTupleSort bx) tys +hsPatType (TuplePat _ bx tys) = mkTupleTy bx tys hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys }) = conLikeResTy con tys hsPatType (SigPatOut _ ty) = ty @@ -1247,7 +1247,6 @@ zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcCoToCo env co zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm ; co' <- zonkTcCoToCo env co ; return (mkEvCast tm' co') } -zonkEvTerm env (EvTupleMk tms) = return (EvTupleMk (zonkIdOccs env tms)) zonkEvTerm _ (EvLit l) = return (EvLit l) zonkEvTerm env (EvTypeable ev) = @@ -1271,8 +1270,6 @@ zonkEvTerm env (EvCallStack cs) EvCsPushCall n l tm -> do { tm' <- zonkEvTerm env tm ; return (EvCallStack (EvCsPushCall n l tm')) } -zonkEvTerm env (EvTupleSel tm n) = do { tm' <- zonkEvTerm env tm - ; return (EvTupleSel tm' n) } zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d ; return (EvSuperClass d' n) } zonkEvTerm env (EvDFunApp df tys tms) diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index fbd21b23f1..785dce751e 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -476,8 +476,8 @@ tc_hs_type hs_ty@(HsExplicitListTy _k tys) exp_kind tc_hs_type hs_ty@(HsExplicitTupleTy _ tys) exp_kind = do { tks <- mapM tc_infer_lhs_type tys ; let n = length tys - kind_con = promotedTupleTyCon BoxedTuple n - ty_con = promotedTupleDataCon BoxedTuple n + kind_con = promotedTupleTyCon Boxed n + ty_con = promotedTupleDataCon Boxed n (taus, ks) = unzip tks tup_k = mkTyConApp kind_con ks ; checkExpectedKind hs_ty tup_k exp_kind @@ -568,10 +568,15 @@ finish_tuple :: HsType Name -> TupleSort -> [TcType] -> ExpKind -> TcM TcType finish_tuple hs_ty tup_sort tau_tys exp_kind = do { traceTc "finish_tuple" (ppr res_kind $$ ppr exp_kind $$ ppr exp_kind) ; checkExpectedKind hs_ty res_kind exp_kind - ; checkWiredInTyCon tycon + ; tycon <- case tup_sort of + ConstraintTuple -> tcLookupTyCon (cTupleTyConName arity) + BoxedTuple -> do { let tc = tupleTyCon Boxed arity + ; checkWiredInTyCon tc + ; return tc } + UnboxedTuple -> return (tupleTyCon Unboxed arity) ; return (mkTyConApp tycon tau_tys) } where - tycon = tupleTyCon tup_sort (length tau_tys) + arity = length tau_tys res_kind = case tup_sort of UnboxedTuple -> unliftedTypeKind BoxedTuple -> liftedTypeKind @@ -1558,7 +1563,7 @@ tc_hs_kind (HsTupleTy _ kis) = checkWiredInTyCon tycon return $ mkTyConApp tycon kappas where - tycon = promotedTupleTyCon BoxedTuple (length kis) + tycon = promotedTupleTyCon Boxed (length kis) -- Argument not kind-shaped tc_hs_kind k = pprPanic "tc_hs_kind" (ppr k) diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index ed4fd913bf..de5df6ae53 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -1015,7 +1015,6 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds fam_envs sc_th super_classes ev_pair = case classifyPredType pred of ClassPred cls tys -> (pred, ev_tm) : super_classes_help ev_tm cls tys - TuplePred preds -> concatMap super_classes (mkEvTupleSelectors ev_tm preds) _ -> [] where (pred, ev_tm) = normalise_pr ev_pair @@ -1023,7 +1022,8 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds fam_envs sc_th ------------ super_classes_help :: EvTerm -> Class -> [TcType] -> [(TcPredType, EvTerm)] super_classes_help ev_tm cls tys -- ev_tm :: cls tys - | sizeTypes tys >= head_size -- Here is where we test for + | not (isCTupleClass cls) + , sizeTypes tys >= head_size -- Here is where we test for = [] -- a smaller dictionary | otherwise = concatMap super_classes (mkEvScSelectors ev_tm cls tys) diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 95715fe03d..ce51b0d796 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -27,6 +27,7 @@ import PrelNames ( knownNatClassName, knownSymbolClassName, ipClassNameKey, import Id( idType ) import Class import TyCon +import DataCon( dataConWrapId ) import FunDeps import FamInst import Inst( tyVarsOfCt ) @@ -2022,8 +2023,15 @@ matchClassInst _ clas [ ty ] _ = panicTcS (text "Unexpected evidence for" <+> ppr (className clas) $$ vcat (map (ppr . idType) (classMethods clas))) +matchClassInst _ clas ts _ + | isCTupleClass clas + , let data_con = tyConSingleDataCon (classTyCon clas) + = return (GenInst ts (EvDFunApp (dataConWrapId data_con) ts)) + -- The dfun is the data constructor! + matchClassInst _ clas [k,t] _ - | className clas == typeableClassName = matchTypeableClass clas k t + | className clas == typeableClassName + = matchTypeableClass clas k t matchClassInst inerts clas tys loc = do { dflags <- getDynFlags diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index 0eaae8f54b..a5d55555bc 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -143,7 +143,6 @@ predTypeOccName :: PredType -> OccName predTypeOccName ty = case classifyPredType ty of ClassPred cls _ -> mkDictOcc (getOccName cls) EqPred _ _ _ -> mkVarOccFS (fsLit "cobox") - TuplePred _ -> mkVarOccFS (fsLit "tup") IrredPred _ -> mkVarOccFS (fsLit "irred") diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 93c4728e45..df2ad1837d 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -589,7 +589,7 @@ tc_pat penv (PArrPat pats _) pat_ty thing_inside } tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside - = do { let tc = tupleTyCon (boxityNormalTupleSort boxity) (length pats) + = do { let tc = tupleTyCon boxity (length pats) ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) pat_ty ; (pats', res) <- tc_lpats penv pats arg_tys thing_inside diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index ea454d5d60..820e969cf4 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -1016,6 +1016,10 @@ checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true checkTc True _ = return () checkTc False err = failWithTc err +failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false +failIfTc False _ = return () +failIfTc True err = failWithTc err + -- Warnings have no 'M' variant, nor failure warnTc :: Bool -> MsgDoc -> TcM () diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index e9705790ed..ee0740f8e4 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -614,7 +614,6 @@ pickQuantifiablePreds qtvs theta EqPred NomEq ty1 ty2 -> quant_fun ty1 || quant_fun ty2 IrredPred ty -> tyVarsOfType ty `intersectsVarSet` qtvs - TuplePred {} -> False pick_cls_pred flex_ctxt tys = tyVarsOfTypes tys `intersectsVarSet` qtvs diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 4ecbd5053c..a7363d85a1 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -38,7 +38,7 @@ import Outputable import TcExpr import SrcLoc import FastString -import DsMeta +import THNames import TcUnify import TcEnv diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 6ac87206bd..59ff6cb79e 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -581,13 +581,24 @@ Then: This fancy footwork (with two bindings for T) is only necesary for the TyCons or Classes of this recursive group. Earlier, finished groups, live in the global env only. + +Note [Declarations for wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For wired-in things we simply ignore the declaration +and take the wired-in information. That avoids complications. +e.g. the need to make the data constructor worker name for + a constraint tuple match the wired-in one -} tcTyClDecl :: RecTyInfo -> LTyClDecl Name -> TcM [TyThing] tcTyClDecl rec_info (L loc decl) + | Just thing <- wiredInNameTyThing_maybe (tcdName decl) + = return [thing] -- See Note [Declarations for wired-in things] + + | otherwise = setSrcSpan loc $ tcAddDeclCtxt decl $ - traceTc "tcTyAndCl-x" (ppr decl) >> - tcTyClDecl1 NoParentTyCon rec_info decl + do { traceTc "tcTyAndCl-x" (ppr decl) + ; tcTyClDecl1 NoParentTyCon rec_info decl } -- "type family" declarations tcTyClDecl1 :: TyConParent -> RecTyInfo -> TyClDecl Name -> TcM [TyThing] @@ -788,7 +799,7 @@ tcDataDefn rec_info tc_name tvs kind else case new_or_data of DataType -> return (mkDataTyConRhs data_cons) NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs tc_name tycon (head data_cons) + mkNewTyConRhs tc_name tycon (head data_cons) ; return (buildAlgTyCon tc_name final_tvs roles (fmap unLoc cType) stupid_theta tc_rhs (rti_is_rec rec_info tc_name) diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 4d4f6823f2..9ce14497b7 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -1377,7 +1377,6 @@ mkMinimalBySCs ptys = [ ploc | ploc <- ptys trans_super_classes pred -- Superclasses of pred, excluding pred itself = case classifyPredType pred of ClassPred cls tys -> transSuperClasses cls tys - TuplePred ts -> concatMap trans_super_classes ts _ -> [] transSuperClasses :: Class -> [Type] -> [PredType] @@ -1387,10 +1386,9 @@ transSuperClasses cls tys -- Superclasses of (cls tys), transSuperClassesPred :: PredType -> [PredType] -- (transSuperClassesPred p) returns (p : p's superclasses) -transSuperClassesPred p +transSuperClassesPred p = case classifyPredType p of ClassPred cls tys -> p : transSuperClasses cls tys - TuplePred ps -> concatMap transSuperClassesPred ps _ -> [p] immSuperClasses :: Class -> [Type] -> [PredType] @@ -1406,7 +1404,6 @@ isImprovementPred ty EqPred NomEq t1 t2 -> not (t1 `tcEqType` t2) EqPred ReprEq _ _ -> False ClassPred cls _ -> classHasFds cls - TuplePred ts -> any isImprovementPred ts IrredPred {} -> True -- Might have equalities after reduction? {- diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index 3225b2848b..16059e68b5 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -24,13 +24,13 @@ import TypeRep import TcType import TcMType import TysWiredIn ( coercibleClass, eqTyConName ) +import PrelNames import Type import Unify( tcMatchTyX ) import Kind import CoAxiom import Class import TyCon -import PrelNames( eqTyConKey ) -- others: import HsSyn -- HsType @@ -45,7 +45,6 @@ import Util import ListSetOps import SrcLoc import Outputable -import Unique ( hasKey ) import BasicTypes ( IntWithInf, infinity ) import FastString @@ -396,7 +395,11 @@ check_type ctxt rank ty = do { checkTc (forAllAllowed rank) (forAllTyErr rank ty) -- Reject e.g. (Maybe (?x::Int => Int)), -- with a decent error message - ; check_valid_theta ctxt theta + + ; check_valid_theta SigmaCtxt theta + -- Allow type T = ?x::Int => Int -> Int + -- but not type T = ?x::Int + ; check_type ctxt rank tau } -- Allow foralls to right of arrow where (tvs, theta, tau) = tcSplitSigmaTy ty @@ -617,15 +620,16 @@ check_pred_help :: Bool -- True <=> under a type synonym check_pred_help under_syn dflags ctxt pred | Just pred' <- coreView pred -- Switch on under_syn when going under a -- synonym (Trac #9838, yuk) - = check_pred_help True dflags ctxt pred' + = check_pred_help True dflags ctxt pred' | otherwise = case splitTyConApp_maybe pred of - Just (tc, tys) | Just cls <- tyConClass_maybe tc - -> check_class_pred dflags ctxt pred cls tys -- Includes Coercible - | tc `hasKey` eqTyConKey - -> check_eq_pred dflags pred tys - | isTupleTyCon tc - -> check_tuple_pred under_syn dflags ctxt pred tys + Just (tc, tys) + | isTupleTyCon tc + -> check_tuple_pred under_syn dflags ctxt pred tys + | Just cls <- tyConClass_maybe tc + -> check_class_pred dflags ctxt pred cls tys -- Includes Coercible + | tc `hasKey` eqTyConKey + -> check_eq_pred dflags pred tys _ -> check_irred_pred under_syn dflags ctxt pred check_eq_pred :: DynFlags -> PredType -> [TcType] -> TcM () @@ -656,16 +660,22 @@ check_irred_pred under_syn dflags ctxt pred -- see Note [ConstraintKinds in predicates] -- But (X t1 t2) is always ok because we just require ConstraintKinds -- at the definition site (Trac #9838) - checkTc (under_syn || xopt Opt_ConstraintKinds dflags || not (hasTyVarHead pred)) - (predIrredErr pred) + failIfTc (not under_syn && not (xopt Opt_ConstraintKinds dflags) + && hasTyVarHead pred) + (predIrredErr pred) -- Make sure it is OK to have an irred pred in this context -- See Note [Irreducible predicates in superclasses] - ; checkTc (xopt Opt_UndecidableInstances dflags || not (dodgy_superclass ctxt)) - (predIrredBadCtxtErr pred) } + ; failIfTc (is_superclass ctxt + && not (xopt Opt_UndecidableInstances dflags) + && has_tyfun_head pred) + (predSuperClassErr pred) } where - dodgy_superclass ctxt - = case ctxt of { ClassSCCtxt _ -> True; InstDeclCtxt -> True; _ -> False } + is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False } + has_tyfun_head ty + = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> isTypeFamilyTyCon tc + Nothing -> False {- Note [ConstraintKinds in predicates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -679,7 +689,7 @@ e.g. module A where Note [Irreducible predicates in superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Allowing irreducible predicates in class superclasses is somewhat dangerous +Allowing type-family calls in class superclasses is somewhat dangerous because we can write: type family Fooish x :: * -> Constraint @@ -688,10 +698,7 @@ because we can write: This will cause the constraint simplifier to loop because every time we canonicalise a (Foo a) class constraint we add a (Fooish () a) constraint which will be immediately -solved to add+canonicalise another (Foo a) constraint. - -It is equally dangerous to allow them in instance heads because in that case the -Paterson conditions may not detect duplication of a type variable or size change. -} +solved to add+canonicalise another (Foo a) constraint. -} ------------------------- check_class_pred :: DynFlags -> UserTypeCtxt -> PredType -> Class -> [TcType] -> TcM () @@ -722,10 +729,25 @@ check_class_pred dflags ctxt pred cls tys ------------------------- okIPCtxt :: UserTypeCtxt -> Bool -- See Note [Implicit parameters in instance decls] +okIPCtxt (FunSigCtxt {}) = True +okIPCtxt (InfSigCtxt {}) = True +okIPCtxt ExprSigCtxt = True +okIPCtxt PatSigCtxt = True +okIPCtxt ResSigCtxt = True +okIPCtxt GenSigCtxt = True +okIPCtxt (ConArgCtxt {}) = True +okIPCtxt (ForSigCtxt {}) = True -- ?? +okIPCtxt ThBrackCtxt = True +okIPCtxt GhciCtxt = True +okIPCtxt SigmaCtxt = True +okIPCtxt (DataTyCtxt {}) = True + okIPCtxt (ClassSCCtxt {}) = False okIPCtxt (InstDeclCtxt {}) = False okIPCtxt (SpecInstCtxt {}) = False -okIPCtxt _ = True +okIPCtxt (TySynCtxt {}) = False +okIPCtxt (RuleSigCtxt {}) = False +okIPCtxt DefaultDeclCtxt = False badIPPred :: PredType -> SDoc badIPPred pred = ptext (sLit "Illegal implicit parameter") <+> quotes (ppr pred) @@ -756,10 +778,9 @@ checkThetaCtxt ctxt theta = vcat [ptext (sLit "In the context:") <+> pprTheta theta, ptext (sLit "While checking") <+> pprUserTypeCtxt ctxt ] -eqPredTyErr, predTyVarErr, predTupleErr, predIrredErr, predIrredBadCtxtErr :: PredType -> SDoc -eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprType pred - $$ - parens (ptext (sLit "Use GADTs or TypeFamilies to permit this")) +eqPredTyErr, predTyVarErr, predTupleErr, predIrredErr, predSuperClassErr :: PredType -> SDoc +eqPredTyErr pred = vcat [ ptext (sLit "Illegal equational constraint") <+> pprType pred + , parens (ptext (sLit "Use GADTs or TypeFamilies to permit this")) ] predTyVarErr pred = vcat [ hang (ptext (sLit "Non type-variable argument")) 2 (ptext (sLit "in the constraint:") <+> pprType pred) , parens (ptext (sLit "Use FlexibleContexts to permit this")) ] @@ -767,9 +788,10 @@ predTupleErr pred = hang (ptext (sLit "Illegal tuple constraint:") <+> pprType 2 (parens constraintKindsMsg) predIrredErr pred = hang (ptext (sLit "Illegal constraint:") <+> pprType pred) 2 (parens constraintKindsMsg) -predIrredBadCtxtErr pred = hang (ptext (sLit "Illegal constraint") <+> quotes (pprType pred) - <+> ptext (sLit "in a superclass/instance context")) - 2 (parens undecidableMsg) +predSuperClassErr pred + = hang (ptext (sLit "Illegal constraint") <+> quotes (pprType pred) + <+> ptext (sLit "in a superclass context")) + 2 (parens undecidableMsg) constraintSynErr :: Type -> SDoc constraintSynErr kind = hang (ptext (sLit "Illegal constraint synonym of kind:") <+> quotes (ppr kind)) @@ -886,10 +908,9 @@ not converge. See Trac #5287. validDerivPred :: TyVarSet -> PredType -> Bool validDerivPred tv_set pred = case classifyPredType pred of - ClassPred _ tys -> check_tys tys - TuplePred ps -> all (validDerivPred tv_set) ps - EqPred {} -> False -- reject equality constraints - _ -> True -- Non-class predicates are ok + ClassPred _ tys -> check_tys tys + EqPred {} -> False -- reject equality constraints + _ -> True -- Non-class predicates are ok where check_tys tys = hasNoDups fvs && sizeTypes tys == fromIntegral (length fvs) @@ -963,6 +984,9 @@ The underlying idea is that context has fewer type constructors than the head. -} +leafTyConKeys :: [Unique] +leafTyConKeys = [eqTyConKey, coercibleTyConKey, ipClassNameKey] + checkInstTermination :: [TcType] -> ThetaType -> TcM () -- See Note [Paterson conditions] checkInstTermination tys theta @@ -976,36 +1000,45 @@ checkInstTermination tys theta check :: PredType -> TcM () check pred - = case classifyPredType pred of - TuplePred preds -> check_preds preds -- Look inside tuple predicates; Trac #8359 - EqPred {} -> return () -- You can't get from equalities - -- to class predicates, so this is safe - _other -- ClassPred, IrredPred - | not (null bad_tvs) - -> addErrTc (predUndecErr pred (nomoreMsg bad_tvs) $$ parens undecidableMsg) - | sizePred pred >= size - -> addErrTc (predUndecErr pred smallerMsg $$ parens undecidableMsg) - | otherwise - -> return () + = case tcSplitTyConApp_maybe pred of + Just (tc, tys) + | getUnique tc `elem` leafTyConKeys + -> return () -- You can't get from equalities or implicit + -- params to class predicates, so this is safe + + | isTupleTyCon tc + -> check_preds tys + -- Look inside tuple predicates; Trac #8359 + + _other -- All others: other ClassPreds, IrredPred + | not (null bad_tvs) -> addErrTc (noMoreMsg bad_tvs what) + | sizePred pred >= size -> addErrTc (smallerMsg what) + | otherwise -> return () where + what = ptext (sLit "constraint") <+> quotes (ppr pred) bad_tvs = filterOut isKindVar (fvType pred \\ fvs) -- Rightly or wrongly, we only check for -- excessive occurrences of *type* variables. -- e.g. type instance Demote {T k} a = T (Demote {k} (Any {k})) -predUndecErr :: PredType -> SDoc -> SDoc -predUndecErr pred msg = sep [msg, - nest 2 (ptext (sLit "in the constraint:") <+> pprType pred)] - -nomoreMsg :: [TcTyVar] -> SDoc -nomoreMsg tvs - = sep [ ptext (sLit "Variable") <> plural tvs <+> quotes (pprWithCommas ppr tvs) - , (if isSingleton tvs then ptext (sLit "occurs") - else ptext (sLit "occur")) - <+> ptext (sLit "more often than in the instance head") ] +smallerMsg :: SDoc -> SDoc +smallerMsg what + = vcat [ hang (ptext (sLit "The") <+> what) + 2 (ptext (sLit "is no smaller than the instance head")) + , parens undecidableMsg ] + +noMoreMsg :: [TcTyVar] -> SDoc -> SDoc +noMoreMsg tvs what + = vcat [ hang (ptext (sLit "Variable") <> plural tvs <+> quotes (pprWithCommas ppr tvs) + <+> occurs <+> ptext (sLit "more often")) + 2 (sep [ ptext (sLit "in the") <+> what + , ptext (sLit "than in the instance head") ]) + , parens undecidableMsg ] + where + occurs = if isSingleton tvs then ptext (sLit "occurs") + else ptext (sLit "occur") -smallerMsg, undecidableMsg, constraintKindsMsg :: SDoc -smallerMsg = ptext (sLit "Constraint is no smaller than the instance head") +undecidableMsg, constraintKindsMsg :: SDoc undecidableMsg = ptext (sLit "Use UndecidableInstances to permit this") constraintKindsMsg = ptext (sLit "Use ConstraintKinds to permit this") @@ -1192,16 +1225,12 @@ checkFamInstRhs lhsTys famInsts size = sizeTypes lhsTys fvs = fvTypes lhsTys check (tc, tys) - | not (all isTyFamFree tys) - = Just (famInstUndecErr famInst nestedMsg $$ parens undecidableMsg) - | not (null bad_tvs) - = Just (famInstUndecErr famInst (nomoreMsg bad_tvs) $$ parens undecidableMsg) - | size <= sizeTypes tys - = Just (famInstUndecErr famInst smallerAppMsg $$ parens undecidableMsg) - | otherwise - = Nothing + | not (all isTyFamFree tys) = Just (nestedMsg what) + | not (null bad_tvs) = Just (noMoreMsg bad_tvs what) + | size <= sizeTypes tys = Just (smallerMsg what) + | otherwise = Nothing where - famInst = TyConApp tc tys + what = ptext (sLit "type family application") <+> quotes (pprType (TyConApp tc tys)) bad_tvs = filterOut isKindVar (fvTypes tys \\ fvs) -- Rightly or wrongly, we only check for -- excessive occurrences of *type* variables. @@ -1247,11 +1276,10 @@ tyFamInstIllegalErr ty colon) 2 $ ppr ty -famInstUndecErr :: Type -> SDoc -> SDoc -famInstUndecErr ty msg - = sep [msg, - nest 2 (ptext (sLit "in the type family application:") <+> - pprType ty)] +nestedMsg :: SDoc -> SDoc +nestedMsg what + = sep [ ptext (sLit "Illegal nested") <+> what + , parens undecidableMsg ] famPatErr :: TyCon -> [TyVar] -> [Type] -> SDoc famPatErr fam_tc tvs pats @@ -1260,10 +1288,6 @@ famPatErr fam_tc tvs pats 2 (hang (ptext (sLit "but the real LHS (expanding synonyms) is:")) 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats) <+> ptext (sLit "= ..."))) -nestedMsg, smallerAppMsg :: SDoc -nestedMsg = ptext (sLit "Nested type family application") -smallerAppMsg = ptext (sLit "Application is no smaller than the instance head") - {- ************************************************************************ * * @@ -1331,14 +1355,14 @@ sizeTypes xs = sum (map sizeType tys) -- "local instances" in expressions). -- See Trac #4200. sizePred :: PredType -> TypeSize -sizePred p = go (classifyPredType p) - where - go (ClassPred cls tys') - | isIPClass cls = 0 -- See Note [Size of a predicate] - | otherwise = sizeTypes tys' - go (EqPred {}) = 0 -- See Note [Size of a predicate] - go (TuplePred ts) = sum (map sizePred ts) - go (IrredPred ty) = sizeType ty +sizePred p + = case classifyPredType p of + ClassPred cls tys + | isIPClass cls -> 0 -- See Note [Size of a predicate] + | isCTupleClass cls -> maximum (0 : map sizePred tys) + | otherwise -> sizeTypes tys + EqPred {} -> 0 -- See Note [Size of a predicate] + IrredPred ty -> sizeType ty {- ************************************************************************ diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 186134363e..827c076b2e 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -61,7 +61,8 @@ module TyCon( tyConTyVars, tyConCType, tyConCType_maybe, tyConDataCons, tyConDataCons_maybe, - tyConSingleDataCon_maybe, tyConSingleAlgDataCon_maybe, + tyConSingleDataCon_maybe, tyConSingleDataCon, + tyConSingleAlgDataCon_maybe, tyConFamilySize, tyConStupidTheta, tyConArity, @@ -1038,7 +1039,7 @@ mkClassTyCon :: Name -> Kind -> [TyVar] -> [Role] -> AlgTyConRhs -> Class mkClassTyCon name kind tyvars roles rhs clas is_rec = mkAlgTyCon name kind tyvars roles Nothing [] rhs (ClassTyCon clas) is_rec False - Nothing -- Class TyCons are not pormoted + Nothing -- Class TyCons are not promoted mkTupleTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' @@ -1047,8 +1048,9 @@ mkTupleTyCon :: Name -> DataCon -> TupleSort -- ^ Whether the tuple is boxed or unboxed -> Maybe TyCon -- ^ Promoted version + -> TyConParent -> TyCon -mkTupleTyCon name kind arity tyvars con sort prom_tc +mkTupleTyCon name kind arity tyvars con sort prom_tc parent = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -1059,7 +1061,7 @@ mkTupleTyCon name kind arity tyvars con sort prom_tc tyConCType = Nothing, algTcStupidTheta = [], algTcRhs = TupleTyCon { data_con = con, tup_sort = sort }, - algTcParent = NoParentTyCon, + algTcParent = parent, algTcRec = NonRecursive, algTcGadtSyntax = False, tcPromoted = prom_tc @@ -1470,17 +1472,23 @@ isPromotedDataCon_maybe _ = Nothing -- -- * Family instances are /not/ implicit as they represent the instance body -- (similar to a @dfun@ does that for a class instance). +-- +-- * Tuples are implicit iff they have a wired-in name +-- (namely: boxed and unboxed tupeles are wired-in and implicit, +-- but constraint tuples are not) isImplicitTyCon :: TyCon -> Bool isImplicitTyCon (FunTyCon {}) = True isImplicitTyCon (PrimTyCon {}) = True isImplicitTyCon (PromotedDataCon {}) = True isImplicitTyCon (PromotedTyCon {}) = True -isImplicitTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True -isImplicitTyCon (AlgTyCon { algTcParent = AssocFamilyTyCon {} }) = True -isImplicitTyCon (AlgTyCon {}) = False -isImplicitTyCon (FamilyTyCon { famTcParent = AssocFamilyTyCon {} }) = True -isImplicitTyCon (FamilyTyCon {}) = False -isImplicitTyCon (SynonymTyCon {}) = False +isImplicitTyCon (AlgTyCon { algTcRhs = rhs, algTcParent = parent, tyConName = name }) + | TupleTyCon {} <- rhs = isWiredInName name + | AssocFamilyTyCon {} <- parent = True + | otherwise = False +isImplicitTyCon (FamilyTyCon { famTcParent = parent }) + | AssocFamilyTyCon {} <- parent = True + | otherwise = False +isImplicitTyCon (SynonymTyCon {}) = False tyConCType_maybe :: TyCon -> Maybe CType tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc @@ -1548,6 +1556,12 @@ tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs }) _ -> Nothing tyConSingleDataCon_maybe _ = Nothing +tyConSingleDataCon :: TyCon -> DataCon +tyConSingleDataCon tc + = case tyConSingleDataCon_maybe tc of + Just c -> c + Nothing -> pprPanic "tyConDataCon" (ppr tc) + tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon -- Returns (Just con) for single-constructor -- *algebraic* data types *not* newtypes diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index f29791c8a4..41b6b2d8b6 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -50,6 +50,7 @@ module Type ( mkClassPred, isClassPred, isEqPred, isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, + isCTupleClass, -- Deconstructing predicate types PredTree(..), EqRel(..), eqRelRole, classifyPredType, @@ -913,6 +914,9 @@ isIPClass :: Class -> Bool isIPClass cls = cls `hasKey` ipClassNameKey -- Class and it corresponding TyCon have the same Unique +isCTupleClass :: Class -> Bool +isCTupleClass cls = isTupleTyCon (classTyCon cls) + isIPPred_maybe :: Type -> Maybe (FastString, Type) isIPPred_maybe ty = do (tc,[t1,t2]) <- splitTyConApp_maybe ty @@ -1020,7 +1024,6 @@ eqRelRole ReprEq = Representational data PredTree = ClassPred Class [Type] | EqPred EqRel Type Type - | TuplePred [PredType] | IrredPred PredType classifyPredType :: PredType -> PredTree @@ -1035,8 +1038,6 @@ classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of -- the Coercible check Just (tc, tys) | Just clas <- tyConClass_maybe tc -> ClassPred clas tys - Just (tc, tys) | isTupleTyCon tc - -> TuplePred tys _ -> IrredPred ev_ty getClassPredTys :: PredType -> (Class, [Type]) diff --git a/compiler/types/TypeRep.hs b/compiler/types/TypeRep.hs index f755f3f9ee..527bfda02e 100644 --- a/compiler/types/TypeRep.hs +++ b/compiler/types/TypeRep.hs @@ -78,6 +78,7 @@ import Outputable import FastString import Util import DynFlags +import StaticFlags( opt_PprStyle_Debug ) -- libraries import Data.List( mapAccumL, partition ) @@ -743,8 +744,7 @@ pprTcApp p pp tc tys ty_args = drop arity tys -- Drop the kind args , ty_args `lengthIs` arity -- Result is saturated = pprPromotionQuote tc <> - (tupleParens tup_sort $ - sep (punctuate comma (map (pp TopPrec) ty_args))) + (tupleParens tup_sort $ pprWithCommas (pp TopPrec) ty_args) | otherwise = sdocWithDynFlags (pprTcApp_help p pp tc tys) @@ -754,11 +754,12 @@ pprTupleApp :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> TupleSort -> [a] -> S pprTupleApp p pp tc sort tys | null tys , ConstraintTuple <- sort - = maybeParen p TopPrec $ - ppr tc <+> dcolon <+> ppr (tyConKind tc) + = if opt_PprStyle_Debug then ptext (sLit "(%%)") + else maybeParen p FunPrec $ + ptext (sLit "() :: Constraint") | otherwise = pprPromotionQuote tc <> - tupleParens sort (sep (punctuate comma (map (pp TopPrec) tys))) + tupleParens sort (pprWithCommas (pp TopPrec) tys) pprTcApp_help :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> DynFlags -> SDoc -- This one has accss to the DynFlags diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs index bcd85cb100..d5bbd65ee9 100644 --- a/compiler/vectorise/Vectorise/Builtins/Base.hs +++ b/compiler/vectorise/Vectorise/Builtins/Base.hs @@ -141,7 +141,7 @@ sumTyCon = indexBuiltin "sumTyCon" sumTyCons prodTyCon :: Int -> Builtins -> TyCon prodTyCon n _ | n >= 2 && n <= mAX_DPH_PROD - = tupleTyCon BoxedTuple n + = tupleTyCon Boxed n | otherwise = pprPanic "prodTyCon" (ppr n) diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs index 6770103d3b..ee7cf9c2b5 100644 --- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs +++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs @@ -192,7 +192,7 @@ initBuiltinVars (Builtins { }) preludeDataCons = [mk_tup n (mkFastString $ "tup" ++ show n) | n <- [2..5]] where - mk_tup n name = (tupleCon BoxedTuple n, name) + mk_tup n name = (tupleDataCon Boxed n, name) -- Auxilliary look up functions ----------------------------------------------- diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs index 0a918f84e9..335b34b909 100644 --- a/compiler/vectorise/Vectorise/Utils/Closure.hs +++ b/compiler/vectorise/Vectorise/Utils/Closure.hs @@ -22,7 +22,7 @@ import TyCon import DataCon import MkId import TysWiredIn -import BasicTypes( TupleSort(..) ) +import BasicTypes( Boxity(..) ) import FastString @@ -128,13 +128,13 @@ buildEnv [] void <- builtin voidVar pvoid <- builtin pvoidVar return (ty, vVar (void, pvoid), \_ body -> body) -buildEnv [v] +buildEnv [v] = return (vVarType v, vVar v, \env body -> vLet (vNonRec v env) body) buildEnv vs = do (lenv_tc, lenv_tyargs) <- pdataReprTyCon ty - let venv_con = tupleCon BoxedTuple (length vs) + let venv_con = tupleDataCon Boxed (length vs) [lenv_con] = tyConDataCons lenv_tc venv = mkCoreTup (map Var vvs) diff --git a/libraries/ghc-prim/GHC/Classes.hs b/libraries/ghc-prim/GHC/Classes.hs index 1f9ec2d9f8..5a3e48e374 100644 --- a/libraries/ghc-prim/GHC/Classes.hs +++ b/libraries/ghc-prim/GHC/Classes.hs @@ -1,6 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, StandaloneDeriving, BangPatterns, - KindSignatures, DataKinds, MultiParamTypeClasses, FunctionalDependencies #-} + KindSignatures, DataKinds, ConstraintKinds, + MultiParamTypeClasses, FunctionalDependencies #-} {-# LANGUAGE AllowAmbiguousTypes #-} -- ip :: IP x a => a is strictly speaking ambiguous, but IP is magic @@ -314,3 +315,37 @@ x# `modInt#` y# else r# where !r# = x# `remInt#` y# + + +{- ************************************************************* +* * +* Constraint tuples * +* * +************************************************************* -} + +class () +class (c1, c2) => (c1, c2) +class (c1, c2, c3) => (c1, c2, c3) +class (c1, c2, c3, c4) => (c1, c2, c3, c4) +class (c1, c2, c3, c4, c5) => (c1, c2, c3, c4, c5) +class (c1, c2, c3, c4, c5, c6) => (c1, c2, c3, c4, c5, c6) +class (c1, c2, c3, c4, c5, c6, c7) => (c1, c2, c3, c4, c5, c6, c7) +class (c1, c2, c3, c4, c5, c6, c7, c8) => (c1, c2, c3, c4, c5, c6, c7, c8) +class (c1, c2, c3, c4, c5, c6, c7, c8, c9) + => (c1, c2, c3, c4, c5, c6, c7, c8, c9) +class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10) + => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10) +class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11) + => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11) +class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12) + => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12) +class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13) + => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13) +class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14) + => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14) +class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15) + => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15) +class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16) + => (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16) + + diff --git a/libraries/ghc-prim/GHC/Tuple.hs b/libraries/ghc-prim/GHC/Tuple.hs index 3c4c8c2bc1..4ebda15d84 100644 --- a/libraries/ghc-prim/GHC/Tuple.hs +++ b/libraries/ghc-prim/GHC/Tuple.hs @@ -23,113 +23,141 @@ default () -- Double and Integer aren't available yet -- constructor @()@. data () = () -data (,) a b = (,) a b -data (,,) a b c = (,,) a b c -data (,,,) a b c d = (,,,) a b c d -data (,,,,) a b c d e = (,,,,) a b c d e -data (,,,,,) a b c d e f = (,,,,,) a b c d e f -data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g -data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h -data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i -data (,,,,,,,,,) a b c d e f g h i j = (,,,,,,,,,) a b c d e f g h i j -data (,,,,,,,,,,) a b c d e f g h i j k = (,,,,,,,,,,) a b c d e f g h i j k -data (,,,,,,,,,,,) a b c d e f g h i j k l = (,,,,,,,,,,,) a b c d e f g h i j k l -data (,,,,,,,,,,,,) a b c d e f g h i j k l m = (,,,,,,,,,,,,) a b c d e f g h i j k l m -data (,,,,,,,,,,,,,) a b c d e f g h i j k l m n = (,,,,,,,,,,,,,) a b c d e f g h i j k l m n -data (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o = (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o -data (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p = (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p -data (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q - = (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q -data (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r - = (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r -data (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s - = (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s -data (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t - = (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t -data (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u - = (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u -data (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v - = (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v -data (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w - = (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w -data (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x - = (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x -data (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y - = (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y -data (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z - = (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z -data (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ +data (a,b) = (a,b) +data (a,b,c) = (a,b,c) +data (a,b,c,d) = (a,b,c,d) +data (a,b,c,d,e) = (a,b,c,d,e) +data (a,b,c,d,e,f) = (a,b,c,d,e,f) +data (a,b,c,d,e,f,g) = (a,b,c,d,e,f,g) +data (a,b,c,d,e,f,g,h) = (a,b,c,d,e,f,g,h) +data (a,b,c,d,e,f,g,h,i) = (a,b,c,d,e,f,g,h,i) +data (a,b,c,d,e,f,g,h,i,j) = (a,b,c,d,e,f,g,h,i,j) +data (a,b,c,d,e,f,g,h,i,j,k) = (a,b,c,d,e,f,g,h,i,j,k) +data (a,b,c,d,e,f,g,h,i,j,k,l) = (a,b,c,d,e,f,g,h,i,j,k,l) +data (a,b,c,d,e,f,g,h,i,j,k,l,m) = (a,b,c,d,e,f,g,h,i,j,k,l,m) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) + +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1,r1,s1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2,f2) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2,f2) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2,f2,g2) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2,f2,g2) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2,f2,g2,h2) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2,f2,g2,h2) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2,f2,g2,h2,i2) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2,f2,g2,h2,i2) +data (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) + = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, + r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) {- Manuel says: Including one more declaration gives a segmentation fault. data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index e893974116..a25d7ffaf2 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples, - RoleAnnotations #-} + MultiParamTypeClasses, RoleAnnotations #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Types diff --git a/testsuite/tests/indexed-types/should_fail/NotRelaxedExamples.stderr b/testsuite/tests/indexed-types/should_fail/NotRelaxedExamples.stderr index dd479b7664..1594d199df 100644 --- a/testsuite/tests/indexed-types/should_fail/NotRelaxedExamples.stderr +++ b/testsuite/tests/indexed-types/should_fail/NotRelaxedExamples.stderr @@ -1,18 +1,17 @@ - -NotRelaxedExamples.hs:9:15: - Nested type family application - in the type family application: F1 (F1 Char) - (Use UndecidableInstances to permit this) - In the type instance declaration for ‘F1’ - -NotRelaxedExamples.hs:10:15: - Application is no smaller than the instance head - in the type family application: F2 [x] - (Use UndecidableInstances to permit this) - In the type instance declaration for ‘F2’ - -NotRelaxedExamples.hs:11:15: - Application is no smaller than the instance head - in the type family application: F3 [Char] - (Use UndecidableInstances to permit this) - In the type instance declaration for ‘F3’ +
+NotRelaxedExamples.hs:9:15: error:
+ Illegal nested type family application ‘F1 (F1 Char)’
+ (Use UndecidableInstances to permit this)
+ In the type instance declaration for ‘F1’
+
+NotRelaxedExamples.hs:10:15: error:
+ The type family application ‘F2 [x]’
+ is no smaller than the instance head
+ (Use UndecidableInstances to permit this)
+ In the type instance declaration for ‘F2’
+
+NotRelaxedExamples.hs:11:15: error:
+ The type family application ‘F3 [Char]’
+ is no smaller than the instance head
+ (Use UndecidableInstances to permit this)
+ In the type instance declaration for ‘F3’
diff --git a/testsuite/tests/indexed-types/should_fail/TyFamUndec.stderr b/testsuite/tests/indexed-types/should_fail/TyFamUndec.stderr index 15cd757181..bdc9c5fbac 100644 --- a/testsuite/tests/indexed-types/should_fail/TyFamUndec.stderr +++ b/testsuite/tests/indexed-types/should_fail/TyFamUndec.stderr @@ -1,18 +1,17 @@ - -TyFamUndec.hs:6:15: - Variable ‘b’ occurs more often than in the instance head - in the type family application: T (b, b) - (Use UndecidableInstances to permit this) - In the type instance declaration for ‘T’ - -TyFamUndec.hs:7:15: - Application is no smaller than the instance head - in the type family application: T (a, Maybe b) - (Use UndecidableInstances to permit this) - In the type instance declaration for ‘T’ - -TyFamUndec.hs:8:15: - Nested type family application - in the type family application: T (a, T b) - (Use UndecidableInstances to permit this) - In the type instance declaration for ‘T’ +
+TyFamUndec.hs:6:15: error:
+ Variable ‘b’ occurs more often
+ in the type family application ‘T (b, b)’ than in the instance head
+ (Use UndecidableInstances to permit this)
+ In the type instance declaration for ‘T’
+
+TyFamUndec.hs:7:15: error:
+ The type family application ‘T (a, Maybe b)’
+ is no smaller than the instance head
+ (Use UndecidableInstances to permit this)
+ In the type instance declaration for ‘T’
+
+TyFamUndec.hs:8:15: error:
+ Illegal nested type family application ‘T (a, T b)’
+ (Use UndecidableInstances to permit this)
+ In the type instance declaration for ‘T’
diff --git a/testsuite/tests/module/all.T b/testsuite/tests/module/all.T index c4c2fffe57..d0b37aaa33 100644 --- a/testsuite/tests/module/all.T +++ b/testsuite/tests/module/all.T @@ -116,7 +116,7 @@ test('mod85', normal, compile, ['']) test('mod86', normal, compile, ['']) test('mod87', normal, compile_fail, ['']) test('mod88', normal, compile_fail, ['']) -test('mod89', normal, compile_fail, ['']) +test('mod89', normal, compile, ['']) test('mod90', normal, compile_fail, ['']) test('mod91', normal, compile_fail, ['']) test('mod92', normal, compile, ['']) diff --git a/testsuite/tests/module/mod89.hs b/testsuite/tests/module/mod89.hs index 2c48d65a16..1e903a0125 100644 --- a/testsuite/tests/module/mod89.hs +++ b/testsuite/tests/module/mod89.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wall #-} + -- !!! Sublist for non-class/tycon module M where import Prelude(map(..)) diff --git a/testsuite/tests/module/mod89.stderr b/testsuite/tests/module/mod89.stderr index 0f956536cb..b355f3050b 100644 --- a/testsuite/tests/module/mod89.stderr +++ b/testsuite/tests/module/mod89.stderr @@ -1,2 +1,10 @@ - -mod89.hs:3:16: Module ‘Prelude’ does not export ‘map(..)’ +
+mod89.hs:5:1: warning:
+ The import item ‘map(..)’ suggests that
+ ‘map’ has (in-scope) constructors or class methods,
+ but it has none
+
+mod89.hs:5:1: warning:
+ The import of ‘Prelude’ is redundant
+ except perhaps to import instances from ‘Prelude’
+ To import instances alone, use: import Prelude()
diff --git a/testsuite/tests/typecheck/should_fail/T9858a.stderr b/testsuite/tests/typecheck/should_fail/T9858a.stderr index 2f815b1824..61c62eaeec 100644 --- a/testsuite/tests/typecheck/should_fail/T9858a.stderr +++ b/testsuite/tests/typecheck/should_fail/T9858a.stderr @@ -1,14 +1,14 @@ - -T9858a.hs:28:18: error: - No instance for (Typeable - (((() :: Constraint), (() :: Constraint)) => ())) - (maybe you haven't applied a function to enough arguments?) - arising from a use of ‘cast’ - In the expression: cast e - In the expression: case cast e of { Just e' -> ecast e' } - In an equation for ‘supercast’: - supercast - = case cast e of { Just e' -> ecast e' } - where - e = Refl - e :: E PX PX +
+T9858a.hs:28:18: error:
+ No instance for (Typeable
+ ((() :: Constraint, () :: Constraint) => ()))
+ (maybe you haven't applied a function to enough arguments?)
+ arising from a use of ‘cast’
+ In the expression: cast e
+ In the expression: case cast e of { Just e' -> ecast e' }
+ In an equation for ‘supercast’:
+ supercast
+ = case cast e of { Just e' -> ecast e' }
+ where
+ e = Refl
+ e :: E PX PX
diff --git a/testsuite/tests/typecheck/should_fail/fd-loop.stderr b/testsuite/tests/typecheck/should_fail/fd-loop.stderr index 96fbc3ef18..44a0618181 100644 --- a/testsuite/tests/typecheck/should_fail/fd-loop.stderr +++ b/testsuite/tests/typecheck/should_fail/fd-loop.stderr @@ -1,12 +1,12 @@ - -fd-loop.hs:12:10: - Variable ‘b’ occurs more often than in the instance head - in the constraint: C a b - (Use UndecidableInstances to permit this) - In the instance declaration for ‘Eq (T a)’ - -fd-loop.hs:12:10: - Variable ‘b’ occurs more often than in the instance head - in the constraint: Eq b - (Use UndecidableInstances to permit this) - In the instance declaration for ‘Eq (T a)’ +
+fd-loop.hs:12:10: error:
+ Variable ‘b’ occurs more often
+ in the constraint ‘C a b’ than in the instance head
+ (Use UndecidableInstances to permit this)
+ In the instance declaration for ‘Eq (T a)’
+
+fd-loop.hs:12:10: error:
+ Variable ‘b’ occurs more often
+ in the constraint ‘Eq b’ than in the instance head
+ (Use UndecidableInstances to permit this)
+ In the instance declaration for ‘Eq (T a)’
diff --git a/testsuite/tests/typecheck/should_fail/tcfail108.stderr b/testsuite/tests/typecheck/should_fail/tcfail108.stderr index 3a2e5a5657..da766582b3 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail108.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail108.stderr @@ -1,6 +1,6 @@ tcfail108.hs:7:10: error:
- Variable ‘f’ occurs more often than in the instance head
- in the constraint: Eq (f (Rec f))
+ Variable ‘f’ occurs more often
+ in the constraint ‘Eq (f (Rec f))’ than in the instance head
(Use UndecidableInstances to permit this)
In the instance declaration for ‘Eq (Rec f)’
diff --git a/testsuite/tests/typecheck/should_fail/tcfail154.stderr b/testsuite/tests/typecheck/should_fail/tcfail154.stderr index 9014b643df..903f61b7de 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail154.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail154.stderr @@ -1,6 +1,6 @@ - -tcfail154.hs:12:10: - Variable ‘a’ occurs more often than in the instance head - in the constraint: C a a - (Use UndecidableInstances to permit this) - In the instance declaration for ‘Eq (T a)’ +
+tcfail154.hs:12:10: error:
+ Variable ‘a’ occurs more often
+ in the constraint ‘C a a’ than in the instance head
+ (Use UndecidableInstances to permit this)
+ In the instance declaration for ‘Eq (T a)’
diff --git a/testsuite/tests/typecheck/should_fail/tcfail157.stderr b/testsuite/tests/typecheck/should_fail/tcfail157.stderr index acdc7df8cf..113e0cc67e 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail157.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail157.stderr @@ -1,12 +1,12 @@ - -tcfail157.hs:27:10: - Variable ‘b’ occurs more often than in the instance head - in the constraint: E m a b - (Use UndecidableInstances to permit this) - In the instance declaration for ‘Foo m (a -> ())’ - -tcfail157.hs:27:10: - Variable ‘b’ occurs more often than in the instance head - in the constraint: Foo m b - (Use UndecidableInstances to permit this) - In the instance declaration for ‘Foo m (a -> ())’ +
+tcfail157.hs:27:10: error:
+ Variable ‘b’ occurs more often
+ in the constraint ‘E m a b’ than in the instance head
+ (Use UndecidableInstances to permit this)
+ In the instance declaration for ‘Foo m (a -> ())’
+
+tcfail157.hs:27:10: error:
+ Variable ‘b’ occurs more often
+ in the constraint ‘Foo m b’ than in the instance head
+ (Use UndecidableInstances to permit this)
+ In the instance declaration for ‘Foo m (a -> ())’
diff --git a/testsuite/tests/typecheck/should_fail/tcfail213.stderr b/testsuite/tests/typecheck/should_fail/tcfail213.stderr index a6b63bd9f1..a29b758a42 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail213.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail213.stderr @@ -1,7 +1,7 @@ - -tcfail213.hs:8:1: - Illegal constraint ‘F a’ in a superclass/instance context - (Use UndecidableInstances to permit this) - In the context: F a - While checking the super-classes of class ‘C’ - In the class declaration for ‘C’ +
+tcfail213.hs:8:1: error:
+ Illegal constraint ‘F a’ in a superclass context
+ (Use UndecidableInstances to permit this)
+ In the context: F a
+ While checking the super-classes of class ‘C’
+ In the class declaration for ‘C’
diff --git a/testsuite/tests/typecheck/should_fail/tcfail214.stderr b/testsuite/tests/typecheck/should_fail/tcfail214.stderr index 5520a3eff1..a2741b876b 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail214.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail214.stderr @@ -1,7 +1,5 @@ - -tcfail214.hs:9:10: - Illegal constraint ‘F a’ in a superclass/instance context - (Use UndecidableInstances to permit this) - In the context: F a - While checking an instance declaration - In the instance declaration for ‘C [a]’ +
+tcfail214.hs:9:10: error:
+ The constraint ‘F a’ is no smaller than the instance head
+ (Use UndecidableInstances to permit this)
+ In the instance declaration for ‘C [a]’
diff --git a/testsuite/tests/typecheck/should_fail/tcfail220.hsig b/testsuite/tests/typecheck/should_fail/tcfail220.hsig index 129bae368c..560fc317a6 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail220.hsig +++ b/testsuite/tests/typecheck/should_fail/tcfail220.hsig @@ -1,5 +1,4 @@ {-# LANGUAGE NoImplicitPrelude #-} module ShouldFail where -data Bool a b c d = False data Maybe a b = Nothing diff --git a/testsuite/tests/typecheck/should_fail/tcfail220.stderr b/testsuite/tests/typecheck/should_fail/tcfail220.stderr index 6a4e87382d..432dc4c1a3 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail220.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail220.stderr @@ -1,17 +1,9 @@ -[1 of 1] Compiling ShouldFail[sig of Prelude] ( tcfail220.hsig, nothing ) - -tcfail220.hsig:4:1: error: - Type constructor ‘Bool’ has conflicting definitions in the module - and its hsig file - Main module: data Bool = False | True - Hsig file: type role Bool phantom phantom phantom phantom - data Bool a b c d = False - The types have different kinds - -tcfail220.hsig:5:1: error: - Type constructor ‘Maybe’ has conflicting definitions in the module - and its hsig file - Main module: data Maybe a = Nothing | Just a - Hsig file: type role Maybe phantom phantom - data Maybe a b = Nothing - The types have different kinds +[1 of 1] Compiling ShouldFail[sig of Prelude] ( tcfail220.hsig, nothing )
+
+tcfail220.hsig:4:1: error:
+ Type constructor ‘Maybe’ has conflicting definitions in the module
+ and its hsig file
+ Main module: data Maybe a = Nothing | Just a
+ Hsig file: type role Maybe phantom phantom
+ data Maybe a b = Nothing
+ The types have different kinds
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index 803323fbc0..a7bc421270 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -813,7 +813,7 @@ ppType (TyApp (TyCon "TVar#") [x,y]) = "mkTVarPrimTy " ++ ppType x ppType (TyApp (VecTyCon _ pptc) []) = pptc -ppType (TyUTup ts) = "(mkTupleTy UnboxedTuple " +ppType (TyUTup ts) = "(mkTupleTy Unboxed " ++ listify (map ppType ts) ++ ")" ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))" |