Commit 2fa402dd authored by simonpj's avatar simonpj
Browse files

[project @ 2000-12-07 08:26:47 by simonpj]

Better handling of HsTupCon (tidy up + fix minor versioning bug)
parent 9fc29e6e
......@@ -45,7 +45,7 @@ import PrimOp ( PrimOp(CCallOp) )
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 )
......@@ -134,7 +134,7 @@ toUfBind (Rec prs) = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs]
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
......@@ -144,6 +144,9 @@ toUfCon (LitAlt l) = case maybeLitLit l of
Nothing -> UfLitAlt l
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)
......@@ -154,7 +157,7 @@ toUfApp (Var v) as
= 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
......
......@@ -38,7 +38,7 @@ import OccName ( NameSpace, tvName )
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
)
......@@ -92,16 +92,18 @@ hsUsOnce_Name = HsTyVar usOnceTyConName
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.
......@@ -304,7 +306,7 @@ toHsType (PredTy p) = HsPredTy (toHsPred p)
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
......
......@@ -77,8 +77,7 @@ extractHsTyNames ty
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`
......@@ -205,7 +204,7 @@ ufConFVs other = emptyFVs
ufNoteFVs (UfCoerce ty) = extractHsTyNames ty
ufNoteFVs note = emptyFVs
hsTupConFVs (HsTupCon n _) = unitFV n
hsTupConFVs (HsTupCon n _ _) = unitFV n
\end{code}
%************************************************************************
......
......@@ -14,7 +14,7 @@ import RnExpr
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
......@@ -34,12 +34,14 @@ import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName, lookupIfaceName,
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 )
......@@ -612,13 +614,13 @@ rnHsType doc (HsListTy ty)
-- 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)
......@@ -633,20 +635,6 @@ rnHsType doc (HsPredTy pred)
rnHsTypes doc tys = mapRn (rnHsType doc) tys
\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 ->
......@@ -749,10 +737,12 @@ rnCoreExpr (UfCCall cc ty)
= 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' ->
......@@ -810,7 +800,7 @@ rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' ->
\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')
......@@ -824,22 +814,22 @@ rnNote UfInlineCall = returnRn UfInlineCall
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}
......
......@@ -32,8 +32,9 @@ import WorkWrap ( mkWrapper )
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 )
......@@ -205,14 +206,16 @@ tcCoreExpr (UfCCall cc ty)
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' ->
......@@ -320,13 +323,9 @@ tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
-- 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
......@@ -339,7 +338,7 @@ tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs)
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
......@@ -351,6 +350,17 @@ tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs)
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}
......
......@@ -35,9 +35,9 @@ import TcType ( TcKind, TcTyVar, TcThetaType, TcTauType,
)
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,
......@@ -190,7 +190,7 @@ kcHsType (HsListTy ty)
= 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
......@@ -345,9 +345,10 @@ tc_type wimp_out (HsListTy ty)
= 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
......@@ -547,6 +548,9 @@ and then we don't need to check for ambiguity either,
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_`
......@@ -555,8 +559,7 @@ checkAmbiguity wimp_out is_source_polytype forall_tyvars theta tau
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)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment