Commit 1091ebc9 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of http://darcs.haskell.org/ghc

parents 3664c198 97ce7b59
......@@ -13,7 +13,7 @@ have a standard form, namely:
\begin{code}
module MkId (
mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId,
mkDictFunId, mkDictFunTy, mkDictSelId,
mkDataConIds,
mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
......@@ -816,11 +816,6 @@ BUT make sure they are *exported* LocalIds (mkExportedLocalId) so
that they aren't discarded by the occurrence analyser.
\begin{code}
mkDefaultMethodId :: Id -- Selector Id
-> Name -- Default method name
-> Id -- Default method Id
mkDefaultMethodId sel_id dm_name = mkExportedLocalId dm_name (idType sel_id)
mkDictFunId :: Name -- Name to use for the dict fun;
-> [TyVar]
-> ThetaType
......
......@@ -48,11 +48,12 @@ module OccName (
-- ** Derived 'OccName's
isDerivedOccName,
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc,
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
mkInstTyCoOcc, mkEqPredCoOcc,
......@@ -539,9 +540,10 @@ isDerivedOccName occ =
\end{code}
\begin{code}
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc,
mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkGenD, mkGenR, mkGenRCo,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
......@@ -553,6 +555,7 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
mkDataConWrapperOcc = mk_simple_deriv varName "$W"
mkWorkerOcc = mk_simple_deriv varName "$w"
mkDefaultMethodOcc = mk_simple_deriv varName "$dm"
mkGenDefMethodOcc = mk_simple_deriv varName "$gdm"
mkClassOpAuxOcc = mk_simple_deriv varName "$c"
mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies
mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon
......@@ -571,10 +574,23 @@ mkCon2TagOcc = mk_simple_deriv varName "$con2tag_"
mkTag2ConOcc = mk_simple_deriv varName "$tag2con_"
mkMaxTagOcc = mk_simple_deriv varName "$maxtag_"
-- Generic derivable classes
-- Generic derivable classes (old)
mkGenOcc1 = mk_simple_deriv varName "$gfrom"
mkGenOcc2 = mk_simple_deriv varName "$gto"
-- Generic deriving mechanism (new)
mkGenD = mk_simple_deriv tcName "D1"
mkGenC :: OccName -> Int -> OccName
mkGenC occ m = mk_deriv tcName ("C1_" ++ show m) (occNameString occ)
mkGenS :: OccName -> Int -> Int -> OccName
mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n)
(occNameString occ)
mkGenR = mk_simple_deriv tcName "Rep_"
mkGenRCo = mk_simple_deriv tcName "CoRep_"
-- data T = MkT ... deriving( Data ) needs defintions for
-- $tT :: Data.Generics.Basics.DataType
-- $cMkT :: Data.Generics.Basics.Constr
......
......@@ -644,7 +644,7 @@ might_fail_pat (ConPatOut { pat_args = ps }) = any might_fail_lpat (hsConPatArgs
-- Finally the ones that are sure to succeed, or which are covered by the checking algorithm
might_fail_pat (LazyPat _) = False -- Always succeeds
might_fail_pat _ = False -- VarPat, WildPat, LitPat, NPat, TypePat
might_fail_pat _ = False -- VarPat, WildPat, LitPat, NPat
--------------
might_fail_lpat :: LPat Id -> Bool
......
......@@ -1062,7 +1062,6 @@ collectl (L _ pat) bndrs
go (SigPatIn pat _) = collectl pat bndrs
go (SigPatOut pat _) = collectl pat bndrs
go (TypePat _) = bndrs
go (CoPat _ pat _) = collectl (noLoc pat) bndrs
go (ViewPat _ pat _) = collectl pat bndrs
go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p)
......
......@@ -420,6 +420,10 @@ rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
-- Singleton => Ok
-- Empty => Too hard, signature ignored
rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
rep_sig (L _ (GenericSig nm _)) = failWithDs msg
where msg = vcat [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm)
, ptext (sLit "Default signatures are not supported by Template Haskell") ]
rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
rep_sig _ = return []
......@@ -631,7 +635,6 @@ repTy (HsKindSig t k) = do
k1 <- repKind k
repTSig t1 k1
repTy (HsSpliceTy splice _ _) = repSplice splice
repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
repTy ty = notHandled "Exotic form of type" (ppr ty)
-- represent a kind
......
......@@ -597,6 +597,10 @@ data Sig name -- Signatures and pragmas
-- f :: Num a => a -> a
TypeSig (Located name) (LHsType name)
-- A type signature for a default method inside a class
-- default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
| GenericSig (Located name) (LHsType name)
-- A type signature in generated code, notably the code
-- generated for record selectors. We simply record
-- the desired Id itself, replete with its name, type
......@@ -666,18 +670,20 @@ okBindSig :: Sig a -> Bool
okBindSig _ = True
okHsBootSig :: Sig a -> Bool
okHsBootSig (TypeSig _ _) = True
okHsBootSig (FixSig _) = True
okHsBootSig _ = False
okHsBootSig (TypeSig _ _) = True
okHsBootSig (GenericSig _ _) = False
okHsBootSig (FixSig _) = True
okHsBootSig _ = False
okClsDclSig :: Sig a -> Bool
okClsDclSig (SpecInstSig _) = False
okClsDclSig _ = True -- All others OK
okInstDclSig :: Sig a -> Bool
okInstDclSig (TypeSig _ _) = False
okInstDclSig (FixSig _) = False
okInstDclSig _ = True
okInstDclSig (TypeSig _ _) = False
okInstDclSig (GenericSig _ _) = False
okInstDclSig (FixSig _) = False
okInstDclSig _ = True
sigName :: LSig name -> Maybe name
-- Used only in Haddock
......@@ -702,9 +708,10 @@ isVanillaLSig (L _(TypeSig {})) = True
isVanillaLSig _ = False
isTypeLSig :: LSig name -> Bool -- Type signatures
isTypeLSig (L _(TypeSig {})) = True
isTypeLSig (L _(IdSig {})) = True
isTypeLSig _ = False
isTypeLSig (L _(TypeSig {})) = True
isTypeLSig (L _(GenericSig {})) = True
isTypeLSig (L _(IdSig {})) = True
isTypeLSig _ = False
isSpecLSig :: LSig name -> Bool
isSpecLSig (L _(SpecSig {})) = True
......@@ -727,6 +734,7 @@ isInlineLSig _ = False
hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) = ptext (sLit "type signature")
hsSigDoc (GenericSig {}) = ptext (sLit "default type signature")
hsSigDoc (IdSig {}) = ptext (sLit "id signature")
hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma")
hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma")
......@@ -741,6 +749,7 @@ eqHsSig :: Eq a => LSig a -> LSig a -> Bool
eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2
eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2
eqHsSig (L _ (GenericSig n1 _)) (L _ (GenericSig n2 _)) = unLoc n1 == unLoc n2
eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2
-- For specialisations, we don't have equality over
-- HsType, so it's not convenient to spot duplicate
......@@ -754,6 +763,7 @@ instance (OutputableBndr name) => Outputable (Sig name) where
ppr_sig :: OutputableBndr name => Sig name -> SDoc
ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty)
ppr_sig (GenericSig var ty) = ptext (sLit "default") <+> pprVarSig (unLoc var) (ppr ty)
ppr_sig (IdSig id) = pprVarSig id (ppr (varType id))
ppr_sig (FixSig fix_sig) = ppr fix_sig
ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl)
......
......@@ -834,7 +834,7 @@ instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats
\begin{code}
type LDerivDecl name = Located (DerivDecl name)
data DerivDecl name = DerivDecl (LHsType name)
data DerivDecl name = DerivDecl { deriv_type :: LHsType name }
deriving (Data, Typeable)
instance (OutputableBndr name) => Outputable (DerivDecl name) where
......
......@@ -134,12 +134,6 @@ data Pat id
(SyntaxExpr id) -- (>=) function, of type t->t->Bool
(SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName)
------------ Generics ---------------
| TypePat (LHsType id) -- Type pattern for generic definitions
-- e.g f{| a+b |} = ...
-- These show up only in class declarations,
-- and should be a top-level pattern
------------ Pattern type signatures ---------------
| SigPatIn (LPat id) -- Pattern with a type signature
(LHsType id)
......@@ -283,7 +277,6 @@ pprPat (NPat l Nothing _) = ppr l
pprPat (NPat l (Just _) _) = char '-' <> ppr l
pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k]
pprPat (QuasiQuotePat qq) = ppr qq
pprPat (TypePat ty) = ptext (sLit "{|") <> ppr ty <> ptext (sLit "|}")
pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co
pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty
......@@ -441,7 +434,6 @@ isIrrefutableHsPat pat
go1 (QuasiQuotePat {}) = urk pat -- Gotten rid of by renamer, before
-- isIrrefutablePat is called
go1 (TypePat {}) = urk pat
urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
......@@ -465,7 +457,6 @@ hsPatNeedsParens (LitPat {}) = False
hsPatNeedsParens (NPat {}) = False
hsPatNeedsParens (NPlusKPat {}) = True
hsPatNeedsParens (QuasiQuotePat {}) = True
hsPatNeedsParens (TypePat {}) = False
conPatNeedsParens :: HsConDetails a b -> Bool
conPatNeedsParens (PrefixCon args) = not (null args)
......
......@@ -168,8 +168,6 @@ data HsType name
-- interface files smaller), so when printing a HsType we may need to
-- add parens.
| HsNumTy Integer -- Generics only
| HsPredTy (HsPred name) -- Only used in the type of an instance
-- declaration, eg. Eq [a] -> Eq a
-- ^^^^
......@@ -440,7 +438,6 @@ ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcol
ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPredTy pred) = ppr pred
ppr_mono_ty _ (HsNumTy n) = integer n -- generics only
ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s
ppr_mono_ty _ (HsCoreTy ty) = ppr ty
......
......@@ -27,7 +27,7 @@ module HsUtils(
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
-- Bindigns
-- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind,
-- Literals
......@@ -547,7 +547,6 @@ collect_lpat (L _ pat) bndrs
go (SigPatIn pat _) = collect_lpat pat bndrs
go (SigPatOut pat _) = collect_lpat pat bndrs
go (QuasiQuotePat _) = bndrs
go (TypePat _) = bndrs
go (CoPat _ pat _) = go pat
\end{code}
......@@ -727,7 +726,6 @@ collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc
collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name]
collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc)
collect_sig_pat (TypePat ty) acc = ty:acc
collect_sig_pat (LazyPat pat) acc = collect_sig_lpat pat acc
collect_sig_pat (BangPat pat) acc = collect_sig_lpat pat acc
......
......@@ -1310,7 +1310,7 @@ instance Binary IfaceDecl where
put_ bh idinfo
put_ _ (IfaceForeign _ _) =
error "Binary.put_(IfaceDecl): IfaceForeign"
put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
putByte bh 2
put_ bh (occNameFS a1)
put_ bh a2
......@@ -1319,7 +1319,6 @@ instance Binary IfaceDecl where
put_ bh a5
put_ bh a6
put_ bh a7
put_ bh a8
put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
putByte bh 3
put_ bh (occNameFS a1)
......@@ -1354,9 +1353,8 @@ instance Binary IfaceDecl where
a5 <- get bh
a6 <- get bh
a7 <- get bh
a8 <- get bh
occ <- return $! mkOccNameFS tcName a1
return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
return (IfaceData occ a2 a3 a4 a5 a6 a7)
3 -> do
a1 <- get bh
a2 <- get bh
......
......@@ -10,7 +10,8 @@ module BuildTyCl (
buildDataCon,
TcMethInfo, buildClass,
mkAbstractTyConRhs,
mkNewTyConRhs, mkDataTyConRhs
mkNewTyConRhs, mkDataTyConRhs,
newImplicitBinder
) where
#include "HsVersions.h"
......@@ -59,13 +60,12 @@ buildAlgTyCon :: Name -> [TyVar]
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
-> RecFlag
-> Bool -- ^ True <=> want generics functions
-> Bool -- ^ True <=> was declared in GADT syntax
-> TyConParent
-> Maybe (TyCon, [Type]) -- ^ family instance if applicable
-> TcRnIf m n TyCon
buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
buildAlgTyCon tc_name tvs stupid_theta rhs is_rec gadt_syn
parent mb_family
| Just fam_inst_info <- mb_family
= -- We need to tie a knot as the coercion of a data instance depends
......@@ -74,11 +74,11 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
fixM $ \ tycon_rec -> do
{ fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec
; return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
fam_parent is_rec want_generics gadt_syn) }
fam_parent is_rec gadt_syn) }
| otherwise
= return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
parent is_rec want_generics gadt_syn)
parent is_rec gadt_syn)
where
kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
......@@ -221,8 +221,9 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
------------------------------------------------------
\begin{code}
type TcMethInfo = (Name, DefMethSpec, Type) -- A temporary intermediate, to communicate
-- between tcClassSigs and buildClass
type TcMethInfo = (Name, DefMethSpec, Type)
-- A temporary intermediate, to communicate between
-- tcClassSigs and buildClass.
buildClass :: Bool -- True <=> do not include unfoldings
-- on dict selectors
......@@ -324,7 +325,8 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
mk_op_item rec_clas (op_name, dm_spec, _)
= do { dm_info <- case dm_spec of
NoDM -> return NoDefMeth
GenericDM -> return GenDefMeth
GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
; return (GenDefMeth dm_name) }
VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
; return (DefMeth dm_name) }
; return (mkDictSelId no_unf op_name rec_clas, dm_info) }
......
......@@ -67,14 +67,6 @@ data IfaceDecl
ifRec :: RecFlag, -- Recursive or not?
ifGadtSyntax :: Bool, -- True <=> declared using
-- GADT syntax
ifGeneric :: Bool, -- True <=> generic converter
-- functions available
-- We need this for imported
-- data decls, since the
-- imported modules may have
-- been compiled with
-- different flags to the
-- current compilation unit
ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
-- Just <=> instance of family
-- Invariant:
......@@ -473,11 +465,11 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
= hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
4 (dcolon <+> ppr kind)
pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context,
ifTyVars = tyvars, ifCons = condecls,
ifRec = isrec, ifFamInst = mbFamInst})
= hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls,
4 (vcat [pprRec isrec, pp_condecls tycon condecls,
pprFamily mbFamInst])
where
pp_nd = case condecls of
......@@ -497,10 +489,6 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
pprRec :: RecFlag -> SDoc
pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec
pprGen :: Bool -> SDoc
pprGen True = ptext (sLit "Generics: yes")
pprGen False = ptext (sLit "Generics: no")
pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc
pprFamily Nothing = ptext (sLit "FamilyInstance: none")
pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst
......
......@@ -1335,9 +1335,9 @@ tyThingToIfaceDecl (AClass clas)
(sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
op_ty = funResultTy rho_ty
toDmSpec NoDefMeth = NoDM
toDmSpec GenDefMeth = GenericDM
toDmSpec (DefMeth _) = VanillaDM
toDmSpec NoDefMeth = NoDM
toDmSpec (GenDefMeth _) = GenericDM
toDmSpec (DefMeth _) = VanillaDM
toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
......@@ -1357,7 +1357,6 @@ tyThingToIfaceDecl (ATyCon tycon)
ifCons = ifaceConDecls (algTyConRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
ifGeneric = tyConHasGenerics tycon,
ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
| isForeignTyCon tycon
......
......@@ -433,7 +433,6 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
ifRec = is_rec,
ifGeneric = want_generic,
ifFamInst = mb_family })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
......@@ -442,7 +441,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; mb_fam_inst <- tcFamInst mb_family
; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
want_generic gadt_syn parent mb_fam_inst
gadt_syn parent mb_fam_inst
})
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
......
......@@ -336,7 +336,6 @@ data ExtensionFlag
| Opt_TemplateHaskell
| Opt_QuasiQuotes
| Opt_ImplicitParams
| Opt_Generics -- "Derivable type classes"
| Opt_ImplicitPrelude
| Opt_ScopedTypeVariables
| Opt_UnboxedTuples
......@@ -358,6 +357,9 @@ data ExtensionFlag
| Opt_DeriveFunctor
| Opt_DeriveTraversable
| Opt_DeriveFoldable
| Opt_DeriveGeneric -- Allow deriving Generic/1
| Opt_DefaultSignatures -- Allow extra signatures for defmeths
| Opt_Generics -- Old generic classes, now deprecated
| Opt_TypeSynonymInstances
| Opt_FlexibleContexts
......@@ -1666,7 +1668,8 @@ xFlags = [
( "ParallelArrays", Opt_ParallelArrays, nop ),
( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ),
( "QuasiQuotes", Opt_QuasiQuotes, nop ),
( "Generics", Opt_Generics, nop ),
( "Generics", Opt_Generics,
\ _ -> deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support." ),
( "ImplicitPrelude", Opt_ImplicitPrelude, nop ),
( "RecordWildCards", Opt_RecordWildCards, nop ),
( "NamedFieldPuns", Opt_RecordPuns, nop ),
......@@ -1708,6 +1711,8 @@ xFlags = [
( "DeriveFunctor", Opt_DeriveFunctor, nop ),
( "DeriveTraversable", Opt_DeriveTraversable, nop ),
( "DeriveFoldable", Opt_DeriveFoldable, nop ),
( "DeriveGeneric", Opt_DeriveGeneric, nop ),
( "DefaultSignatures", Opt_DefaultSignatures, nop ),
( "TypeSynonymInstances", Opt_TypeSynonymInstances, nop ),
( "FlexibleContexts", Opt_FlexibleContexts, nop ),
( "FlexibleInstances", Opt_FlexibleInstances, nop ),
......@@ -1888,6 +1893,7 @@ glasgowExtsFlags = [
, Opt_DeriveFunctor
, Opt_DeriveFoldable
, Opt_DeriveTraversable
, Opt_DeriveGeneric
, Opt_FlexibleContexts
, Opt_FlexibleInstances
, Opt_ConstrainedClassMethods
......
......@@ -55,6 +55,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
("InstType ", inst_type_ds),
("InstData ", inst_data_ds),
("TypeSigs ", bind_tys),
("GenericSigs ", generic_sigs),
("ValBinds ", val_bind_ds),
("FunBinds ", fn_bind_ds),
("InlineMeths ", method_inlines),
......@@ -74,7 +75,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls)
(fixity_sigs, bind_tys, bind_specs, bind_inlines)
(fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs)
= count_sigs [d | SigD d <- decls]
-- NB: this omits fixity decls on local bindings and
-- in class decls. ToDo
......@@ -112,13 +113,14 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
count_bind (FunBind {}) = (0,1)
count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b)
count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs)
sig_info (FixSig _) = (1,0,0,0)
sig_info (TypeSig _ _) = (0,1,0,0)
sig_info (SpecSig _ _ _) = (0,0,1,0)
sig_info (InlineSig _ _) = (0,0,0,1)
sig_info _ = (0,0,0,0)
sig_info (FixSig _) = (1,0,0,0,0)
sig_info (TypeSig _ _) = (0,1,0,0,0)
sig_info (SpecSig _ _ _) = (0,0,1,0,0)
sig_info (InlineSig _ _) = (0,0,0,1,0)
sig_info (GenericSig _ _) = (0,0,0,0,1)
sig_info _ = (0,0,0,0,0)
import_info (L _ (ImportDecl _ _ _ qual as spec))
= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
......@@ -137,13 +139,13 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
class_info decl@(ClassDecl {})
= case count_sigs (map unLoc (tcdSigs decl)) of
(_,classops,_,_) ->
(_,classops,_,_,_) ->
(classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
class_info _ = (0,0)
inst_info (InstDecl _ inst_meths inst_sigs ats)
= case count_sigs (map unLoc inst_sigs) of
(_,_,ss,is) ->
(_,_,ss,is,_) ->
case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
(tyDecl, dtDecl) ->
(addpr (foldr add2 (0,0)
......@@ -157,13 +159,11 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
addpr :: (Int,Int) -> Int
add2 :: (Int,Int) -> (Int,Int) -> (Int, Int)
add4 :: (Int,Int,Int,Int) -> (Int,Int,Int,Int) -> (Int, Int, Int, Int)
add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int)
add6 :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int)
addpr (x,y) = x+y
add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4)
add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6)
\end{code}
......
......@@ -55,7 +55,7 @@ module HscTypes (
-- * TyThings and type environments
TyThing(..),
tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, tyThingCoAxiom,
implicitTyThings, isImplicitTyThing,
implicitTyThings, implicitTyConThings, implicitClassThings, isImplicitTyThing,
TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
......@@ -1027,22 +1027,18 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
-- The order of the list does not matter.
implicitTyThings :: TyThing -> [TyThing]
-- For data and newtype declarations:
implicitTyThings (ATyCon tc)
= -- fields (names of selectors)
-- (possibly) implicit coercion and family coercion
-- depending on whether it's a newtype or a family instance or both
implicitCoTyCon tc ++
-- for each data constructor in order,
-- the contructor, worker, and (possibly) wrapper
concatMap (extras_plus . ADataCon) (tyConDataCons tc)
implicitTyThings (ACoAxiom _cc)
= []
implicitTyThings (AClass cl)
= -- dictionary datatype:
implicitTyThings (AnId _) = []
implicitTyThings (ACoAxiom _cc) = []
implicitTyThings (ATyCon tc) = implicitTyConThings tc
implicitTyThings (AClass cl) = implicitClassThings cl
implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc)
-- For data cons add the worker and (possibly) wrapper
implicitClassThings :: Class -> [TyThing]
implicitClassThings cl
= -- Does not include default methods, because those Ids may have
-- their own pragmas, unfoldings etc, not derived from the Class object
-- Dictionary datatype:
-- [extras_plus:]
-- type constructor
-- [recursive call:]
......@@ -1058,11 +1054,16 @@ implicitTyThings (AClass cl)
-- superclass and operation selectors
map AnId (classAllSelIds cl)
implicitTyThings (ADataCon dc) =
-- For data cons add the worker and (possibly) wrapper
map AnId (dataConImplicitIds dc)
implicitTyConThings :: TyCon -> [TyThing]
implicitTyConThings tc
= -- fields (names of selectors)
-- (possibly) implicit coercion and family coercion
-- depending on whether it's a newtype or a family instance or both
implicitCoTyCon tc ++
-- for each data constructor in order,
-- the contructor, worker, and (possibly) wrapper
concatMap (extras_plus . ADataCon) (tyConDataCons tc)
implicitTyThings (AnId _) = []
-- add a thing and recursive call
extras_plus :: TyThing -> [TyThing]
......
......@@ -335,11 +335,6 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") }
{ token ITcubxparen }
}
<0> {
"{|" / { ifExtension genericsEnabled } { token ITocurlybar }
"|}" / { ifExtension genericsEnabled } { token ITccurlybar }
}
<0,option_prags> {
\( { special IToparen }
\) { special ITcparen }
......@@ -1754,8 +1749,10 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap stored in an unboxed
-- integer
genericsBit :: Int
genericsBit = 0 -- {| and |}