{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Generics.Eot.Eot (
  HasEotG(..),
  Named(..)
  ) where

import           Data.Proxy
import           Data.Void
import           GHC.Generics
import           GHC.TypeLits

-- * datatype

class HasEotG (a :: * -> *) where
  type EotG a :: *
  toEotG :: a x -> EotG a
  fromEotG :: EotG a -> a x

instance HasConstructorsG f => HasEotG (D1 c f) where
  type EotG (D1 c f) = Constructors f
  toEotG :: D1 c f x -> EotG (D1 c f)
toEotG (M1 f x
x) = f x -> Constructors f
forall (a :: * -> *) x. HasConstructorsG a => a x -> Constructors a
toEotConstructors f x
x
  fromEotG :: EotG (D1 c f) -> D1 c f x
fromEotG EotG (D1 c f)
x = f x -> D1 c f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f x -> D1 c f x) -> f x -> D1 c f x
forall a b. (a -> b) -> a -> b
$ Constructors f -> f x
forall (a :: * -> *) x. HasConstructorsG a => Constructors a -> a x
fromEotConstructors Constructors f
EotG (D1 c f)
x

-- * constructors

class HasConstructorsG (a :: * -> *) where
  type Constructors a :: *
  toEotConstructors :: a x -> Constructors a
  fromEotConstructors :: Constructors a -> a x

instance (HasConstructorsG a, HasConstructorsG b, Normalize (Constructors a) (Constructors b)) =>
  HasConstructorsG (a :+: b) where
    type Constructors (a :+: b) = GEither (Constructors a) (Constructors b)
    toEotConstructors :: (:+:) a b x -> Constructors (a :+: b)
toEotConstructors = \ case
      L1 a x
a -> Constructors a
-> Proxy (Constructors b)
-> GEither (Constructors a) (Constructors b)
forall a b. Normalize a b => a -> Proxy b -> GEither a b
gLeft (a x -> Constructors a
forall (a :: * -> *) x. HasConstructorsG a => a x -> Constructors a
toEotConstructors a x
a) (Proxy (Constructors b)
forall k (t :: k). Proxy t
Proxy :: Proxy (Constructors b))
      R1 b x
b -> Proxy (Constructors a)
-> Constructors b -> GEither (Constructors a) (Constructors b)
forall a b. Normalize a b => Proxy a -> b -> GEither a b
gRight (Proxy (Constructors a)
forall k (t :: k). Proxy t
Proxy :: Proxy (Constructors a)) (b x -> Constructors b
forall (a :: * -> *) x. HasConstructorsG a => a x -> Constructors a
toEotConstructors b x
b)
    fromEotConstructors :: Constructors (a :+: b) -> (:+:) a b x
fromEotConstructors Constructors (a :+: b)
x = case GEither (Constructors a) (Constructors b)
-> Either (Constructors a) (Constructors b)
forall a b. Normalize a b => GEither a b -> Either a b
gEither GEither (Constructors a) (Constructors b)
Constructors (a :+: b)
x of
      Left Constructors a
a -> a x -> (:+:) a b x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (Constructors a -> a x
forall (a :: * -> *) x. HasConstructorsG a => Constructors a -> a x
fromEotConstructors Constructors a
a)
      Right Constructors b
b -> b x -> (:+:) a b x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (Constructors b -> b x
forall (a :: * -> *) x. HasConstructorsG a => Constructors a -> a x
fromEotConstructors Constructors b
b)

instance HasFieldsG f => HasConstructorsG (C1 c f) where
  type Constructors (C1 c f) = Either (Fields f) Void
  toEotConstructors :: C1 c f x -> Constructors (C1 c f)
toEotConstructors = Fields f -> Either (Fields f) Void
forall a b. a -> Either a b
Left (Fields f -> Either (Fields f) Void)
-> (C1 c f x -> Fields f) -> C1 c f x -> Either (Fields f) Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> Fields f
forall (a :: * -> *) x. HasFieldsG a => a x -> Fields a
toEotFields (f x -> Fields f) -> (C1 c f x -> f x) -> C1 c f x -> Fields f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. C1 c f x -> f x
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
  fromEotConstructors :: Constructors (C1 c f) -> C1 c f x
fromEotConstructors = \ case
    Left fields -> f x -> C1 c f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f x -> C1 c f x) -> f x -> C1 c f x
forall a b. (a -> b) -> a -> b
$ Fields f -> f x
forall (a :: * -> *) x. HasFieldsG a => Fields a -> a x
fromEotFields Fields f
fields
    Right void -> Void -> C1 c f x
forall a. Void -> a
absurd Void
void

instance HasConstructorsG V1 where
  type Constructors V1 = Void
  toEotConstructors :: V1 x -> Constructors V1
