Commit d5c4754d authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Check category of type instances and some newtype family fixes

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
parent b5d068a2
......@@ -51,7 +51,8 @@ import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon,
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 )
......@@ -61,12 +62,12 @@ import Name ( Name, getSrcLoc )
import Outputable
import Maybe ( isJust, fromJust, isNothing, catMaybes )
import Maybes ( expectJust )
import Monad ( unless )
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 List ( delete )
import Digraph ( SCC(..) )
import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics,
Opt_UnboxStrictFields ) )
......@@ -270,8 +271,12 @@ tcIdxTyInstDecl1 :: TyClDecl Name
-> 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
......@@ -287,7 +292,12 @@ tcIdxTyInstDecl1 (decl@TySynonym {})
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
......@@ -1164,7 +1174,16 @@ tooFewParmsErr 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"),
......
......@@ -23,7 +23,8 @@ import Type ( predTypeRep, tcView )
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 )
......@@ -238,7 +239,8 @@ calcRecFlags boot_details tyclss
-- 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
......
......@@ -550,13 +550,15 @@ isDataTyCon tc@(AlgTyCon {algTcRhs = rhs})
OpenNewTyCon -> False
NewTyCon {} -> False
AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc)
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
......@@ -746,7 +748,10 @@ newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }})
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
......
......@@ -117,7 +117,8 @@ import PrelNames( openTypeKindTyConKey, unliftedTypeKindTyConKey,
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,
......@@ -448,7 +449,7 @@ repType looks through
(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}
......@@ -457,7 +458,8 @@ repType :: Type -> Type
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 *
......
Markdown is supported
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