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

Check that AT instance is in a class

Mon Sep 18 19:16:40 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Check that AT instance is in a class
  Sat Aug 26 21:49:56 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Check that AT instance is in a class
parent 7ab880e6
......@@ -28,9 +28,10 @@ import TcHsType ( kcHsSigType, tcHsKindedType )
import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifySuperClasses )
import Type ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy,
splitFunTys, TyThing )
splitFunTys, TyThing(ATyCon) )
import Coercion ( mkSymCoercion )
import TyCon ( TyCon, newTyConCo, tyConTyVars )
import TyCon ( TyCon, tyConName, newTyConCo, tyConTyVars,
isAssocTyCon, tyConFamInst_maybe )
import DataCon ( classDataCon, dataConTyCon, dataConInstArgTys )
import Class ( classBigSig )
import Var ( TyVar, Id, idName, idType, tyVarKind )
......@@ -38,7 +39,8 @@ import Id ( mkSysLocal )
import UniqSupply ( uniqsFromSupply, splitUniqSupply )
import MkId ( mkDictFunId )
import Name ( Name, getSrcLoc )
import Maybe ( catMaybes )
import Maybe ( isNothing, fromJust, catMaybes )
import Monad ( when )
import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
import ListSetOps ( minusList )
import Outputable
......@@ -147,8 +149,8 @@ tcInstDecls1 tycl_decls inst_decls
-- (1) Do the ordinary instance declarations and instances of
-- indexed types
; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls
; idxty_info_tycons <- mappM tcIdxTyInstDecl idxty_decls
; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls
; idxty_info_tycons <- mappM tcIdxTyInstDeclTL idxty_decls
; let { (local_infos,
local_tycons) = unzip local_info_tycons
......@@ -186,6 +188,27 @@ tcInstDecls1 tycl_decls inst_decls
generic_inst_info ++ deriv_inst_info ++ local_idxty_info,
deriv_binds)
}}}}}
where
-- Make sure that toplevel type instance are not for associated types.
-- !!!TODO: Need to perform this check for the InstInfo structures of type
-- functions, too.
tcIdxTyInstDeclTL ldecl@(L loc decl) =
do { (info, tything) <- tcIdxTyInstDecl ldecl
; setSrcSpan loc $
when (isAssocFamily tything) $
addErr $ assocInClassErr (tcdName decl)
; return (info, tything)
}
isAssocFamily (Just (ATyCon tycon)) =
case tyConFamInst_maybe tycon of
Nothing -> panic "isAssocFamily: no family?!?"
Just (fam, _) -> isAssocTyCon fam
isAssocFamily (Just _ ) = panic "isAssocFamily: no tycon?!?"
isAssocFamily Nothing = False
assocInClassErr name =
ptext SLIT("Associated type must be inside class instance") <+>
quotes (ppr name)
addInsts :: [InstInfo] -> TcM a -> TcM a
addInsts infos thing_inside
......
......@@ -51,7 +51,7 @@ import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon,
tyConDataCons, mkForeignTyCon, isProductTyCon,
isRecursiveTyCon, isOpenTyCon,
tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName,
isNewTyCon, tyConKind )
isNewTyCon, tyConKind, makeTyConAssoc, isAssocTyCon )
import DataCon ( DataCon, dataConUserType, dataConName,
dataConFieldLabels, dataConTyCon, dataConAllTyVars,
dataConFieldType, dataConResTys )
......@@ -620,7 +620,7 @@ tcTyClDecl1 _calc_isrec
-- Check that we don't use kind signatures without Glasgow extensions
; checkTc gla_exts $ badSigTyDecl tc_name
; return [ATyCon (buildSynTyCon tc_name tvs' (OpenSynTyCon kind))]
; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)]
}
-- kind signature for an indexed data type
......@@ -707,7 +707,7 @@ tcTyClDecl1 calc_isrec
{ ctxt' <- tcHsKindedContext ctxt
; fds' <- mappM (addLocM tc_fundep) fundeps
; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats
; let ats' = concat atss
; let ats' = map makeTyThingAssoc . concat $ atss
; sig_stuff <- tcClassSigs class_name sigs meths
; clas <- fixM (\ clas ->
let -- This little knot is just so we can get
......@@ -726,6 +726,8 @@ tcTyClDecl1 calc_isrec
tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ;
; tvs2' <- mappM tcLookupTyVar tvs2 ;
; return (tvs1', tvs2') }
makeTyThingAssoc (ATyCon tycon) = ATyCon (makeTyConAssoc tycon)
makeTyThingAssoc _ = panic "makeTyThingAssoc"
tcTyClDecl1 calc_isrec
......
......@@ -15,7 +15,8 @@ module TyCon(
isFunTyCon, isUnLiftedTyCon, isProductTyCon,
isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, isAssocTyCon,
makeTyConAssoc,
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
isHiBootTyCon, isSuperKindTyCon,
......@@ -94,11 +95,14 @@ data TyCon
tyConName :: Name,
tyConKind :: Kind,
tyConArity :: Arity,
tyConTyVars :: [TyVar], -- Scopes over (a) the algTcStupidTheta
-- (b) the cached types in
-- algTyConRhs.NewTyCon
-- But not over the data constructors
tyConIsAssoc :: Bool, -- for families: declared in a class?
algTcSelIds :: [Id], -- Its record selectors (empty if none)
algTcGadtSyntax :: Bool, -- True <=> the data type was declared using GADT syntax
......@@ -133,13 +137,14 @@ data TyCon
}
| SynTyCon {
tyConUnique :: Unique,
tyConName :: Name,
tyConKind :: Kind,
tyConArity :: Arity,
tyConTyVars :: [TyVar], -- Bound tyvars
synTcRhs :: SynTyConRhs -- Expanded type in here
tyConUnique :: Unique,
tyConName :: Name,
tyConKind :: Kind,
tyConArity :: Arity,
tyConTyVars :: [TyVar], -- Bound tyvars
tyConIsAssoc :: Bool, -- for families: declared in a class?
synTcRhs :: SynTyConRhs -- Expanded type in here
}
| PrimTyCon { -- Primitive types; cannot be defined in Haskell
......@@ -399,6 +404,7 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn
tyConKind = kind,
tyConArity = length tyvars,
tyConTyVars = tyvars,
tyConIsAssoc = False,
algTcStupidTheta = stupid,
algTcRhs = rhs,
algTcSelIds = sel_ids,
......@@ -468,6 +474,7 @@ mkSynTyCon name kind tyvars rhs
tyConKind = kind,
tyConArity = length tyvars,
tyConTyVars = tyvars,
tyConIsAssoc = False,
synTcRhs = rhs
}
......@@ -573,6 +580,16 @@ isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True
isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon }) = True
isOpenTyCon _ = False
isAssocTyCon :: TyCon -> Bool
isAssocTyCon (AlgTyCon { tyConIsAssoc = isAssoc }) = isAssoc
isAssocTyCon (SynTyCon { tyConIsAssoc = isAssoc }) = isAssoc
isAssocTyCon _ = False
makeTyConAssoc :: TyCon -> TyCon
makeTyConAssoc tc@(AlgTyCon {}) = tc { tyConIsAssoc = True }
makeTyConAssoc tc@(SynTyCon {}) = tc { tyConIsAssoc = True }
makeTyConAssoc tc = pprPanic "makeTyConAssoc" (ppr tc)
isTupleTyCon :: TyCon -> Bool
-- The unit tycon didn't used to be classed as a tuple tycon
-- but I thought that was silly so I've undone it
......
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