Mon Sep 18 19:23:39 EDT 2006 Manuel M T Chakravarty <chak@cse.unsw.edu.au>
* Check category of type instances and some newtype family fixes
Thu Aug 31 16:54:14 EDT 2006 Manuel M T Chakravarty <chak@cse.unsw.edu.au>
* Check category of type instances and some newtype family fixes
tyConDataCons, mkForeignTyCon, isProductTyCon,
isRecursiveTyCon, isOpenTyCon,
tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName,
tyConDataCons, mkForeignTyCon, isProductTyCon,
isRecursiveTyCon, isOpenTyCon,
tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName,
- isNewTyCon, tyConKind, setTyConArgPoss )
+ isNewTyCon, isDataTyCon, tyConKind,
+ setTyConArgPoss )
import DataCon ( DataCon, dataConUserType, dataConName,
dataConFieldLabels, dataConTyCon, dataConAllTyVars,
dataConFieldType, dataConResTys )
import DataCon ( DataCon, dataConUserType, dataConName,
dataConFieldLabels, dataConTyCon, dataConAllTyVars,
dataConFieldType, dataConResTys )
import Outputable
import Maybe ( isJust, fromJust, isNothing, catMaybes )
import Maybes ( expectJust )
import Outputable
import Maybe ( isJust, fromJust, isNothing, catMaybes )
import Maybes ( expectJust )
import Unify ( tcMatchTys, tcMatchTyX )
import Util ( zipLazy, isSingleton, notNull, sortLe )
import List ( partition, elemIndex )
import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan )
import ListSetOps ( equivClasses, minusList )
import Unify ( tcMatchTys, tcMatchTyX )
import Util ( zipLazy, isSingleton, notNull, sortLe )
import List ( partition, elemIndex )
import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan )
import ListSetOps ( equivClasses, minusList )
import Digraph ( SCC(..) )
import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics,
Opt_UnboxStrictFields ) )
import Digraph ( SCC(..) )
import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics,
Opt_UnboxStrictFields ) )
-> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error
tcIdxTyInstDecl1 (decl@TySynonym {})
-> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error
tcIdxTyInstDecl1 (decl@TySynonym {})
- = kcIdxTyPats decl $ \k_tvs k_typats resKind _ ->
- do { -- (1) kind check the right hand side of the type equation
+ = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
+ do { -- check that the family declaration is for a synonym
+ unless (isSynTyCon family) $
+ addErr (wrongKindOfFamily family)
+
+ ; -- (1) kind check the right hand side of the type equation
; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
-- (2) type check type equation
; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
-- (2) type check type equation
tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
tcdCons = cons})
= kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
tcdCons = cons})
= kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
- do { -- (1) kind check the data declaration as usual
+ do { -- check that the family declaration is for the right kind
+ unless (new_or_data == NewType && isNewTyCon family ||
+ new_or_data == DataType && isDataTyCon family) $
+ addErr (wrongKindOfFamily family)
+
+ ; -- (1) kind check the data declaration as usual
; k_decl <- kcDataDecl decl k_tvs
; let k_ctxt = tcdCtxt k_decl
k_cons = tcdCons k_decl
; k_decl <- kcDataDecl decl k_tvs
; let k_ctxt = tcdCtxt k_decl
k_cons = tcdCons k_decl
= ptext SLIT("Indexed type instance has too few parameters:") <+>
quotes (ppr tc_name)
= ptext SLIT("Indexed type instance has too few parameters:") <+>
quotes (ppr tc_name)
-badBootTyIdxDeclErr = ptext SLIT("Illegal indexed type instance in hs-boot file")
+badBootTyIdxDeclErr =
+ ptext SLIT("Illegal indexed type instance in hs-boot file")
+
+wrongKindOfFamily family =
+ ptext SLIT("Wrong category of type instance; declaration was for a") <+>
+ kindOfFamily
+ where
+ kindOfFamily | isSynTyCon family = ptext SLIT("type synonym")
+ | isDataTyCon family = ptext SLIT("data type")
+ | isNewTyCon family = ptext SLIT("newtype")
emptyConDeclsErr tycon
= sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
emptyConDeclsErr tycon
= sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
import HscTypes ( TyThing(..), ModDetails(..) )
import TyCon ( TyCon, tyConArity, tyConDataCons, tyConTyVars,
isSynTyCon, isAlgTyCon,
import HscTypes ( TyThing(..), ModDetails(..) )
import TyCon ( TyCon, tyConArity, tyConDataCons, tyConTyVars,
isSynTyCon, isAlgTyCon,
- tyConName, isNewTyCon, isProductTyCon, newTyConRhs )
+ tyConName, isNewTyCon, isProductTyCon, newTyConRhs,
+ isOpenTyCon )
import Class ( classTyCon )
import DataCon ( dataConOrigArgTys )
import Var ( TyVar )
import Class ( classTyCon )
import DataCon ( dataConOrigArgTys )
import Var ( TyVar )
-- rather less nice, so I'm not going to do that yet.
--------------- Newtypes ----------------------
-- rather less nice, so I'm not going to do that yet.
--------------- Newtypes ----------------------
- new_tycons = filter isNewTyCon all_tycons
+ new_tycons = filter isNewTyConAndNotOpen all_tycons
+ isNewTyConAndNotOpen tycon = isNewTyCon tycon && not (isOpenTyCon tycon)
nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers
-- is_rec_nt is a locally-used helper function
nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers
-- is_rec_nt is a locally-used helper function
OpenNewTyCon -> False
NewTyCon {} -> False
AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc)
OpenNewTyCon -> False
NewTyCon {} -> False
AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc)
isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
isDataTyCon other = False
isNewTyCon :: TyCon -> Bool
isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
isDataTyCon other = False
isNewTyCon :: TyCon -> Bool
-isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True
-isNewTyCon other = False
+isNewTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of
+ OpenNewTyCon -> True
+ NewTyCon {} -> True
+ _ -> False
+isNewTyCon other = False
isProductTyCon :: TyCon -> Bool
-- A "product" tycon
isProductTyCon :: TyCon -> Bool
-- A "product" tycon
newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon)
newTyConCo :: TyCon -> Maybe TyCon
newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon)
newTyConCo :: TyCon -> Maybe TyCon
-newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }}) = co
+newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }})
+ = co
+newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = OpenNewTyCon})
+ = Nothing
newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon)
tyConPrimRep :: TyCon -> PrimRep
newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon)
tyConPrimRep :: TyCon -> PrimRep
ubxTupleKindTyConKey, argTypeKindTyConKey )
import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
ubxTupleKindTyConKey, argTypeKindTyConKey )
import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
- isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs,
+ isFunTyCon, isNewTyCon, isOpenTyCon, newTyConRep,
+ newTyConRhs,
isAlgTyCon, tyConArity, isSuperKindTyCon,
tcExpandTyCon_maybe, coreExpandTyCon_maybe,
tyConKind, PrimRep(..), tyConPrimRep, tyConUnique,
isAlgTyCon, tyConArity, isSuperKindTyCon,
tcExpandTyCon_maybe, coreExpandTyCon_maybe,
tyConKind, PrimRep(..), tyConPrimRep, tyConUnique,
(b) synonyms
(c) predicates
(d) usage annotations
(b) synonyms
(c) predicates
(d) usage annotations
- (e) all newtypes, including recursive ones
+ (e) all newtypes, including recursive ones, but not newtype families
It's useful in the back end.
\begin{code}
It's useful in the back end.
\begin{code}
repType ty | Just ty' <- coreView ty = repType ty'
repType (ForAllTy _ ty) = repType ty
repType (TyConApp tc tys)
repType ty | Just ty' <- coreView ty = repType ty'
repType (ForAllTy _ ty) = repType ty
repType (TyConApp tc tys)
- | isNewTyCon tc = -- Recursive newtypes are opaque to coreView
+ | isNewTyCon tc &&
+ not (isOpenTyCon tc) = -- Recursive newtypes are opaque to coreView
-- but we must expand them here. Sure to
-- be saturated because repType is only applied
-- to types of kind *
-- but we must expand them here. Sure to
-- be saturated because repType is only applied
-- to types of kind *