Commit 3cf8ecdc authored by Austin Seipp's avatar Austin Seipp

Revert multiple commits

This reverts multiple commits from Simon:

  - 04a484ea Test Trac #10359
  - a9ccd37a Test Trac #10403
  - c0aae6f6 Test Trac #10248
  - eb6ca851 Make the "matchable-given" check happen first
  - ca173aa3 Add a case to checkValidTyCon
  - 51cbad15 Update haddock submodule
  - 6e1174da Separate transCloVarSet from fixVarSet
  - a8493e03 Fix imports in HscMain (stage2)
  - a154944b Two wibbles to fix the build
  - 5910a1bc Change in capitalisation of error msg
  - 130e93aa Refactor tuple constraints
  - 8da785d5 Delete commented-out line

These break the build by causing Haddock to fail mysteriously when
trying to examine GHC.Prim it seems.
parent 04a484ea
......@@ -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 "#)")
{-
************************************************************************
......
......@@ -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
_ -> []
{-
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)]
{-
************************************************************************
......
......@@ -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
......
......@@ -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
......
......@@ -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]
......
......@@ -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')
......
......@@ -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
)
......
......@@ -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
]
......
This diff is collapsed.
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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'
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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