Commit ffc21506 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor tuple constraints

Make tuple constraints be handled by a perfectly ordinary
type class, with the component constraints being the
superclasses:
    class (c1, c2) => (c2, c2)

This change was provoked by

  #10359  inability to re-use a given tuple
          constraint as a whole

  #9858   confusion between term tuples
          and constraint tuples

but it's generally a very nice simplification. We get rid of
 -  In Type, the TuplePred constructor of PredTree,
    and all the code that dealt with TuplePreds
 -  In TcEvidence, the constructors EvTupleMk, EvTupleSel

See Note [How tuples work] in TysWiredIn.

Of course, nothing is ever entirely simple. This one
proved quite fiddly.

- I did quite a bit of renaming, which makes this patch
  touch a lot of modules. In partiuclar tupleCon -> tupleDataCon.

- I made constraint tuples known-key rather than wired-in.
  This is different to boxed/unboxed tuples, but it proved
  awkward to have all the superclass selectors wired-in.
  Easier just to use the standard mechanims.

- While I was fiddling with known-key names, I split the TH Name
  definitions out of DsMeta into a new module THNames.  That meant
  that the known-key names can all be gathered in PrelInfo, without
  causing module loops.

- I found that the parser was parsing an import item like
      T( .. )
  as a *data constructor* T, and then using setRdrNameSpace to
  fix it.  Stupid!  So I changed the parser to parse a *type
  constructor* T, which means less use of setRdrNameSpace.

  I also improved setRdrNameSpace to behave better on Exact Names.
  Largely on priciple; I don't think it matters a lot.

- When compiling a data type declaration for a wired-in thing like
  tuples (,), or lists, we don't really need to look at the
  declaration.  We have the wired-in thing!  And not doing so avoids
  having to line up the uniques for data constructor workers etc.
  See Note [Declarations for wired-in things]

- I found that FunDeps.oclose wasn't taking superclasses into
  account; easily fixed.

- Some error message refactoring for invalid constraints in TcValidity

