diff options
| author | Austin Seipp <austin@well-typed.com> | 2015-05-14 10:55:03 -0500 |
|---|---|---|
| committer | Austin Seipp <austin@well-typed.com> | 2015-05-14 10:55:03 -0500 |
| commit | 3cf8ecdc70cb295a2b9606080a1c7b5fa8eb16f4 (patch) | |
| tree | e7989a081754885163e9dc20a6545820ebeab532 | |
| parent | 04a484eafc9eb9f8774b4bdd41a5dc6c9f640daf (diff) | |
| download | haskell-3cf8ecdc70cb295a2b9606080a1c7b5fa8eb16f4.tar.gz | |
Revert multiple commits
This reverts multiple commits from Simon:
- 04a484eafc9eb9f8774b4bdd41a5dc6c9f640daf Test Trac #10359
- a9ccd37add8315e061c02e5bf26c08f05fad9ac9 Test Trac #10403
- c0aae6f699cbd222d826d0b8d78d6cb3f682079e Test Trac #10248
- eb6ca851f553262efe0824b8dcbe64952de4963d Make the "matchable-given" check happen first
- ca173aa30467a0b1023682d573fcd94244d85c50 Add a case to checkValidTyCon
- 51cbad15f86fca1d1b0e777199eb1079a1b64d74 Update haddock submodule
- 6e1174da5b8e0b296f5bfc8b39904300d04eb5b7 Separate transCloVarSet from fixVarSet
- a8493e03b89f3b3bfcdb6005795de050501f5c29 Fix imports in HscMain (stage2)
- a154944bf07b2e13175519bafebd5a03926bf105 Two wibbles to fix the build
- 5910a1bc8142b4e56a19abea104263d7bb5c5d3f Change in capitalisation of error msg
- 130e93aab220bdf14d08028771f83df210da340b Refactor tuple constraints
- 8da785d59f5989b9a9df06386d5bd13f65435bc0 Delete commented-out line
These break the build by causing Haddock to fail mysteriously when
trying to examine GHC.Prim it seems.
96 files changed, 1770 insertions, 2232 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index 682317b2f3..cf1bf58e9d 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -46,7 +46,7 @@ module BasicTypes( Boxity(..), isBoxed, - TupleSort(..), tupleSortBoxity, boxityTupleSort, + TupleSort(..), tupleSortBoxity, boxityNormalTupleSort, 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,20 +573,19 @@ data TupleSort deriving( Eq, Data, Typeable ) tupleSortBoxity :: TupleSort -> Boxity -tupleSortBoxity BoxedTuple = Boxed -tupleSortBoxity UnboxedTuple = Unboxed +tupleSortBoxity BoxedTuple = Boxed +tupleSortBoxity UnboxedTuple = Unboxed tupleSortBoxity ConstraintTuple = Boxed -boxityTupleSort :: Boxity -> TupleSort -boxityTupleSort Boxed = BoxedTuple -boxityTupleSort Unboxed = UnboxedTuple +boxityNormalTupleSort :: Boxity -> TupleSort +boxityNormalTupleSort Boxed = BoxedTuple +boxityNormalTupleSort Unboxed = UnboxedTuple tupleParens :: TupleSort -> SDoc -> SDoc tupleParens BoxedTuple p = parens p -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 +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 "#)") {- ************************************************************************ diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 79c14726cd..46d79d8f81 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -1015,6 +1015,7 @@ 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 4ebeecaacc..094347a4fa 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs @@ -32,7 +32,7 @@ module RdrName ( nameRdrName, getRdrName, -- ** Destruction - rdrNameOcc, rdrNameSpace, demoteRdrName, + rdrNameOcc, rdrNameSpace, setRdrNameSpace, demoteRdrName, isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, @@ -153,6 +153,32 @@ 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 70600d8d11..ecff80fec8 100644 --- a/compiler/basicTypes/Unique.hs +++ b/compiler/basicTypes/Unique.hs @@ -43,7 +43,6 @@ module Unique ( mkAlphaTyVarUnique, mkPrimOpIdUnique, mkTupleTyConUnique, mkTupleDataConUnique, - mkCTupleTyConUnique, mkPreludeMiscIdUnique, mkPreludeDataConUnique, mkPreludeTyConUnique, mkPreludeClassUnique, mkPArrDataConUnique, @@ -284,25 +283,25 @@ Allocation of unique supply characters: mkAlphaTyVarUnique :: Int -> Unique mkPreludeClassUnique :: Int -> Unique mkPreludeTyConUnique :: Int -> Unique -mkTupleTyConUnique :: Boxity -> Arity -> Unique -mkCTupleTyConUnique :: Arity -> Unique -mkPreludeDataConUnique :: Arity -> Unique -mkTupleDataConUnique :: Boxity -> Arity -> Unique +mkTupleTyConUnique :: TupleSort -> Int -> Unique +mkPreludeDataConUnique :: Int -> Unique +mkTupleDataConUnique :: TupleSort -> Int -> 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 Boxed a = mkUnique '4' (3*a) -mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a) -mkCTupleTyConUnique a = mkUnique 'k' (3*a) +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) -- Data constructor keys occupy *two* slots. The first is used for the -- data constructor itself and its wrapper function (the function that @@ -310,9 +309,10 @@ mkCTupleTyConUnique 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 Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels) -mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a) +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) mkPrimOpIdUnique op = mkUnique '9' op mkPreludeMiscIdUnique i = mkUnique '0' i diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs index 7adc89832a..7b21487d68 100644 --- a/compiler/basicTypes/VarSet.hs +++ b/compiler/basicTypes/VarSet.hs @@ -16,8 +16,8 @@ module VarSet ( unionVarSet, unionVarSets, mapUnionVarSet, intersectVarSet, intersectsVarSet, disjointVarSet, isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, - minusVarSet, foldVarSet, filterVarSet, - transCloVarSet, fixVarSet, + minusVarSet, foldVarSet, filterVarSet, + transCloVarSet, lookupVarSet, mapVarSet, sizeVarSet, seqVarSet, elemVarSetByKey, partitionVarSet ) where @@ -110,28 +110,13 @@ intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2) disjointVarSet s1 s2 = isEmptyVarSet (s1 `intersectVarSet` s2) subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2) -fixVarSet :: (VarSet -> VarSet) -- Map the current set to a new set - -> VarSet -> VarSet --- (fixVarSet f s) repeatedly applies f to the set s, --- until it reaches a fixed point. -fixVarSet fn vars - | new_vars `subVarSet` vars = vars - | otherwise = fixVarSet fn new_vars - where - new_vars = fn vars - transCloVarSet :: (VarSet -> VarSet) -- Map some variables in the set to -- extra variables that should be in it -> VarSet -> VarSet --- (transCloVarSet f s) repeatedly applies f to new candidates, adding any --- new variables to s that it finds thereby, until it reaches a fixed point. --- --- The function fn could be (Var -> VarSet), but we use (VarSet -> VarSet) --- for efficiency, so that the test can be batched up. --- It's essential that fn will work fine if given new candidates --- one at at time; ie fn {v1,v2} = fn v1 `union` fn v2 --- Use fixVarSet if the function needs to see the whole set all at once +-- (transCloVarSet f s) repeatedly applies f to the set s, adding any +-- new variables to s that it finds thereby, until it reaches a fixed +-- point. The actual algorithm is a bit more efficient. transCloVarSet fn seeds = go seeds seeds where @@ -139,7 +124,7 @@ transCloVarSet fn seeds -> VarSet -- Work-list; un-processed subset of accumulating result -> VarSet -- Specification: go acc vs = acc `union` transClo fn vs - + go acc candidates | isEmptyVarSet new_vs = acc | otherwise = go (acc `unionVarSet` new_vs) new_vs diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 13285a5b3c..ec0bb5e225 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -1570,7 +1570,7 @@ lookupIdInScope id oneTupleDataConId :: Id -- Should not happen -oneTupleDataConId = dataConWorkId (tupleDataCon Boxed 1) +oneTupleDataConId = dataConWorkId (tupleCon BoxedTuple 1) checkBndrIdInScope :: Var -> Var -> LintM () checkBndrIdInScope binder id diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs index 3b76aef36d..6905641f56 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 (tupleDataCon Boxed (length cs)) +mkCoreTup cs = mkConApp (tupleCon BoxedTuple (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 (tupleDataCon Boxed (length vars)), vars, Var the_var)] + [(DataAlt (tupleCon BoxedTuple (length vars)), vars, Var the_var)] -- | A generalization of 'mkTupleSelector', allowing the body -- of the case to be an arbitrary expression. @@ -537,8 +537,7 @@ 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 (tupleDataCon Boxed (length vars)), vars, body)] + = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon BoxedTuple (length vars)), vars, body)] {- ************************************************************************ diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs index ecea85021c..24abf1828a 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 = pprWithCommas pprCoreExpr val_args + pp_tup_args = sep (punctuate comma (map 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 (pprWithCommas ppr_bndr args) + = tupleParens sort (hsep (punctuate comma (map ppr_bndr args))) where ppr_bndr = pprBndr CaseBind tc = dataConTyCon dc diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index af72f74312..3d855d4407 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 (tupleDataCon boxity arity) + = unLoc $ mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) (map tidy_lpat ps) tys where arity = length ps diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 44795b9dfa..55cd7d2ac3 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 (tupleDataCon Boxed 2), [var1, var2], body)] + [(DataAlt (tupleCon BoxedTuple 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 f67ffacdc4..8e56fb5f7d 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -40,18 +40,19 @@ import Digraph import PrelNames import TysPrim ( mkProxyPrimTy ) -import TyCon +import TyCon ( isTupleTyCon, tyConDataCons_maybe + , tyConName, isPromotedTyCon, isPromotedDataCon, tyConKind ) import TcEvidence import TcType import Type import Kind (returnsConstraintKind) import Coercion hiding (substCo) -import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy +import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon, mkListTy , mkBoxedTupleTy, stringTy ) import Id import MkId(proxyHashId) import Class -import DataCon ( dataConTyCon ) +import DataCon ( dataConTyCon, dataConWorkId ) import Name import MkId ( seqId ) import IdInfo ( IdDetails(..) ) @@ -69,6 +70,7 @@ import BasicTypes hiding ( TopLevel ) import DynFlags import FastString import ErrUtils( MsgDoc ) +import ListSetOps( getNth ) import Util import Control.Monad( when ) import MonadUtils @@ -851,6 +853,23 @@ 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 90121a0f5f..5c5fde0b14 100644 --- a/compiler/deSugar/DsCCall.hs +++ b/compiler/deSugar/DsCCall.hs @@ -226,7 +226,7 @@ boxResult result_ty _ -> [] return_result state anss - = mkCoreConApps (tupleDataCon Unboxed (2 + length extra_result_tys)) + = mkCoreConApps (tupleCon UnboxedTuple (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 Unboxed arity) + ccall_res_ty = mkTyConApp (tupleTyCon UnboxedTuple arity) (realWorldStatePrimTy : ls) - the_alt = ( DataAlt (tupleDataCon Unboxed arity) + the_alt = ( DataAlt (tupleCon UnboxedTuple arity) , (state_id : args_ids) , the_rhs ) diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 37c927dddd..78a6d11632 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -23,6 +23,7 @@ import DsMonad import Name import NameEnv import FamInstEnv( topNormaliseType ) + import DsMeta import HsSyn @@ -292,7 +293,7 @@ dsExpr (ExplicitTuple tup_args boxity) -- The reverse is because foldM goes left-to-right ; return $ mkCoreLams lam_vars $ - mkCoreConApps (tupleDataCon boxity (length tup_args)) + mkCoreConApps (tupleCon (boxityNormalTupleSort boxity) (length tup_args)) (map (Type . exprType) args ++ args) } dsExpr (HsSCC _ cc expr@(L loc _)) = do @@ -427,7 +428,7 @@ dsExpr (HsStatic expr@(L loc _)) = do , srcLocCol $ realSrcSpanStart r ) _ -> (0, 0) - srcLoc = mkCoreConApps (tupleDataCon Boxed 2) + srcLoc = mkCoreConApps (tupleCon BoxedTuple 2) [ Type intTy , Type intTy , mkIntExprInt dflags line, mkIntExprInt dflags col ] diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 34ef0e808e..9eb37a9c1e 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -15,7 +15,15 @@ -- a Royal Pain (triggers other recompilation). ----------------------------------------------------------------------------- -module DsMeta( dsBracket ) where +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 #include "HsVersions.h" @@ -33,12 +41,11 @@ 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 ) +import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName, dataName ) import Module import Id import Name hiding( isVarOcc, isTcOcc, varName, tcName ) -import THNames import NameEnv import TcType import TyCon @@ -2088,3 +2095,830 @@ 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 5840578942..c8e30f18a7 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 ( isGenerated ) +import BasicTypes ( boxityNormalTupleSort, 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 (tupleDataCon boxity arity) pats tys + tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort 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 4934d18c5a..09c252b3df 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -164,6 +164,7 @@ Library IdInfo Lexeme Literal + DsMeta Llvm Llvm.AbsSyn Llvm.MetaData @@ -421,8 +422,6 @@ Library TcSplice Class Coercion - DsMeta - THNames FamInstEnv FunDeps InstEnv diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index b95d05322f..56efbb8fad 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 ( Boxity(..) ) +import BasicTypes ( TupleSort(UnboxedTuple) ) import TysPrim import PrelNames import TysWiredIn @@ -832,9 +832,8 @@ 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 (tupleDataCon Unboxed (length terms))) - (error "unboxedTupleTerm: no HValue for unboxed tuple") terms + unboxedTupleTerm ty terms = Term ty (Right (tupleCon UnboxedTuple (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 20cb234dbd..031a340a0b 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 Boxed n))) tys' + -> mk_apps (HsTyVar (getRdrName (tupleTyCon BoxedTuple 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 Unboxed n))) tys' + -> mk_apps (HsTyVar (getRdrName (tupleTyCon UnboxedTuple 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 e9171a4f66..efefd17e4a 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -636,7 +636,8 @@ ppr_expr (SectionR op expr) pp_infixly v = sep [pprInfixOcc v, pp_expr] ppr_expr (ExplicitTuple exprs boxity) - = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) + = tupleParens (boxityNormalTupleSort 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 5d74edf2e0..6cde90854d 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -302,24 +302,17 @@ 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 (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 (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 (ListPat pats _ _) = brackets (interpp'SP pats) -pprPat (PArrPat pats _) = paBrackets (interpp'SP pats) -pprPat (TuplePat pats bx _) = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) +pprPat (PArrPat pats _) = paBrackets (interpp'SP pats) +pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP 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 }) @@ -332,6 +325,14 @@ 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 caa83013e0..ebd3bd4847 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 (pprWithCommas ppr tys) +ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys) where std_con = case con of HsUnboxedTuple -> UnboxedTuple _ -> BoxedTuple diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 9d3ef75bec..e99ad4d547 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 ( knownKeyNames ) +import PrelInfo (wiredInThings, basicKnownKeyNames) import Id (idName, isDataConWorkId_maybe) import TysWiredIn import IfaceEnv @@ -303,11 +303,14 @@ 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 @@ -346,7 +349,7 @@ putTupleName_ bh tc tup_sort thing_tag sort_tag = case tup_sort of BoxedTuple -> 0 UnboxedTuple -> 1 - ConstraintTuple -> pprPanic "putTupleName:ConstraintTuple" (ppr tc) + ConstraintTuple -> 2 -- See Note [Symbol table representation of names] getSymtabName :: NameCacheUpdater @@ -367,10 +370,11 @@ getSymtabName _ncu _dict symtab bh = do 2 -> idName (dataConWorkId dc) _ -> pprPanic "getSymtabName:unknown tuple thing" (ppr i) where - dc = tupleDataCon sort arity + dc = tupleCon sort arity sort = case (i .&. 0x30000000) `shiftR` 28 of - 0 -> Boxed - 1 -> Unboxed + 0 -> BoxedTuple + 1 -> UnboxedTuple + 2 -> ConstraintTuple _ -> 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 b6db5dc9ee..6e14700cfa 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -21,7 +21,6 @@ module BuildTyCl ( import IfaceEnv import FamInstEnv( FamInstEnvs ) -import TysWiredIn( isCTupleTyConName ) import DataCon import PatSyn import Var @@ -283,9 +282,6 @@ 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 c5aa1a521b..0838cb8468 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 (pprWithCommas ppr as) +pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (interpp'SP as) pprIfaceExpr add_par i@(IfaceLam _ _) = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow, @@ -1136,10 +1136,11 @@ 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 (IfaceTupleTy _ _ ts) = freeNamesIfTcArgs ts +freeNamesIfType (IfaceTyConApp tc ts) = + freeNamesIfTc tc &&& 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 6dfff6e4e5..dc3c5c5039 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -10,8 +10,7 @@ This module defines interface types and binders module IfaceType ( IfExtName, IfLclName, - IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), - IfaceTyCon(..), IfaceTyConInfo(..), + IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoercion(..), IfaceTyLit(..), IfaceTcArgs(..), IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, IfaceTvBndr, IfaceIdBndr, @@ -45,12 +44,12 @@ module IfaceType ( #include "HsVersions.h" import Coercion -import DataCon ( isTupleDataCon ) +import DataCon ( dataConTyCon ) import TcType import DynFlags import TypeRep import Unique( hasKey ) -import Util ( filterOut, zipWithEqual ) +import Util ( filterOut, lengthIs, zipWithEqual ) import TyCon hiding ( pprPromotionQuote ) import CoAxiom import Id @@ -100,19 +99,13 @@ 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 - - | 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 + -- Includes newtypes, synonyms, tuples + | IfaceLitTy IfaceTyLit type IfacePredType = IfaceType type IfaceContext = [IfacePredType] @@ -135,14 +128,10 @@ data IfaceTcArgs -- coercion constructors, the lot. -- We have to tag them in order to pretty print them -- properly. -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 IfaceTyCon + = IfaceTc { ifaceTyConName :: IfExtName } + | IfacePromotedDataCon { ifaceTyConName :: IfExtName } + | IfacePromotedTyCon { ifaceTyConName :: IfExtName } data IfaceCoercion = IfaceReflCo Role IfaceType @@ -218,9 +207,8 @@ ifTyVarsOfType ty IfaceForAllTy (var,t) ty -> delOneFromUniqSet (ifTyVarsOfType ty) var `unionUniqSets` ifTyVarsOfType t - IfaceTyConApp _ args -> ifTyVarsOfArgs args - IfaceTupleTy _ _ args -> ifTyVarsOfArgs args - IfaceLitTy _ -> emptyUniqSet + IfaceTyConApp _ args -> ifTyVarsOfArgs args + IfaceLitTy _ -> emptyUniqSet ifTyVarsOfArgs :: IfaceTcArgs -> UniqSet IfLclName ifTyVarsOfArgs args = argv emptyUniqSet args @@ -250,7 +238,6 @@ 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 @@ -317,6 +304,18 @@ we want ************************************************************************ * * + Functions over IFaceTyCon +* * +************************************************************************ +-} + +--isPromotedIfaceTyCon :: IfaceTyCon -> Bool +--isPromotedIfaceTyCon (IfacePromotedTyCon _) = True +--isPromotedIfaceTyCon _ = False + +{- +************************************************************************ +* * Pretty-printing * * ************************************************************************ @@ -396,7 +395,6 @@ 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) @@ -523,6 +521,10 @@ 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) @@ -538,10 +540,22 @@ ppr_iface_tc_app pp ctxt_prec tc tys where tc_name = ifaceTyConName tc -pprTuple :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> SDoc -pprTuple sort info args - = pprPromotionQuoteI info <> - tupleParens sort (pprWithCommas pprIfaceType (tcArgsIfaceTypes args)) + 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 + ppr_tylit :: IfaceTyLit -> SDoc ppr_tylit (IfaceNumTyLit n) = integer n @@ -621,34 +635,27 @@ instance Outputable IfaceTyCon where ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) pprPromotionQuote :: IfaceTyCon -> SDoc -pprPromotionQuote tc = pprPromotionQuoteI (ifaceTyConInfo tc) - -pprPromotionQuoteI :: IfaceTyConInfo -> SDoc -pprPromotionQuoteI NoIfaceTyConInfo = empty -pprPromotionQuoteI IfacePromotedDataCon = char '\'' -pprPromotionQuoteI IfacePromotedTyCon = ifPprDebug (char '\'') +pprPromotionQuote (IfacePromotedDataCon _ ) = char '\'' +pprPromotionQuote (IfacePromotedTyCon _) = ifPprDebug (char '\'') +pprPromotionQuote _ = empty instance Outputable IfaceCoercion where ppr = pprIfaceCoercion instance Binary IfaceTyCon where - 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 + 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 get bh = - do i <- getByte bh - case i of - 0 -> return NoIfaceTyConInfo - 1 -> return IfacePromotedDataCon - _ -> return IfacePromotedTyCon + 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) instance Outputable IfaceTyLit where ppr = ppr_tylit @@ -722,10 +729,9 @@ 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 7; put_ bh n } + = do { putByte bh 30; put_ bh n } get bh = do h <- getByte bh @@ -746,8 +752,6 @@ 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) @@ -900,32 +904,12 @@ 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) -- 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 +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) toIfaceTyVar :: TyVar -> FastString toIfaceTyVar = occNameFS . getOccName @@ -936,17 +920,13 @@ toIfaceCoVar = occNameFS . getOccName ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTyCon tc - = IfaceTyCon tc_name info - where - tc_name = tyConName tc - info | isPromotedDataCon tc = IfacePromotedDataCon - | isPromotedTyCon tc = IfacePromotedTyCon - | otherwise = NoIfaceTyConInfo + | isPromotedDataCon tc = IfacePromotedDataCon tc_name + | isPromotedTyCon tc = IfacePromotedTyCon tc_name + | otherwise = IfaceTc tc_name + where tc_name = tyConName tc toIfaceTyCon_name :: Name -> IfaceTyCon -toIfaceTyCon_name n = IfaceTyCon n NoIfaceTyConInfo - -- Used for the "rough-match" tycon stuff, - -- where pretty-printing is not an issue +toIfaceTyCon_name = IfaceTc toIfaceTyLit :: TyLit -> IfaceTyLit toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 2553643525..1beae57cc7 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, Arity, TupleSort(..), Boxity(..) ) +import BasicTypes ( strongLoopBreaker ) 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.roughTopNames does + -- This function *must* mirror exactly what Rules.topFreeName 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,7 +652,6 @@ 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 @@ -806,7 +805,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo -- name is not a tycon => internal inconsistency Just _ -> notATyConErr -- tycon is external - Nothing -> tcIfaceTyConByName name + Nothing -> tcIfaceTyCon (IfaceTc name) } notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name) @@ -825,7 +824,6 @@ 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') } @@ -844,34 +842,6 @@ 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 @@ -972,15 +942,15 @@ tcIfaceExpr (IfaceFCall cc ty) = do dflags <- getDynFlags return (Var (mkFCallId dflags u cc ty')) -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) } +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) where arity = length args + con_id = dataConWorkId (tupleCon boxity arity) + tcIfaceExpr (IfaceLam (bndr, os) body) = bindIfaceBndr bndr $ \bndr' -> @@ -1089,7 +1059,7 @@ tcIfaceLit :: Literal -> IfL Literal -- so tcIfaceLit just fills in the type. -- See Note [Integer literals] in Literal tcIfaceLit (LitInteger i _) - = do t <- tcIfaceTyConByName integerTyConName + = do t <- tcIfaceTyCon (IfaceTc integerTyConName) return (mkLitInteger i (mkTyConTy t)) tcIfaceLit lit = return lit @@ -1267,7 +1237,6 @@ 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] @@ -1310,25 +1279,20 @@ 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 (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) +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) + } tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name diff --git a/compiler/main/Constants.hs b/compiler/main/Constants.hs index 22bd4e6e02..0f23fc242e 100644 --- a/compiler/main/Constants.hs +++ b/compiler/main/Constants.hs @@ -17,9 +17,6 @@ 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 5ae104b1da..0acbdff8a5 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -90,7 +90,9 @@ import BasicTypes ( HValue ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker import CoreTidy ( tidyExpr ) -import Type ( Type, Kind ) +import Type ( Type ) +import PrelNames +import {- Kind parts of -} Type ( Kind ) import CoreLint ( lintInteractiveExpr ) import VarEnv ( emptyTidyEnv ) import Panic @@ -99,6 +101,7 @@ import ConLike import GHC.Exts #endif +import DsMeta ( templateHaskellNames ) import Module import Packages import RdrName @@ -189,6 +192,12 @@ 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/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index e2876a43d3..914a1459df 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -43,6 +43,7 @@ import CmdLineParser import FastString import SrcLoc import Util +-- import Maybes ( firstJusts ) import Panic import Control.Monad diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 7ffa6b6a05..eb2aa0c276 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, tupleDataCon, nilDataCon, +import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, unboxedUnitTyCon, unboxedUnitDataCon, listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) @@ -728,9 +728,10 @@ qcname_ext :: { Located RdrName } -- Variable or data constructor | 'type' qcname {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2))) [mj AnnType $1,mj AnnVal $2] } -qcname :: { Located RdrName } -- Variable or type constructor +-- Cannot pull into qcname_ext, as qcname is also used in expression. +qcname :: { Located RdrName } -- Variable or data constructor : qvar { $1 } - | oqtycon { $1 } + | qcon { $1 } ----------------------------------------------------------------------------- -- Import Declarations @@ -2276,9 +2277,8 @@ aexp1 :: { LHsExpr RdrName } | aexp2 { $1 } aexp2 :: { LHsExpr RdrName } - : qvar { sL1 $1 (HsVar $! unLoc $1) } - | qcon { sL1 $1 (HsVar $! unLoc $1) } - | ipvar { sL1 $1 (HsIPVar $! unLoc $1) } + : ipvar { sL1 $1 (HsIPVar $! unLoc $1) } + | qcname { sL1 $1 (HsVar $! 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 $> $ tupleDataCon Boxed (snd $2 + 1)) + | '(' commas ')' {% ams (sLL $1 $> $ tupleCon BoxedTuple (snd $2 + 1)) (mop $1:mcp $3:(mcommas (fst $2))) } | '(#' '#)' {% ams (sLL $1 $> $ unboxedUnitDataCon) [mo $1,mc $2] } - | '(#' commas '#)' {% ams (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1)) + | '(#' commas '#)' {% ams (sLL $1 $> $ tupleCon UnboxedTuple (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 Boxed + | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon BoxedTuple (snd $2 + 1))) (mop $1:mcp $3:(mcommas (fst $2))) } - | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Unboxed + | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon UnboxedTuple (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 39589fe72c..f0dc1ea433 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -21,7 +21,6 @@ module RdrHsSyn ( mkPatSynMatchGroup, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp mkTyClD, mkInstD, - setRdrNameSpace, cvBindGroup, cvBindsAndSigs, @@ -66,24 +65,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 -import Name -import BasicTypes +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 TcEvidence ( idHsWrapper ) import Lexer -import Type ( TyThing(..) ) -import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon, - nilDataConName, nilDataConKey, - listTyConName, listTyConKey ) +import TysWiredIn ( unitTyCon, unitDataCon ) 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 @@ -138,7 +137,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 True tycl_hdr + ; (cls, tparams,ann) <- checkTyClHdr 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 @@ -272,7 +271,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 False tycl_hdr + = do { (tc, tparams,ann) <- checkTyClHdr 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 @@ -307,7 +306,7 @@ mkTySynonym :: SrcSpan -> LHsType RdrName -- RHS -> P (LTyClDecl RdrName) mkTySynonym loc lhs rhs - = do { (tc, tparams,ann) <- checkTyClHdr False lhs + = do { (tc, tparams,ann) <- checkTyClHdr 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) <> @@ -320,7 +319,7 @@ mkTyFamInstEqn :: LHsType RdrName -> LHsType RdrName -> P (TyFamInstEqn RdrName,[AddAnn]) mkTyFamInstEqn lhs rhs - = do { (tc, tparams,ann) <- checkTyClHdr False lhs + = do { (tc, tparams,ann) <- checkTyClHdr lhs ; let err xhs = hang (text "In type family instance equation of" <+> quotes (ppr tc) <> colon) 2 (ppr xhs) @@ -340,7 +339,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 False tycl_hdr + = do { (tc, tparams,ann) <- checkTyClHdr 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 ( @@ -360,7 +359,7 @@ mkFamDecl :: SrcSpan -> Maybe (LHsKind RdrName) -- Optional kind signature -> P (LTyClDecl RdrName) mkFamDecl loc info lhs ksig - = do { (tc, tparams,ann) <- checkTyClHdr False lhs + = do { (tc, tparams,ann) <- checkTyClHdr 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 @@ -546,9 +545,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 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) + 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) mk_rest [L l (HsRecTy flds)] = RecCon (L l flds) mk_rest ts = PrefixCon ts @@ -663,91 +662,6 @@ 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 @@ -824,9 +738,7 @@ checkRecordSyntax lr@(L loc r) (text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r) -checkTyClHdr :: Bool -- True <=> class header - -- False <=> type header - -> LHsType RdrName +checkTyClHdr :: 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 @@ -834,28 +746,22 @@ checkTyClHdr :: Bool -- True <=> class header -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) -- Int :*: Bool into (:*:, [Int, Bool]) -- returning the pieces -checkTyClHdr is_cls ty +checkTyClHdr 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 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) + 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) checkContext :: LHsType RdrName -> P (LHsContext RdrName) checkContext (L l orig_t) @@ -1575,12 +1481,14 @@ mkModuleImpExp n@(L l name) subs = case subs of ImpExpAbs | isVarNameSpace (rdrNameSpace name) -> IEVar n - | otherwise -> IEThingAbs (L l name) - ImpExpAll -> IEThingAll (L l name) - ImpExpList xs -> IEThingWith (L l name) xs + | otherwise -> IEThingAbs (L l nameT) + ImpExpAll -> IEThingAll (L l nameT) + ImpExpList xs -> IEThingWith (L l nameT) xs + + where + nameT = setRdrNameSpace name tcClsName -mkTypeImpExp :: Located RdrName -- TcCls or Var name space - -> P (Located RdrName) +mkTypeImpExp :: Located RdrName -> P (Located RdrName) mkTypeImpExp name = do allowed <- extension explicitNamespacesEnabled if allowed diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs index 4d1cd9af95..2303a8edd3 100644 --- a/compiler/prelude/PrelInfo.hs +++ b/compiler/prelude/PrelInfo.hs @@ -10,7 +10,7 @@ module PrelInfo ( primOpRules, builtinRules, ghcPrimExports, - wiredInThings, knownKeyNames, + wiredInThings, basicKnownKeyNames, primOpId, -- Random other things @@ -30,7 +30,6 @@ import PrimOp import DataCon import Id import MkId -import Name( Name, getName ) import TysPrim import TysWiredIn import HscTypes @@ -39,31 +38,12 @@ 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 - -{- ********************************************************************* +{- +************************************************************************ * * - Wired in things +\subsection[builtinNameInfo]{Lookup built-in names} * * ************************************************************************ diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index ded9583c62..113dfdc507 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -121,6 +121,7 @@ import Module import OccName import RdrName import Unique +import BasicTypes import Name import SrcLoc import FastString @@ -519,6 +520,19 @@ 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 * * ************************************************************************ @@ -1558,6 +1572,9 @@ 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 1ab8543afc..5c6b70072b 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 (tupleDataCon Unboxed 2) + return $ mkConApp (tupleCon UnboxedTuple 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 (tupleDataCon Unboxed 2) + = Just $ mkConApp (tupleCon UnboxedTuple 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 (tupleDataCon Unboxed 2) + Just $ mkConApp (tupleCon UnboxedTuple 2) [Type integerTy, Type intHashTy, Lit (LitInteger y integerTy), diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs index dbeade27bc..de6d49b96a 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(..), Boxity(..) ) +import BasicTypes ( Arity, Fixity(..), FixityDirection(..), TupleSort(..) ) import ForeignCall ( CLabelString ) import Unique ( Unique, mkPrimOpIdUnique ) import Outputable diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs deleted file mode 100644 index 5ccfaeb3e8..0000000000 --- a/compiler/prelude/THNames.hs +++ /dev/null @@ -1,836 +0,0 @@ --- %************************************************************************ --- %* * --- 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 34c1838997..6c2ffb7417 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -43,22 +43,21 @@ module TysWiredIn ( wordTyCon, wordDataCon, wordTyConName, wordTy, -- * List - listTyCon, listTyCon_RDR, listTyConName, listTyConKey, - nilDataCon, nilDataConName, nilDataConKey, - consDataCon_RDR, consDataCon, consDataConName, - + listTyCon, nilDataCon, nilDataConName, consDataCon, consDataConName, + listTyCon_RDR, consDataCon_RDR, listTyConName, mkListTy, mkPromotedListTy, -- * Tuples mkTupleTy, mkBoxedTupleTy, - tupleTyCon, tupleDataCon, tupleTyConName, + tupleTyCon, tupleCon, promotedTupleTyCon, promotedTupleDataCon, - unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, - pairTyCon, + unitTyCon, unitDataCon, unitDataConId, pairTyCon, unboxedUnitTyCon, unboxedUnitDataCon, unboxedSingletonTyCon, unboxedSingletonDataCon, unboxedPairTyCon, unboxedPairDataCon, - cTupleTyConName, cTupleTyConNames, isCTupleTyConName, + + -- * Unit + unitTy, -- * Kinds typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind, @@ -85,7 +84,7 @@ import PrelNames import TysPrim -- others: -import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) +import Constants ( mAX_TUPLE_SIZE ) import Module ( Module ) import Type ( mkTyConApp ) import DataCon @@ -96,14 +95,11 @@ import Class ( Class, mkClass ) import TypeRep import RdrName import Name -import NameSet ( NameSet, mkNameSet, elemNameSet ) -import BasicTypes ( Arity, RecFlag(..), Boxity(..), - TupleSort(..) ) +import BasicTypes ( TupleSort(..), tupleSortBoxity, + Arity, RecFlag(..), Boxity(..) ) import ForeignCall -import Unique ( incrUnique, - mkTupleTyConUnique, mkTupleDataConUnique, - mkCTupleTyConUnique, mkPArrDataConUnique ) -import SrcLoc ( noSrcSpan ) +import Unique ( incrUnique, mkTupleTyConUnique, + mkTupleDataConUnique, mkPArrDataConUnique ) import Data.Array import FastString import Outputable @@ -323,39 +319,14 @@ 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, 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 + 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. * When looking up an OccName in the original-name cache (IfaceEnv.lookupOrigNameCache), we spot the tuple OccName to make sure @@ -369,164 +340,140 @@ isBuiltInOcc_maybe :: OccName -> Maybe Name -- map to wired-in Names with BuiltInSyntax isBuiltInOcc_maybe occ = case occNameString occ of - "[]" -> choose_ns listTyConName nilDataConName + "[]" -> choose_ns listTyCon nilDataCon ":" -> Just consDataConName "[::]" -> Just parrTyConName - "()" -> tup_name Boxed 0 - "(##)" -> tup_name Unboxed 0 - '(':',':rest -> parse_tuple Boxed 2 rest - '(':'#':',':rest -> parse_tuple Unboxed 2 rest + "(##)" -> choose_ns unboxedUnitTyCon unboxedUnitDataCon + "()" -> choose_ns unitTyCon unitDataCon + '(':'#':',':rest -> parse_tuple UnboxedTuple 2 rest + '(':',':rest -> parse_tuple BoxedTuple 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 = tup_name sort n + | tail_matches sort rest = choose_ns (tupleTyCon sort n) + (tupleCon sort n) | otherwise = Nothing - 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)) + tail_matches BoxedTuple ")" = True + tail_matches UnboxedTuple "#)" = True + tail_matches _ _ = False choose_ns tc dc - | isTcClsNameSpace ns = Just tc - | isDataConNameSpace ns = Just dc - | otherwise = pprPanic "tup_name" (ppr occ) + | isTcClsNameSpace ns = Just (getName tc) + | isDataConNameSpace ns = Just (getName dc) + | otherwise = Just (getName (dataConWorkId dc)) -mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName +mkTupleOcc :: NameSpace -> TupleSort -> 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 - Unboxed -> '(' : '#' : commas ++ "#)" - Boxed -> '(' : commas ++ ")" - - commas = take (ar-1) (repeat ',') + UnboxedTuple -> '(' : '#' : commas ++ "#)" + BoxedTuple -> '(' : commas ++ ")" + ConstraintTuple -> '(' : commas ++ ")" -mkCTupleOcc :: NameSpace -> Arity -> OccName -mkCTupleOcc ns ar = mkOccName ns str - where - str = "(%" ++ commas ++ "%)" commas = take (ar-1) (repeat ',') -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 + -- 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 tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially -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) +tupleTyCon BoxedTuple i = fst (boxedTupleArr ! i) +tupleTyCon UnboxedTuple i = fst (unboxedTupleArr ! i) +tupleTyCon ConstraintTuple i = fst (factTupleArr ! i) -promotedTupleTyCon :: Boxity -> Arity -> TyCon -promotedTupleTyCon boxity i = promoteTyCon (tupleTyCon boxity i) +promotedTupleTyCon :: TupleSort -> Arity -> TyCon +promotedTupleTyCon sort i = promoteTyCon (tupleTyCon sort i) -promotedTupleDataCon :: Boxity -> Arity -> TyCon -promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i) +promotedTupleDataCon :: TupleSort -> Arity -> TyCon +promotedTupleDataCon sort i = promoteDataCon (tupleCon sort 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) +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) -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]] +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]] -mk_tuple :: Boxity -> Int -> (TyCon,DataCon) -mk_tuple boxity arity = (tycon, tuple_con) +mk_tuple :: TupleSort -> Int -> (TyCon,DataCon) +mk_tuple sort arity = (tycon, tuple_con) where - 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 + 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 (ATyCon tycon) BuiltInSyntax tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind + res_kind = case sort of + BoxedTuple -> liftedTypeKind + UnboxedTuple -> unliftedTypeKind + ConstraintTuple -> constraintKind - res_kind = case boxity of - Boxed -> liftedTypeKind - Unboxed -> unliftedTypeKind - - tyvars = take arity $ case boxity of - Boxed -> alphaTyVars - Unboxed -> openAlphaTyVars + tyvars = take arity $ case sort of + BoxedTuple -> alphaTyVars + UnboxedTuple -> openAlphaTyVars + ConstraintTuple -> tyVarList constraintKind tuple_con = pcDataCon dc_name tyvars tyvar_tys tycon tyvar_tys = mkTyVarTys tyvars - dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq + dc_name = mkWiredInName modu (mkTupleOcc dataName sort arity) dc_uniq (AConLike (RealDataCon tuple_con)) BuiltInSyntax - tc_uniq = mkTupleTyConUnique boxity arity - dc_uniq = mkTupleDataConUnique boxity arity + tc_uniq = mkTupleTyConUnique sort arity + dc_uniq = mkTupleDataConUnique sort arity unitTyCon :: TyCon -unitTyCon = tupleTyCon Boxed 0 - -unitTyConKey :: Unique -unitTyConKey = getUnique unitTyCon - +unitTyCon = tupleTyCon BoxedTuple 0 unitDataCon :: DataCon unitDataCon = head (tyConDataCons unitTyCon) - unitDataConId :: Id unitDataConId = dataConWorkId unitDataCon pairTyCon :: TyCon -pairTyCon = tupleTyCon Boxed 2 +pairTyCon = tupleTyCon BoxedTuple 2 unboxedUnitTyCon :: TyCon -unboxedUnitTyCon = tupleTyCon Unboxed 0 - +unboxedUnitTyCon = tupleTyCon UnboxedTuple 0 unboxedUnitDataCon :: DataCon -unboxedUnitDataCon = tupleDataCon Unboxed 0 +unboxedUnitDataCon = tupleCon UnboxedTuple 0 unboxedSingletonTyCon :: TyCon -unboxedSingletonTyCon = tupleTyCon Unboxed 1 - +unboxedSingletonTyCon = tupleTyCon UnboxedTuple 1 unboxedSingletonDataCon :: DataCon -unboxedSingletonDataCon = tupleDataCon Unboxed 1 +unboxedSingletonDataCon = tupleCon UnboxedTuple 1 unboxedPairTyCon :: TyCon -unboxedPairTyCon = tupleTyCon Unboxed 2 - +unboxedPairTyCon = tupleTyCon UnboxedTuple 2 unboxedPairDataCon :: DataCon -unboxedPairDataCon = tupleDataCon Unboxed 2 +unboxedPairDataCon = tupleCon UnboxedTuple 2 {- ************************************************************************ @@ -807,17 +754,17 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}. \end{itemize} -} -mkTupleTy :: Boxity -> [Type] -> Type +mkTupleTy :: TupleSort -> [Type] -> Type -- Special case for *boxed* 1-tuples, which are represented by the type itself -mkTupleTy Boxed [ty] = ty -mkTupleTy boxity tys = mkTyConApp (tupleTyCon boxity (length tys)) tys +mkTupleTy sort [ty] | Boxed <- tupleSortBoxity sort = ty +mkTupleTy sort tys = mkTyConApp (tupleTyCon sort (length tys)) tys -- | Build the type of a small tuple that holds the specified type of thing mkBoxedTupleTy :: [Type] -> Type -mkBoxedTupleTy tys = mkTupleTy Boxed tys +mkBoxedTupleTy tys = mkTupleTy BoxedTuple tys unitTy :: Type -unitTy = mkTupleTy Boxed [] +unitTy = mkTupleTy BoxedTuple [] {- ************************************************************************ diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 28da6cb413..0794412051 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -53,7 +53,6 @@ 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 00381b3567..036d6520fb 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -32,7 +32,6 @@ import NameSet import Avail import HscTypes import RdrName -import RdrHsSyn ( setRdrNameSpace ) import Outputable import Maybes import SrcLoc @@ -653,14 +652,10 @@ 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. -} @@ -768,30 +763,19 @@ 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, 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]))] + (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 = [] case mb_parent of - Nothing -> return ([(renamed_ie, avail)], warns) - -- non-associated ty/cls - Just parent -> return ((renamed_ie, AvailTC parent [name]) : sub_avails, warns) - -- associated type + -- 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) IEThingAbs (L l tc) | want_hiding -- hiding ( C ) diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index 737dcc9584..5d12720e2c 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 THNames ( liftName ) +import DsMeta ( liftName ) #ifdef GHCI import ErrUtils ( dumpIfSet_dyn_printer ) +import DsMeta ( decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) import TcEnv ( tcMetaTy ) import Hooks import Var ( Id ) -import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeName - , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) +import DsMeta ( quoteExpName, quotePatName, quoteDecName, quoteTypeName ) import Util import {-# SOURCE #-} TcExpr ( tcMonoExpr ) diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs index f3d592f49c..0fc6ccf226 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 (tupleDataCon Unboxed 0) +ubxTupleId0 = dataConWorkId (tupleCon UnboxedTuple 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 (tupleDataCon Unboxed (length tys)) + StgConApp (tupleCon UnboxedTuple (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 (tupleDataCon Unboxed (length args')) args' + | isUnboxedTupleCon dc = StgConApp (tupleCon UnboxedTuple (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 (tupleDataCon Unboxed n), ys, uses, unariseExpr us2' rho' e)]) + = (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple 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 (tupleDataCon Unboxed n), ys', uses', unariseExpr us2' rho'' e)]) + = (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple 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 61633f9834..de1bf08a31 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -1725,7 +1725,8 @@ mkCallUDs' env f args type_determines_value pred -- See Note [Type determines value] = case classifyPredType pred of - ClassPred cls _ -> not (isIPClass cls) -- Superclasses can't be IPs + ClassPred cls _ -> not (isIPClass cls) + TuplePred ps -> all type_determines_value ps 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 304a3cbacb..8c96afadd6 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 ( tupleDataCon ) +import TysWiredIn ( tupleCon ) import Type import Coercion hiding ( substTy, substTyVarBndr ) import FamInstEnv -import BasicTypes ( Boxity(..), OneShotInfo(..), worstOneShot ) +import BasicTypes ( TupleSort(..), 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 = tupleDataCon Unboxed (length arg_tys) + ubx_tup_con = tupleCon UnboxedTuple (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 830873c1b9..53ecb48cc7 100644 --- a/compiler/typecheck/FunDeps.hs +++ b/compiler/typecheck/FunDeps.hs @@ -23,7 +23,6 @@ import Name import Var import Class import Type -import TcType( immSuperClasses ) import Unify import InstEnv import VarSet @@ -446,29 +445,32 @@ 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 = fixVarSet extend fixed_tvs + | otherwise = loop fixed_tvs where - 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 + 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 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])] - 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 - _ -> [] + TuplePred ts -> concatMap determined ts + _ -> [] {- ************************************************************************ diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 1383bdd909..78a53fba39 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -173,11 +173,42 @@ 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 * * ************************************************************************ @@ -353,6 +384,7 @@ 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 a4c4703ec3..88c88bdc53 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -320,6 +320,8 @@ 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 6e026941f8..6dd01f9f1f 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, mkEvScSelectors, + EvTerm(..), mkEvCast, evVarsOfTerm, mkEvTupleSelectors, mkEvScSelectors, EvLit(..), evTermCoercion, EvCallStack(..), EvTypeable(..), @@ -712,6 +712,10 @@ 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 @@ -971,6 +975,11 @@ 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..] @@ -997,8 +1006,10 @@ 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 @@ -1078,6 +1089,8 @@ 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 a9622588a0..155cdb42be 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 THNames( liftStringName, liftName ) +import DsMeta( 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 boxity (length tup_args) + = do { let tup_tc = tupleTyCon (boxityNormalTupleSort 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 boxity arity + tup_tc = tupleTyCon (boxityNormalTupleSort 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 THNames.liftStringName + do { sid <- tcLookupId DsMeta.liftStringName -- See Note [Lifting strings] ; return (HsVar sid) } else setConstraintVar lie_var $ -- Put the 'lift' constraint into the right LIE newMethodFromName (OccurrenceOf (idName id)) - THNames.liftName id_ty + DsMeta.liftName id_ty -- Update the pending splices ; ps <- readMutVar ps_var diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index d30c1ca3b1..d18e6edb60 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 :: TyCon -> [a] -> a -- Tuple type + , ft_tup :: TupleSort -> [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,7 +1644,8 @@ 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 - | isTupleTyCon con = (caseTuple con xrs, True) + | Just sort <- tyConTuple_maybe con + = (caseTuple sort 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) @@ -1715,11 +1716,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))) - -> 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] } + -> 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] {- ************************************************************************ diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 02d993f70c..80dd175e3c 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 bx tys +hsPatType (TuplePat _ bx tys) = mkTupleTy (boxityNormalTupleSort bx) tys hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys }) = conLikeResTy con tys hsPatType (SigPatOut _ ty) = ty @@ -1247,6 +1247,7 @@ 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) = @@ -1270,6 +1271,8 @@ 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 785dce751e..fbd21b23f1 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 Boxed n - ty_con = promotedTupleDataCon Boxed n + kind_con = promotedTupleTyCon BoxedTuple n + ty_con = promotedTupleDataCon BoxedTuple n (taus, ks) = unzip tks tup_k = mkTyConApp kind_con ks ; checkExpectedKind hs_ty tup_k exp_kind @@ -568,15 +568,10 @@ 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 - ; 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) + ; checkWiredInTyCon tycon ; return (mkTyConApp tycon tau_tys) } where - arity = length tau_tys + tycon = tupleTyCon tup_sort (length tau_tys) res_kind = case tup_sort of UnboxedTuple -> unliftedTypeKind BoxedTuple -> liftedTypeKind @@ -1563,7 +1558,7 @@ tc_hs_kind (HsTupleTy _ kis) = checkWiredInTyCon tycon return $ mkTyConApp tycon kappas where - tycon = promotedTupleTyCon Boxed (length kis) + tycon = promotedTupleTyCon BoxedTuple (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 de5df6ae53..ed4fd913bf 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -1015,6 +1015,7 @@ 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 @@ -1022,8 +1023,7 @@ 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 - | not (isCTupleClass cls) - , sizeTypes tys >= head_size -- Here is where we test for + | 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 18a798fc62..95715fe03d 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -27,7 +27,6 @@ import PrelNames ( knownNatClassName, knownSymbolClassName, ipClassNameKey, import Id( idType ) import Class import TyCon -import DataCon( dataConWrapId ) import FunDeps import FamInst import Inst( tyVarsOfCt ) @@ -1531,12 +1530,13 @@ emitFunDepDeriveds fd_eqns topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) topReactionsStage wi - = do { tir <- doTopReact wi + = do { inerts <- getTcSInerts + ; tir <- doTopReact inerts wi ; case tir of ContinueWith wi -> return (ContinueWith wi) Stop ev s -> return (Stop ev (ptext (sLit "Top react:") <+> s)) } -doTopReact :: WorkItem -> TcS (StopOrContinue Ct) +doTopReact :: InertSet -> WorkItem -> TcS (StopOrContinue Ct) -- The work item does not react with the inert set, so try interaction with top-level -- instances. Note: -- @@ -1544,11 +1544,10 @@ doTopReact :: WorkItem -> TcS (StopOrContinue Ct) -- Instead superclasses are added in the worklist as part of the -- canonicalization process. See Note [Adding superclasses]. -doTopReact work_item +doTopReact inerts work_item = do { traceTcS "doTopReact" (ppr work_item) ; case work_item of - CDictCan {} -> do { inerts <- getTcSInerts - ; doTopReactDict inerts work_item } + CDictCan {} -> doTopReactDict inerts work_item CFunEqCan {} -> doTopReactFunEq work_item _ -> -- Any other work item does not react with any top-level equations return (ContinueWith work_item) } @@ -1570,9 +1569,8 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls -- of generating some improvements -- C.f. Example 3 of Note [The improvement story] -- It's easy because no evidence is involved - = do { dflags <- getDynFlags - ; lkup_inst_res <- matchClassInst dflags inerts cls xis dict_loc - ; case lkup_inst_res of + = do { lkup_inst_res <- matchClassInst inerts cls xis dict_loc + ; case lkup_inst_res of GenInst preds _ s -> do { mapM_ (emitNewDerived dict_loc) preds ; unless s $ insertSafeOverlapFailureTcS work_item @@ -1583,9 +1581,8 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls ; continueWith work_item } } | otherwise -- Wanted, but not cached - = do { dflags <- getDynFlags - ; lkup_inst_res <- matchClassInst dflags inerts cls xis dict_loc - ; case lkup_inst_res of + = do { lkup_inst_res <- matchClassInst inerts cls xis dict_loc + ; case lkup_inst_res of GenInst theta mk_ev s -> do { addSolvedDict fl cls xis ; unless s $ insertSafeOverlapFailureTcS work_item @@ -1987,41 +1984,9 @@ instance Outputable LookupInstResult where where ss = text $ if s then "[safe]" else "[unsafe]" -matchClassInst :: DynFlags -> InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult - --- First check whether there is an in-scope Given that could --- match this constraint. In that case, do not use top-level --- instances. See Note [Instance and Given overlap] -matchClassInst dflags inerts clas tys _ - | not (xopt Opt_IncoherentInstances dflags) - , not (isEmptyBag matchable_givens) - = do { traceTcS "Delaying instance application" $ - vcat [ text "Work item=" <+> pprType (mkClassPred clas tys) - , text "Relevant given dictionaries=" - <+> ppr matchable_givens ] - ; return NoInstance } - where - matchable_givens :: Cts - matchable_givens = filterBag matchable_given $ - findDictsByClass (inert_dicts $ inert_cans inerts) clas - - matchable_given ct - | CDictCan { cc_class = clas_g, cc_tyargs = sys, cc_ev = fl } <- ct - , isGiven fl - , Just {} <- tcUnifyTys bind_meta_tv tys sys - = ASSERT( clas_g == clas ) True - matchable_given _ = False - - bind_meta_tv :: TcTyVar -> BindFlag - -- Any meta tyvar may be unified later, so we treat it as - -- bindable when unifying with givens. That ensures that we - -- conservatively assume that a meta tyvar might get unified with - -- something that matches the 'given', until demonstrated - -- otherwise. - bind_meta_tv tv | isMetaTyVar tv = BindMe - | otherwise = Skolem +matchClassInst :: InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult -matchClassInst _ _ clas [ ty ] _ +matchClassInst _ clas [ ty ] _ | className clas == knownNatClassName , Just n <- isNumLitTy ty = makeDict (EvNum n) @@ -2057,22 +2022,17 @@ 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) - tuple_ev = EvDFunApp (dataConWrapId data_con) ts - = return (GenInst ts tuple_ev True) - -- The dfun is the data constructor! +matchClassInst _ clas [k,t] _ + | className clas == typeableClassName = matchTypeableClass clas k t -matchClassInst _ _ clas [k,t] _ - | className clas == typeableClassName - = matchTypeableClass clas k t - -matchClassInst dflags _ clas tys loc - = do { traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr pred ] +matchClassInst inerts clas tys loc + = do { dflags <- getDynFlags + ; traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr pred + , text "inerts=" <+> ppr inerts ] ; instEnvs <- getInstEnvs - ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy] - (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys + ; safeOverlapCheck <- ((`elem` [Sf_Safe, Sf_Trustworthy]) . safeHaskell) + `fmap` getDynFlags + ; let (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps) ; case (matches, unify, safeHaskFail) of @@ -2084,6 +2044,16 @@ matchClassInst dflags _ clas tys loc -- A single match (& no safe haskell failure) ([(ispec, inst_tys)], [], False) + | not (xopt Opt_IncoherentInstances dflags) + , not (isEmptyBag unifiable_givens) + -> -- See Note [Instance and Given overlap] + do { traceTcS "Delaying instance application" $ + vcat [ text "Work item=" <+> pprType (mkClassPred clas tys) + , text "Relevant given dictionaries=" + <+> ppr unifiable_givens ] + ; return NoInstance } + + | otherwise -> do { let dfun_id = instanceDFunId ispec ; traceTcS "matchClass success" $ vcat [text "dict" <+> ppr pred, @@ -2109,6 +2079,26 @@ matchClassInst dflags _ clas tys loc ; (tys, theta) <- instDFunType dfun_id mb_inst_tys ; return $ GenInst theta (EvDFunApp dfun_id tys) so } + unifiable_givens :: Cts + unifiable_givens = filterBag matchable $ + findDictsByClass (inert_dicts $ inert_cans inerts) clas + + matchable (CDictCan { cc_class = clas_g, cc_tyargs = sys, cc_ev = fl }) + | isGiven fl + , Just {} <- tcUnifyTys bind_meta_tv tys sys + = ASSERT( clas_g == clas ) True + | otherwise = False -- No overlap with a solved, already been taken care of + -- by the overlap check with the instance environment. + matchable ct = pprPanic "Expecting dictionary!" (ppr ct) + + bind_meta_tv :: TcTyVar -> BindFlag + -- Any meta tyvar may be unified later, so we treat it as + -- bindable when unifying with givens. That ensures that we + -- conservatively assume that a meta tyvar might get unified with + -- something that matches the 'given', until demonstrated + -- otherwise. + bind_meta_tv tv | isMetaTyVar tv = BindMe + | otherwise = Skolem {- Note [Instance and Given overlap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2144,18 +2134,12 @@ Trac #4981 and #5002. Other notes: -* The check is done *first*, so that it also covers classes - with built-in instance solving, such as - - constraint tuples - - natural numbers - - Typeable - -* The given-overlap problem is arguably not easy to appear in practice - due to our aggressive prioritization of equality solving over other +* This is arguably not easy to appear in practice due to our + aggressive prioritization of equality solving over other constraints, but it is possible. I've added a test case in typecheck/should-compile/GivenOverlapping.hs -* Another "live" example is Trac #10195; another is #10177. +* Another "live" example is Trac #10195 * We ignore the overlap problem if -XIncoherentInstances is in force: see Trac #6002 for a worked-out example where this makes a diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index a5d55555bc..0eaae8f54b 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -143,6 +143,7 @@ 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 df2ad1837d..93c4728e45 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 boxity (length pats) + = do { let tc = tupleTyCon (boxityNormalTupleSort 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 820e969cf4..ea454d5d60 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -1016,10 +1016,6 @@ 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 ee0740f8e4..e9705790ed 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -614,6 +614,7 @@ 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 a7363d85a1..4ecbd5053c 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -38,7 +38,7 @@ import Outputable import TcExpr import SrcLoc import FastString -import THNames +import DsMeta import TcUnify import TcEnv diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 1b324f668a..6ac87206bd 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -581,24 +581,13 @@ 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 $ - do { traceTc "tcTyAndCl-x" (ppr decl) - ; tcTyClDecl1 NoParentTyCon rec_info decl } + traceTc "tcTyAndCl-x" (ppr decl) >> + tcTyClDecl1 NoParentTyCon rec_info decl -- "type family" declarations tcTyClDecl1 :: TyConParent -> RecTyInfo -> TyClDecl Name -> TcM [TyThing] @@ -799,7 +788,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) @@ -1451,9 +1440,6 @@ checkValidTyCl thing checkValidTyCon :: TyCon -> TcM () checkValidTyCon tc - | isPrimTyCon tc -- Happens when Haddock'ing GHC.Prim - = return () - | Just cl <- tyConClass_maybe tc = checkValidClass cl diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 9ce14497b7..4d4f6823f2 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -1377,6 +1377,7 @@ 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] @@ -1386,9 +1387,10 @@ 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] @@ -1404,6 +1406,7 @@ 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 16059e68b5..3225b2848b 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,6 +45,7 @@ import Util import ListSetOps import SrcLoc import Outputable +import Unique ( hasKey ) import BasicTypes ( IntWithInf, infinity ) import FastString @@ -395,11 +396,7 @@ 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 SigmaCtxt theta - -- Allow type T = ?x::Int => Int -> Int - -- but not type T = ?x::Int - + ; check_valid_theta ctxt theta ; check_type ctxt rank tau } -- Allow foralls to right of arrow where (tvs, theta, tau) = tcSplitSigmaTy ty @@ -620,16 +617,15 @@ 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) - | 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 + 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 _ -> check_irred_pred under_syn dflags ctxt pred check_eq_pred :: DynFlags -> PredType -> [TcType] -> TcM () @@ -660,22 +656,16 @@ 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) - failIfTc (not under_syn && not (xopt Opt_ConstraintKinds dflags) - && hasTyVarHead pred) - (predIrredErr pred) + checkTc (under_syn || xopt Opt_ConstraintKinds dflags || not (hasTyVarHead pred)) + (predIrredErr pred) -- Make sure it is OK to have an irred pred in this context -- See Note [Irreducible predicates in superclasses] - ; failIfTc (is_superclass ctxt - && not (xopt Opt_UndecidableInstances dflags) - && has_tyfun_head pred) - (predSuperClassErr pred) } + ; checkTc (xopt Opt_UndecidableInstances dflags || not (dodgy_superclass ctxt)) + (predIrredBadCtxtErr pred) } where - is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False } - has_tyfun_head ty - = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> isTypeFamilyTyCon tc - Nothing -> False + dodgy_superclass ctxt + = case ctxt of { ClassSCCtxt _ -> True; InstDeclCtxt -> True; _ -> False } {- Note [ConstraintKinds in predicates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -689,7 +679,7 @@ e.g. module A where Note [Irreducible predicates in superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Allowing type-family calls in class superclasses is somewhat dangerous +Allowing irreducible predicates in class superclasses is somewhat dangerous because we can write: type family Fooish x :: * -> Constraint @@ -698,7 +688,10 @@ 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. -} +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. -} ------------------------- check_class_pred :: DynFlags -> UserTypeCtxt -> PredType -> Class -> [TcType] -> TcM () @@ -729,25 +722,10 @@ 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 (TySynCtxt {}) = False -okIPCtxt (RuleSigCtxt {}) = False -okIPCtxt DefaultDeclCtxt = False +okIPCtxt _ = True badIPPred :: PredType -> SDoc badIPPred pred = ptext (sLit "Illegal implicit parameter") <+> quotes (ppr pred) @@ -778,9 +756,10 @@ checkThetaCtxt ctxt theta = vcat [ptext (sLit "In the context:") <+> pprTheta theta, ptext (sLit "While checking") <+> pprUserTypeCtxt ctxt ] -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")) ] +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")) 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")) ] @@ -788,10 +767,9 @@ predTupleErr pred = hang (ptext (sLit "Illegal tuple constraint:") <+> pprType 2 (parens constraintKindsMsg) predIrredErr pred = hang (ptext (sLit "Illegal constraint:") <+> pprType pred) 2 (parens constraintKindsMsg) -predSuperClassErr pred - = hang (ptext (sLit "Illegal constraint") <+> quotes (pprType pred) - <+> ptext (sLit "in a superclass context")) - 2 (parens undecidableMsg) +predIrredBadCtxtErr pred = hang (ptext (sLit "Illegal constraint") <+> quotes (pprType pred) + <+> ptext (sLit "in a superclass/instance context")) + 2 (parens undecidableMsg) constraintSynErr :: Type -> SDoc constraintSynErr kind = hang (ptext (sLit "Illegal constraint synonym of kind:") <+> quotes (ppr kind)) @@ -908,9 +886,10 @@ not converge. See Trac #5287. validDerivPred :: TyVarSet -> PredType -> Bool validDerivPred tv_set pred = case classifyPredType pred of - ClassPred _ tys -> check_tys tys - EqPred {} -> False -- reject equality constraints - _ -> True -- Non-class predicates are ok + ClassPred _ tys -> check_tys tys + TuplePred ps -> all (validDerivPred tv_set) ps + EqPred {} -> False -- reject equality constraints + _ -> True -- Non-class predicates are ok where check_tys tys = hasNoDups fvs && sizeTypes tys == fromIntegral (length fvs) @@ -984,9 +963,6 @@ 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 @@ -1000,45 +976,36 @@ checkInstTermination tys theta check :: PredType -> TcM () check pred - = 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 () + = 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 () 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})) -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") +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") ] -undecidableMsg, constraintKindsMsg :: SDoc +smallerMsg, undecidableMsg, constraintKindsMsg :: SDoc +smallerMsg = ptext (sLit "Constraint is no smaller than the instance head") undecidableMsg = ptext (sLit "Use UndecidableInstances to permit this") constraintKindsMsg = ptext (sLit "Use ConstraintKinds to permit this") @@ -1225,12 +1192,16 @@ checkFamInstRhs lhsTys famInsts size = sizeTypes lhsTys fvs = fvTypes lhsTys check (tc, tys) - | not (all isTyFamFree tys) = Just (nestedMsg what) - | not (null bad_tvs) = Just (noMoreMsg bad_tvs what) - | size <= sizeTypes tys = Just (smallerMsg what) - | otherwise = Nothing + | 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 where - what = ptext (sLit "type family application") <+> quotes (pprType (TyConApp tc tys)) + famInst = TyConApp tc tys bad_tvs = filterOut isKindVar (fvTypes tys \\ fvs) -- Rightly or wrongly, we only check for -- excessive occurrences of *type* variables. @@ -1276,10 +1247,11 @@ tyFamInstIllegalErr ty colon) 2 $ ppr ty -nestedMsg :: SDoc -> SDoc -nestedMsg what - = sep [ ptext (sLit "Illegal nested") <+> what - , parens undecidableMsg ] +famInstUndecErr :: Type -> SDoc -> SDoc +famInstUndecErr ty msg + = sep [msg, + nest 2 (ptext (sLit "in the type family application:") <+> + pprType ty)] famPatErr :: TyCon -> [TyVar] -> [Type] -> SDoc famPatErr fam_tc tvs pats @@ -1288,6 +1260,10 @@ 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") + {- ************************************************************************ * * @@ -1355,14 +1331,14 @@ sizeTypes xs = sum (map sizeType tys) -- "local instances" in expressions). -- See Trac #4200. sizePred :: PredType -> TypeSize -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 +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 {- ************************************************************************ diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 827c076b2e..186134363e 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -61,8 +61,7 @@ module TyCon( tyConTyVars, tyConCType, tyConCType_maybe, tyConDataCons, tyConDataCons_maybe, - tyConSingleDataCon_maybe, tyConSingleDataCon, - tyConSingleAlgDataCon_maybe, + tyConSingleDataCon_maybe, tyConSingleAlgDataCon_maybe, tyConFamilySize, tyConStupidTheta, tyConArity, @@ -1039,7 +1038,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 promoted + Nothing -- Class TyCons are not pormoted mkTupleTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' @@ -1048,9 +1047,8 @@ 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 parent +mkTupleTyCon name kind arity tyvars con sort prom_tc = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -1061,7 +1059,7 @@ mkTupleTyCon name kind arity tyvars con sort prom_tc parent tyConCType = Nothing, algTcStupidTheta = [], algTcRhs = TupleTyCon { data_con = con, tup_sort = sort }, - algTcParent = parent, + algTcParent = NoParentTyCon, algTcRec = NonRecursive, algTcGadtSyntax = False, tcPromoted = prom_tc @@ -1472,23 +1470,17 @@ 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 = 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 +isImplicitTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True +isImplicitTyCon (AlgTyCon { algTcParent = AssocFamilyTyCon {} }) = True +isImplicitTyCon (AlgTyCon {}) = False +isImplicitTyCon (FamilyTyCon { famTcParent = AssocFamilyTyCon {} }) = True +isImplicitTyCon (FamilyTyCon {}) = False +isImplicitTyCon (SynonymTyCon {}) = False tyConCType_maybe :: TyCon -> Maybe CType tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc @@ -1556,12 +1548,6 @@ 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 41b6b2d8b6..f29791c8a4 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -50,7 +50,6 @@ module Type ( mkClassPred, isClassPred, isEqPred, isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, - isCTupleClass, -- Deconstructing predicate types PredTree(..), EqRel(..), eqRelRole, classifyPredType, @@ -914,9 +913,6 @@ 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 @@ -1024,6 +1020,7 @@ eqRelRole ReprEq = Representational data PredTree = ClassPred Class [Type] | EqPred EqRel Type Type + | TuplePred [PredType] | IrredPred PredType classifyPredType :: PredType -> PredTree @@ -1038,6 +1035,8 @@ 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 527bfda02e..f755f3f9ee 100644 --- a/compiler/types/TypeRep.hs +++ b/compiler/types/TypeRep.hs @@ -78,7 +78,6 @@ import Outputable import FastString import Util import DynFlags -import StaticFlags( opt_PprStyle_Debug ) -- libraries import Data.List( mapAccumL, partition ) @@ -744,7 +743,8 @@ 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 $ pprWithCommas (pp TopPrec) ty_args) + (tupleParens tup_sort $ + sep (punctuate comma (map (pp TopPrec) ty_args))) | otherwise = sdocWithDynFlags (pprTcApp_help p pp tc tys) @@ -754,12 +754,11 @@ pprTupleApp :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> TupleSort -> [a] -> S pprTupleApp p pp tc sort tys | null tys , ConstraintTuple <- sort - = if opt_PprStyle_Debug then ptext (sLit "(%%)") - else maybeParen p FunPrec $ - ptext (sLit "() :: Constraint") + = maybeParen p TopPrec $ + ppr tc <+> dcolon <+> ppr (tyConKind tc) | otherwise = pprPromotionQuote tc <> - tupleParens sort (pprWithCommas (pp TopPrec) tys) + tupleParens sort (sep (punctuate comma (map (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 d5bbd65ee9..bcd85cb100 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 Boxed n + = tupleTyCon BoxedTuple n | otherwise = pprPanic "prodTyCon" (ppr n) diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs index ee7cf9c2b5..6770103d3b 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 = (tupleDataCon Boxed n, name) + mk_tup n name = (tupleCon BoxedTuple n, name) -- Auxilliary look up functions ----------------------------------------------- diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs index 335b34b909..0a918f84e9 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( Boxity(..) ) +import BasicTypes( TupleSort(..) ) 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 = tupleDataCon Boxed (length vs) + let venv_con = tupleCon BoxedTuple (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 73ae69ebf1..1f9ec2d9f8 100644 --- a/libraries/ghc-prim/GHC/Classes.hs +++ b/libraries/ghc-prim/GHC/Classes.hs @@ -1,17 +1,11 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, StandaloneDeriving, BangPatterns, - KindSignatures, DataKinds, ConstraintKinds, - MultiParamTypeClasses, FunctionalDependencies #-} + KindSignatures, DataKinds, MultiParamTypeClasses, FunctionalDependencies #-} {-# LANGUAGE AllowAmbiguousTypes #-} -- ip :: IP x a => a is strictly speaking ambiguous, but IP is magic {-# OPTIONS_GHC -fno-warn-unused-imports #-} --- -fno-warn-unused-imports needed for the GHC.Tuple import below. Sigh. - -{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} --- -fno-warn-unused-top-binds is there (I hope) to stop Haddock complaining --- about the constraint tuples being defined but not used - +-- XXX -fno-warn-unused-imports needed for the GHC.Tuple import below. Sigh. {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -320,37 +314,3 @@ 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 4ebda15d84..3c4c8c2bc1 100644 --- a/libraries/ghc-prim/GHC/Tuple.hs +++ b/libraries/ghc-prim/GHC/Tuple.hs @@ -23,141 +23,113 @@ 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,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) +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__ {- 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 a25d7ffaf2..e893974116 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples, - MultiParamTypeClasses, RoleAnnotations #-} + RoleAnnotations #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Types diff --git a/testsuite/tests/ghci/scripts/T10248.script b/testsuite/tests/ghci/scripts/T10248.script deleted file mode 100644 index 6614044ad6..0000000000 --- a/testsuite/tests/ghci/scripts/T10248.script +++ /dev/null @@ -1,2 +0,0 @@ -:set -fdefer-type-errors -Just <$> _ diff --git a/testsuite/tests/ghci/scripts/T10248.stderr b/testsuite/tests/ghci/scripts/T10248.stderr deleted file mode 100644 index 1245b994fd..0000000000 --- a/testsuite/tests/ghci/scripts/T10248.stderr +++ /dev/null @@ -1,18 +0,0 @@ - -<interactive>:3:10: warning: - Found hole ‘_’ with type: IO () - In the second argument of ‘(<$>)’, namely ‘_’ - In the first argument of ‘ghciStepIO :: - IO a_alT -> IO a_alT’, namely - ‘Just <$> _’ - In a stmt of an interactive GHCi command: - it <- ghciStepIO :: IO a_alT -> IO a_alT (Just <$> _) -*** Exception: <interactive>:3:10: error: - Found hole ‘_’ with type: IO () - In the second argument of ‘(<$>)’, namely ‘_’ - In the first argument of ‘ghciStepIO :: - IO a_alT -> IO a_alT’, namely - ‘Just <$> _’ - In a stmt of an interactive GHCi command: - it <- ghciStepIO :: IO a_alT -> IO a_alT (Just <$> _) -(deferred type error) diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index 85ba5afe17..1582344063 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -216,4 +216,3 @@ test('T10408A', normal, run_command, ['$MAKE -s --no-print-directory T10408A']) test('T10408B', normal, run_command, ['$MAKE -s --no-print-directory T10408B']) -test('T10248', normal, ghci_script, ['T10248.script']) diff --git a/testsuite/tests/indexed-types/should_fail/NotRelaxedExamples.stderr b/testsuite/tests/indexed-types/should_fail/NotRelaxedExamples.stderr index 1594d199df..dd479b7664 100644 --- a/testsuite/tests/indexed-types/should_fail/NotRelaxedExamples.stderr +++ b/testsuite/tests/indexed-types/should_fail/NotRelaxedExamples.stderr @@ -1,17 +1,18 @@ -
-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’
+ +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’ diff --git a/testsuite/tests/indexed-types/should_fail/TyFamUndec.stderr b/testsuite/tests/indexed-types/should_fail/TyFamUndec.stderr index bdc9c5fbac..15cd757181 100644 --- a/testsuite/tests/indexed-types/should_fail/TyFamUndec.stderr +++ b/testsuite/tests/indexed-types/should_fail/TyFamUndec.stderr @@ -1,17 +1,18 @@ -
-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’
+ +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’ diff --git a/testsuite/tests/module/all.T b/testsuite/tests/module/all.T index d0b37aaa33..c4c2fffe57 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, ['']) +test('mod89', normal, compile_fail, ['']) 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 1e903a0125..2c48d65a16 100644 --- a/testsuite/tests/module/mod89.hs +++ b/testsuite/tests/module/mod89.hs @@ -1,5 +1,3 @@ -{-# 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 b355f3050b..0f956536cb 100644 --- a/testsuite/tests/module/mod89.stderr +++ b/testsuite/tests/module/mod89.stderr @@ -1,10 +1,2 @@ -
-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()
+ +mod89.hs:3:16: Module ‘Prelude’ does not export ‘map(..)’ diff --git a/testsuite/tests/partial-sigs/should_compile/T10403.hs b/testsuite/tests/partial-sigs/should_compile/T10403.hs deleted file mode 100644 index a33646da5d..0000000000 --- a/testsuite/tests/partial-sigs/should_compile/T10403.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -module T10403 where - -data I a = I a -instance Functor I where - fmap f (I a) = I (f a) - -newtype B t a = B a -instance Functor (B t) where - fmap f (B a) = B (f a) - -newtype H f = H (f ()) - -app :: H (B t) -app = h (H . I) (B ()) - -h :: _ => _ ---h :: Functor m => (a -> b) -> m a -> H m -h f b = (H . fmap (const ())) (fmap f b) diff --git a/testsuite/tests/partial-sigs/should_compile/T10403.stderr b/testsuite/tests/partial-sigs/should_compile/T10403.stderr deleted file mode 100644 index 6b0660dbad..0000000000 --- a/testsuite/tests/partial-sigs/should_compile/T10403.stderr +++ /dev/null @@ -1,17 +0,0 @@ - -T10403.hs:17:6: warning: - Found hole ‘_’ with inferred constraints: Functor f - In the type signature for ‘h’: _ => _ - -T10403.hs:17:11: warning: - Found hole ‘_’ with type: (a -> b) -> f a -> H f - Where: ‘f’ is a rigid type variable bound by - the inferred type of h :: Functor f => (a -> b) -> f a -> H f - at T10403.hs:19:1 - ‘b’ is a rigid type variable bound by - the inferred type of h :: Functor f => (a -> b) -> f a -> H f - at T10403.hs:19:1 - ‘a’ is a rigid type variable bound by - the inferred type of h :: Functor f => (a -> b) -> f a -> H f - at T10403.hs:19:1 - In the type signature for ‘h’: _ => _ diff --git a/testsuite/tests/partial-sigs/should_compile/all.T b/testsuite/tests/partial-sigs/should_compile/all.T index 91294a580c..e83e070dcd 100644 --- a/testsuite/tests/partial-sigs/should_compile/all.T +++ b/testsuite/tests/partial-sigs/should_compile/all.T @@ -46,4 +46,3 @@ test('SomethingShowable', normal, compile, ['-ddump-types -fno-warn-partial-type test('Uncurry', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) test('UncurryNamed', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures']) test('WarningWildcardInstantiations', normal, compile, ['-ddump-types']) -test('T10403', normal, compile, ['']) diff --git a/testsuite/tests/perf/should_run/T10359.hs b/testsuite/tests/perf/should_run/T10359.hs deleted file mode 100644 index fa10560970..0000000000 --- a/testsuite/tests/perf/should_run/T10359.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ConstraintKinds #-} - -module Main( main, boo ) where - -import Prelude hiding (repeat) - -boo xs f = (\x -> f x, xs) - -repeat :: Int -> (a -> a) -> a -> a -repeat 1 f x = f x -repeat n f x = n `seq` x `seq` repeat (n-1) f $ f x - ----- Buggy version ------------------- - -type Numerical a = (Fractional a, Real a) - -data Box a = Box - { func :: forall dum. (Numerical dum) => dum -> a -> a - , obj :: !a } - -do_step :: (Numerical num) => num -> Box a -> Box a -do_step number Box{..} = Box{ obj = func number obj, .. } - -start :: Box Double -start = Box { func = \x y -> realToFrac x + y - , obj = 0 } - -test :: Int -> IO () -test steps = putStrLn $ show $ obj $ repeat steps (do_step 1) start - ----- Driver ------------ - -main :: IO () -main = test 2000 -- compare test2 10000000 or test3 10000000, but test4 20000 - - -{- ----- No tuple constraint synonym is better ------------------------------------------- - -data Box2 a = Box2 - { func2 :: forall num. (Fractional num, Real num) => num -> a -> a - , obj2 :: !a } - -do_step2 :: (Fractional num, Real num) => num -> Box2 a -> Box2 a -do_step2 number Box2{..} = Box2{ obj2 = func2 number obj2, ..} - -start2 :: Box2 Double -start2 = Box2 { func2 = \x y -> realToFrac x + y - , obj2 = 0 } - -test2 :: Int -> IO () -test2 steps = putStrLn $ show $ obj2 $ repeat steps (do_step2 1) start2 - ----- Not copying the function field works too ---------------------------------------------- - -do_step3 :: (Numerical num) => num -> Box a -> Box a -do_step3 number b@Box{..} = b{ obj = func number obj } - -test3 :: Int -> IO () -test3 steps = putStrLn $ show $ obj $ repeat steps (do_step3 1) start - ----- But record wildcards are not at fault ------------------------------------------- - -do_step4 :: (Numerical num) => num -> Box a -> Box a -do_step4 number Box{func = f, obj = x} = Box{ obj = f number x, func = f } - -test4 :: Int -> IO () -test4 steps = putStrLn $ show $ obj $ repeat steps (do_step4 1) start --} - - -{- -First of all, very nice example. Thank you for making it so small and easy to work with. - -I can see what's happening. The key part is what happens here: -{{{ -do_step4 :: (Numerical num) => num -> Box a -> Box a -do_step4 number Box{ func = f, obj = x} - = Box{ func = f, obj = f number x } -}}} -After elaboration (ie making dictionaries explicit) we get this: -{{{ -do_step4 dn1 number (Box {func = f, obj = x }) - = Box { func = \dn2 -> f ( case dn2 of (f,r) -> f - , case dn2 of (f,r) -> r) - , obj = f dn1 number x } -}}} -That's odd! We expected this: -{{{ -do_step4 dn1 number (Box {func = f, obj = x }) - = Box { func = f - , obj = f dn1 number x } -}}} -And indeed, the allocation of all those `\dn2` closures is what is causing the problem. -So we are missing this optimisation: -{{{ - (case dn2 of (f,r) -> f, case dn2 of (f,r) -> r) -===> - dn2 -}}} -If we did this, then the lambda would look like `\dn2 -> f dn2` which could eta-reduce to `f`. -But there are at least three problems: - * The tuple transformation above is hard to spot - * The tuple transformation is not quite semantically right; if `dn2` was bottom, the LHS and RHS are different - * The eta-reduction isn't quite semantically right: if `f` ws bottom, the LHS and RHS are different. - -You might argue that the latter two can be ignored because dictionary arguments are special; -indeed we often toy with making them strict. - -But perhaps a better way to avoid the tuple-transformation issue would be not to construct that strange expression in the first place. Where is it coming from? It comes from the call to `f` (admittedly applied to no arguments) in `Box { ..., func = f }`. GHC needs a dictionary for `(Numerical dum)` (I changed the name of the type variable in `func`'s type in the definition of `Box`). Since it's just a pair GHC says "fine, I'll build a pair, out of `Fractional dum` and `Real dum`. How does it get those dictionaries? By selecting the components of the `Franctional dum` passed to `f`. - -If GHC said instead "I need `Numerical dum` and behold I have one in hand, it'd be much better. It doesn't because tuple constraints are treated specially. But if we adopted the idea in #10362, we would (automatically) get to re-use the `Numerical dum` constraint. That would leave us with eta reduction, which is easier. - -As to what will get you rolling, a good solution is `test3`, which saves instantiating and re-generalising `f`. The key thing is to update all the fields ''except'' the polymorphic `func` field. I'm surprised you say that it doesn't work. Can you give a (presumably more complicated) example to demonstrate? Maybe there's a separate bug! - --} - - diff --git a/testsuite/tests/perf/should_run/T10359.stdout b/testsuite/tests/perf/should_run/T10359.stdout deleted file mode 100644 index f6f4e0735a..0000000000 --- a/testsuite/tests/perf/should_run/T10359.stdout +++ /dev/null @@ -1 +0,0 @@ -2000.0 diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T index c95dfa0110..f6801040e3 100644 --- a/testsuite/tests/perf/should_run/all.T +++ b/testsuite/tests/perf/should_run/all.T @@ -1,16 +1,8 @@ # Tests that newArray/newArray_ is being optimised correctly -test('T10359', - [stats_num_field('bytes allocated', - [(wordsize(64), 499512, 5), - (wordsize(32), 250000, 5)]), - only_ways(['normal']) - ], - compile_and_run, - ['-O']) - # fortunately the values here are mostly independent of the wordsize, # because the test allocates an unboxed array of doubles. + test('T3586', [stats_num_field('peak_megabytes_allocated', (17, 1)), # expected value: 17 (amd64/Linux) diff --git a/testsuite/tests/rts/outofmem.stderr-i386-unknown-mingw32 b/testsuite/tests/rts/outofmem.stderr-i386-unknown-mingw32 index 2786841ad7..4b16ce9598 100644 --- a/testsuite/tests/rts/outofmem.stderr-i386-unknown-mingw32 +++ b/testsuite/tests/rts/outofmem.stderr-i386-unknown-mingw32 @@ -1 +1 @@ -outofmem.exe: out of memory
+outofmem.exe: Out of memory diff --git a/testsuite/tests/typecheck/should_fail/T9858a.stderr b/testsuite/tests/typecheck/should_fail/T9858a.stderr index 61c62eaeec..2f815b1824 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 44a0618181..96fbc3ef18 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: 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)’
+ +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)’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail108.stderr b/testsuite/tests/typecheck/should_fail/tcfail108.stderr index da766582b3..3a2e5a5657 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
- in the constraint ‘Eq (f (Rec f))’ than in the instance head
+ Variable ‘f’ occurs more often than in the instance head
+ in the constraint: Eq (f (Rec f))
(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 903f61b7de..9014b643df 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: 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)’
+ +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)’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail157.stderr b/testsuite/tests/typecheck/should_fail/tcfail157.stderr index 113e0cc67e..acdc7df8cf 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: 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 -> ())’
+ +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 -> ())’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail213.stderr b/testsuite/tests/typecheck/should_fail/tcfail213.stderr index a29b758a42..a6b63bd9f1 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: 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’
+ +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’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail214.stderr b/testsuite/tests/typecheck/should_fail/tcfail214.stderr index a2741b876b..5520a3eff1 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail214.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail214.stderr @@ -1,5 +1,7 @@ -
-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]’
+ +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]’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail220.hsig b/testsuite/tests/typecheck/should_fail/tcfail220.hsig index 560fc317a6..129bae368c 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail220.hsig +++ b/testsuite/tests/typecheck/should_fail/tcfail220.hsig @@ -1,4 +1,5 @@ {-# 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 432dc4c1a3..6a4e87382d 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail220.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail220.stderr @@ -1,9 +1,17 @@ -[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
+[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 diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index a7bc421270..803323fbc0 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 Unboxed " +ppType (TyUTup ts) = "(mkTupleTy UnboxedTuple " ++ listify (map ppType ts) ++ ")" ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))" diff --git a/utils/haddock b/utils/haddock -Subproject 5a57a24c44e06e964c4ea2276c842c722c4e93d +Subproject 2380f07c430c525b205ce2eae6dab23c8388d89 |