toEotConstructors V1 x
v1 = V1 x -> Void -> Void
seq V1 x
v1 ([Char] -> Void
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible")
  fromEotConstructors :: Constructors V1 -> V1 x
fromEotConstructors = Constructors V1 -> V1 x
forall a. Void -> a
absurd

-- * GEither

class Normalize a b where
  type GEither a b :: *
  gLeft :: a -> Proxy b -> GEither a b
  gRight :: Proxy a -> b -> GEither a b
  gEither :: GEither a b -> Either a b

instance Normalize b c => Normalize (Either a b) c where
  type GEither (Either a b) c = Either a (GEither b c)
  gLeft :: Either a b -> Proxy c -> GEither (Either a b) c
gLeft (Left a
a) Proxy c
Proxy = a -> Either a (GEither b c)
forall a b. a -> Either a b
Left a
a
  gLeft (Right b
b) Proxy c
Proxy = GEither b c -> Either a (GEither b c)
forall a b. b -> Either a b
Right (GEither b c -> Either a (GEither b c))
-> GEither b c -> Either a (GEither b c)
forall a b. (a -> b) -> a -> b
$ b -> Proxy c -> GEither b c
forall a b. Normalize a b => a -> Proxy b -> GEither a b
gLeft b
b (Proxy c
forall k (t :: k). Proxy t
Proxy :: Proxy c)
  gRight :: Proxy (Either a b) -> c -> GEither (Either a b) c
gRight Proxy (Either a b)
Proxy c
c = GEither b c -> Either a (GEither b c)
forall a b. b -> Either a b
Right (GEither b c -> Either a (GEither b c))
-> GEither b c -> Either a (GEither b c)
forall a b. (a -> b) -> a -> b
$ Proxy b -> c -> GEither b c
forall a b. Normalize a b => Proxy a -> b -> GEither a b
gRight (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b) c
c
  gEither :: Either a (GEither b c) -> Either (Either a b) c
  gEither :: Either a (GEither b c) -> Either (Either a b) c
gEither = \ case
    Left a
a -> Either a b -> Either (Either a b) c
forall a b. a -> Either a b
Left (a -> Either a b
forall a b. a -> Either a b
Left a
a)
    Right GEither b c
g -> case GEither b c -> Either b c
forall a b. Normalize a b => GEither a b -> Either a b
gEither GEither b c
g of
      Left b
b -> Either a b -> Either (Either a b) c
forall a b. a -> Either a b
Left (b -> Either a b
forall a b. b -> Either a b
Right b
b)
      Right c
c -> c -> Either (Either a b) c
forall a b. b -> Either a b
Right c
c

instance Normalize Void b where
  type GEither Void b = b
  gLeft :: Void -> Proxy b -> GEither Void b
gLeft Void
void Proxy b
Proxy = Void -> b
forall a. Void -> a
absurd Void
void
  gRight :: Proxy Void -> b -> GEither Void b
gRight Proxy Void
Proxy b
b = b
GEither Void b
b
  gEither :: b -> Either Void b
  gEither :: b -> Either Void b
gEither = b -> Either Void b
forall a b. b -> Either a b
Right

-- * fields

class HasFieldsG (a :: * -> *) where
  type Fields a :: *
  toEotFields :: a x -> Fields a
  fromEotFields :: Fields a -> a x

instance (HasFieldsG a, HasFieldsG b, Concat (Fields a) (Fields b)) =>
  HasFieldsG (a :*: b) where
    type Fields (a :*: b) = Fields a +++ Fields b
    toEotFields :: (:*:) a b x -> Fields (a :*: b)
toEotFields (a x
a :*: b x
b) = a x -> Fields a
forall (a :: * -> *) x. HasFieldsG a => a x -> Fields a
toEotFields a x
a Fields a -> Fields b -> Fields a +++ Fields b
forall a b. Concat a b => a -> b -> a +++ b
+++ b x -> Fields b
forall (a :: * -> *) x. HasFieldsG a => a x -> Fields a
toEotFields b x
b
    fromEotFields :: Fields (a :*: b) -> (:*:) a b x
fromEotFields Fields (a :*: b)
x = case (Fields a +++ Fields b) -> (Fields a, Fields b)
forall a b. Concat a b => (a +++ b) -> (a, b)
unConcat Fields a +++ Fields b
Fields (a :*: b)
x of
      (Fields a
a, Fields b
b) -> Fields a -> a x
forall (a :: * -> *) x. HasFieldsG a => Fields a -> a x
fromEotFields Fields a
a a x -> b x -> (:*:) a b x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: Fields b -> b x
forall (a :: * -> *) x. HasFieldsG a => Fields a -> a x
fromEotFields Fields b
b

data Named (a :: Symbol) field = Named field deriving Int -> Named a field -> ShowS
[Named a field] -> ShowS
Named a field -> [Char]
(Int -> Named a field -> ShowS)
-> (Named a field -> [Char])
-> ([Named a field] -> ShowS)
-> Show (Named a field)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall (a :: Symbol) field.
Show field =>
Int -> Named a field -> ShowS
forall (a :: Symbol) field. Show field => [Named a field] -> ShowS
forall (a :: Symbol) field. Show field => Named a field -> [Char]
showList :: [Named a field] -> ShowS
$cshowList :: forall (a :: Symbol) field. Show field => [Named a field] -> ShowS
show :: Named a field -> [Char]
$cshow :: forall (a :: Symbol) field. Show field => Named a field -> [Char]
showsPrec :: Int -> Named a field -> ShowS
$cshowsPrec :: forall (a :: Symbol) field.
Show field =>
Int -> Named a field -> ShowS
Show
data Unnamed field = Unnamed field deriving Int -> Unnamed field -> ShowS
[Unnamed field] -> ShowS
Unnamed field -> [Char]
(Int -> Unnamed field -> ShowS)
-> (Unnamed field -> [Char])
-> ([Unnamed field] -> ShowS)
-> Show (Unnamed field)
forall field. Show field => Int -> Unnamed field -> ShowS
forall field. Show field => [Unnamed field] -> ShowS
forall field. Show field => Unnamed field -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Unnamed field] -> ShowS
$cshowList :: forall field. Show field => [Unnamed field] -> ShowS
show :: Unnamed field -> [Char]
$cshow :: forall field. Show field => Unnamed field -> [Char]
showsPrec :: Int -> Unnamed field -> ShowS
$cshowsPrec :: forall field. Show field => Int -> Unnamed field -> ShowS
Show

