{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Generics.Eot.Datatype where

import           Data.Maybe
import           Data.Proxy
import qualified GHC.Generics as GHC
import           GHC.Generics hiding (Datatype(..), Constructor(..))

-- | Type for meta information about ADTs.
data Datatype
  = Datatype {
    Datatype -> String
datatypeName :: String, -- ^ unqualified name of the type
    Datatype -> [Constructor]
constructors :: [Constructor]
  }
  deriving (Int -> Datatype -> ShowS
[Datatype] -> ShowS
Datatype -> String
(Int -> Datatype -> ShowS)
-> (Datatype -> String) -> ([Datatype] -> ShowS) -> Show Datatype
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Datatype] -> ShowS
$cshowList :: [Datatype] -> ShowS
show :: Datatype -> String
$cshow :: Datatype -> String
showsPrec :: Int -> Datatype -> ShowS
$cshowsPrec :: Int -> Datatype -> ShowS
Show, Datatype -> Datatype -> Bool
(Datatype -> Datatype -> Bool)
-> (Datatype -> Datatype -> Bool) -> Eq Datatype
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Datatype -> Datatype -> Bool
$c/= :: Datatype -> Datatype -> Bool
== :: Datatype -> Datatype -> Bool
$c== :: Datatype -> Datatype -> Bool
Eq)

data Constructor
  = Constructor {
    Constructor -> String
constructorName :: String,
    Constructor -> Fields
fields :: Fields
  }
  deriving (Int -> Constructor -> ShowS
[Constructor] -> ShowS
Constructor -> String
(Int -> Constructor -> ShowS)
-> (Constructor -> String)
-> ([Constructor] -> ShowS)
-> Show Constructor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Constructor] -> ShowS
$cshowList :: [Constructor] -> ShowS
show :: Constructor -> String
$cshow :: Constructor -> String
showsPrec :: Int -> Constructor -> ShowS
$cshowsPrec :: Int -> Constructor -> ShowS
Show, Constructor -> Constructor -> Bool
(Constructor -> Constructor -> Bool)
-> (Constructor -> Constructor -> Bool) -> Eq Constructor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Constructor -> Constructor -> Bool
$c/= :: Constructor -> Constructor -> Bool
== :: Constructor -> Constructor -> Bool
$c== :: Constructor -> Constructor -> Bool
Eq)

-- | Type that represents meta information about fields of one
-- constructor.
data Fields
  = Selectors [String]
    -- ^ Record constructor, containing the list of the selector names.
  | NoSelectors Int
    -- ^ Constructor with fields, but without selector names.
    -- The argument gives the number of fields.
  | NoFields
    -- ^ Constructor without fields.
  deriving (Int -> Fields -> ShowS
[Fields] -> ShowS
Fields -> String
(Int -> Fields -> ShowS)
-> (Fields -> String) -> ([Fields] -> ShowS) -> Show Fields
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Fields] -> ShowS
$cshowList :: [Fields] -> ShowS
show :: Fields -> String
$cshow :: Fields -> String
showsPrec :: Int -> Fields -> ShowS
$cshowsPrec :: Int -> Fields -> ShowS
Show, Fields -> Fields -> Bool
(Fields -> Fields -> Bool)
-> (Fields -> Fields -> Bool) -> Eq Fields
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Fields -> Fields -> Bool
$c/= :: Fields -> Fields -> Bool
== :: Fields -> Fields -> Bool
$c== :: Fields -> Fields -> Bool
Eq)

-- * datatype

class GenericDatatype (a :: * -> *) where
  datatypeC :: Proxy a -> Datatype

instance (GHC.Datatype c, GenericConstructors f) =>
  GenericDatatype (D1 c f) where
    datatypeC :: Proxy (D1 c f) -> Datatype
datatypeC Proxy (D1 c f)
Proxy = String -> [Constructor] -> Datatype
Datatype String
n [Constructor]
constructors
      where
        n :: String
n = M1 D c f Any -> String
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
GHC.datatypeName (forall x. M1 D c f x
forall a. HasCallStack => a
undefined :: D1 c f x)
        constructors :: [Constructor]
constructors = Proxy f -> [Constructor]
forall (a :: * -> *).
GenericConstructors a =>
Proxy a -> [Constructor]
getConstructors (Proxy f
forall k (t :: k). Proxy t
Proxy :: Proxy f)

-- * constructors

class GenericConstructors (a :: * -> *) where
  getConstructors :: Proxy a -> [Constructor]

