\begin{code}
module TcTyClsDecls (
- tcTyAndClassDecls, tcFamInstDecl, mkAuxBinds
+ tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds
) where
#include "HsVersions.h"
import TyCon
import DataCon
import Id
-import MkId ( rEC_SEL_ERROR_ID )
+import MkId ( rEC_SEL_ERROR_ID, mkDefaultMethodId )
import IdInfo
import Var
import VarSet
import Name
import Outputable
import Maybes
-import Monad
import Unify
import Util
import SrcLoc
import BasicTypes
import Bag
+import Control.Monad
import Data.List
\end{code}
tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
-> 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
-- 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 }
+ ; rec_sel_binds = mkRecSelBinds alg_tyclss
+ ; dm_ids = mkDefaultMethodIds alg_tyclss }
; traceTc ((text "Adding" <+> ppr alg_tyclss)
$$ (text "and" <+> ppr implicit_things))
; env <- tcExtendGlobalEnv implicit_things getGblEnv
- ; return (env, aux_binds) }
+ ; return (env, rec_sel_binds, dm_ids) }
}
where
-- Pull associated types out of class declarations, to tie them into the
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
+ do { -- type family instances require -XTypeFamilies
+ -- and can't (currently) be in an hs-boot file
; type_families <- doptM Opt_TypeFamilies
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; checkTc type_families $ badFamInstDecl (tcdLName decl)
; 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"
; 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
<+> brackets (ppr k_tvs))
; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl)))
- ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs
+ ; 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
-- 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)
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) Nothing
})
; return [ATyCon tycon]
}
-------------------
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!
-- 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
}
%************************************************************************
\begin{code}
-mkAuxBinds :: [TyThing] -> HsValBinds Name
+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
-mkAuxBinds ty_things
+mkRecSelBinds ty_things
= ValBindsOut [(NonRecursive, b) | b <- binds] sigs
where
(sigs, binds) = unzip rec_sels
projects / ghc-hetmet.git / blobdiff