\begin{code}
module TcTyClsDecls (
- tcTyAndClassDecls, tcFamInstDecl, mkAuxBinds
+ tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds
) where
#include "HsVersions.h"
import HsSyn
-import HsTypes
-import BasicTypes
import HscTypes
import BuildTyCl
import TcUnify
import TcMType
import TcType
import TysWiredIn ( unitTy )
-import FunDeps
import Type
import Generics
import Class
import TyCon
import DataCon
import Id
-import MkId ( rEC_SEL_ERROR_ID )
+import MkId ( mkDefaultMethodId )
+import MkCore ( rEC_SEL_ERROR_ID )
import IdInfo
import Var
import VarSet
import Name
-import OccName
import Outputable
import Maybes
-import Monad
import Unify
import Util
import SrcLoc
import BasicTypes
import Bag
+import Control.Monad
import Data.List
-import Control.Monad ( mplus )
\end{code}
%* *
%************************************************************************
-Dealing with a group
-~~~~~~~~~~~~~~~~~~~~
-Consider a mutually-recursive group, binding
-a type constructor T and a class C.
-
-Step 1: getInitialKind
- Construct a KindEnv by binding T and C to a kind variable
-
-Step 2: kcTyClDecl
- In that environment, do a kind check
-
-Step 3: Zonk the kinds
-
-Step 4: buildTyConOrClass
- Construct an environment binding T to a TyCon and C to a Class.
- a) Their kinds comes from zonking the relevant kind variable
- b) Their arity (for synonyms) comes direct from the decl
- c) The funcional dependencies come from the decl
- d) The rest comes a knot-tied binding of T and C, returned from Step 4
- e) The variances of the tycons in the group is calculated from
- the knot-tied stuff
-
-Step 5: tcTyClDecl1
- In this environment, walk over the decls, constructing the TyCons and Classes.
- This uses in a strict way items (a)-(c) above, which is why they must
- be constructed in Step 4. Feed the results back to Step 4.
- For this step, pass the is-recursive flag as the wimp-out flag
- to tcTyClDecl1.
-
-
-Step 6: Extend environment
- We extend the type environment with bindings not only for the TyCons and Classes,
- but also for their "implicit Ids" like data constructors and class selectors
-
-Step 7: checkValidTyCl
- For a recursive group only, check all the decls again, just
- to check all the side conditions on validity. We could not
- do this before because we were in a mutually recursive knot.
-
-Identification of recursive TyCons
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
-@TyThing@s.
-
-Identifying a TyCon as recursive serves two purposes
-
-1. Avoid infinite types. Non-recursive newtypes are treated as
-"transparent", like type synonyms, after the type checker. If we did
-this for all newtypes, we'd get infinite types. So we figure out for
-each newtype whether it is "recursive", and add a coercion if so. In
-effect, we are trying to "cut the loops" by identifying a loop-breaker.
-
-2. Avoid infinite unboxing. This is nothing to do with newtypes.
-Suppose we have
- data T = MkT Int T
- f (MkT x t) = f t
-Well, this function diverges, but we don't want the strictness analyser
-to diverge. But the strictness analyser will diverge because it looks
-deeper and deeper into the structure of T. (I believe there are
-examples where the function does something sane, and the strictness
-analyser still diverges, but I can't see one now.)
-
-Now, concerning (1), the FC2 branch currently adds a coercion for ALL
-newtypes. I did this as an experiment, to try to expose cases in which
-the coercions got in the way of optimisations. If it turns out that we
-can indeed always use a coercion, then we don't risk recursive types,
-and don't need to figure out what the loop breakers are.
-
-For newtype *families* though, we will always have a coercion, so they
-are always loop breakers! So you can easily adjust the current
-algorithm by simply treating all newtype families as loop breakers (and
-indeed type families). I think.
-
\begin{code}
-tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
+tcTyAndClassDecls :: ModDetails
+ -> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order
-> TcM (TcGblEnv, -- Input env extended by types and classes
-- and their implicit Ids,DataCons
- HsValBinds Name) -- Renamed bindings for record selectors
+ HsValBinds Name, -- Renamed bindings for record selectors
+ [Id]) -- Default method ids
-- Fails if there are any errors
-tcTyAndClassDecls boot_details allDecls
+tcTyAndClassDecls boot_details decls_s
= checkNoErrs $ -- The code recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
- do { -- Omit instances of type families; they are handled together
- -- with the *heads* of class instances
- ; let decls = filter (not . isFamInstDecl . unLoc) allDecls
+ do { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s
+ -- Remove family instance decls altogether
+ -- They are dealt with by TcInstDcls
+
+ ; tyclss <- fixM $ \ rec_tyclss ->
+ tcExtendRecEnv (zipRecTyClss tyclds_s rec_tyclss) $
+ -- We must populate the environment with the loop-tied
+ -- T's right away (even before kind checking), because
+ -- the kind checker may "fault in" some type constructors
+ -- that recursively mention T
+
+ do { -- Kind-check in dependency order
+ -- See Note [Kind checking for type and class decls]
+ kc_decls <- kcTyClDecls tyclds_s
+
+ -- And now build the TyCons/Classes
+ ; let rec_flags = calcRecFlags boot_details rec_tyclss
+ ; concatMapM (tcTyClDecl rec_flags) kc_decls }
+
+ ; tcExtendGlobalEnv tyclss $ do
+ { -- Perform the validity check
+ -- We can do this now because we are done with the recursive knot
+ traceTc "ready for validity check" empty
+ ; mapM_ (addLocM checkValidTyCl) (concat tyclds_s)
+ ; traceTc "done" empty
- -- First check for cyclic type synonysm or classes
- -- See notes with checkCycleErrs
- ; checkCycleErrs decls
- ; mod <- getModule
- ; traceTc (text "tcTyAndCl" <+> ppr mod)
- ; (syn_tycons, alg_tyclss) <- fixM (\ ~(_rec_syn_tycons, rec_alg_tyclss) ->
- do { let { -- Seperate ordinary synonyms from all other type and
- -- class declarations and add all associated type
- -- declarations from type classes. The latter is
- -- required so that the temporary environment for the
- -- knot includes all associated family declarations.
- ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc)
- decls
- ; alg_at_decls = concatMap addATs alg_decls
- }
- -- Extend the global env with the knot-tied results
- -- for data types and classes
- --
- -- We must populate the environment with the loop-tied
- -- T's right away, because the kind checker may "fault
- -- in" some type constructors that recursively
- -- mention T
- ; let gbl_things = mkGlobalThings alg_at_decls rec_alg_tyclss
- ; tcExtendRecEnv gbl_things $ do
-
- -- Kind-check the declarations
- { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls
-
- ; let { -- Calculate rec-flag
- ; calc_rec = calcRecFlags boot_details rec_alg_tyclss
- ; tc_decl = addLocM (tcTyClDecl calc_rec) }
-
- -- Type-check the type synonyms, and extend the envt
- ; syn_tycons <- tcSynDecls kc_syn_decls
- ; tcExtendGlobalEnv syn_tycons $ do
-
- -- Type-check the data types and classes
- { alg_tyclss <- mapM tc_decl kc_alg_decls
- ; return (syn_tycons, concat alg_tyclss)
- }}})
- -- Finished with knot-tying now
- -- Extend the environment with the finished things
- ; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do
-
- -- Perform the validity check
- { traceTc (text "ready for validity check")
- ; mapM_ (addLocM checkValidTyCl) decls
- ; traceTc (text "done")
-
-- Add the implicit things;
- -- we want them in the environment because
+ -- we want them in the environment because
-- they may be mentioned in interface files
-- NB: All associated types and their implicit things will be added a
-- second time here. This doesn't matter as the definitions are
-- the same.
- ; let { implicit_things = concatMap implicitTyThings alg_tyclss
- ; aux_binds = mkAuxBinds alg_tyclss }
- ; traceTc ((text "Adding" <+> ppr alg_tyclss)
- $$ (text "and" <+> ppr implicit_things))
+ ; let { implicit_things = concatMap implicitTyThings tyclss
+ ; rec_sel_binds = mkRecSelBinds tyclss
+ ; dm_ids = mkDefaultMethodIds tyclss }
+
; env <- tcExtendGlobalEnv implicit_things getGblEnv
- ; return (env, aux_binds) }
- }
- where
- -- Pull associated types out of class declarations, to tie them into the
- -- knot above.
- -- NB: We put them in the same place in the list as `tcTyClDecl' will
- -- eventually put the matching `TyThing's. That's crucial; otherwise,
- -- the two argument lists of `mkGlobalThings' don't match up.
- addATs decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
- addATs decl = [decl]
-
-mkGlobalThings :: [LTyClDecl Name] -- The decls
- -> [TyThing] -- Knot-tied, in 1-1 correspondence with the decls
- -> [(Name,TyThing)]
--- Driven by the Decls, and treating the TyThings lazily
--- make a TypeEnv for the new things
-mkGlobalThings decls things
- = map mk_thing (decls `zipLazy` things)
+ ; return (env, rec_sel_binds, dm_ids) } }
+
+zipRecTyClss :: [[LTyClDecl Name]]
+ -> [TyThing] -- Knot-tied
+ -> [(Name,TyThing)]
+-- Build a name-TyThing mapping for the things bound by decls
+-- being careful not to look at the [TyThing]
+-- The TyThings in the result list must have a visible ATyCon/AClass,
+-- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor
+zipRecTyClss decls_s rec_things
+ = [ get decl | decls <- decls_s, L _ decl <- flattenATs decls ]
where
- mk_thing (L _ (ClassDecl {tcdLName = L _ name}), ~(AClass cl))
- = (name, AClass cl)
- mk_thing (L _ decl, ~(ATyCon tc))
- = (tcdName decl, ATyCon tc)
+ rec_type_env :: TypeEnv
+ rec_type_env = mkTypeEnv rec_things
+
+ get :: TyClDecl Name -> (Name, TyThing)
+ get (ClassDecl {tcdLName = L _ name}) = (name, AClass cl)
+ where
+ Just (AClass cl) = lookupTypeEnv rec_type_env name
+ get decl = (name, ATyCon tc)
+ where
+ name = tcdName decl
+ Just (ATyCon tc) = lookupTypeEnv rec_type_env name
\end{code}
GADTs).
\begin{code}
-tcFamInstDecl :: LTyClDecl Name -> TcM TyThing
-tcFamInstDecl (L loc decl)
+tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
+tcFamInstDecl top_lvl (L loc decl)
= -- Prime error recovery, set source location
setSrcSpan loc $
tcAddDeclCtxt decl $
- do { -- type families require -XTypeFamilies and can't be in an
- -- hs-boot file
- ; type_families <- doptM Opt_TypeFamilies
+ do { -- type family instances require -XTypeFamilies
+ -- and can't (currently) be in an hs-boot file
+ ; type_families <- xoptM Opt_TypeFamilies
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; checkTc type_families $ badFamInstDecl (tcdLName decl)
; checkTc (not is_boot) $ badBootFamInstDeclErr
; tc <- tcFamInstDecl1 decl
; checkValidTyCon tc -- Remember to check validity;
-- no recursion to worry about here
+
+ -- Check that toplevel type instances are not for associated types.
+ ; when (isTopLevel top_lvl && isAssocFamily tc)
+ (addErr $ assocInClassErr (tcdName decl))
+
; return (ATyCon tc) }
+isAssocFamily :: TyCon -> Bool -- Is an assocaited type
+isAssocFamily tycon
+ = case tyConFamInst_maybe tycon of
+ Nothing -> panic "isAssocFamily: no family?!?"
+ Just (fam, _) -> isTyConAssoc fam
+
+assocInClassErr :: Name -> SDoc
+assocInClassErr name
+ = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
+ ptext (sLit "must be inside a class instance")
+
+
+
tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
-- "type instance"
tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
= kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
do { -- check that the family declaration is for a synonym
- unless (isSynTyCon family) $
- addErr (wrongKindOfFamily family)
+ checkTc (isFamilyTyCon family) (notFamily family)
+ ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
; -- (1) kind check the right-hand side of the type equation
- ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
+ ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
+ -- ToDo: the ExpKind could be better
-- we need the exact same number of type parameters as the family
-- declaration
; checkValidTypeInst t_typats t_rhs
-- (4) construct representation tycon
- ; rep_tc_name <- newFamInstTyConName tc_name loc
+ ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
- (typeKind t_rhs) (Just (family, t_typats))
+ (typeKind t_rhs)
+ NoParentTyCon (Just (family, t_typats))
}}
-- "newtype instance" and "data instance"
tcdCons = cons})
= kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
do { -- check that the family declaration is for the right kind
- unless (isAlgTyCon fam_tycon) $
- addErr (wrongKindOfFamily fam_tycon)
+ checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
+ ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
; -- (1) kind check the data declaration as usual
; k_decl <- kcDataDecl decl k_tvs
-- foralls earlier)
; mapM_ checkTyFamFreeness t_typats
+ -- Check that we don't use GADT syntax in H98 world
+ ; gadt_ok <- xoptM Opt_GADTs
+ ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
+
-- (b) a newtype has exactly one constructor
; checkTc (new_or_data == DataType || isSingleton k_cons) $
newtypeConError tc_name (length k_cons)
-- (4) construct representation tycon
- ; rep_tc_name <- newFamInstTyConName tc_name loc
+ ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
; let ex_ok = True -- Existentials ok for type families!
; fixM (\ rep_tycon -> do
{ let orig_res_ty = mkTyConApp fam_tycon t_typats
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
- False h98_syntax (Just (fam_tycon, t_typats))
+ False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
-- We always assume that indexed types are recursive. Why?
-- (1) Due to their open nature, we can never be sure that a
-- further instance might not introduce a new recursive
-> TcM a
kcIdxTyPats decl thing_inside
= kcHsTyVars (tcdTyVars decl) $ \tvs ->
- do { fam_tycon <- tcLookupLocatedTyCon (tcdLName decl)
+ do { let tc_name = tcdLName decl
+ ; fam_tycon <- tcLookupLocatedTyCon tc_name
; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
; hs_typats = fromJust $ tcdTyPats decl }
-- type functions can have a higher-kinded result
; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
- ; typats <- zipWithM kcCheckHsType hs_typats kinds
+ ; typats <- zipWithM kcCheckLHsType hs_typats
+ [ EK kind (EkArg (ppr tc_name) n)
+ | (kind,n) <- kinds `zip` [1..]]
; thing_inside tvs typats resultKind fam_tycon
}
- where
\end{code}
%* *
%************************************************************************
+Note [Kind checking for type and class decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Kind checking is done thus:
+
+ 1. Make up a kind variable for each parameter of the *data* type,
+ and class, decls, and extend the kind environment (which is in
+ the TcLclEnv)
+
+ 2. Dependency-analyse the type *synonyms* (which must be non-recursive),
+ and kind-check them in dependency order. Extend the kind envt.
+
+ 3. Kind check the data type and class decls
+
+Synonyms are treated differently to data type and classes,
+because a type synonym can be an unboxed type
+ type Foo = Int#
+and a kind variable can't unify with UnboxedTypeKind
+So we infer their kinds in dependency order
+
We need to kind check all types in the mutually recursive group
before we know the kind of the type variables. For example:
include the kinds of associated families into the construction of the
initial kind environment. (This is handled by `allDecls').
+
\begin{code}
-kcTyClDecls :: [LTyClDecl Name] -> [Located (TyClDecl Name)]
- -> TcM ([LTyClDecl Name], [Located (TyClDecl Name)])
-kcTyClDecls syn_decls alg_decls
- = do { -- First extend the kind env with each data type, class, and
- -- indexed type, mapping them to a type variable
- let initialKindDecls = concat [allDecls decl | L _ decl <- alg_decls]
- ; alg_kinds <- mapM getInitialKind initialKindDecls
- ; tcExtendKindEnv alg_kinds $ do
-
- -- Now kind-check the type synonyms, in dependency order
- -- We do these differently to data type and classes,
- -- because a type synonym can be an unboxed type
- -- type Foo = Int#
- -- and a kind variable can't unify with UnboxedTypeKind
- -- So we infer their kinds in dependency order
- { (kc_syn_decls, syn_kinds) <- kcSynDecls (calcSynCycles syn_decls)
- ; tcExtendKindEnv syn_kinds $ do
-
- -- Now kind-check the data type, class, and kind signatures,
- -- returning kind-annotated decls; we don't kind-check
- -- instances of indexed types yet, but leave this to
- -- `tcInstDecls1'
- { kc_alg_decls <- mapM (wrapLocM kcTyClDecl)
- (filter (not . isFamInstDecl . unLoc) alg_decls)
-
- ; return (kc_syn_decls, kc_alg_decls) }}}
+kcTyClDecls :: [[LTyClDecl Name]] -> TcM [LTyClDecl Name]
+kcTyClDecls [] = return []
+kcTyClDecls (decls : decls_s) = do { (tcl_env, kc_decls1) <- kcTyClDecls1 decls
+ ; kc_decls2 <- setLclEnv tcl_env (kcTyClDecls decls_s)
+ ; return (kc_decls1 ++ kc_decls2) }
+
+kcTyClDecls1 :: [LTyClDecl Name] -> TcM (TcLclEnv, [LTyClDecl Name])
+kcTyClDecls1 decls
+ = do { -- Omit instances of type families; they are handled together
+ -- with the *heads* of class instances
+ ; let (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls
+ alg_at_decls = flattenATs alg_decls
+
+ ; mod <- getModule
+ ; traceTc "tcTyAndCl" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls))
+
+ -- First check for cyclic classes
+ ; checkClassCycleErrs alg_decls
+
+ -- Kind checking; see Note [Kind checking for type and class decls]
+ ; alg_kinds <- mapM getInitialKind alg_at_decls
+ ; tcExtendKindEnv alg_kinds $ do
+
+ { (kc_syn_decls, tcl_env) <- kcSynDecls (calcSynCycles syn_decls)
+ ; setLclEnv tcl_env $ do
+ { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) alg_decls
+
+ -- Kind checking done for this group, so zonk the kind variables
+ -- See Note [Kind checking for type and class decls]
+ ; mapM_ (zonkTcKindToKind . snd) alg_kinds
+
+ ; return (tcl_env, kc_syn_decls ++ kc_alg_decls) } } }
+
+flattenATs :: [LTyClDecl Name] -> [LTyClDecl Name]
+flattenATs decls = concatMap flatten decls
where
- -- get all declarations relevant for determining the initial kind
- -- environment
- allDecls (decl@ClassDecl {tcdATs = ats}) = decl : [ at
- | L _ at <- ats
- , isFamilyDecl at]
- allDecls decl | isFamInstDecl decl = []
- | otherwise = [decl]
+ flatten decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
+ flatten decl = [decl]
-------------------------------------------------------------------------
-getInitialKind :: TyClDecl Name -> TcM (Name, TcKind)
+getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind)
-- Only for data type, class, and indexed type declarations
-- Get as much info as possible from the data, class, or indexed type decl,
-- so as to maximise usefulness of error messages
-getInitialKind decl
+getInitialKind (L _ decl)
= do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl)
; res_kind <- mk_res_kind decl
; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
where
- mk_arg_kind (UserTyVar _) = newKindVar
+ mk_arg_kind (UserTyVar _ _) = newKindVar
mk_arg_kind (KindedTyVar _ kind) = return kind
mk_res_kind (TyFamily { tcdKind = Just kind }) = return kind
----------------
kcSynDecls :: [SCC (LTyClDecl Name)]
-> TcM ([LTyClDecl Name], -- Kind-annotated decls
- [(Name,TcKind)]) -- Kind bindings
+ TcLclEnv) -- Kind bindings
kcSynDecls []
- = return ([], [])
+ = do { tcl_env <- getLclEnv; return ([], tcl_env) }
kcSynDecls (group : groups)
- = do { (decl, nk) <- kcSynDecl group
- ; (decls, nks) <- tcExtendKindEnv [nk] (kcSynDecls groups)
- ; return (decl:decls, nk:nks) }
+ = do { (decl, nk) <- kcSynDecl group
+ ; (decls, tcl_env) <- tcExtendKindEnv [nk] (kcSynDecls groups)
+ ; return (decl:decls, tcl_env) }
----------------
kcSynDecl :: SCC (LTyClDecl Name)
kcSynDecl (AcyclicSCC (L loc decl))
= tcAddDeclCtxt decl $
kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
- do { traceTc (text "kcd1" <+> ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl))
+ do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl))
<+> brackets (ppr k_tvs))
- ; (k_rhs, rhs_kind) <- kcHsType (tcdSynRhs decl)
- ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl)))
- ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs
+ ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
+ ; traceTc "kcd2" (ppr (unLoc (tcdLName decl)))
+ ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs
; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
(unLoc (tcdLName decl), tc_kind)) })
= do { recSynErr decls; failM } -- Fail here to avoid error cascade
-- of out-of-scope tycons
-kindedTyVarKind :: LHsTyVarBndr Name -> Kind
-kindedTyVarKind (L _ (KindedTyVar _ k)) = k
-kindedTyVarKind x = pprPanic "kindedTyVarKind" (ppr x)
-
------------------------------------------------------------------------
kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
-- Not used for type synonyms (see kcSynDecl)
= tcAddDeclCtxt decl $
do { tc_ty_thing <- tcLookupLocated (tcdLName decl)
; let tc_kind = case tc_ty_thing of
- AThing k -> k
- _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
+ AThing k -> k
+ _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
(kinds, _) = splitKindFunTys tc_kind
hs_tvs = tcdTyVars decl
kinded_tvs = ASSERT( length kinds >= length hs_tvs )
- [ L loc (KindedTyVar (hsTyVarName tv) k)
- | (L loc tv, k) <- zip hs_tvs kinds]
- ; tcExtendKindEnvTvs kinded_tvs (thing_inside kinded_tvs) }
+ zipWith add_kind hs_tvs kinds
+ ; tcExtendKindEnvTvs kinded_tvs thing_inside }
+ where
+ add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k)
+ add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k)
-- Kind check a data declaration, assuming that we already extended the
-- kind environment with the type variables of the left-hand side (these
; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
where
-- doc comments are typechecked to Nothing here
- kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) = do
- kcHsTyVars ex_tvs $ \ex_tvs' -> do
- ex_ctxt' <- kcHsContext ex_ctxt
- details' <- kc_con_details details
- res' <- case res of
- ResTyH98 -> return ResTyH98
- ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
- return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing)
+ kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
+ , con_cxt = ex_ctxt, con_details = details, con_res = res })
+ = addErrCtxt (dataConCtxt name) $
+ kcHsTyVars ex_tvs $ \ex_tvs' -> do
+ do { ex_ctxt' <- kcHsContext ex_ctxt
+ ; details' <- kc_con_details details
+ ; res' <- case res of
+ ResTyH98 -> return ResTyH98
+ ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
+ ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
+ , con_details = details', con_res = res' }) }
kc_con_details (PrefixCon btys)
= do { btys' <- mapM kc_larg_ty btys
-- default result kind is '*'
}
where
- unifyClassParmKinds (L _ (KindedTyVar n k))
- | Just classParmKind <- lookup n classTyKinds = unifyKind k classParmKind
- | otherwise = return ()
- unifyClassParmKinds x = pprPanic "kcFamilyDecl/unifyClassParmKinds" (ppr x)
- classTyKinds = [(n, k) | L _ (KindedTyVar n k) <- classTvs]
+ unifyClassParmKinds (L _ tv)
+ | (n,k) <- hsTyVarNameKind tv
+ , Just classParmKind <- lookup n classTyKinds
+ = unifyKind k classParmKind
+ | otherwise = return ()
+ classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs]
+
kcFamilyDecl _ (TySynonym {}) -- type family defaults
= panic "TcTyClsDecls.kcFamilyDecl: not implemented yet"
kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
%************************************************************************
\begin{code}
-tcSynDecls :: [LTyClDecl Name] -> TcM [TyThing]
-tcSynDecls [] = return []
-tcSynDecls (decl : decls)
- = do { syn_tc <- addLocM tcSynDecl decl
- ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls)
- ; return (syn_tc : syn_tcs) }
+tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing]
- -- "type"
-tcSynDecl :: TyClDecl Name -> TcM TyThing
-tcSynDecl
- (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
- = tcTyVarBndrs tvs $ \ tvs' -> do
- { traceTc (text "tcd1" <+> ppr tc_name)
- ; rhs_ty' <- tcHsKindedType rhs_ty
- ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty')
- (typeKind rhs_ty') Nothing
- ; return (ATyCon tycon)
- }
-tcSynDecl d = pprPanic "tcSynDecl" (ppr d)
-
---------------------
-tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
-
-tcTyClDecl calc_isrec decl
- = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl)
+tcTyClDecl calc_isrec (L loc decl)
+ = setSrcSpan loc $ tcAddDeclCtxt decl $
+ tcTyClDecl1 NoParentTyCon calc_isrec decl
-- "type family" declarations
-tcTyClDecl1 :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
-tcTyClDecl1 _calc_isrec
+tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
+tcTyClDecl1 parent _calc_isrec
(TyFamily {tcdFlavour = TypeFamily,
tcdLName = L _ tc_name, tcdTyVars = tvs,
tcdKind = Just kind}) -- NB: kind at latest added during kind checking
= tcTyVarBndrs tvs $ \ tvs' -> do
- { traceTc (text "type family: " <+> ppr tc_name)
+ { traceTc "type family:" (ppr tc_name)
-- Check that we don't use families without -XTypeFamilies
- ; idx_tys <- doptM Opt_TypeFamilies
+ ; idx_tys <- xoptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
- -- Check for no type indices
- ; checkTc (not (null tvs)) (noIndexTypes tc_name)
-
- ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) kind Nothing
+ ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
; return [ATyCon tycon]
}
-- "data family" declaration
-tcTyClDecl1 _calc_isrec
+tcTyClDecl1 parent _calc_isrec
(TyFamily {tcdFlavour = DataFamily,
tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
= tcTyVarBndrs tvs $ \ tvs' -> do
- { traceTc (text "data family: " <+> ppr tc_name)
+ { traceTc "data family:" (ppr tc_name)
; extra_tvs <- tcDataKindSig mb_kind
; let final_tvs = tvs' ++ extra_tvs -- we may not need these
-- Check that we don't use families without -XTypeFamilies
- ; idx_tys <- doptM Opt_TypeFamilies
+ ; idx_tys <- xoptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
- -- Check for no type indices
- ; checkTc (not (null tvs)) (noIndexTypes tc_name)
-
; tycon <- buildAlgTyCon tc_name final_tvs []
- mkOpenDataTyConRhs Recursive False True Nothing
+ DataFamilyTyCon Recursive False True
+ parent Nothing
; return [ATyCon tycon]
}
+ -- "type"
+tcTyClDecl1 _parent _calc_isrec
+ (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
+ = ASSERT( isNoParent _parent )
+ tcTyVarBndrs tvs $ \ tvs' -> do
+ { traceTc "tcd1" (ppr tc_name)
+ ; rhs_ty' <- tcHsKindedType rhs_ty
+ ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty')
+ (typeKind rhs_ty') NoParentTyCon Nothing
+ ; return [ATyCon tycon] }
+
-- "newtype" and "data"
-- NB: not used for newtype/data instances (whether associated or not)
-tcTyClDecl1 calc_isrec
+tcTyClDecl1 _parent calc_isrec
(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
- = tcTyVarBndrs tvs $ \ tvs' -> do
+ = ASSERT( isNoParent _parent )
+ tcTyVarBndrs tvs $ \ tvs' -> do
{ extra_tvs <- tcDataKindSig mb_ksig
; let final_tvs = tvs' ++ extra_tvs
; stupid_theta <- tcHsKindedContext ctxt
- ; want_generic <- doptM Opt_Generics
+ ; want_generic <- xoptM Opt_Generics
; unbox_strict <- doptM Opt_UnboxStrictFields
- ; empty_data_decls <- doptM Opt_EmptyDataDecls
- ; kind_signatures <- doptM Opt_KindSignatures
- ; existential_ok <- doptM Opt_ExistentialQuantification
- ; gadt_ok <- doptM Opt_GADTs
+ ; empty_data_decls <- xoptM Opt_EmptyDataDecls
+ ; kind_signatures <- xoptM Opt_KindSignatures
+ ; existential_ok <- xoptM Opt_ExistentialQuantification
+ ; gadt_ok <- xoptM Opt_GADTs
+ ; gadtSyntax_ok <- xoptM Opt_GADTSyntax
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context
-- Check that we don't use GADT syntax in H98 world
- ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name)
+ ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)
-- Check that we don't use kind signatures without Glasgow extensions
; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs tc_name tycon (head data_cons)
; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
- (want_generic && canDoGenerics data_cons) h98_syntax Nothing
+ (want_generic && canDoGenerics data_cons) (not h98_syntax)
+ NoParentTyCon Nothing
})
; return [ATyCon tycon]
}
where
is_rec = calc_isrec tc_name
- h98_syntax = case cons of -- All constructors have same shape
- L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
- _ -> True
+ h98_syntax = consUseH98Syntax cons
-tcTyClDecl1 calc_isrec
+tcTyClDecl1 _parent calc_isrec
(ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs,
tcdCtxt = ctxt, tcdMeths = meths,
tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
- = tcTyVarBndrs tvs $ \ tvs' -> do
+ = ASSERT( isNoParent _parent )
+ tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
; fds' <- mapM (addLocM tc_fundep) fundeps
- ; atss <- mapM (addLocM (tcTyClDecl1 (const Recursive))) ats
- -- NB: 'ats' only contains "type family" and "data family"
- -- declarations as well as type family defaults
- ; let ats' = map (setAssocFamilyPermutation tvs') (concat atss)
; sig_stuff <- tcClassSigs class_name sigs meths
- ; clas <- fixM (\ clas ->
- let -- This little knot is just so we can get
+ ; clas <- fixM $ \ clas -> do
+ { let -- This little knot is just so we can get
-- hold of the name of the class TyCon, which we
-- need to look up its recursiveness
tycon_name = tyConName (classTyCon clas)
tc_isrec = calc_isrec tycon_name
- in
- buildClass False {- Must include unfoldings for selectors -}
- class_name tvs' ctxt' fds' ats'
- sig_stuff tc_isrec)
- ; return (AClass clas : ats')
+ ; atss' <- mapM (addLocM $ tcTyClDecl1 (AssocFamilyTyCon clas) (const Recursive)) ats
+ -- NB: 'ats' only contains "type family" and "data family"
+ -- declarations as well as type family defaults
+ ; buildClass False {- Must include unfoldings for selectors -}
+ class_name tvs' ctxt' fds' (concat atss')
+ sig_stuff tc_isrec }
+ ; return (AClass clas : map ATyCon (classATs clas))
-- NB: Order is important due to the call to `mkGlobalThings' when
-- tying the the type and class declaration type checking knot.
}
; tvs2' <- mapM tcLookupTyVar tvs2 ;
; return (tvs1', tvs2') }
-tcTyClDecl1 _
+tcTyClDecl1 _ _
(ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
= return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)]
-tcTyClDecl1 _ d = pprPanic "tcTyClDecl1" (ppr d)
+tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d)
-----------------------------------
tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type)
-> TcM DataCon
tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types
- (ConDecl name _ tvs ctxt details res_ty _)
+ con@(ConDecl {con_name = name, con_qvars = tvs, con_cxt = ctxt
+ , con_details = details, con_res = res_ty })
= addErrCtxt (dataConCtxt name) $
tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
- ; checkTc (existential_ok || (null tvs && null (unLoc ctxt)))
+ ; checkTc (existential_ok || conRepresentibleWithH98Syntax con)
(badExistential name)
; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty
; let
name = tyVarName tv
(env', occ') = tidyOccName env (getOccName name)
+consUseH98Syntax :: [LConDecl a] -> Bool
+consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
+consUseH98Syntax _ = True
+ -- All constructors have same shape
+
+conRepresentibleWithH98Syntax :: ConDecl Name -> Bool
+conRepresentibleWithH98Syntax
+ (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 })
+ = null tvs && null (unLoc ctxt)
+conRepresentibleWithH98Syntax
+ (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) })
+ = null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs)
+ where -- Each type variable should be used exactly once in the
+ -- result type, and the result type must just be the type
+ -- constructor applied to type variables
+ f (HsAppTy (L _ t1) (L _ (HsTyVar v2))) vs
+ = (v2 `elem` vs) && f t1 (delete v2 vs)
+ f (HsTyVar _) [] = True
+ f _ _ = False
+
-------------------
tcConArg :: Bool -- True <=> -funbox-strict_fields
-> LHsType Name
- -> TcM (TcType, StrictnessMark)
+ -> TcM (TcType, HsBang)
tcConArg unbox_strict bty
= do { arg_ty <- tcHsBangType bty
; let bang = getBangStrictness bty
- ; return (arg_ty, chooseBoxingStrategy unbox_strict arg_ty bang) }
+ ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang
+ ; return (arg_ty, strict_mark) }
-- We attempt to unbox/unpack a strict field when either:
-- (i) The field is marked '!!', or
--
-- We have turned off unboxing of newtypes because coercions make unboxing
-- and reboxing more complicated
-chooseBoxingStrategy :: Bool -> TcType -> HsBang -> StrictnessMark
+chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang
chooseBoxingStrategy unbox_strict_fields arg_ty bang
= case bang of
- HsNoBang -> NotMarkedStrict
- HsStrict | unbox_strict_fields
- && can_unbox arg_ty -> MarkedUnboxed
- HsUnbox | can_unbox arg_ty -> MarkedUnboxed
- _ -> MarkedStrict
+ HsNoBang -> HsNoBang
+ HsUnpack -> can_unbox HsUnpackFailed arg_ty
+ HsStrict | unbox_strict_fields -> can_unbox HsStrict arg_ty
+ | otherwise -> HsStrict
+ HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
+ -- Source code never has shtes
where
- -- we can unbox if the type is a chain of newtypes with a product tycon
- -- at the end
- can_unbox arg_ty = case splitTyConApp_maybe arg_ty of
- Nothing -> False
- Just (arg_tycon, tycon_args) ->
- not (isRecursiveTyCon arg_tycon) && -- Note [Recusive unboxing]
- isProductTyCon arg_tycon &&
- (if isNewTyCon arg_tycon then
- can_unbox (newTyConInstRhs arg_tycon tycon_args)
- else True)
+ can_unbox :: HsBang -> TcType -> HsBang
+ -- Returns HsUnpack if we can unpack arg_ty
+ -- fail_bang if we know what arg_ty is but we can't unpack it
+ -- HsStrict if it's abstract, so we don't know whether or not we can unbox it
+ can_unbox fail_bang arg_ty
+ = case splitTyConApp_maybe arg_ty of
+ Nothing -> fail_bang
+
+ Just (arg_tycon, tycon_args)
+ | isAbstractTyCon arg_tycon -> HsStrict
+ -- See Note [Don't complain about UNPACK on abstract TyCons]
+ | not (isRecursiveTyCon arg_tycon) -- Note [Recusive unboxing]
+ , isProductTyCon arg_tycon
+ -- We can unbox if the type is a chain of newtypes
+ -- with a product tycon at the end
+ -> if isNewTyCon arg_tycon
+ then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args)
+ else HsUnpack
+
+ | otherwise -> fail_bang
\end{code}
+Note [Don't complain about UNPACK on abstract TyCons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We are going to complain about UnpackFailed, but if we say
+ data T = MkT {-# UNPACK #-} !Wobble
+and Wobble is a newtype imported from a module that was compiled
+without optimisation, we don't want to complain. Because it might
+be fine when optimsation is on. I think this happens when Haddock
+is working over (say) GHC souce files.
+
Note [Recursive unboxing]
~~~~~~~~~~~~~~~~~~~~~~~~~
Be careful not to try to unbox this!
tied, so we can look at things freely.
\begin{code}
-checkCycleErrs :: [LTyClDecl Name] -> TcM ()
-checkCycleErrs tyclss
+checkClassCycleErrs :: [LTyClDecl Name] -> TcM ()
+checkClassCycleErrs tyclss
| null cls_cycles
= return ()
| otherwise
checkValidTyCl decl
= tcAddDeclCtxt decl $
do { thing <- tcLookupLocatedGlobal (tcdLName decl)
- ; traceTc (text "Validity of" <+> ppr thing)
+ ; traceTc "Validity of" (ppr thing)
; case thing of
ATyCon tc -> checkValidTyCon tc
- AClass cl -> checkValidClass cl
- _ -> panic "checkValidTyCl"
- ; traceTc (text "Done validity of" <+> ppr thing)
+ AClass cl -> do { checkValidClass cl
+ ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) }
+ _ -> panic "checkValidTyCl"
+ ; traceTc "Done validity of" (ppr thing)
}
-------------------------
checkValidTyCon tc
| isSynTyCon tc
= case synTyConRhs tc of
- OpenSynTyCon _ _ -> return ()
- SynonymTyCon ty -> checkValidType syn_ctxt ty
+ SynFamilyTyCon {} -> return ()
+ SynonymTyCon ty -> checkValidType syn_ctxt ty
| otherwise
= do -- Check the context on the data decl
checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
checkValidDataCon tc con
= setSrcSpan (srcLocSpan (getSrcLoc con)) $
addErrCtxt (dataConCtxt con) $
- do { let tc_tvs = tyConTyVars tc
+ do { traceTc "Validity of data con" (ppr con)
+ ; let tc_tvs = tyConTyVars tc
res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
actual_res_ty = dataConOrigResTy con
; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
-- Reason: it's really the argument of an equality constraint
; checkValidType ctxt (dataConUserType con)
; when (isNewTyCon tc) (checkNewDataCon con)
+ ; mapM_ check_bang (dataConStrictMarks con `zip` [1..])
}
where
ctxt = ConArgCtxt (dataConName con)
+ check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n)
+ check_bang _ = return ()
+
+ cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the")
+ , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)]
-------------------------------
checkNewDataCon :: DataCon -> TcM ()
-- Return type is (T a b c)
; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con)
-- No existentials
- ; checkTc (not (any isMarkedStrict (dataConStrictMarks con)))
+ ; checkTc (not (any isBanged (dataConStrictMarks con)))
(newtypeStrictError con)
-- No strictness
}
-------------------------------
checkValidClass :: Class -> TcM ()
checkValidClass cls
- = do { constrained_class_methods <- doptM Opt_ConstrainedClassMethods
- ; multi_param_type_classes <- doptM Opt_MultiParamTypeClasses
- ; fundep_classes <- doptM Opt_FunctionalDependencies
+ = do { constrained_class_methods <- xoptM Opt_ConstrainedClassMethods
+ ; multi_param_type_classes <- xoptM Opt_MultiParamTypeClasses
+ ; fundep_classes <- xoptM Opt_FunctionalDependencies
-- Check that the class is unary, unless GlaExs
; checkTc (notNull tyvars) (nullaryClassErr cls)
-- The 'tail' removes the initial (C a) from the
-- class itself, leaving just the method type
- ; traceTc (text "class op type" <+> ppr op_ty <+> ppr tau)
+ ; traceTc "class op type" (ppr op_ty <+> ppr tau)
; checkValidType (FunSigCtxt op_name) tau
-- Check that the type mentions at least one of
-- class Error e => Game b mv e | b -> mv e where
-- newBoard :: MonadState b m => m ()
-- Here, MonadState has a fundep m->b, so newBoard is fine
- ; let grown_tyvars = grow theta (mkVarSet tyvars)
+ ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars)
; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
(noClassTyVarErr cls sel_id)
%************************************************************************
\begin{code}
-mkAuxBinds :: [TyThing] -> HsValBinds Name
-mkAuxBinds ty_things
+mkDefaultMethodIds :: [TyThing] -> [Id]
+-- See Note [Default method Ids and Template Haskell]
+mkDefaultMethodIds things
+ = [ mkDefaultMethodId sel_id dm_name
+ | AClass cls <- things
+ , (sel_id, DefMeth dm_name) <- classOpItems cls ]
+\end{code}
+
+Note [Default method Ids and Template Haskell]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (Trac #4169):
+ class Numeric a where
+ fromIntegerNum :: a
+ fromIntegerNum = ...
+
+ ast :: Q [Dec]
+ ast = [d| instance Numeric Int |]
+
+When we typecheck 'ast' we have done the first pass over the class decl
+(in tcTyClDecls), but we have not yet typechecked the default-method
+declarations (becuase they can mention value declarations). So we
+must bring the default method Ids into scope first (so they can be seen
+when typechecking the [d| .. |] quote, and typecheck them later.
+
+\begin{code}
+mkRecSelBinds :: [TyThing] -> HsValBinds Name
+-- NB We produce *un-typechecked* bindings, rather like 'deriving'
+-- This makes life easier, because the later type checking will add
+-- all necessary type abstractions and applications
+mkRecSelBinds ty_things
= ValBindsOut [(NonRecursive, b) | b <- binds] sigs
where
(sigs, binds) = unzip rec_sels
| ATyCon tc <- ty_things
, fld <- tyConFields tc ]
-
mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
mkRecSelBind (tycon, sel_name)
= (L loc (IdSig sel_id), unitBag (L loc sel_bind))
where
- loc = getSrcSpan tycon
- sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo
+ loc = getSrcSpan tycon
+ sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo
rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
-- Find a representative constructor, con1
- all_cons = tyConDataCons tycon
+ all_cons = tyConDataCons tycon
cons_w_field = [ con | con <- all_cons
, sel_name `elem` dataConFieldLabels con ]
con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
-- Selector type; Note [Polymorphic selectors]
- field_ty = dataConFieldType con1 sel_name
- (field_tvs, field_theta, field_tau)
- | is_naughty = ([], [], unitTy)
- | otherwise = tcSplitSigmaTy field_ty
+ field_ty = dataConFieldType con1 sel_name
data_ty = dataConOrigResTy con1
data_tvs = tyVarsOfType data_ty
is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)
- sel_ty = mkForAllTys (varSetElems data_tvs ++ field_tvs) $
- mkPhiTy (dataConStupidTheta con1) $ -- Urgh!
- mkPhiTy field_theta $ -- Urgh!
- mkFunTy data_ty field_tau
+ (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
+ sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors]
+ | otherwise = mkForAllTys (varSetElems data_tvs ++ field_tvs) $
+ mkPhiTy (dataConStupidTheta con1) $ -- Urgh!
+ mkPhiTy field_theta $ -- Urgh!
+ mkFunTy data_ty field_tau
-- Make the binding: sel (C2 { fld = x }) = x
-- sel (C7 { fld = x }) = x
-- where cons_w_field = [C2,C7]
- sel_bind = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt)
+ sel_bind | is_naughty = mkFunBind sel_lname [mkSimpleMatch [] unit_rhs]
+ | otherwise = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt)
mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)]
- (L loc match_body)
+ (L loc (HsVar field_var))
mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
rec_field = HsRecField { hsRecFieldId = sel_lname
, hsRecFieldArg = nlVarPat field_var
, hsRecPun = False }
- match_body | is_naughty = ExplicitTuple [] Boxed
- | otherwise = HsVar field_var
sel_lname = L loc sel_name
field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
-- Add catch-all default case unless the case is exhaustive
-- We do this explicitly so that we get a nice error message that
-- mentions this particular record selector
- deflt | length cons_w_field == length all_cons = []
+ deflt | not (any is_unused all_cons) = []
| otherwise = [mkSimpleMatch [nlWildPat]
(nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID))
(nlHsLit msg_lit))]
+
+ -- Do not add a default case unless there are unmatched
+ -- constructors. We must take account of GADTs, else we
+ -- get overlap warning messages from the pattern-match checker
+ is_unused con = not (con `elem` cons_w_field
+ || dataConCannotMatch inst_tys con)
+ inst_tys = tyConAppArgs data_ty
+
+ unit_rhs = mkLHsTupleExpr []
msg_lit = HsStringPrim $ mkFastString $
occNameString (getOccName sel_name)
helpfully, rather than saying unhelpfully that 'x' is not in scope.
Hence the sel_naughty flag, to identify record selectors that don't really exist.
-In general, a field is naughty if its type mentions a type variable that
-isn't in the result type of the constructor.
+In general, a field is "naughty" if its type mentions a type variable that
+isn't in the result type of the constructor. Note that this *allows*
+GADT record selectors (Note [GADT record selectors]) whose types may look
+like sel :: T [a] -> a
-We make a dummy binding for naughty selectors, so that they can be treated
-uniformly, apart from their sel_naughty field. The function is never called.
+For naughty selectors we make a dummy binding
+ sel = ()
+for naughty selectors, so that the later type-check will add them to the
+environment, and they'll be exported. The function is never called, because
+the tyepchecker spots the sel_naughty field.
Note [GADT record selectors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
badGenericMethodType :: Name -> Kind -> SDoc
badGenericMethodType op op_ty
= hang (ptext (sLit "Generic method type is too complex"))
- 4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
+ 2 (vcat [ppr op <+> dcolon <+> ppr op_ty,
ptext (sLit "You can only use type variables, arrows, lists, and tuples")])
recSynErr :: [LTyClDecl Name] -> TcRn ()
badExistential :: Located Name -> SDoc
badExistential con_name
= hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+>
- ptext (sLit "has existential type variables, or a context"))
+ ptext (sLit "has existential type variables, a context, or a specialised result type"))
2 (parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this"))
badStupidTheta :: Name -> SDoc
quotes (ppr tc_name)
, nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ]
-noIndexTypes :: Name -> SDoc
-noIndexTypes tc_name
- = ptext (sLit "Type family constructor") <+> quotes (ppr tc_name)
- <+> ptext (sLit "must have at least one type index parameter")
-
badFamInstDecl :: Outputable a => a -> SDoc
badFamInstDecl tc_name
= vcat [ ptext (sLit "Illegal family instance for") <+>
<+> ppr exp_arity
badBootFamInstDeclErr :: SDoc
-badBootFamInstDeclErr =
- ptext (sLit "Illegal family instance in hs-boot file")
-
+badBootFamInstDeclErr
+ = ptext (sLit "Illegal family instance in hs-boot file")
+
+notFamily :: TyCon -> SDoc
+notFamily tycon
+ = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
+ , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
+
wrongKindOfFamily :: TyCon -> SDoc
-wrongKindOfFamily family =
- ptext (sLit "Wrong category of family instance; declaration was for a") <+>
- kindOfFamily
+wrongKindOfFamily family
+ = ptext (sLit "Wrong category of family instance; declaration was for a")
+ <+> kindOfFamily
where
kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
| isAlgTyCon family = ptext (sLit "data type")
projects / ghc-hetmet.git / blobdiff