instance (GenericConstructors a, GenericConstructors b) =>
  GenericConstructors (a :+: b) where
    getConstructors :: Proxy (a :+: b) -> [Constructor]
getConstructors Proxy (a :+: b)
Proxy = Proxy a -> [Constructor]
forall (a :: * -> *).
GenericConstructors a =>
Proxy a -> [Constructor]
getConstructors Proxy a
a [Constructor] -> [Constructor] -> [Constructor]
forall a. [a] -> [a] -> [a]
++ Proxy b -> [Constructor]
forall (a :: * -> *).
GenericConstructors a =>
Proxy a -> [Constructor]
getConstructors Proxy b
b
      where
        Proxy a
a :: Proxy a = Proxy a
forall k (t :: k). Proxy t
Proxy
        Proxy b
b :: Proxy b = Proxy b
forall k (t :: k). Proxy t
Proxy

instance (GHC.Constructor c, GenericFields f) =>
  GenericConstructors (C1 c f) where
    getConstructors :: Proxy (C1 c f) -> [Constructor]
getConstructors Proxy (C1 c f)
Proxy = [String -> Fields -> Constructor
Constructor String
n (Proxy f -> Fields
forall (a :: * -> *). GenericFields a => Proxy a -> Fields
getFields Proxy f
f)]
      where
        n :: String
n = M1 C c f Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
GHC.conName (forall x. M1 C c f x
forall a. HasCallStack => a
undefined :: (C1 c f x))
        Proxy f
f :: Proxy f = Proxy f
forall k (t :: k). Proxy t
Proxy

instance GenericConstructors V1 where
  getConstructors :: Proxy V1 -> [Constructor]
getConstructors Proxy V1
Proxy = []

-- * fields

getFields :: GenericFields a => Proxy a -> Fields
getFields :: Proxy a -> Fields
getFields Proxy a
proxy = case Proxy a -> [Maybe String]
forall (a :: * -> *). GenericFields a => Proxy a -> [Maybe String]
getFieldsC Proxy a
proxy of
  [] -> Fields
NoFields
  l :: [Maybe String]
l@(Maybe String
Nothing : [Maybe String]
_) -> Int -> Fields
NoSelectors ([Maybe String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe String]
l)
  l :: [Maybe String]
l@(Just String
_ : [Maybe String]
_) -> [String] -> Fields
Selectors ([Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String]
l)

class GenericFields (a :: * -> *) where
  getFieldsC :: Proxy a -> [Maybe String]

instance (GenericFields a, GenericFields b) =>
  GenericFields (a :*: b) where
    getFieldsC :: Proxy (a :*: b) -> [Maybe String]
getFieldsC Proxy (a :*: b)
Proxy = Proxy a -> [Maybe String]
forall (a :: * -> *). GenericFields a => Proxy a -> [Maybe String]
getFieldsC Proxy a
a [Maybe String] -> [Maybe String] -> [Maybe String]
forall a. [a] -> [a] -> [a]
++ Proxy b -> [Maybe String]
forall (a :: * -> *). GenericFields a => Proxy a -> [Maybe String]
getFieldsC Proxy b
b
      where
        Proxy a
a :: Proxy a = Proxy a
forall k (t :: k). Proxy t
Proxy
        Proxy b
b :: Proxy b = Proxy b
forall k (t :: k). Proxy t
Proxy

instance Selector c => GenericFields (S1 c (Rec0 f)) where
  getFieldsC :: Proxy (S1 c (Rec0 f)) -> [Maybe String]
getFieldsC Proxy (S1 c (Rec0 f))
proxy = [Proxy (S1 c (Rec0 f)) -> Maybe String
forall (c :: Meta) f.
Selector c =>
Proxy (S1 c (Rec0 f)) -> Maybe String
getField Proxy (S1 c (Rec0 f))
proxy]

getField :: forall c f . Selector c =>
  Proxy (S1 c (Rec0 f)) -> Maybe String
getField :: Proxy (S1 c (Rec0 f)) -> Maybe String
getField Proxy (S1 c (Rec0 f))
Proxy = case M1 S c (Rec0 f) Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (forall x. M1 S c (Rec0 f) x
forall a. HasCallStack => a
undefined :: S1 c (Rec0 f) x) of
  String
"" -> Maybe String
forall a. Maybe a
Nothing
  String
s -> String -> Maybe String
forall a. a -> Maybe a
Just String
s

instance GenericFields U1 where
  getFieldsC :: Proxy U1 -> [Maybe String]
getFieldsC Proxy U1
Proxy = []