\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
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 $
; 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"
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