X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=8989d431044eb7b79f968cc574142a0363f05502;hb=4029d85741ffa537084e97ba276605b6a443c304;hp=229e9971616e74564390abd1cd3b5c0efe3fb54c;hpb=836b1e90821aacc9d1e09fe78085f911597274c8;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 229e997..8989d43 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -7,7 +7,7 @@ TcTyClsDecls: Typecheck type and class declarations \begin{code} module TcTyClsDecls ( - tcTyAndClassDecls, tcFamInstDecl, mkAuxBinds + tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds ) where #include "HsVersions.h" @@ -30,7 +30,7 @@ import Class 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 @@ -136,7 +136,9 @@ indeed type families). I think. 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 @@ -202,11 +204,12 @@ 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 @@ -244,8 +247,8 @@ lot of kinding and type checking code with ordinary algebraic data types (and 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 $ @@ -260,8 +263,26 @@ tcFamInstDecl (L loc 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" @@ -763,7 +784,7 @@ tcTyClDecl1 calc_isrec 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] } @@ -925,11 +946,12 @@ consUseH98Syntax _ = True ------------------- 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 @@ -937,27 +959,47 @@ tcConArg unbox_strict bty -- -- 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! @@ -1105,9 +1147,15 @@ checkValidDataCon tc con -- 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 () @@ -1119,7 +1167,7 @@ checkNewDataCon con -- 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 } @@ -1201,11 +1249,36 @@ checkValidClass cls %************************************************************************ \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