- Haddock needs to absorb the change too; so there is a submodule update
parent 76024fdb
......@@ -46,7 +46,7 @@ module BasicTypes(
Boxity(..), isBoxed,
TupleSort(..), tupleSortBoxity, boxityNormalTupleSort,
TupleSort(..), tupleSortBoxity, boxityTupleSort,
tupleParens,
-- ** The OneShotInfo type
......@@ -94,7 +94,7 @@ module BasicTypes(
import FastString
import Outputable
import SrcLoc ( Located,unLoc )
import StaticFlags( opt_PprStyle_Debug )
import Data.Data hiding (Fixity)
import Data.Function (on)
import GHC.Exts (Any)
......@@ -573,19 +573,20 @@ data TupleSort
deriving( Eq, Data, Typeable )
tupleSortBoxity :: TupleSort -> Boxity
tupleSortBoxity BoxedTuple = Boxed
tupleSortBoxity UnboxedTuple = Unboxed
tupleSortBoxity BoxedTuple = Boxed
tupleSortBoxity UnboxedTuple = Unboxed
tupleSortBoxity ConstraintTuple = Boxed
boxityNormalTupleSort :: Boxity -> TupleSort
boxityNormalTupleSort Boxed = BoxedTuple
boxityNormalTupleSort Unboxed = UnboxedTuple
boxityTupleSort :: Boxity -> TupleSort
boxityTupleSort Boxed = BoxedTuple
boxityTupleSort Unboxed = UnboxedTuple
tupleParens :: TupleSort -> SDoc -> SDoc
tupleParens BoxedTuple p = parens p
tupleParens ConstraintTuple p = parens p -- The user can't write fact tuples
-- directly, we overload the (,,) syntax
tupleParens UnboxedTuple p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
tupleParens UnboxedTuple p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %)
| opt_PprStyle_Debug = ptext (sLit "(%") <+> p <+> ptext (sLit "%)")
| otherwise = parens p
{-
************************************************************************
......
......@@ -1015,7 +1015,6 @@ dataConCannotMatch tys con
-- TODO: could gather equalities from superclasses too
predEqs pred = case classifyPredType pred of
EqPred NomEq ty1 ty2 -> [(ty1, ty2)]
TuplePred ts -> concatMap predEqs ts
_ -> []
{-
......
......@@ -32,7 +32,7 @@ module RdrName (
nameRdrName, getRdrName,
-- ** Destruction
rdrNameOcc, rdrNameSpace, setRdrNameSpace, demoteRdrName,
rdrNameOcc, rdrNameSpace, demoteRdrName,
isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual,
isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,
......@@ -153,32 +153,6 @@ rdrNameOcc (Exact name) = nameOccName name
rdrNameSpace :: RdrName -> NameSpace
rdrNameSpace = occNameSpace . rdrNameOcc
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
-- ^ This rather gruesome function is used mainly by the parser.
-- When parsing:
--
-- > data T a = T | T1 Int
--
-- we parse the data constructors as /types/ because of parser ambiguities,
-- so then we need to change the /type constr/ to a /data constr/
--
-- The exact-name case /can/ occur when parsing:
--
-- > data [] a = [] | a : [a]
--
-- For the exact-name case we return an original name.
setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
setRdrNameSpace (Exact n) ns
| isExternalName n
= Orig (nameModule n) occ
| otherwise -- This can happen when quoting and then splicing a fixity
-- declaration for a type
= Exact $ mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)
where
occ = setOccNameSpace ns (nameOccName n)
-- demoteRdrName lowers the NameSpace of RdrName.
-- see Note [Demotion] in OccName
demoteRdrName :: RdrName -> Maybe RdrName
......
......@@ -43,6 +43,7 @@ module Unique (
mkAlphaTyVarUnique,
mkPrimOpIdUnique,
mkTupleTyConUnique, mkTupleDataConUnique,
mkCTupleTyConUnique,
mkPreludeMiscIdUnique, mkPreludeDataConUnique,
mkPreludeTyConUnique, mkPreludeClassUnique,
mkPArrDataConUnique,
......@@ -283,25 +284,25 @@ Allocation of unique supply characters:
mkAlphaTyVarUnique :: Int -> Unique
mkPreludeClassUnique :: Int -> Unique
mkPreludeTyConUnique :: Int -> Unique
mkTupleTyConUnique :: TupleSort -> Int -> Unique
mkPreludeDataConUnique :: Int -> Unique
mkTupleDataConUnique :: TupleSort -> Int -> Unique
mkTupleTyConUnique :: Boxity -> Arity -> Unique
mkCTupleTyConUnique :: Arity -> Unique
mkPreludeDataConUnique :: Arity -> Unique
mkTupleDataConUnique :: Boxity -> Arity -> Unique
mkPrimOpIdUnique :: Int -> Unique
mkPreludeMiscIdUnique :: Int -> Unique
mkPArrDataConUnique :: Int -> Unique
mkAlphaTyVarUnique i = mkUnique '1' i
mkPreludeClassUnique i = mkUnique '2' i
mkAlphaTyVarUnique i = mkUnique '1' i
mkPreludeClassUnique i = mkUnique '2' i
-- Prelude type constructors occupy *three* slots.
-- The first is for the tycon itself; the latter two
-- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info.
mkPreludeTyConUnique i = mkUnique '3' (3*i)
mkTupleTyConUnique BoxedTuple a = mkUnique '4' (3*a)
mkTupleTyConUnique UnboxedTuple a = mkUnique '5' (3*a)
mkTupleTyConUnique ConstraintTuple a = mkUnique 'k' (3*a)
mkPreludeTyConUnique i = mkUnique '3' (3*i)
mkTupleTyConUnique Boxed a = mkUnique '4' (3*a)
mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
mkCTupleTyConUnique a = mkUnique 'k' (3*a)
-- Data constructor keys occupy *two* slots. The first is used for the
-- data constructor itself and its wrapper function (the function that
......@@ -309,10 +310,9 @@ mkTupleTyConUnique ConstraintTuple a = mkUnique 'k' (3*a)
-- used for the worker function (the function that builds the constructor
-- representation).
mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic
mkTupleDataConUnique BoxedTuple a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels)
mkTupleDataConUnique UnboxedTuple a = mkUnique '8' (2*a)
mkTupleDataConUnique ConstraintTuple a = mkUnique 'h' (2*a)
mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic
mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels)
mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a)
mkPrimOpIdUnique op = mkUnique '9' op
mkPreludeMiscIdUnique i = mkUnique '0' i
......
......@@ -16,8 +16,8 @@ module VarSet (
unionVarSet, unionVarSets, mapUnionVarSet,
intersectVarSet, intersectsVarSet, disjointVarSet,
isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,
minusVarSet, foldVarSet, filterVarSet,
transCloVarSet,
minusVarSet, foldVarSet, filterVarSet,
transCloVarSet, fixVarSet,
lookupVarSet, mapVarSet, sizeVarSet, seqVarSet,
elemVarSetByKey, partitionVarSet
) where
......@@ -110,13 +110,28 @@ 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 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 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 fn seeds
= go seeds seeds
where
......@@ -124,7 +139,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 (tupleCon BoxedTuple 1)
oneTupleDataConId = dataConWorkId (tupleDataCon Boxed 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 (tupleCon BoxedTuple (length cs))
mkCoreTup cs = mkConApp (tupleDataCon Boxed (length cs))
(map (Type . exprType) cs ++ cs)
-- | Build a big tuple holding the specified variables
......@@ -484,7 +484,7 @@ mkSmallTupleSelector [var] should_be_the_same_var _ scrut
mkSmallTupleSelector vars the_var scrut_var scrut
= ASSERT( notNull vars )
Case scrut scrut_var (idType the_var)
[(DataAlt (tupleCon BoxedTuple (length vars)), vars, Var the_var)]
[(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)]
-- | A generalization of 'mkTupleSelector', allowing the body
-- of the case to be an arbitrary expression.
......@@ -537,7 +537,8 @@ mkSmallTupleCase [var] body _scrut_var scrut
= bindNonRec var scrut body
mkSmallTupleCase vars body scrut_var scrut
-- One branch no refinement?
= Case scrut scrut_var (exprType body) [(DataAlt (tupleCon BoxedTuple (length vars)), vars, body)]
= Case scrut scrut_var (exprType body)
[(DataAlt (tupleDataCon Boxed (length vars)), vars, body)]
{-
************************************************************************
......
......@@ -131,7 +131,7 @@ ppr_expr add_par expr@(App {})
let
pp_args = sep (map pprArg args)
val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples
pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args))
pp_tup_args = pprWithCommas pprCoreExpr val_args
in
case fun of
Var f -> case isDataConWorkId_maybe f of
......@@ -230,7 +230,7 @@ pprCoreAlt (con, args, rhs)
ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
ppr_case_pat (DataAlt dc) args
| Just sort <- tyConTuple_maybe tc
= tupleParens sort (hsep (punctuate comma (map ppr_bndr args)))
= tupleParens sort (pprWithCommas ppr_bndr args)
where
ppr_bndr = pprBndr CaseBind
tc = dataConTyCon dc
......
......@@ -722,7 +722,7 @@ tidy_pat (PArrPat ps ty)
[ty]
tidy_pat (TuplePat ps boxity tys)
= unLoc $ mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity)
= unLoc $ mkPrefixConPat (tupleDataCon boxity arity)
(map tidy_lpat ps) tys
where
arity = length ps
......
......@@ -152,7 +152,7 @@ coreCaseTuple uniqs scrut_var vars body
coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
coreCasePair scrut_var var1 var2 body
= Case (Var scrut_var) scrut_var (exprType body)
[(DataAlt (tupleCon BoxedTuple 2), [var1, var2], body)]
[(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)]
mkCorePairTy :: Type -> Type -> Type
mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]
......
......@@ -40,19 +40,18 @@ import Digraph
import PrelNames
import TysPrim ( mkProxyPrimTy )
import TyCon ( isTupleTyCon, tyConDataCons_maybe
, tyConName, isPromotedTyCon, isPromotedDataCon, tyConKind )
import TyCon
import TcEvidence
import TcType
import Type
import Kind (returnsConstraintKind)
import Coercion hiding (substCo)
import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon, mkListTy
import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy
, mkBoxedTupleTy, stringTy )
import Id
import MkId(proxyHashId)
import Class
import DataCon ( dataConTyCon, dataConWorkId )
import DataCon ( dataConTyCon )
import Name
import MkId ( seqId )
import IdInfo ( IdDetails(..) )
......@@ -70,7 +69,6 @@ import BasicTypes hiding ( TopLevel )
import DynFlags
import FastString
import ErrUtils( MsgDoc )
import ListSetOps( getNth )
import Util
import Control.Monad( when )
import MonadUtils
......@@ -853,23 +851,6 @@ dsEvTerm (EvCast tm co)
dsEvTerm (EvDFunApp df tys tms) = return (Var df `mkTyApps` tys `mkApps` (map Var tms))
dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions]
dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
dsEvTerm (EvTupleSel tm n)
= do { tup <- dsEvTerm tm
; let scrut_ty = exprType tup
(tc, tys) = splitTyConApp scrut_ty
Just [dc] = tyConDataCons_maybe tc
xs = mkTemplateLocals tys
the_x = getNth xs n
; ASSERT( isTupleTyCon tc )
return $
Case tup (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] }
dsEvTerm (EvTupleMk tms)
= return (Var (dataConWorkId dc) `mkTyApps` map idType tms `mkApps` map Var tms)
where
dc = tupleCon ConstraintTuple (length tms)
dsEvTerm (EvSuperClass d n)
= do { d' <- dsEvTerm d
; let (cls, tys) = getClassPredTys (exprType d')
......
......@@ -226,7 +226,7 @@ boxResult result_ty
_ -> []
return_result state anss
= mkCoreConApps (tupleCon UnboxedTuple (2 + length extra_result_tys))
= mkCoreConApps (tupleDataCon Unboxed (2 + length extra_result_tys))
(map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
++ (state : anss))
......@@ -290,9 +290,9 @@ mk_alt return_result (Just prim_res_ty, wrap_result)
let
the_rhs = return_result (Var state_id)
(wrap_result (Var result_id) : map Var as)
ccall_res_ty = mkTyConApp (tupleTyCon UnboxedTuple arity)
ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
(realWorldStatePrimTy : ls)
the_alt = ( DataAlt (tupleCon UnboxedTuple arity)
the_alt = ( DataAlt (tupleDataCon Unboxed arity)
, (state_id : args_ids)
, the_rhs
)
......
......@@ -23,7 +23,6 @@ import DsMonad
import Name
import NameEnv
import FamInstEnv( topNormaliseType )
import DsMeta
import HsSyn
......@@ -293,7 +292,7 @@ dsExpr (ExplicitTuple tup_args boxity)
-- The reverse is because foldM goes left-to-right
; return $ mkCoreLams lam_vars $
mkCoreConApps (tupleCon (boxityNormalTupleSort boxity) (length tup_args))
mkCoreConApps (tupleDataCon boxity (length tup_args))
(map (Type . exprType) args ++ args) }
dsExpr (HsSCC _ cc expr@(L loc _)) = do
......@@ -428,7 +427,7 @@ dsExpr (HsStatic expr@(L loc _)) = do
, srcLocCol $ realSrcSpanStart r
)
_ -> (0, 0)
srcLoc = mkCoreConApps (tupleCon BoxedTuple 2)
srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
[ Type intTy , Type intTy
, mkIntExprInt dflags line, mkIntExprInt dflags col
]
......
This diff is collapsed.
......@@ -43,7 +43,7 @@ import Maybes
import Util
import Name
import Outputable
import BasicTypes ( boxityNormalTupleSort, isGenerated )
import BasicTypes ( isGenerated )
import FastString
import Control.Monad( when )
......@@ -568,7 +568,7 @@ tidy1 _ (TuplePat pats boxity tys)
= return (idDsWrapper, unLoc tuple_ConPat)
where
arity = length pats
tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats tys
tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
-- LitPats: we *might* be able to replace these w/ a simpler form
tidy1 _ (LitPat lit)
......
......@@ -164,7 +164,6 @@ Library
IdInfo
Lexeme
Literal
DsMeta
Llvm
Llvm.AbsSyn
Llvm.MetaData
......@@ -422,6 +421,8 @@ Library
TcSplice
Class
Coercion
DsMeta
THNames
FamInstEnv
FunDeps
InstEnv
......
......@@ -48,7 +48,7 @@ import Name
import VarEnv
import Util
import VarSet
import BasicTypes ( TupleSort(UnboxedTuple) )
import BasicTypes ( Boxity(..) )
import TysPrim
import PrelNames
import TysWiredIn
......@@ -832,8 +832,9 @@ extractSubTerms recurse clos = liftM thirdOf3 . go 0 (nonPtrs clos)
let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws
return (ptr_i, ws1, Prim ty ws0)
unboxedTupleTerm ty terms = Term ty (Right (tupleCon UnboxedTuple (length terms)))
(error "unboxedTupleTerm: no HValue for unboxed tuple") terms
unboxedTupleTerm ty terms
= Term ty (Right (tupleDataCon Unboxed (length terms)))
(error "unboxedTupleTerm: no HValue for unboxed tuple") terms
-- Fast, breadth-first Type reconstruction
......
......@@ -993,14 +993,14 @@ cvtTypeKind ty_str ty
| n == 1
-> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
| otherwise
-> mk_apps (HsTyVar (getRdrName (tupleTyCon BoxedTuple n))) tys'
-> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
UnboxedTupleT n
| length tys' == n -- Saturated
-> if n==1 then return (head tys') -- Singleton tuples treated
-- like nothing (ie just parens)
else returnL (HsTupleTy HsUnboxedTuple tys')
| otherwise
-> mk_apps (HsTyVar (getRdrName (tupleTyCon UnboxedTuple n))) tys'
-> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys'
ArrowT
| [x',y'] <- tys' -> returnL (HsFunTy x' y')
| otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
......
......@@ -636,8 +636,7 @@ ppr_expr (SectionR op expr)
pp_infixly v = sep [pprInfixOcc v, pp_expr]
ppr_expr (ExplicitTuple exprs boxity)
= tupleParens (boxityNormalTupleSort boxity)
(fcat (ppr_tup_args $ map unLoc exprs))
= tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))
where
ppr_tup_args [] = []
ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
......
......@@ -302,17 +302,24 @@ pprParendPat p | hsPatNeedsParens p = parens (pprPat p)
| otherwise = pprPat p
pprPat :: (OutputableBndr name) => Pat name -> SDoc
pprPat (VarPat var) = pprPatBndr var
pprPat (WildPat _) = char '_'
pprPat (LazyPat pat) = char '~' <> pprParendLPat pat
pprPat (BangPat pat) = char '!' <> pprParendLPat pat
pprPat (AsPat name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat]
pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
pprPat (ParPat pat) = parens (ppr pat)
pprPat (VarPat var) = pprPatBndr var
pprPat (WildPat _) = char '_'
pprPat (LazyPat pat) = char '~' <> pprParendLPat pat
pprPat (BangPat pat) = char '!' <> pprParendLPat pat
pprPat (AsPat name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat]
pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
pprPat (ParPat pat) = parens (ppr pat)
pprPat (LitPat s) = ppr s
pprPat (NPat l Nothing _) = ppr l
pprPat (NPat l (Just _) _) = char '-' <> ppr l
pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k]
pprPat (SplicePat splice) = pprSplice splice
pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co
pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty
pprPat (ListPat pats _ _) = brackets (interpp'SP pats)
pprPat (PArrPat pats _) = paBrackets (interpp'SP pats)
pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats)
pprPat (PArrPat pats _) = paBrackets (interpp'SP pats)
pprPat (TuplePat pats bx _) = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
pat_binds = binds, pat_args = details })
......@@ -325,14 +332,6 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
<+> pprConArgs details
else pprUserCon (unLoc con) details
pprPat (LitPat s) = ppr s
pprPat (NPat l Nothing _) = ppr l
pprPat (NPat l (Just _) _) = char '-' <> ppr l
pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k]
pprPat (SplicePat splice) = pprSplice splice
pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co
pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty
pprUserCon :: (OutputableBndr con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
......
......@@ -825,7 +825,7 @@ ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty TyConPrec ty
ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds
ppr_mono_ty _ (HsTyVar name) = pprPrefixOcc name
ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2
ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys)
where std_con = case con of
HsUnboxedTuple -> UnboxedTuple
_ -> BoxedTuple
......
......@@ -24,7 +24,7 @@ import TcRnMonad
import TyCon
import ConLike
import DataCon (dataConName, dataConWorkId, dataConTyCon)
import PrelInfo (wiredInThings, basicKnownKeyNames)
import PrelInfo ( knownKeyNames )
import Id (idName, isDataConWorkId_maybe)
import TysWiredIn
import IfaceEnv
......@@ -303,14 +303,11 @@ serialiseName bh name _ = do
knownKeyNamesMap :: UniqFM Name
knownKeyNamesMap = listToUFM_Directly [(nameUnique n, n) | n <- knownKeyNames]
where
knownKeyNames :: [Name]
knownKeyNames = map getName wiredInThings ++ basicKnownKeyNames
-- See Note [Symbol table representation of names]
putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName _dict BinSymbolTable{
putName _dict BinSymbolTable{
bin_symtab_map = symtab_map_ref,
bin_symtab_next = symtab_next } bh name
| name `elemUFM` knownKeyNamesMap
......@@ -349,7 +346,7 @@ putTupleName_ bh tc tup_sort thing_tag
sort_tag = case tup_sort of
BoxedTuple -> 0
UnboxedTuple -> 1
ConstraintTuple -> 2
ConstraintTuple -> pprPanic "putTupleName:ConstraintTuple" (ppr tc)
-- See Note [Symbol table representation of names]
getSymtabName :: NameCacheUpdater
......@@ -370,11 +367,10 @@ getSymtabName _ncu _dict symtab bh = do
2 -> idName (dataConWorkId dc)
_ -> pprPanic "getSymtabName:unknown tuple thing" (ppr i)
where
dc = tupleCon sort arity
dc = tupleDataCon sort arity
sort = case (i .&. 0x30000000) `shiftR` 28 of
0 -> BoxedTuple
1 -> UnboxedTuple
2 -> ConstraintTuple
0 -> Boxed
1 -> Unboxed
_ -> pprPanic "getSymtabName:unknown tuple sort" (ppr i)
thing_tag = (i .&. 0x0CFFFFFF) `shiftR` 26
arity = fromIntegral (i .&. 0x03FFFFFF)
......
......@@ -21,6 +21,7 @@ module BuildTyCl (
import IfaceEnv
import FamInstEnv( FamInstEnvs )
import TysWiredIn( isCTupleTyConName )
import DataCon
import PatSyn
import Var
......@@ -282,6 +283,9 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
; rhs <- if use_newtype
then mkNewTyConRhs tycon_name rec_tycon dict_con
else if isCTupleTyConName tycon_name
then return (TupleTyCon { data_con = dict_con
, tup_sort = ConstraintTuple })
else return (mkDataTyConRhs [dict_con])
; let { clas_kind = mkPiKinds tvs constraintKind
...