Commit e72062f5 authored by simonpj's avatar simonpj
Browse files

[project @ 1997-09-05 16:23:41 by simonpj]

SLPJ fixes
parent 73ac6d4b
......@@ -45,7 +45,11 @@ import Name ( isLocallyDefined, isWiredInName, modAndOcc, nameModule, pprOccNam
OccName, occNameString, nameOccName, nameString, isExported,
Name {-instance NamedThing-}, Provenance, NamedThing(..)
)
import TyCon ( TyCon(..) {-instance NamedThing-} )
import TyCon ( TyCon {-instance NamedThing-},
isSynTyCon, isAlgTyCon, isNewTyCon, tyConDataCons,
tyConTheta, tyConTyVars,
getSynTyConDefn
)
import Class ( GenClass(..){-instance NamedThing-}, SYN_IE(Class), classBigSig )
import FieldLabel ( FieldLabel{-instance NamedThing-},
fieldLabelName, fieldLabelType )
......@@ -403,30 +407,32 @@ upp_class clas = ifaceClass PprInterface clas
\begin{code}
ifaceTyCon :: PprStyle -> TyCon -> Doc
ifaceTyCon sty tycon
= case tycon of
DataTyCon uniq name kind tyvars theta data_cons deriv new_or_data
-> hsep [ ptext (keyword new_or_data),
ppr_decl_context sty theta,
ppr sty name,
hsep (map (pprTyVarBndr sty) tyvars),
ptext SLIT("="),
hsep (punctuate (ptext SLIT(" | ")) (map ppr_con data_cons)),
semi
]
SynTyCon uniq name kind arity tyvars ty
-> hsep [ ptext SLIT("type"),
ppr sty name,
hsep (map (pprTyVarBndr sty) tyvars),
ptext SLIT("="),
ppr sty ty,
semi
]
other -> pprPanic "pprIfaceTyDecl" (ppr PprDebug tycon)
| isSynTyCon tycon
= hsep [ ptext SLIT("type"),
ppr sty (getName tycon),
hsep (map (pprTyVarBndr sty) tyvars),
ptext SLIT("="),
ppr sty ty,
semi
]
where
keyword NewType = SLIT("newtype")
keyword DataType = SLIT("data")
(tyvars, ty) = getSynTyConDefn tycon
ifaceTyCon sty tycon
| isAlgTyCon tycon
= hsep [ ptext keyword,
ppr_decl_context sty (tyConTheta tycon),
ppr sty (getName tycon),
hsep (map (pprTyVarBndr sty) (tyConTyVars tycon)),
ptext SLIT("="),
hsep (punctuate (ptext SLIT(" | ")) (map ppr_con (tyConDataCons tycon))),
semi
]
where
keyword | isNewTyCon tycon = SLIT("newtype")
| otherwise = SLIT("data")
ppr_con data_con
| null field_labels
......@@ -458,6 +464,9 @@ ifaceTyCon sty tycon
ppr_strict_mark strict_mark <> pprParendType sty (fieldLabelType field_label)
]
ifaceTyCon sty tycon
= pprPanic "pprIfaceTyDecl" (ppr PprDebug tycon)
ifaceClass sty clas
= hsep [ptext SLIT("class"),
ppr_decl_context sty theta,
......
......@@ -16,7 +16,7 @@ IMP_Ubiq(){-uitous-}
import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
import Name ( mkWiredInTyConName )
import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn
import TyCon ( mkPrimTyCon, mkDataTyCon, SYN_IE(TyCon) )
import TyCon ( mkPrimTyCon, mkDataTyCon, TyCon )
import BasicTypes ( NewOrData(..) )
import Type ( applyTyCon, mkTyVarTys, mkTyConTy, SYN_IE(Type) )
import TyVar ( GenTyVar(..), alphaTyVars )
......@@ -44,9 +44,7 @@ pcPrimTyCon key str arity primrep
= the_tycon
where
name = mkWiredInTyConName key gHC__ str the_tycon
the_tycon = mkPrimTyCon name (mk_kind arity) primrep
mk_kind 0 = mkUnboxedTypeKind
mk_kind n = mkTypeKind `mkArrowKind` mk_kind (n-1)
the_tycon = mkPrimTyCon name arity primrep
charPrimTy = applyTyCon charPrimTyCon []
......
......@@ -411,10 +411,14 @@ show_uniq PprDebug u = ppr PprDebug u
show_uniq sty u = empty
\end{code}
Printing in error messages
Printing in error messages. These two must look the same.
\begin{code}
noInstanceErr inst sty = ptext SLIT("No instance for:") <+> ppr sty inst
noSimpleInst clas ty sty
= ptext SLIT("No instance for:") <+>
(pprQuote sty (\ sty -> ppr sty clas <+> pprParendGenType sty ty))
\end{code}
%************************************************************************
......@@ -534,10 +538,6 @@ lookupSimpleInst class_inst_env clas ty
Just (dfun,tenv) -> returnTc [(c,instantiateTy tenv t) | (c,t) <- theta]
where
(_, theta, _) = splitSigmaTy (idType dfun)
noSimpleInst clas ty sty
= ptext SLIT("No instance for") <+>
(pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty)
\end{code}
......
......@@ -26,7 +26,7 @@ import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr),
mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod )
import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcAddImportedIdInfo,
import TcEnv ( tcLookupClass, tcLookupTyVar, newLocalIds, tcAddImportedIdInfo,
tcExtendGlobalTyVars )
import TcBinds ( tcBindWithSigs, TcSigInfo(..) )
import TcKind ( unifyKind, TcKind )
......
......@@ -37,7 +37,7 @@ import RnEnv ( newDfunName, bindLocatedLocalsRn )
import RnMonad ( SYN_IE(RnM), RnDown, GDown, SDown, RnNameSupply(..),
setNameSupplyRn, renameSourceCode, thenRn, mapRn, returnRn )
import Bag ( Bag, isEmptyBag, unionBags, listToBag )
import Bag ( Bag, emptyBag, isEmptyBag, unionBags, listToBag )
import Class ( classKey, GenClass, SYN_IE(Class) )
import ErrUtils ( addErrLoc, SYN_IE(Error) )
import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId )
......@@ -48,7 +48,7 @@ import Name ( isLocallyDefined, getSrcLoc, ExportFlag(..), Provenance,
)
import Outputable ( PprStyle(..), Outputable(..){-instances e.g., (,)-} )
import PprType ( GenType, GenTyVar, GenClass, TyCon )
import Pretty ( ($$), vcat, hsep, hcat, parens,
import Pretty ( ($$), vcat, hsep, hcat, parens, empty, (<+>),
ptext, char, hang, Doc )
import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
......@@ -207,7 +207,9 @@ tcDeriving :: Module -- name of module under scrutiny
-- for debugging via -ddump-derivings.
tcDeriving modname rn_name_supply inst_decl_infos_in
= -- Fish the "deriving"-related information out of the TcEnv
= recoverTc (returnTc (emptyBag, EmptyBinds, \_ -> empty)) $
-- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
makeDerivEqns `thenTc` \ eqns ->
......@@ -431,13 +433,21 @@ solveDerivEqns inst_decl_infos_in orig_eqns
initial_solutions :: [DerivSoln]
initial_solutions = [ [] | _ <- orig_eqns ]
------------------------------------------------------------------
-- iterateDeriv calculates the next batch of solutions,
-- compares it with the current one; finishes if they are the
-- same, otherwise recurses with the new solutions.
-- It fails if any iteration fails
iterateDeriv :: [DerivSoln] ->TcM s [InstInfo]
iterateDeriv current_solns
= checkNoErrsTc (iterateOnce current_solns) `thenTc` \ (new_inst_infos, new_solns) ->
if (current_solns `eq_solns` new_solns) then
returnTc new_inst_infos
else
iterateDeriv new_solns
------------------------------------------------------------------
iterateOnce current_solns
= -- Extend the inst info from the explicit instance decls
-- with the current set of solutions, giving a
......@@ -448,27 +458,24 @@ solveDerivEqns inst_decl_infos_in orig_eqns
in
-- Simplify each RHS
listTc [ tcSimplifyThetas class_to_inst_env [{-Nothing "given"-}] deriv_rhs
| (_,_,_,deriv_rhs) <- orig_eqns ] `thenTc` \ next_solns ->
listTc [ tcAddErrCtxt (derivCtxt tc) $
tcSimplifyThetas class_to_inst_env [{-Nothing "given"-}] deriv_rhs
| (_,tc,_,deriv_rhs) <- orig_eqns ] `thenTc` \ next_solns ->
-- Canonicalise the solutions, so they compare nicely
let canonicalised_next_solns
= [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in
if (current_solns `eq_solns` canonicalised_next_solns) then
returnTc new_inst_infos
else
iterateDeriv canonicalised_next_solns
= [ sortLt lt_rhs next_soln | next_soln <- next_solns ]
in
returnTc (new_inst_infos, canonicalised_next_solns)
where
------------------------------------------------------------------
lt_rhs r1 r2 = case cmp_rhs r1 r2 of { LT_ -> True; _ -> False }
eq_solns s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False }
cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2
cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2)
------------------------------------------------------------------
lt_rhs r1 r2 = case cmp_rhs r1 r2 of { LT_ -> True; _ -> False }
eq_solns s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False }
cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2
cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2)
= (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2)
#ifdef DEBUG
cmp_rhs other_1 other_2
cmp_rhs other_1 other_2
= panic# "tcDeriv:cmp_rhs:" --(hsep [ppr PprDebug other_1, ppr PprDebug other_2])
#endif
......@@ -483,9 +490,16 @@ add_solns :: Bag InstInfo -- The global, non-derived ones
-- because we need the LHS info for addClassInstance.
add_solns inst_infos_in eqns solns
= discardErrsTc (buildInstanceEnvs all_inst_infos) `thenTc` \ inst_mapper ->
-- ------------------
-- OLD: checkErrsTc above now deals with this
-- = discardErrsTc (buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
-- We do the discard-errs so that we don't get repeated error messages
-- about missing or duplicate instances.
-- about duplicate instances.
-- They'll appear later, when we do the top-level buildInstanceEnvs.
-- ------------------
= buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
returnTc (new_inst_infos, inst_mapper)
where
new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns
......@@ -503,7 +517,8 @@ add_solns inst_infos_in eqns solns
(my_panic "upragmas")
where
dummy_dfun_id
= mkDictFunId bottom dummy_dfun_ty bottom bottom
= mkDictFunId (getName tycon) dummy_dfun_ty bottom bottom
-- The name is getSrcLoc'd in an error message
where
bottom = panic "dummy_dfun_id"
......@@ -722,4 +737,7 @@ derivingThingErr thing why tycon sty
= hang (hsep [ptext SLIT("Can't make a derived instance of"), ptext thing])
0 (hang (hsep [ptext SLIT("for the type"), ppr sty tycon])
0 (parens (ptext why)))
derivCtxt tycon sty
= ptext SLIT("When deriving classes for") <+> ppr sty tycon
\end{code}
......@@ -39,7 +39,7 @@ import TcType ( SYN_IE(TcIdBndr), TcIdOcc(..),
import TyVar ( unionTyVarSets, emptyTyVarSet, tyVarSetToList, SYN_IE(TyVar) )
import PprType ( GenTyVar )
import Type ( tyVarsOfTypes, splitForAllTy )
import TyCon ( TyCon, tyConKind, synTyConArity, SYN_IE(Arity) )
import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon, SYN_IE(Arity) )
import Class ( SYN_IE(Class), GenClass )
import TcMonad
......@@ -141,21 +141,34 @@ tcLookupTyVar name
tcLookupTyCon name
= case maybeWiredInTyConName name of
Just tc -> returnTc (kindToTcKind (tyConKind tc), synTyConArity tc, tc)
Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
case lookupUFM tce name of
Just stuff -> returnTc stuff
Nothing -> -- Could be that he's using a class name as a type constructor
case lookupUFM ce name of
Just _ -> failTc (classAsTyConErr name)
Nothing -> pprPanic "tcLookupTyCon:" (ppr PprDebug name)
= -- Try for a wired-in tycon
case maybeWiredInTyConName name of {
Just tc | isSynTyCon tc -> returnTc (kind, Just (tyConArity tc), tc)
| otherwise -> returnTc (kind, Nothing, tc)
where {
kind = kindToTcKind (tyConKind tc)
};
Nothing ->
-- Try in the environment
tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
case lookupUFM tce name of {
Just stuff -> returnTc stuff;
Nothing ->
-- Could be that he's using a class name as a type constructor
case lookupUFM ce name of
Just _ -> failTc (classAsTyConErr name)
Nothing -> pprPanic "tcLookupTyCon:" (ppr PprDebug name)
} }
tcLookupTyConByKey uniq
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
let
(kind, arity, tycon) = lookupWithDefaultUFM_Directly tce
(pprPanic "tcLookupTyCon:" (pprUnique10 uniq))
(pprPanic "tcLookupTyConByKey:" (pprUnique10 uniq))
uniq
in
returnNF_Tc tycon
......
......@@ -66,7 +66,9 @@ import TysWiredIn ( addrTy,
boolTy, charTy, stringTy, mkListTy,
mkTupleTy, mkPrimIoTy, stDataCon
)
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists,
unifyFunTy, unifyListTy, unifyTupleTy
)
import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
......@@ -334,15 +336,11 @@ tcExpr in_expr@(ExplicitList exprs) res_ty -- Non-empty list
tcExpr expr elt_ty
tcExpr (ExplicitTuple exprs) res_ty
-- ToDo: more direct way of testing if res_ty is a tuple type (cf. unifyListTy)?
= mapNF_Tc (\ _ -> newTyVarTy mkBoxedTypeKind) [1..len] `thenNF_Tc` \ ty_vars ->
unifyTauTy (mkTupleTy len ty_vars) res_ty `thenTc_`
mapAndUnzipTc (\ (expr,ty_var) -> tcExpr expr ty_var)
(exprs `zip` ty_vars) -- we know they're of equal length.
= unifyTupleTy (length exprs) res_ty `thenTc` \ arg_tys ->
mapAndUnzipTc (\ (expr, arg_ty) -> tcExpr expr arg_ty)
(exprs `zip` arg_tys) -- we know they're of equal length.
`thenTc` \ (exprs', lies) ->
returnTc (ExplicitTuple exprs', plusLIEs lies)
where
len = length exprs
tcExpr (RecordCon con rbinds) res_ty
= tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
......@@ -483,7 +481,7 @@ tcExpr (RecordUpd record_expr rbinds) res_ty
tcExpr (ArithSeqIn seq@(From expr)) res_ty
= unifyListTy res_ty `thenTc` \ elt_ty ->
tcExpr expr elt_ty `thenTc` \ (expr', lie1) ->
tcExpr expr elt_ty `thenTc` \ (expr', lie1) ->
tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq)
......@@ -549,11 +547,9 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
let
(sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
in
unifyTauTy sig_tau' res_ty `thenTc_`
-- Type check the expression, *after* we've incorporated the signature
-- info into res_ty
tcExpr expr res_ty `thenTc` \ (texpr, lie) ->
-- Type check the expression, expecting the signature type
tcExpr expr sig_tau' `thenTc` \ (texpr, lie) ->
-- Check the type variables of the signature,
-- *after* typechecking the expression
......@@ -565,6 +561,13 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
(mkTyVarSet sig_tyvars')
sig_dicts lie `thenTc_`
-- Now match the signature type with res_ty.
-- We must not do this earlier, because res_ty might well
-- mention variables free in the environment, and we'd get
-- bogus complaints about not being able to for-all the
-- sig_tyvars
unifyTauTy sig_tau' res_ty `thenTc_`
-- If everything is ok, return the stuff unchanged, except for
-- the effect of any substutions etc. We simply discard the
-- result of the tcSimplifyAndCheck, except for any default
......@@ -588,20 +591,6 @@ tcExpr_id id_expr
other -> newTyVarTy mkTypeKind `thenNF_Tc` \ id_ty ->
tcExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) ->
returnTc (id_expr', lie_id, id_ty)
--ToDo: move to Unify?
unifyListTy :: TcType s -- expected list type
-> TcM s (TcType s) -- list element type
unifyListTy res_ty
-- ToDo: more direct way of testing if res_ty is a list type (cf. unifyFunTy)?
= newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ elt_ty ->
unifyTauTy (mkListTy elt_ty) res_ty `thenTc_`
-- This zonking makes the returned type as informative
-- as possible.
zonkTcType elt_ty `thenNF_Tc` \ elt_ty' ->
returnTc elt_ty'
\end{code}
%************************************************************************
......
......@@ -192,8 +192,7 @@ tcInstDecls1 unf_env decls mod_name rn_name_supply
in
-- Handle "derived" instances; note that we only do derivings
-- for things in this module; we ignore deriving decls from
-- interfaces! We pass fixities, because they may be used
-- in deriving Read and Show.
-- interfaces!
tcDeriving mod_name rn_name_supply decl_inst_info
`thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
......
......@@ -17,7 +17,7 @@ module TcMonad(
listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
failTc, warnTc, recoverTc, recoverNF_Tc, discardErrsTc,
failTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
tcGetEnv, tcSetEnv,
tcGetDefaultTys, tcSetDefaultTys,
......@@ -316,6 +316,40 @@ recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
recoverNF_Tc recover m down env
= recoverSST (\ _ -> recover down env) (m down env)
-- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
-- If m fails then (checkNoErrsTc m) fails.
-- If m succeeds, it checks whether m generated any errors messages
-- (it might have recovered internally)
-- If so, it fails too.
-- Regardless, any errors generated by m are propagated to the enclosing
-- context.
checkNoErrsTc :: TcM s r -> TcM s r
checkNoErrsTc m down env
= newMutVarSST (emptyBag,emptyBag) `thenSST` \ m_errs_var ->
let
errs_var = getTcErrs down
propagate_errs
= readMutVarSST m_errs_var `thenSST` \ (m_warns, m_errs) ->
readMutVarSST errs_var `thenSST` \ (warns, errs) ->
writeMutVarSST errs_var (warns `unionBags` m_warns,
errs `unionBags` m_errs) `thenSST_`
returnSST m_errs
in
recoverFSST (\ _ -> propagate_errs `thenSST_` failFSST ()) $
m (setTcErrs down m_errs_var) env `thenFSST` \ result ->
-- Check that m has no errors; if it has internal recovery
-- mechanisms it might "succeed" but having found a bunch of
-- errors along the way.
propagate_errs `thenSST` \ errs ->
if isEmptyBag errs then
returnFSST result
else
failFSST ()
-- (tryTc r m) tries m; if it succeeds it returns it,
-- otherwise it returns r. Any error messages added by m are discarded,
-- whether or not m succeeds.
......
......@@ -9,21 +9,25 @@ updatable substitution).
\begin{code}
#include "HsVersions.h"
module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) where
module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists,
unifyFunTy, unifyListTy, unifyTupleTy
) where
IMP_Ubiq()
-- friends:
import TcMonad
import Type ( GenType(..), typeKind, mkFunTy, getFunTy_maybe )
import TyCon ( TyCon, mkFunTyCon )
import Type ( GenType(..), typeKind, mkFunTy, getFunTy_maybe, splitAppTys )
import TyCon ( TyCon, mkFunTyCon, isTupleTyCon, tyConArity )
import Class ( GenClass )
import TyVar ( GenTyVar(..), SYN_IE(TyVar), tyVarKind )
import TcType ( SYN_IE(TcType), TcMaybe(..), SYN_IE(TcTauType), SYN_IE(TcTyVar),
newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType
)
-- others:
import Kind ( Kind, hasMoreBoxityInfo, mkTypeKind )
import Kind ( Kind, hasMoreBoxityInfo, mkTypeKind, mkBoxedTypeKind )
import TysWiredIn ( listTyCon, mkListTy, mkTupleTy )
import Usage ( duffUsage )
import PprType ( GenTyVar, GenType ) -- instances
import Pretty
......@@ -317,20 +321,62 @@ unifyFunTy ty@(TyVarTy tyvar)
= tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
BoundTo ty' -> unifyFunTy ty'
other -> unify_fun_ty_help ty
UnBound -> newTyVarTy mkTypeKind `thenNF_Tc` \ arg ->
newTyVarTy mkTypeKind `thenNF_Tc` \ res ->
tcWriteTyVar tyvar (mkFunTy arg res) `thenNF_Tc_`
returnTc (arg,res)
unifyFunTy ty
= case getFunTy_maybe ty of
Just arg_and_res -> returnTc arg_and_res
Nothing -> unify_fun_ty_help ty
DontBind -> failTc (expectedFunErr ty)
unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification
= newTyVarTy mkTypeKind `thenNF_Tc` \ arg ->
newTyVarTy mkTypeKind `thenNF_Tc` \ res ->
unifyTauTy (mkFunTy arg res) ty `thenTc_`
returnTc (arg,res)
\end{code}
unifyFunTy other_ty
= case getFunTy_maybe other_ty of
Just arg_and_res -> returnTc arg_and_res
Nothing -> failTc (expectedFunErr other_ty)
\begin{code}
unifyListTy :: TcType s -- expected list type
-> TcM s (TcType s) -- list element type
unifyListTy ty@(TyVarTy tyvar)
= tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
BoundTo ty' -> unifyListTy ty'
other -> unify_list_ty_help ty
unifyListTy (AppTy (TyConTy tycon _) arg_ty)
| tycon == listTyCon
= returnTc arg_ty
unifyListTy ty = unify_list_ty_help ty
unify_list_ty_help ty -- Revert to ordinary unification
= newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ elt_ty ->
unifyTauTy (mkListTy elt_ty) ty `thenTc_`
returnTc elt_ty
\end{code}
\begin{code}
unifyTupleTy :: Arity -> TcType s -> TcM s [TcType s]
unifyTupleTy arity ty@(TyVarTy tyvar)
= tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
BoundTo ty' -> unifyTupleTy arity ty'
other -> unify_tuple_ty_help arity ty
unifyTupleTy arity ty
= case splitAppTys ty of
(TyConTy tycon _, arg_tys) | isTupleTyCon tycon
&& tyConArity tycon == arity
-> returnTc arg_tys
other -> unify_tuple_ty_help arity ty
unify_tuple_ty_help arity ty
= mapNF_Tc (\ _ -> newTyVarTy mkBoxedTypeKind) [1..arity] `thenNF_Tc` \ arg_tys ->
unifyTauTy (mkTupleTy arity arg_tys) ty `thenTc_`
returnTc arg_tys
\end{code}
%************************************************************************
%* *
......
......@@ -34,7 +34,7 @@ import {-# SOURCE #-} Id
import Type ( GenType(..), maybeAppTyCon, Type(..), splitFunTy,
splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTys )
import TyVar ( GenTyVar(..), TyVar(..), cloneTyVar )
import TyCon ( TyCon(..), NewOrData )
import TyCon ( TyCon, NewOrData, isFunTyCon, isTupleTyCon, tyConArity )
import Class ( SYN_IE(Class), GenClass(..) )
import Kind ( Kind(..), isBoxedTypeKind, pprParendKind )
import Usage ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar), cloneUVar )
......@@ -199,15 +199,16 @@ ppr_ty env ctxt_prec (DictTy clas ty usage)
-- Some help functions
ppr_corner env ctxt_prec (TyConTy FunTyCon usage) arg_tys
| length arg_tys == 2
ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
| isFunTyCon tycon && length arg_tys == 2
= ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
where
(ty1:ty2:_) = arg_tys
ppr_corner env ctxt_prec (TyConTy (TupleTyCon _ _ arity) usage) arg_tys
| not (codeStyle (pStyle env)) -- no magic in that case
&& length arg_tys == arity -- no magic if partially applied
ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
| isTupleTyCon tycon
&& not (codeStyle (pStyle env)) -- no magic in that case
&& length arg_tys == tyConArity tycon -- no magic if partially applied
= parens arg_tys_w_commas
where
arg_tys_w_commas = hsep (punctuate comma (map (ppr_ty env tOP_PREC) arg_tys))
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[TyCon]{The @TyCon@ datatype}
......@@ -7,12 +7,13 @@
#include "HsVersions.h"
module TyCon(
TyCon(..), -- NB: some pals need to see representation
TyCon,
SYN_IE(Arity), NewOrData(..),
isFunTyCon, isPrimTyCon, isBoxedTyCon,
isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, maybeNewTyCon,
isEnumerationTyCon, isTupleTyCon,
mkDataTyCon,
mkFunTyCon,
......@@ -30,11 +31,10 @@ module TyCon(
tyConDerivings,
tyConTheta,
tyConPrimRep,
synTyConArity,
tyConArity,
getSynTyConDefn,
maybeTyConSingleCon,
isEnumerationTyCon, isTupleTyCon,
derivedClasses
) where
......@@ -58,8 +58,9 @@ import {-# SOURCE #-} TysWiredIn ( tupleCon )
import BasicTypes ( SYN_IE(Arity), NewOrData(..) )
import TyVar ( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar, SYN_IE(TyVar) )
import Usage ( GenUsage, SYN_IE(Usage) )
import Kind ( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkUnboxedTypeKind,
mkArrowKind, resultKind, argKind
)
import Maybes
import Name ( Name, nameUnique, mkWiredInTyConName, NamedThing(getName) )
import Unique ( Unique, funTyConKey, Uniquable(..) )
......@@ -102,6 +103,7 @@ data TyCon
Unique -- Always unboxed; hence never represented by a closure
Name -- Often represented by a bit-pattern for the thing
Kind -- itself (eg Int#), but sometimes by a pointer to
Arity
PrimRep
| SpecTyCon -- A specialised TyCon; eg (Arr# Int#), or (List Int#)
......@@ -134,13 +136,19 @@ mkSpecTyCon = SpecTyCon