I am trying to produce data structure which mimics a toJSON structure:
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fprint-potential-instances #-}
module Gen where
import Data.Proxy
import GHC.Generics
import GHC.TypeLits
data Syntax
= ObjectS String [Syntax]
| IntS String
| CharS String
deriving (Eq, Show, Generic)
target :: [Syntax]
target = [IntS "rfLeft", ObjectS "rfRight" [CharS "sfOne"]]
class GUnnamedSpec f where
genericUnnamedSpec :: Proxy f -> String -> Syntax
instance GUnnamedSpec Int where -- U1
genericUnnamedSpec _ = IntS
instance GUnnamedSpec Char where -- U2
genericUnnamedSpec _ = CharS
instance (Spec f) => GUnnamedSpec f where -- U3
genericUnnamedSpec _ n = ObjectS n $ spec $ Proxy @f
instance (GUnnamedSpec f) => GUnnamedSpec (Rec0 f p) where -- U4
genericUnnamedSpec _ = genericUnnamedSpec $ Proxy @f
instance (GUnnamedSpec (f p)) => GUnnamedSpec (D1 m f p) where -- U5
genericUnnamedSpec _ = genericUnnamedSpec $ Proxy @(f p)
instance (GUnnamedSpec (f p)) => GUnnamedSpec (S1 ('MetaSel 'Nothing u s l) f p) where -- U6
genericUnnamedSpec _ = genericUnnamedSpec $ Proxy @(f p)
instance (GUnnamedSpec (f p)) => GUnnamedSpec (C1 m f p) where -- U7
genericUnnamedSpec _ = genericUnnamedSpec $ Proxy @(f p)
class GNamedSpec f where
genericNamedSpec :: Proxy (f p) -> [Syntax]
instance (GNamedSpec f, GNamedSpec g) => GNamedSpec (f :*: g) where -- N1
genericNamedSpec _ = genericNamedSpec (Proxy @(f ())) <> genericNamedSpec (Proxy @(g ()))
instance (GUnnamedSpec (f ()), KnownSymbol n) => GNamedSpec (S1 ('MetaSel ('Just n) u s l) f) where -- N2
genericNamedSpec _ = [genericUnnamedSpec (Proxy @(f ())) $ symbolVal (Proxy @n)]
instance (GNamedSpec f) => GNamedSpec (D1 m f) where -- N3
genericNamedSpec _ = genericNamedSpec $ Proxy @(f ())
instance (GNamedSpec f) => GNamedSpec (C1 m f) where -- N4
genericNamedSpec _ = genericNamedSpec $ Proxy @(f ())
class Spec a where
spec :: Proxy a -> [Syntax]
default spec :: (Generic a, GNamedSpec (Rep a)) => Proxy a -> [Syntax]
spec _ = genericNamedSpec $ Proxy @(Rep a ())
I have the following types:
data RootT = RootT
{ rfLeft :: Int,
rfRight :: SubT
}
deriving (Eq, Show, Generic, Spec)
data SubT = SubT {sfOne :: Char}
deriving (Eq, Show, Generic, Spec)
They have this structure:
(undefined :: Rep SubT p)
:: D1
('MetaData "SubT" "Gen" "main" 'False)
(C1
('MetaCons "SubT" 'PrefixI 'True)
(S1
('MetaSel
('Just "sfOne")
'NoSourceUnpackedness
'NoSourceStrictness
'DecidedLazy)
(Rec0 Char)))
p
*Gen GHC.Generics> :t (undefined :: Rep RootT p)
(undefined :: Rep RootT p)
:: D1
('MetaData "RootT" "Gen" "main" 'False)
(C1
('MetaCons "RootT" 'PrefixI 'True)
(S1
('MetaSel
('Just "rfLeft")
'NoSourceUnpackedness
'NoSourceStrictness
'DecidedLazy)
(Rec0 Int)
:*: S1
('MetaSel
('Just "rfRight")
'NoSourceUnpackedness
'NoSourceStrictness
'DecidedLazy)
(Rec0 SubT)))
p
In my understanding it should be resolved as follows:
SubT: N4 -> N3 -> N2 -> U4 -> U2
RootT: N4 -> N3 -> N1 -> (N2 -> U4 -> U2, N2 -> U4 -> U3)
While I have these errors:
Gen.hs:26:32: error:
• Overlapping instances for GUnnamedSpec (K1 R Int ())
arising from the 'deriving' clause of a data type declaration
Matching instances:
instance Spec f => GUnnamedSpec f
-- Defined at Gen.hs:49:10
...plus one instance involving out-of-scope types
instance GUnnamedSpec f => GUnnamedSpec (Rec0 f p)
-- Defined at Gen.hs:52:10
• When deriving the instance for (Spec RootT)
|
26 | deriving (Eq, Show, Generic, Spec)
| ^^^^
Gen.hs:29:32: error:
• Overlapping instances for GUnnamedSpec (K1 R Char ())
arising from the 'deriving' clause of a data type declaration
Matching instances:
instance Spec f => GUnnamedSpec f
-- Defined at Gen.hs:49:10
...plus one instance involving out-of-scope types
instance GUnnamedSpec f => GUnnamedSpec (Rec0 f p)
-- Defined at Gen.hs:52:10
• When deriving the instance for (Spec SubT)
|
29 | deriving (Eq, Show, Generic, Spec)
|
Is there a way to remove the ambiguity?
Several things are weird here.
Typically, you'll want to make your Generic classes take types of kind Type -> Type or k -> Type, and not to worry about the p parameter unless you need to deal with Generic1. So I'd expect something more like
class GUnnamedSpec (f :: Type -> Type) where
genericUnnamedSpec :: Proxy f -> String -> Syntax
class GNamedSpec (f :: Type -> Type) where
genericNamedSpec :: Proxy f -> [Syntax]
If you use AllowAmbiguousTypes, then you can drop the proxies too.
These are really unusual and confusing:
instance Spec f => GUnnamedSpec f where -- U3
genericUnnamedSpec _ n = ObjectS n $ spec $ Proxy @f
instance (GUnnamedSpec f) => GUnnamedSpec (Rec0 f p) where -- U4
genericUnnamedSpec _ = genericUnnamedSpec $ Proxy @f
The first one should be dropped altogether. You can change the second one to branch the way you want. Here's one way:
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes#-}
{-# OPTIONS_GHC -fprint-potential-instances #-}
module Gen where
import Data.Proxy
import GHC.Generics
import GHC.TypeLits
import Data.Kind (Type)
import Data.Semigroup (Semigroup (..))
data Syntax
= ObjectS String [Syntax]
| IntS String
| CharS String
deriving (Eq, Show, Generic)
target :: [Syntax]
target = [IntS "rfLeft", ObjectS "rfRight" [CharS "sfOne"]]
class GUnnamedSpec (f :: Type -> Type) where
genericUnnamedSpec :: String -> Syntax
instance GUnnamedSpec (K1 i Int) where -- U1
genericUnnamedSpec = IntS
instance GUnnamedSpec (K1 i Char) where -- U2
genericUnnamedSpec = CharS
instance {-# OVERLAPPABLE #-} Spec a => GUnnamedSpec (K1 i a) where -- U4
genericUnnamedSpec n = ObjectS n $ spec @a
instance GUnnamedSpec f => GUnnamedSpec (D1 m f) where -- U5
genericUnnamedSpec = genericUnnamedSpec @f
instance GUnnamedSpec f => GUnnamedSpec (S1 ('MetaSel 'Nothing u s l) f) where -- U6
genericUnnamedSpec = genericUnnamedSpec @f
instance GUnnamedSpec f => GUnnamedSpec (C1 m f) where -- U7
genericUnnamedSpec = genericUnnamedSpec @f
class GNamedSpec (f :: Type -> Type) where
genericNamedSpec :: [Syntax]
instance (GNamedSpec f, GNamedSpec g) => GNamedSpec (f :*: g) where -- N1
genericNamedSpec = genericNamedSpec @f <> genericNamedSpec @g
instance (GUnnamedSpec f, KnownSymbol n) => GNamedSpec (S1 ('MetaSel ('Just n) u s l) f) where -- N2
genericNamedSpec = [genericUnnamedSpec @f $ symbolVal (Proxy @n)]
instance GNamedSpec f => GNamedSpec (D1 m f) where -- N3
genericNamedSpec = genericNamedSpec @f
instance GNamedSpec f => GNamedSpec (C1 m f) where -- N4
genericNamedSpec = genericNamedSpec @f
class Spec (a :: Type) where
spec :: [Syntax]
default spec :: (Generic a, GNamedSpec (Rep a)) => [Syntax]
spec = genericNamedSpec @(Rep a)
As far as I can tell, the only GUnnamedSpec instances used are the K1 ones. This is because (I believe) the only thing that can be under an S1 in a Rep is a K1 (this is different for Rep1, but you don't need that for your purpose). Assuming this is right, you can simplify further.
class UnnamedSpec a where
unnamedSpec :: String -> Syntax
instance UnnamedSpec Int where -- U1
unnamedSpec = IntS
instance UnnamedSpec Char where -- U2
unnamedSpec = CharS
instance {-# OVERLAPPABLE #-} Spec a => UnnamedSpec a where -- U4
unnamedSpec n = ObjectS n $ spec @a
class GNamedSpec (f :: Type -> Type) where
genericNamedSpec :: [Syntax]
instance (GNamedSpec f, GNamedSpec g) => GNamedSpec (f :*: g) where -- N1
genericNamedSpec = genericNamedSpec @f <> genericNamedSpec @g
instance (UnnamedSpec a, KnownSymbol n) => GNamedSpec (S1 ('MetaSel ('Just n) u s l) (K1 i a)) where -- N2
genericNamedSpec = [unnamedSpec @a $ symbolVal (Proxy @n)]
instance GNamedSpec f => GNamedSpec (D1 m f) where -- N3
genericNamedSpec = genericNamedSpec @f
instance GNamedSpec f => GNamedSpec (C1 m f) where -- N4
genericNamedSpec = genericNamedSpec @f
class Spec (a :: Type) where
spec :: [Syntax]
default spec :: (Generic a, GNamedSpec (Rep a)) => [Syntax]
spec = genericNamedSpec @(Rep a)