Commit 7ed482d9 authored by jpm@cs.ox.ac.uk's avatar jpm@cs.ox.ac.uk Committed by Austin Seipp

Implement #5462 (deriving clause for arbitrary classes)

Summary: (this has been submitted on behalf on @dreixel)

Reviewers: simonpj, hvr, austin

Reviewed By: simonpj, austin

Subscribers: goldfire, thomie, carter, dreixel

Differential Revision: https://phabricator.haskell.org/D476

GHC Trac Issues: #5462
parent 067f1e4f
......@@ -736,6 +736,7 @@ Class object.
data DefMethSpec = NoDM -- No default method
| VanillaDM -- Default method given with polymorphic code
| GenericDM -- Default method given with generic code
deriving Eq
instance Outputable DefMethSpec where
ppr NoDM = empty
......
......@@ -564,6 +564,7 @@ data ExtensionFlag
| Opt_DeriveFoldable
| Opt_DeriveGeneric -- Allow deriving Generic/1
| Opt_DefaultSignatures -- Allow extra signatures for defmeths
| Opt_DeriveAnyClass -- Allow deriving any class
| Opt_TypeSynonymInstances
| Opt_FlexibleContexts
......@@ -2873,6 +2874,7 @@ xFlags = [
$ deprecate $ "It was widely considered a misfeature, " ++
"and has been removed from the Haskell language." ),
( "DefaultSignatures", Opt_DefaultSignatures, nop ),
( "DeriveAnyClass", Opt_DeriveAnyClass, nop ),
( "DeriveDataTypeable", Opt_DeriveDataTypeable, nop ),
( "DeriveFoldable", Opt_DeriveFoldable, nop ),
( "DeriveFunctor", Opt_DeriveFunctor, nop ),
......
......@@ -530,8 +530,8 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
-- If AutoDeriveTypeable is set, we automatically add Typeable instances
-- for every data type and type class declared in the module
; auto_typeable <- xoptM Opt_AutoDeriveTypeable
; eqns4 <- deriveAutoTypeable auto_typeable (eqns1 ++ eqns3) tycl_decls
; auto_typeable <- xoptM Opt_AutoDeriveTypeable
; eqns4 <- deriveAutoTypeable auto_typeable (eqns1 ++ eqns3) tycl_decls
; let eqns = eqns1 ++ eqns2 ++ eqns3 ++ eqns4
......@@ -782,7 +782,7 @@ deriveTyData is_instance tvs tc tc_args (L loc deriv_pred)
-- newtype K a a = ... deriving( Monad )
; spec <- mkEqnHelp Nothing (univ_kvs' ++ univ_tvs')
cls final_cls_tys tc final_tc_args Nothing
cls final_cls_tys tc final_tc_args Nothing
; return [spec] } }
derivePolyKindedTypeable :: Bool -> Class -> [Type]
......@@ -1001,9 +1001,10 @@ mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
tycon tc_args rep_tc rep_tc_args mtheta
= case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of
-- NB: pass the *representation* tycon to checkSideConditions
CanDerive -> go_for_it
NonDerivableClass -> bale_out (nonStdErr cls)
NonDerivableClass msg -> bale_out (nonStdErr cls $$ msg)
DerivableClassError msg -> bale_out msg
CanDerive -> go_for_it
DerivableViaInstance -> go_for_it
where
go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
......@@ -1049,7 +1050,7 @@ mkPolyKindedTypeableEqn cls tc
2 (ptext (sLit "You need DeriveDataTypeable to derive Typeable instances")))
; loc <- getSrcSpanM
; let prom_dcs = mapMaybe promoteDataCon_maybe (tyConDataCons tc)
; let prom_dcs = mapMaybe promoteDataCon_maybe (tyConDataCons tc)
; mapM (mk_one loc) (tc : prom_dcs) }
where
mk_one loc tc = do { traceTc "mkPolyKindedTypeableEqn" (ppr tc)
......@@ -1112,7 +1113,11 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
-- (a) We recurse over argument types to generate constraints
-- See Functor examples in TcGenDeriv
-- (b) The rep_tc_args will be one short
is_functor_like = getUnique cls `elem` functorLikeClassKeys
is_functor_like = getUnique cls `elem` functorLikeClassKeys
|| onlyOneAndTypeConstr inst_tys
onlyOneAndTypeConstr [inst_ty] =
typeKind inst_ty `tcEqKind` mkArrowKind liftedTypeKind liftedTypeKind
onlyOneAndTypeConstr _ = False
get_std_constrained_tys :: Type -> [Type]
get_std_constrained_tys ty
......@@ -1165,6 +1170,37 @@ We have some special hacks to support things like
Specifically, we use TcGenDeriv.box_if_necy to box the Int# into an Int
(which we know how to show). It's a bit ad hoc.
Note [Deriving any class]
~~~~~~~~~~~~~~~~~~~~~~~~~
Currently, you can use a deriving clause, or standalone-deriving declaration,
only for:
* a built-in class like Eq or Show, for which GHC knows how to generate
the instance code
* a newtype, via the "newtype-deriving" mechanism.
However, with GHC.Generics we can write this:
data T a = ...blah..blah... deriving( Generic )
instance C a => C (T a) -- No 'where' clause
where C is some "random" user-defined class. Usually, an instance decl with no
'where' clause would be pretty useless, but now that we have default method
signatures, in conjunction with deriving( Generic ), the instance can be useful.
That in turn leads to a desire to say
data T a = ...blah..blah... deriving( Generic, C )
which is even more compact. That is what DeriveAnyClass implements. This is
not restricted to Generics; any class can be derived, simply giving rise to
an empty instance.
The only thing left to answer is how to determine the context (in case of
standard deriving; in standalone deriving, the user provides the context).
GHC uses the same heuristic for figuring out the class context that it uses for
Eq in the case of *-kinded classes, and for Functor in the case of
* -> *-kinded classes. That may not be optimal or even wrong. But in such
cases, standalone deriving can still be used.
\begin{code}
------------------------------------------------------------------
......@@ -1177,7 +1213,8 @@ Specifically, we use TcGenDeriv.box_if_necy to box the Int# into an Int
data DerivStatus = CanDerive
| DerivableClassError SDoc -- Standard class, but can't do it
| NonDerivableClass -- Non-standard class
| DerivableViaInstance -- See Note [Deriving any class]
| NonDerivableClass SDoc -- Non-standard class
checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
-> TyCon -> [Type] -- tycon and its parameters
......@@ -1190,7 +1227,8 @@ checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args
-- cls_tys (the type args other than last)
-- should be null
| otherwise -> DerivableClassError (classArgsErr cls cls_tys) -- e.g. deriving( Eq s )
| otherwise = NonDerivableClass -- Not a standard class
| otherwise = maybe DerivableViaInstance NonDerivableClass
(canDeriveAnyClass dflags rep_tc cls)
classArgsErr :: Class -> [Type] -> SDoc
classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
......@@ -1225,7 +1263,7 @@ sideConditions mtheta cls
| cls_key == gen1ClassKey = Just (checkFlag Opt_DeriveGeneric `andCond`
cond_vanilla `andCond`
cond_Representable1Ok)
| otherwise = Nothing
| otherwise = Nothing
where
cls_key = getUnique cls
cond_std = cond_stdOK mtheta False -- Vanilla data constructors, at least one,
......@@ -1495,7 +1533,8 @@ mkNewTypeEqn dflags overlap_mode tvs
cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
| ASSERT( length cls_tys + 1 == classArity cls )
might_derive_via_coercible && (newtype_deriving || std_class_via_coercible cls)
might_derive_via_coercible && ((newtype_deriving && not deriveAnyClass)
|| std_class_via_coercible cls)
= do traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
dfun_name <- new_dfun_name cls tycon
loc <- getSrcSpanM
......@@ -1518,18 +1557,29 @@ mkNewTypeEqn dflags overlap_mode tvs
, ds_newtype = True }
| otherwise
= case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of
CanDerive -> go_for_it -- Use the standard H98 method
DerivableClassError msg -- Error with standard class
-- Error with standard class
DerivableClassError msg
| might_derive_via_coercible -> bale_out (msg $$ suggest_nd)
| otherwise -> bale_out msg
NonDerivableClass -- Must use newtype deriving
| newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving
| might_derive_via_coercible -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving!
-- Must use newtype deriving or DeriveAnyClass
NonDerivableClass _msg
-- Too hard, even with newtype deriving
| newtype_deriving -> bale_out cant_derive_err
-- Try newtype deriving!
| might_derive_via_coercible -> bale_out (non_std $$ suggest_nd)
| otherwise -> bale_out non_std
-- CanDerive/DerivableViaInstance
_ -> do when (newtype_deriving && deriveAnyClass) $
addWarnTc (sep [ ptext (sLit "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled")
, ptext (sLit "Defaulting to the DeriveAnyClass strategy for instantiating") <+> ppr cls ])
go_for_it
where
newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags
go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
bale_out msg = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg)
newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags
deriveAnyClass = xopt Opt_DeriveAnyClass dflags
go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args
rep_tycon rep_tc_args mtheta
bale_out = bale_out' newtype_deriving
bale_out' b = failWithTc . derivingThingErr b cls cls_tys inst_ty
non_std = nonStdErr cls
suggest_nd = ptext (sLit "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
......@@ -2041,7 +2091,7 @@ genDerivStuff loc clas dfun_name tycon comaux_maybe
Note [Bindings for Generalised Newtype Deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
Consider
class Eq a => C a where
f :: a -> a
newtype N a = MkN [a] deriving( C )
......
......@@ -17,7 +17,8 @@ This is where we do all the grimy bindings' generation.
module TcGenDeriv (
BagDerivStuff, DerivStuff(..),
genDerivedBinds,
canDeriveAnyClass,
genDerivedBinds,
FFoldType(..), functorLikeTraverse,
deepSubtypesContaining, foldDataConArgs,
mkCoerceClassMethEqn,
......@@ -65,8 +66,9 @@ import Bag
import Fingerprint
import TcEnv (InstInfo)
import ListSetOps( assocMaybe )
import Data.List ( partition, intersperse )
import ListSetOps ( assocMaybe )
import Data.List ( partition, intersperse )
import Data.Maybe ( isNothing )
\end{code}
\begin{code}
......@@ -106,7 +108,12 @@ genDerivedBinds dflags fix_env clas loc tycon
= gen_fn loc tycon
| otherwise
= pprPanic "genDerivStuff: bad derived class" (ppr clas)
-- Deriving any class simply means giving an empty instance, so no
-- bindings have to be generated.
= ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas)
, ppr "genDerivStuff: bad derived class" <+> ppr clas )
(emptyBag, emptyBag)
where
gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
gen_list = [ (eqClassKey, gen_Eq_binds)
......@@ -121,6 +128,20 @@ genDerivedBinds dflags fix_env clas loc tycon
, (functorClassKey, gen_Functor_binds)
, (foldableClassKey, gen_Foldable_binds)
, (traversableClassKey, gen_Traversable_binds) ]
-- Nothing: we can (try to) derive it via Generics
-- Just s: we can't, reason s
canDeriveAnyClass :: DynFlags -> TyCon -> Class -> Maybe SDoc
canDeriveAnyClass dflags _tycon clas =
let b `orElse` s = if b then Nothing else Just (ptext (sLit s))
Just m <> _ = Just m
Nothing <> n = n
-- We can derive a given class for a given tycon via Generics iff
in -- 1) The class is not a "standard" class (like Show, Functor, etc.)
(not (getUnique clas `elem` standardClassKeys) `orElse` "")
-- 2) Opt_DeriveAnyClass is on
<> (xopt Opt_DeriveAnyClass dflags `orElse` "Try enabling DeriveAnyClass")
\end{code}
%************************************************************************
......@@ -1231,7 +1252,7 @@ we generate
We are passed the Typeable2 class as well as T
\begin{code}
gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon
gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon
-> (LHsBinds RdrName, BagDerivStuff)
gen_Typeable_binds dflags loc tycon
= ( unitBag $ mk_easy_FunBind loc typeRep_RDR [nlWildPat]
......
......@@ -805,6 +805,13 @@
<entry>dynamic</entry>
<entry><option>-XNoDefaultSignatures</option></entry>
</row>
<row>
<entry><option>-XDeriveAnyClass</option></entry>
<entry>Enable <link linkend="derive-any-class">deriving for any
class</link>.</entry>
<entry>dynamic</entry>
<entry><option>-XNoDeriveAnyClass</option></entry>
</row>
<row>
<entry><option>-XDeriveDataTypeable</option></entry>
<entry>Enable <link linkend="deriving-typeable">deriving for the Data and Typeable classes</link>.
......
This diff is collapsed.
......@@ -33,6 +33,7 @@ expectedGhcOnlyExtensions :: [String]
expectedGhcOnlyExtensions = ["RelaxedLayout",
"AlternativeLayoutRule",
"AlternativeLayoutRuleTransitional",
"DeriveAnyClass",
"JavaScriptFFI",
"PatternSynonyms"]
......
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
module Enum where
import GHC.Generics
-----------------------------------------------------------------------------
-- Utility functions for Enum'
-----------------------------------------------------------------------------
infixr 5 |||
-- | Interleave elements from two lists. Similar to (++), but swap left and
-- right arguments on every recursive application.
--
-- From Mark Jones' talk at AFP2008
(|||) :: [a] -> [a] -> [a]
[] ||| ys = ys
(x:xs) ||| ys = x : ys ||| xs
-- | Diagonalization of nested lists. Ensure that some elements from every
-- sublist will be included. Handles infinite sublists.
--
-- From Mark Jones' talk at AFP2008
diag :: [[a]] -> [a]
diag = concat . foldr skew [] . map (map (\x -> [x]))
skew :: [[a]] -> [[a]] -> [[a]]
skew [] ys = ys
skew (x:xs) ys = x : combine (++) xs ys
combine :: (a -> a -> a) -> [a] -> [a] -> [a]
combine _ xs [] = xs
combine _ [] ys = ys
combine f (x:xs) (y:ys) = f x y : combine f xs ys
findIndex :: (a -> Bool) -> [a] -> Maybe Int
findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y]
in if (null l)
then Nothing
else Just (head l)
--------------------------------------------------------------------------------
-- Generic enum
--------------------------------------------------------------------------------
class Enum' f where
enum' :: [f a]
instance Enum' U1 where
enum' = [U1]
instance (GEnum c) => Enum' (K1 i c) where
enum' = map K1 genum
instance (Enum' f) => Enum' (M1 i c f) where
enum' = map M1 enum'
instance (Enum' f, Enum' g) => Enum' (f :+: g) where
enum' = map L1 enum' ||| map R1 enum'
instance (Enum' f, Enum' g) => Enum' (f :*: g) where
enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ]
instance (GEnum a) => GEnum (Maybe a)
instance (GEnum a) => GEnum [a]
genumDefault :: (Generic a, Enum' (Rep a)) => [a]
genumDefault = map to enum'
class GEnum a where
genum :: [a]
default genum :: (Generic a, Enum' (Rep a)) => [a]
genum = genumDefault
instance GEnum Int where
genum = [0..] ||| (neg 0) where
neg n = (n-1) : neg (n-1)
......@@ -37,8 +37,7 @@ class GEq a where
instance GEq Char where geq = (==)
instance GEq Int where geq = (==)
instance GEq Float where geq = (==)
{-
-- Generic instances
instance (GEq a) => GEq (Maybe a)
instance (GEq a) => GEq [a]
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
-- DeriveAnyClass not enabled
module T5462No1 where
import GHC.Generics hiding (C, C1, D)
import GFunctor
class C1 a where
c1 :: a -> Int
class C2 a where
c2 :: a -> Int
c2 _ = 0
newtype F a = F1 [a]
deriving (Show, Eq, Generic, Generic1, GFunctor)
data G = G1 deriving (C1)
data H = H1 deriving (C2)
[1 of 2] Compiling GFunctor ( GFunctor/GFunctor.hs, GFunctor/GFunctor.o )
[2 of 2] Compiling T5462No1 ( T5462No1.hs, T5462No1.o )
T5462No1.hs:24:42:
Can't make a derived instance of ‘GFunctor F’:
‘GFunctor’ is not a derivable class
Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension
In the newtype declaration for ‘F’
T5462No1.hs:26:23:
Can't make a derived instance of ‘C1 G’:
‘C1’ is not a derivable class
Try enabling DeriveAnyClass
In the data declaration for ‘G’
T5462No1.hs:27:23:
Can't make a derived instance of ‘C2 H’:
‘C2’ is not a derivable class
Try enabling DeriveAnyClass
In the data declaration for ‘H’
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveAnyClass #-}
module Main where
import GHC.Generics hiding (C, C1, D)
import GEq1A
import Enum
import GFunctor
data A = A1
deriving (Show, Generic, GEq, GEnum)
data B a = B1 | B2 a (B a)
deriving (Show, Generic, Generic1, GEq, GEnum, GFunctor)
data C phantom a = C1 | C2 a (C phantom a)
deriving (Show, Generic, Generic1, GEq, GEnum, GFunctor)
data D f a = D1 (f a) (f (D f a)) deriving (Generic, Generic1)
deriving instance (Show (f a), Show (f (D f a))) => Show (D f a)
deriving instance (GEq (f a), GEq (f (D f a))) => GEq (D f a)
data E f a = E1 (f a)
deriving (Show, Eq, Generic, Generic1, GFunctor)
main = print (
geq A1 A1
, take 10 (genum :: [A])
, geq (B2 A1 B1) B1
, gmap (++ "lo") (B2 "hel" B1)
, take 3 (genum :: [B A])
, geq (C2 A1 C1) C1
, gmap (++ "lo") (C2 "hel" C1)
, geq (D1 "a" []) (D1 "a" [])
, gmap (++ "lo") (E1 ["hel"])
)
(True,[A1],False,B2 "hello" B1,[B1,B2 A1 B1,B2 A1 (B2 A1 B1)],False,C2 "hello" C1,True,E1 ["hello"])
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Main where
import GHC.Generics hiding (C, C1, D)
import GFunctor
class C1 a where
c1 :: a -> Int
c1 _ = 1
class C2 a where
c21 :: a -> Int
c21 = c22
c22 :: a -> Int
c22 = c21
{-# MINIMAL c21 | c22 #-}
newtype D = D Int deriving C1
instance C1 Int where c1 _ = 2
newtype F a = F1 [a]
deriving (Show, Eq, Generic, Generic1, GFunctor)
data G = G1 deriving (C1)
data H = H1 deriving (C2)
main = print (c1 (D 3))
......@@ -19,11 +19,15 @@ test('GenCannotDoRep1_6', normal, compile_fail, [''])
test('GenCannotDoRep1_7', normal, compile_fail, [''])
test('GenCannotDoRep1_8', normal, compile_fail, [''])
test('T5884', normal, compile, [''])
test('GenNewtype', normal, compile_and_run, [''])
test('T5462Yes1', normal, multimod_compile_and_run, ['T5462Yes1', '-iGEq -iGEnum -iGFunctor'])
test('T5462Yes2', normal, multimod_compile_and_run, ['T5462Yes2', '-iGFunctor'])
test('T5462No1', normal, multimod_compile_fail, ['T5462No1', '-iGFunctor'])
test('GenDerivOutput1_0', normal, compile, ['-dsuppress-uniques'])
test('GenDerivOutput1_1', normal, compile, ['-dsuppress-uniques'])
test('T5884', normal, compile, [''])
test('GenNewtype', normal, compile_and_run, [''])
test('GenDerivOutput1_0', normal, compile, ['-dsuppress-uniques'])
test('GenDerivOutput1_1', normal, compile, ['-dsuppress-uniques'])
test('T7878', extra_clean(['T7878A.o' ,'T7878A.hi'
,'T7878A.o-boot','T7878A.hi-boot'
......
......@@ -2,4 +2,5 @@
mod53.hs:4:22:
Can't make a derived instance of ‘C T’:
‘C’ is not a derivable class
Try enabling DeriveAnyClass
In the data declaration for ‘T’
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