instance KnownSymbol name => HasFieldsG (S1 ('MetaSel ('Just name) x y z) (Rec0 f)) where
  type Fields (S1 ('MetaSel ('Just name) x y z) (Rec0 f)) = (Named name f, ())
  toEotFields :: S1 ('MetaSel ('Just name) x y z) (Rec0 f) x
-> Fields (S1 ('MetaSel ('Just name) x y z) (Rec0 f))
toEotFields (M1 (K1 f
x)) = (f -> Named name f
forall (a :: Symbol) field. field -> Named a field
Named f
x, ())
  fromEotFields :: Fields (S1 ('MetaSel ('Just name) x y z) (Rec0 f))
-> S1 ('MetaSel ('Just name) x y z) (Rec0 f) x
fromEotFields (Named x, ()) = K1 R f x -> S1 ('MetaSel ('Just name) x y z) (Rec0 f) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R f x -> S1 ('MetaSel ('Just name) x y z) (Rec0 f) x)
-> K1 R f x -> S1 ('MetaSel ('Just name) x y z) (Rec0 f) x
forall a b. (a -> b) -> a -> b
$ f -> K1 R f x
forall k i c (p :: k). c -> K1 i c p
K1 f
x

instance HasFieldsG (S1 ('MetaSel 'Nothing x y z) (Rec0 f)) where
  type Fields (S1 ('MetaSel 'Nothing x y z) (Rec0 f)) = (Unnamed f, ())
  toEotFields :: S1 ('MetaSel 'Nothing x y z) (Rec0 f) x
-> Fields (S1 ('MetaSel 'Nothing x y z) (Rec0 f))
toEotFields (M1 (K1 f
x)) = (f -> Unnamed f
forall field. field -> Unnamed field
Unnamed f
x, ())
  fromEotFields :: Fields (S1 ('MetaSel 'Nothing x y z) (Rec0 f))
-> S1 ('MetaSel 'Nothing x y z) (Rec0 f) x
fromEotFields (Unnamed x, ()) = K1 R f x -> S1 ('MetaSel 'Nothing x y z) (Rec0 f) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R f x -> S1 ('MetaSel 'Nothing x y z) (Rec0 f) x)
-> K1 R f x -> S1 ('MetaSel 'Nothing x y z) (Rec0 f) x
forall a b. (a -> b) -> a -> b
$ f -> K1 R f x
forall k i c (p :: k). c -> K1 i c p
K1 f
x

instance HasFieldsG U1 where
  type Fields U1 = ()
  toEotFields :: U1 x -> Fields U1
toEotFields U1 x
U1 = ()
  fromEotFields :: Fields U1 -> U1 x
fromEotFields () = U1 x
forall k (p :: k). U1 p
U1

-- * heterogenous lists

class Concat a b where
  type a +++ b :: *
  (+++) :: a -> b -> (a +++ b)
  unConcat :: (a +++ b) -> (a, b)

instance Concat as bs => Concat (a, as) bs where
  type (a, as) +++ bs = (a, as +++ bs)
  (a
a, as
as) +++ :: (a, as) -> bs -> (a, as) +++ bs
+++ bs
bs = (a
a, as
as as -> bs -> as +++ bs
forall a b. Concat a b => a -> b -> a +++ b
+++ bs
bs)
  unConcat :: (a, as +++ bs) -> ((a, as), bs)
  unConcat :: (a, as +++ bs) -> ((a, as), bs)
unConcat (a
a, as +++ bs
rest) = case (as +++ bs) -> (as, bs)
forall a b. Concat a b => (a +++ b) -> (a, b)
unConcat as +++ bs
rest of
    (as
as, bs
bs) -> ((a
a, as
as), bs
bs)

instance Concat () bs where
  type () +++ bs = bs
  () +++ :: () -> bs -> () +++ bs
+++ bs
bs = bs
() +++ bs
bs
  unConcat :: bs -> ((), bs)
  unConcat :: bs -> ((), bs)
unConcat bs
bs = ((), bs
bs)