Commit ada48bbc authored by dreixel's avatar dreixel

Add a new flag XDefaultSignatures to enable just the signatures on the default...

Add a new flag XDefaultSignatures to enable just the signatures on the default methods. Redefine the behavior of XGenerics to mean enable XDefaultSignatures and XDeriveRepresentable.
parent 7d54412f
......@@ -597,8 +597,8 @@ data Sig name -- Signatures and pragmas
-- f :: Num a => a -> a
TypeSig (Located name) (LHsType name)
-- A type signature for a generic function inside a class
-- generic eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
-- 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
......@@ -734,7 +734,7 @@ isInlineLSig _ = False
hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) = ptext (sLit "type signature")
hsSigDoc (GenericSig {}) = ptext (sLit "generic default 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")
......@@ -763,7 +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 "generic") <+> 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)
......
......@@ -321,7 +321,6 @@ data ExtensionFlag
| Opt_TemplateHaskell
| Opt_QuasiQuotes
| Opt_ImplicitParams
| Opt_Generics -- generic deriving mechanism
| Opt_ImplicitPrelude
| Opt_ScopedTypeVariables
| Opt_UnboxedTuples
......@@ -343,7 +342,9 @@ data ExtensionFlag
| Opt_DeriveFunctor
| Opt_DeriveTraversable
| Opt_DeriveFoldable
| Opt_DeriveRepresentable
| Opt_DeriveRepresentable -- Allow deriving Representable0/1
| Opt_DefaultSignatures -- Allow extra signatures for defmeths
| Opt_Generics -- Generic deriving mechanism
| Opt_TypeSynonymInstances
| Opt_FlexibleContexts
......@@ -1679,6 +1680,7 @@ xFlags = [
( "DeriveTraversable", Opt_DeriveTraversable, nop ),
( "DeriveFoldable", Opt_DeriveFoldable, nop ),
( "DeriveRepresentable", Opt_DeriveRepresentable, nop ),
( "DefaultSignatures", Opt_DefaultSignatures, nop ),
( "TypeSynonymInstances", Opt_TypeSynonymInstances, nop ),
( "FlexibleContexts", Opt_FlexibleContexts, nop ),
( "FlexibleInstances", Opt_FlexibleInstances, nop ),
......@@ -1744,6 +1746,9 @@ impliedFlags
, (Opt_RecordWildCards, turnOn, Opt_DisambiguateRecordFields)
, (Opt_ParallelArrays, turnOn, Opt_ParallelListComp)
-- The new behavior of the XGenerics flag is just to turn on these two flags
, (Opt_Generics, turnOn, Opt_DefaultSignatures)
, (Opt_Generics, turnOn, Opt_DeriveRepresentable)
]
optLevelFlags :: [([Int], DynFlag)]
......
......@@ -814,8 +814,8 @@ checkValSig lhs@(L l _) ty
where
hint = if foreign_RDR `looks_like` lhs
then "Perhaps you meant to use -XForeignFunctionInterface?"
else if generic_RDR `looks_like` lhs
then "Perhaps you meant to use -XGenerics?"
else if default_RDR `looks_like` lhs
then "Perhaps you meant to use -XDefaultSignatures?"
else "Should be of form <variable> :: <type>"
-- A common error is to forget the ForeignFunctionInterface flag
-- so check for that, and suggest. cf Trac #3805
......@@ -825,7 +825,7 @@ checkValSig lhs@(L l _) ty
looks_like _ _ = False
foreign_RDR = mkUnqual varName (fsLit "foreign")
generic_RDR = mkUnqual varName (fsLit "generic")
default_RDR = mkUnqual varName (fsLit "default")
checkDoAndIfThenElse :: LHsExpr RdrName
-> Bool
......
......@@ -713,8 +713,8 @@ renameSig mb_names sig@(TypeSig v ty)
; return (TypeSig new_v new_ty) }
renameSig mb_names sig@(GenericSig v ty)
= do { generics_on <- xoptM Opt_Generics
; unless generics_on (addErr (genericSigErr sig))
= do { defaultSigs_on <- xoptM Opt_DefaultSignatures
; unless defaultSigs_on (addErr (defaultSigErr sig))
; new_v <- lookupSigOccRn mb_names sig v
; new_ty <- rnHsSigType (quotes (ppr v)) ty
; return (GenericSig new_v new_ty) } -- JPM: ?
......@@ -840,10 +840,10 @@ misplacedSigErr (L loc sig)
= addErrAt loc $
sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig]
genericSigErr :: Sig RdrName -> SDoc
genericSigErr sig = vcat [ hang (ptext (sLit "Unexpected generic default signature:"))
defaultSigErr :: Sig RdrName -> SDoc
defaultSigErr sig = vcat [ hang (ptext (sLit "Unexpected default signature:"))
2 (ppr sig)
, ptext (sLit "Use -XGenerics to enable generic default signatures") ]
, ptext (sLit "Use -XDefaultSignatures to enable default signatures") ]
methodBindErr :: HsBindLR RdrName RdrName -> SDoc
methodBindErr mbind
......
......@@ -460,6 +460,7 @@ stored in NewTypeDerived.
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
\begin{code}
{-
-- Make the EarlyDerivSpec for Representable0
mkGenDerivSpec :: TyCon -> TcRn (EarlyDerivSpec)
mkGenDerivSpec tc = do
......@@ -470,8 +471,8 @@ mkGenDerivSpec tc = do
; let mtheta = Just []
; ds <- mkEqnHelp StandAloneDerivOrigin tc_tvs cls cls_tys tc_app mtheta
-- JPM TODO: StandAloneDerivOrigin?...
; {- pprTrace "mkGenDerivSpec" (ppr (tc, ds)) $ -} return ds }
; return ds }
-}
-- Make the "extras" for the generic representation
mkGenDerivExtras :: TyCon
-> TcRn (MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])
......@@ -494,9 +495,10 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
= do { eqns1 <- mapAndRecoverM deriveTyData all_tydata
; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
-- Generate EarlyDerivSpec's for Representable, if asked for
; (xGenerics, xDeriveRepresentable) <- genericsFlags
-- ; (xGenerics, xDerRep) <- genericsFlags
; xDerRep <- genericsFlag
; let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ]
; allTyDecls <- mapM tcLookupTyCon allTyNames
-- ; allTyDecls <- mapM tcLookupTyCon allTyNames
-- Select only those types that derive Representable
; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata
, getClassName c == Just rep0ClassName ]
......@@ -504,7 +506,7 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
| L _ (DerivDecl (L _ t)) <- deriv_decls
, getClassName t == Just rep0ClassName ]
; derTyDecls <- mapM tcLookupTyCon $
filter (needsExtras xDeriveRepresentable
filter (needsExtras xDerRep
(sel_tydata ++ sel_deriv_decls)) allTyNames
-- We need to generate the extras to add to what has
-- already been derived
......@@ -512,6 +514,7 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
-- For the remaining types, if Generics is on, we need to
-- generate both the instances and the extras, but only for the
-- types we can represent.
{-
; let repTyDecls = filter canDoGenerics allTyDecls
; let remTyDecls = filter (\x -> not (x `elem` derTyDecls)) repTyDecls
; generic_instances <- if xGenerics
......@@ -520,24 +523,14 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
; generic_extras_flag <- if xGenerics
then mapM mkGenDerivExtras remTyDecls
else return []
-- Merge and return everything
; {- pprTrace "allTyDecls" (ppr allTyDecls) $
pprTrace "derTyDecls" (ppr derTyDecls) $
pprTrace "repTyDecls" (ppr repTyDecls) $
pprTrace "remTyDecls" (ppr remTyDecls) $
pprTrace "xGenerics" (ppr xGenerics) $
pprTrace "xDeriveRep" (ppr xDeriveRepresentable) $
pprTrace "all_tydata" (ppr all_tydata) $
pprTrace "eqns1" (ppr eqns1) $
pprTrace "eqns2" (ppr eqns2) $
-}
return ( eqns1 ++ eqns2 ++ generic_instances
, generic_extras_deriv ++ generic_extras_flag) }
-- Merge and return everything
; return ( eqns1 ++ eqns2 -- ++ generic_instances
, generic_extras_deriv {- ++ generic_extras_flag -}) }
where
needsExtras xDeriveRepresentable tydata tc_name =
-- We need extras if the flag DeriveGenerics is on and this type is
-- We need extras if the flag DeriveRepresentable is on and this type is
-- deriving Representable
xDeriveRepresentable && tc_name `elem` tydata
needsExtras xDerRep tydata tc_name = xDerRep && tc_name `elem` tydata
-- Extracts the name of the class in the deriving
getClassName :: HsType Name -> Maybe Name
......@@ -546,8 +539,10 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
-- Extracts the name of the type in the deriving
getTypeName :: HsType Name -> Maybe Name
getTypeName (HsPredTy (HsClassP _ [L _ (HsTyVar n)])) = Just n
getTypeName _ = Nothing
getTypeName (HsTyVar n) = Just n
getTypeName (HsOpTy _ (L _ n) _) = Just n
getTypeName (HsPredTy (HsClassP _ [L _ n])) = getTypeName n
getTypeName _ = Nothing
extractTyDataPreds decls
= [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
......@@ -563,10 +558,10 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
2 (ptext (sLit "Use an instance declaration instead")))
genericsFlags :: TcM (Bool, Bool)
genericsFlags = do dOpts <- getDOpts
return ( xopt Opt_Generics dOpts
, xopt Opt_DeriveRepresentable dOpts)
genericsFlag :: TcM Bool
genericsFlag = do dOpts <- getDOpts
return ( xopt Opt_Generics dOpts
|| xopt Opt_DeriveRepresentable dOpts)
------------------------------------------------------------------
deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
......@@ -965,7 +960,7 @@ orCond c1 c2 tc
Nothing -> Nothing -- c1 succeeds
Just x -> case c2 tc of -- c1 fails
Nothing -> Nothing
Just y -> Just (x $$ ptext (sLit " and") $$ y)
Just y -> Just (x $$ ptext (sLit " or") $$ y)
-- Both fail
andCond :: Condition -> Condition -> Condition
......
......@@ -50,12 +50,6 @@ canDoGenerics tycon
= let result = not (any bad_con (tyConDataCons tycon)) -- See comment below
-- We do not support datatypes with context (for now)
&& null (tyConStupidTheta tycon)
{-
-- Primitives are (probably) not representable either
&& not (isPrimTyCon tycon)
-- Foreigns are (probably) not representable either
&& not (isForeignTyCon tycon)
-}
-- We don't like type families
&& not (isFamilyTyCon tycon)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment