import Demand ( StrictnessInfo )
import Literal ( Literal, maybeLitLit )
import PrimOp ( CCall, pprCCallOp )
-import DataCon ( dataConTyCon )
+import DataCon ( dataConTyCon, dataConSourceArity )
import TyCon ( isTupleTyCon, tupleTyConBoxity )
import Type ( Kind )
import FiniteMap ( lookupFM )
toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r)
---------------------
-toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (getName dc) (tupleTyConBoxity tc))
+toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (mk_hs_tup_con tc dc)
| otherwise = UfDataAlt (getName dc)
where
tc = dataConTyCon dc
toUfCon DEFAULT = UfDefault
---------------------
+mk_hs_tup_con tc dc = HsTupCon (getName dc) (tupleTyConBoxity tc) (dataConSourceArity dc)
+
+---------------------
toUfBndr x | isId x = UfValBinder (getName x) (toHsType (varType x))
| otherwise = UfTyBinder (getName x) (varType x)
= case isDataConId_maybe v of
-- We convert the *worker* for tuples into UfTuples
Just dc | isTupleTyCon tc && saturated
- -> UfTuple (HsTupCon (getName dc) (tupleTyConBoxity tc)) tup_args
+ -> UfTuple (mk_hs_tup_con tc dc) tup_args
where
val_args = dropWhile isTypeArg as
saturated = length val_args == idArity v
import Var ( TyVar, tyVarKind )
import Subst ( mkTyVarSubst, substTy )
import PprType ( {- instance Outputable Kind -}, pprParendKind )
-import BasicTypes ( Boxity(..), tupleParens )
+import BasicTypes ( Boxity(..), Arity, tupleParens )
import PrelNames ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey, hasKey,
usOnceTyConName, usManyTyConName
)
hsUsMany_Name = HsTyVar usManyTyConName
-----------------------
-data HsTupCon name = HsTupCon name Boxity
+data HsTupCon name = HsTupCon name Boxity Arity
instance Eq name => Eq (HsTupCon name) where
- (HsTupCon _ b1) == (HsTupCon _ b2) = b1==b2
+ (HsTupCon _ b1 a1) == (HsTupCon _ b2 a2) = b1==b2 && a1==a2
mkHsTupCon :: NameSpace -> Boxity -> [a] -> HsTupCon RdrName
-mkHsTupCon space boxity args = HsTupCon (mkTupConRdrName space boxity (length args)) boxity
+mkHsTupCon space boxity args = HsTupCon (mkTupConRdrName space boxity arity) boxity arity
+ where
+ arity = length args
hsTupParens :: HsTupCon name -> SDoc -> SDoc
-hsTupParens (HsTupCon _ b) p = tupleParens b p
+hsTupParens (HsTupCon _ b _) p = tupleParens b p
-----------------------
-- Combine adjacent for-alls.
toHsType ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind *
| not saturated = generic_case
- | isTupleTyCon tc = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc)) tys'
+ | isTupleTyCon tc = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc) (tyConArity tc)) tys'
| tc `hasKey` listTyConKey = HsListTy (head tys')
| tc `hasKey` usOnceTyConKey = hsUsOnce_Name -- must print !, . unqualified
| tc `hasKey` usManyTyConKey = hsUsMany_Name -- must print !, . unqualified
where
get (HsAppTy ty1 ty2) = get ty1 `unionNameSets` get ty2
get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` get ty
- get (HsTupleTy (HsTupCon n _) tys) = unitNameSet n
- `unionNameSets` extractHsTyNames_s tys
+ get (HsTupleTy con tys) = hsTupConFVs con `unionNameSets` extractHsTyNames_s tys
get (HsFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2
get (HsPredTy p) = extractHsPredTyNames p
get (HsOpTy ty1 tycon ty2) = get ty1 `unionNameSets` get ty2 `unionNameSets`
ufNoteFVs (UfCoerce ty) = extractHsTyNames ty
ufNoteFVs note = emptyFVs
-hsTupConFVs (HsTupCon n _) = unitFV n
+hsTupConFVs (HsTupCon n _ _) = unitFV n
\end{code}
%************************************************************************
import HsSyn
import HscTypes ( GlobalRdrEnv )
import HsTypes ( hsTyVarNames, pprHsContext )
-import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr, elemRdrEnv )
+import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, elemRdrEnv )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl,
extractRuleBndrsTyVars, extractHsTyRdrTyVars,
extractHsCtxtRdrTyVars, extractGenericPatTyVars
import RnMonad
import Class ( FunDep, DefMeth (..) )
+import DataCon ( dataConId )
import Name ( Name, OccName, nameOccName, NamedThing(..) )
import NameSet
import PrelInfo ( derivableClassKeys, cCallishClassKeys )
import PrelNames ( deRefStablePtr_RDR, newStablePtr_RDR,
bindIO_RDR, returnIO_RDR
)
+import TysWiredIn ( tupleCon )
import List ( partition, nub )
import Outputable
import SrcLoc ( SrcLoc )
-- Unboxed tuples are allowed to have poly-typed arguments. These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys)
+rnHsType doc (HsTupleTy (HsTupCon _ boxity arity) tys)
-- Don't do lookupOccRn, because this is built-in syntax
-- so it doesn't need to be in scope
= mapRn (rnHsType doc) tys `thenRn` \ tys' ->
- returnRn (HsTupleTy (HsTupCon n' boxity) tys')
+ returnRn (HsTupleTy (HsTupCon tup_name boxity arity) tys')
where
- n' = tupleTyCon_name boxity (length tys)
+ tup_name = tupleTyCon_name boxity arity
rnHsType doc (HsAppTy ty1 ty2)
\end{code}
\begin{code}
--- We use lookupOcc here because this is interface file only stuff
--- and we need the workers...
-rnHsTupCon (HsTupCon n boxity)
- = lookupOccRn n `thenRn` \ n' ->
- returnRn (HsTupCon n' boxity)
-
-rnHsTupConWkr (HsTupCon n boxity)
- -- Tuple construtors are for the *worker* of the tuple
- -- Going direct saves needless messing about
- = lookupOccRn (mkRdrNameWkr n) `thenRn` \ n' ->
- returnRn (HsTupCon n' boxity)
-\end{code}
-
-\begin{code}
rnForAll doc forall_tyvars ctxt ty
= bindTyVarsRn doc forall_tyvars $ \ new_tyvars ->
rnContext doc ctxt `thenRn` \ new_ctxt ->
= rnHsType (text "ccall") ty `thenRn` \ ty' ->
returnRn (UfCCall cc ty')
-rnCoreExpr (UfTuple con args)
- = rnHsTupConWkr con `thenRn` \ con' ->
- mapRn rnCoreExpr args `thenRn` \ args' ->
- returnRn (UfTuple con' args')
+rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
+ = mapRn rnCoreExpr args `thenRn` \ args' ->
+ returnRn (UfTuple (HsTupCon tup_name boxity arity) args')
+ where
+ tup_name = getName (dataConId (tupleCon boxity arity))
+ -- Get the *worker* name and use that
rnCoreExpr (UfApp fun arg)
= rnCoreExpr fun `thenRn` \ fun' ->
\begin{code}
rnCoreAlt (con, bndrs, rhs)
- = rnUfCon con bndrs `thenRn` \ con' ->
+ = rnUfCon con `thenRn` \ con' ->
bindCoreLocalsRn bndrs $ \ bndrs' ->
rnCoreExpr rhs `thenRn` \ rhs' ->
returnRn (con', bndrs', rhs')
rnNote UfInlineMe = returnRn UfInlineMe
-rnUfCon UfDefault _
+rnUfCon UfDefault
= returnRn UfDefault
-rnUfCon (UfTupleAlt tup_con) bndrs
- = rnHsTupCon tup_con `thenRn` \ (HsTupCon con' _) ->
- returnRn (UfDataAlt con')
- -- Makes the type checker a little easier
+rnUfCon (UfTupleAlt (HsTupCon _ boxity arity))
+ = returnRn (UfTupleAlt (HsTupCon tup_name boxity arity))
+ where
+ tup_name = getName (tupleCon boxity arity)
-rnUfCon (UfDataAlt con) _
+rnUfCon (UfDataAlt con)
= lookupOccRn con `thenRn` \ con' ->
returnRn (UfDataAlt con')
-rnUfCon (UfLitAlt lit) _
+rnUfCon (UfLitAlt lit)
= returnRn (UfLitAlt lit)
-rnUfCon (UfLitLitAlt lit ty) _
+rnUfCon (UfLitLitAlt lit ty)
= rnHsType (text "litlit") ty `thenRn` \ ty' ->
returnRn (UfLitLitAlt lit ty')
\end{code}
import Id ( Id, mkId, mkVanillaId, isDataConWrapId_maybe )
import MkId ( mkCCallOpId )
import IdInfo
-import DataCon ( dataConSig, dataConArgTys )
+import DataCon ( DataCon, dataConId, dataConSig, dataConArgTys )
import Type ( mkTyVarTys, splitAlgTyConApp_maybe )
+import TysWiredIn ( tupleCon )
import Var ( mkTyVar, tyVarKind )
import Name ( Name )
import Demand ( wwLazy )
tcGetUnique `thenNF_Tc` \ u ->
returnTc (Var (mkCCallOpId u cc ty'))
-tcCoreExpr (UfTuple (HsTupCon name _) args)
- = tcVar name `thenTc` \ con_id ->
- mapTc tcCoreExpr args `thenTc` \ args' ->
+tcCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
+ = mapTc tcCoreExpr args `thenTc` \ args' ->
let
-- Put the missing type arguments back in
con_args = map (Type . exprType) args' ++ args'
in
returnTc (mkApps (Var con_id) con_args)
+ where
+ con_id = dataConId (tupleCon boxity arity)
+
tcCoreExpr (UfLam bndr body)
= tcCoreLamBndr bndr $ \ bndr' ->
-- A case alternative is made quite a bit more complicated
-- by the fact that we omit type annotations because we can
-- work them out. True enough, but its not that easy!
-tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs)
- = tcVar con_name `thenTc` \ con_id ->
+tcCoreAlt scrut_ty alt@(con, names, rhs)
+ = tcConAlt con `thenTc` \ con ->
let
- con = case isDataConWrapId_maybe con_id of
- Just con -> con
- Nothing -> pprPanic "tcCoreAlt" (ppr con_id)
-
(main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
(_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of
arg_ids
#ifdef DEBUG
| length id_names /= length arg_tys
- = pprPanic "tcCoreAlts" (ppr (con_name, names, rhs) $$
+ = pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$
(ppr main_tyvars <+> ppr ex_tyvars) $$
ppr arg_tys)
| otherwise
tcExtendGlobalValEnv arg_ids $
tcCoreExpr rhs `thenTc` \ rhs' ->
returnTc (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
+
+
+tcConAlt :: UfConAlt Name -> TcM DataCon
+tcConAlt (UfTupleAlt (HsTupCon _ boxity arity))
+ = returnTc (tupleCon boxity arity)
+
+tcConAlt (UfDataAlt con_name)
+ = tcVar con_name `thenTc` \ con_id ->
+ returnTc (case isDataConWrapId_maybe con_id of
+ Just con -> con
+ Nothing -> pprPanic "tcCoreAlt" (ppr con_id))
\end{code}
\begin{code}
)
import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr,
instFunDeps, instFunDepsOfTheta )
-import FunDeps ( tyVarFunDep, oclose )
+import FunDeps ( oclose )
import TcUnify ( unifyKind, unifyOpenTypeKind )
-import Type ( Type, Kind, PredType(..), ThetaType,
+import Type ( Type, Kind, PredType(..), ThetaType, SigmaType, TauType,
mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy,
zipFunTys, hoistForAllTys,
mkSigmaTy, mkPredTy, mkTyConApp,
= kcBoxedType ty `thenTc` \ tau_ty ->
returnTc boxedTypeKind
-kcHsType (HsTupleTy (HsTupCon _ boxity) tys)
+kcHsType (HsTupleTy (HsTupCon _ boxity _) tys)
= mapTc kcTypeType tys `thenTc_`
returnTc (case boxity of
Boxed -> boxedTypeKind
= tc_arg_type wimp_out ty `thenTc` \ tau_ty ->
returnTc (mkListTy tau_ty)
-tc_type wimp_out (HsTupleTy (HsTupCon _ boxity) tys)
- = mapTc tc_tup_arg tys `thenTc` \ tau_tys ->
- returnTc (mkTupleTy boxity (length tys) tau_tys)
+tc_type wimp_out (HsTupleTy (HsTupCon _ boxity arity) tys)
+ = ASSERT( arity == length tys )
+ mapTc tc_tup_arg tys `thenTc` \ tau_tys ->
+ returnTc (mkTupleTy boxity arity tau_tys)
where
tc_tup_arg = case boxity of
Boxed -> tc_arg_type wimp_out
because the test can't fail (see is_ambig).
\begin{code}
+checkAmbiguity :: RecFlag -> Bool
+ -> [TyVar] -> ThetaType -> TauType
+ -> TcM SigmaType
checkAmbiguity wimp_out is_source_polytype forall_tyvars theta tau
| isRec wimp_out = returnTc sigma_ty
| otherwise = mapTc_ check_pred theta `thenTc_`
sigma_ty = mkSigmaTy forall_tyvars theta tau
tau_vars = tyVarsOfType tau
fds = instFunDepsOfTheta theta
- tvFundep = tyVarFunDep fds
- extended_tau_vars = oclose tvFundep tau_vars
+ extended_tau_vars = oclose fds tau_vars
is_ambig ct_var = (ct_var `elem` forall_tyvars) &&
not (ct_var `elemUFM` extended_tau_vars)
projects / ghc-hetmet.git / commitdiff