-- ** 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, mkGenR0, mkGenR0Co, mkGenC, mkGenS,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
mkInstTyCoOcc, mkEqPredCoOcc,
{ occNameSpace :: !NameSpace
, occNameFS :: !FastString
}
+ deriving Typeable
\end{code}
compare (OccName sp1 s1) (OccName sp2 s2)
= (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2)
- INSTANCE_TYPEABLE0(OccName,occNameTc,"OccName")
-
instance Data OccName where
-- don't traverse?
toConstr _ = abstractConstr "OccName"
\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, mkGenR0, mkGenR0Co,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
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
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)
+
+mkGenR0 = mk_simple_deriv tcName "Rep0_"
+mkGenR0Co = mk_simple_deriv tcName "CoRep0_"
+
-- data T = MkT ... deriving( Data ) needs defintions for
-- $tT :: Data.Generics.Basics.DataType
-- $cMkT :: Data.Generics.Basics.Constr
finsts_mod = mi_finsts iface
hash_env = mi_hash_fn iface
mod_hash = mi_mod_hash iface
- export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
- | otherwise = Nothing
+ export_hash | depend_on_exports = Just (mi_exp_hash iface)
+ | otherwise = Nothing
used_occs = lookupModuleEnv ent_map mod `orElse` []
Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
Just r -> r
- depend_on_exports mod =
- case lookupModuleEnv direct_imports mod of
- Just _ -> True
- -- Even if we used 'import M ()', we have to register a
- -- usage on the export list because we are sensitive to
- -- changes in orphan instances/rules.
- Nothing -> False
- -- In GHC 6.8.x the above line read "True", and in
- -- fact it recorded a dependency on *all* the
- -- modules underneath in the dependency tree. This
- -- happens to make orphans work right, but is too
- -- expensive: it'll read too many interface files.
- -- The 'isNothing maybe_iface' check above saved us
- -- from generating many of these usages (at least in
- -- one-shot mode), but that's even more bogus!
+ depend_on_exports = is_direct_import
+ {- True
+ Even if we used 'import M ()', we have to register a
+ usage on the export list because we are sensitive to
+ changes in orphan instances/rules.
+ False
+ In GHC 6.8.x we always returned true, and in
+ fact it recorded a dependency on *all* the
+ modules underneath in the dependency tree. This
+ happens to make orphans work right, but is too
+ expensive: it'll read too many interface files.
+ The 'isNothing maybe_iface' check above saved us
+ from generating many of these usages (at least in
+ one-shot mode), but that's even more bogus!
+ -}
\end{code}
\begin{code}
(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)
| ITderiving
| ITdo
| ITelse
+ | ITgeneric
| IThiding
| ITif
| ITimport
( "deriving", ITderiving, 0 ),
( "do", ITdo, 0 ),
( "else", ITelse, 0 ),
+ ( "generic", ITgeneric, bit genericsBit ),
( "hiding", IThiding, 0 ),
( "if", ITif, 0 ),
( "import", ITimport, 0 ),
-- integer
genericsBit :: Int
-genericsBit = 0 -- {| and |}
+genericsBit = 0 -- {|, |} and "generic"
ffiBit :: Int
ffiBit = 1
parrBit :: Int
mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
mkPState flags buf loc =
PState {
- buffer = buf,
+ buffer = buf,
dflags = flags,
messages = emptyMessages,
last_loc = mkSrcSpan loc loc,
alr_justClosedExplicitLetBlock = False
}
where
- bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
- .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
- .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
- .|. arrowsBit `setBitIf` xopt Opt_Arrows flags
- .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
- .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
- .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
- .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
- .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
- .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
- .|. haddockBit `setBitIf` dopt Opt_Haddock flags
- .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
- .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
- .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
- .|. recBit `setBitIf` xopt Opt_DoRec flags
- .|. recBit `setBitIf` xopt Opt_Arrows flags
- .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
- .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
+ bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
+ .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
+ .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
+ .|. arrowsBit `setBitIf` xopt Opt_Arrows flags
+ .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
+ .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
+ .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
+ .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
+ .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
+ .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
+ .|. haddockBit `setBitIf` dopt Opt_Haddock flags
+ .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
+ .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
+ .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
+ .|. recBit `setBitIf` xopt Opt_DoRec flags
+ .|. recBit `setBitIf` xopt Opt_Arrows flags
+ .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
+ .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
.|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags
.|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags
.|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
.|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
- .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
+ .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
.|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
- | otherwise = 0
+ | otherwise = 0
addWarning :: DynFlag -> SrcSpan -> SDoc -> P ()
addWarning option srcspan warning
(anal_binds, anal_dus) -> return (valbind', valbind'_dus)
where
valbind' = ValBindsOut anal_binds sigs'
- valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus
+ valbind'_dus = anal_dus `plusDU` usesOnly (hsSigsFVs sigs')
+ -- Put the sig uses *after* the bindings
+ -- so that the binders are removed from
+ -- the uses in the sigs
}
rnValBindsRHS _ _ b = pprPanic "rnValBindsRHS" (ppr b)
-> RnM (LHsBinds Name, FreeVars)
rnMethodBinds cls sig_fn gen_tyvars binds
- = foldlM do_one (emptyBag,emptyFVs) (bagToList binds)
+ = do { checkDupRdrNames meth_names
+ -- Check that the same method is not given twice in the
+ -- same instance decl instance C T where
+ -- f x = ...
+ -- g y = ...
+ -- f x = ...
+ -- We must use checkDupRdrNames because the Name of the
+ -- method is the Name of the class selector, whose SrcSpan
+ -- points to the class declaration; and we use rnMethodBinds
+ -- for instance decls too
+
+ ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) }
where
+ meth_names = collectMethodBinders binds
do_one (binds,fvs) bind
= do { (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind
; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
-- Check for duplicates on RdrName version,
-- because renamed version has unboundName for
-- not-in-scope binders, which gives bogus dup-sig errors
-
+ -- NB: in a class decl, a 'generic' sig is not considered
+ -- equal to an ordinary sig, so we allow, say
+ -- class C a where
+ -- op :: a -> a
+ -- generic op :: Eq a => a -> a
+
; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs
; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs'
; new_ty <- rnHsSigType (quotes (ppr v)) ty
; return (TypeSig new_v new_ty) }
+renameSig mb_names sig@(GenericSig v ty)
+ = do { new_v <- lookupSigOccRn mb_names sig v
+ ; new_ty <- rnHsSigType (quotes (ppr v)) ty
+ ; return (GenericSig new_v new_ty) } -- JPM: ?
+
renameSig _ (SpecInstSig ty)
= do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty
; return (SpecInstSig new_ty) }
-- The typechecker (not the renamer) checks that all
-- the bindings are for the right class
let
- meth_names = collectMethodBinders mbinds
(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
in
- checkDupRdrNames meth_names `thenM_`
- -- Check that the same method is not given twice in the
- -- same instance decl instance C T where
- -- f x = ...
- -- g y = ...
- -- f x = ...
- -- We must use checkDupRdrNames because the Name of the
- -- method is the Name of the class selector, whose SrcSpan
- -- points to the class declaration
-
extendTyVarEnvForMethodBinds inst_tyvars (
-- (Slightly strangely) the forall-d tyvars scope over
-- the method bindings too
add_sig :: LSig a -> HsValBinds a -> HsValBinds a
add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
- \end{code}
+ \end{code}
projects / ghc-hetmet.git / commitdiff