{- | 

Code generate type definitions in any language based on Haskell types.

-}
module FieldsAndCases
  ( matchRecordLikeDataType,
    isEnumWithoutData,
    ToTypeDefs (..),
    ToTypeDef (..),
    IsTypeExpr (..),
    TypeExpr (..),
    TypeDef (..),
    Case (..),
    CaseArgs (..),
    Field (..),
    PositionalArg (..),
    QualifiedName (..),
  )
where

import Data.String.Conversions (cs)
import GHC.Generics
import GHC.TypeLits (KnownSymbol, symbolVal)
import Relude

-- | Haskell type definition.
data TypeDef texpr = TypeDef
  { forall texpr. TypeDef texpr -> QualifiedName
qualifiedName :: QualifiedName,
    forall texpr. TypeDef texpr -> [Case texpr]
cases :: [Case texpr]
  }
  deriving (Int -> TypeDef texpr -> ShowS
[TypeDef texpr] -> ShowS
TypeDef texpr -> String
(Int -> TypeDef texpr -> ShowS)
-> (TypeDef texpr -> String)
-> ([TypeDef texpr] -> ShowS)
-> Show (TypeDef texpr)
forall texpr. Show texpr => Int -> TypeDef texpr -> ShowS
forall texpr. Show texpr => [TypeDef texpr] -> ShowS
forall texpr. Show texpr => TypeDef texpr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall texpr. Show texpr => Int -> TypeDef texpr -> ShowS
showsPrec :: Int -> TypeDef texpr -> ShowS
$cshow :: forall texpr. Show texpr => TypeDef texpr -> String
show :: TypeDef texpr -> String
$cshowList :: forall texpr. Show texpr => [TypeDef texpr] -> ShowS
showList :: [TypeDef texpr] -> ShowS
Show, TypeDef texpr -> TypeDef texpr -> Bool
(TypeDef texpr -> TypeDef texpr -> Bool)
-> (TypeDef texpr -> TypeDef texpr -> Bool) -> Eq (TypeDef texpr)
forall texpr. Eq texpr => TypeDef texpr -> TypeDef texpr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall texpr. Eq texpr => TypeDef texpr -> TypeDef texpr -> Bool
== :: TypeDef texpr -> TypeDef texpr -> Bool
$c/= :: forall texpr. Eq texpr => TypeDef texpr -> TypeDef texpr -> Bool
/= :: TypeDef texpr -> TypeDef texpr -> Bool
Eq)

-- | Haskell type constructor.
data Case texpr = Case
  { forall texpr. Case texpr -> Text
tagName :: Text,
    forall texpr. Case texpr -> Maybe (CaseArgs texpr)
caseArgs :: Maybe (CaseArgs texpr)
  }
  deriving (Int -> Case texpr -> ShowS
[Case texpr] -> ShowS
Case texpr -> String
(Int -> Case texpr -> ShowS)
-> (Case texpr -> String)
-> ([Case texpr] -> ShowS)
-> Show (Case texpr)
forall texpr. Show texpr => Int -> Case texpr -> ShowS
forall texpr. Show texpr => [Case texpr] -> ShowS
forall texpr. Show texpr => Case texpr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall texpr. Show texpr => Int -> Case texpr -> ShowS
showsPrec :: Int -> Case texpr -> ShowS
$cshow :: forall texpr. Show texpr => Case texpr -> String
show :: Case texpr -> String
$cshowList :: forall texpr. Show texpr => [Case texpr] -> ShowS
showList :: [Case texpr] -> ShowS
Show, Case texpr -> Case texpr -> Bool
(Case texpr -> Case texpr -> Bool)
-> (Case texpr -> Case texpr -> Bool) -> Eq (Case texpr)
forall texpr. Eq texpr => Case texpr -> Case texpr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall texpr. Eq texpr => Case texpr -> Case texpr -> Bool
== :: Case texpr -> Case texpr -> Bool
$c/= :: forall texpr. Eq texpr => Case texpr -> Case texpr -> Bool
/= :: Case texpr -> Case texpr -> Bool
Eq)

-- | Haskell type constructor arguments.
data CaseArgs texpr
  = CasePositionalArgs [PositionalArg texpr]
  | CaseFields [Field texpr]
  deriving (Int -> CaseArgs texpr -> ShowS
[CaseArgs texpr] -> ShowS
CaseArgs texpr -> String
(Int -> CaseArgs texpr -> ShowS)
-> (CaseArgs texpr -> String)
-> ([CaseArgs texpr] -> ShowS)
-> Show (CaseArgs texpr)
forall texpr. Show texpr => Int -> CaseArgs texpr -> ShowS
forall texpr. Show texpr => [CaseArgs texpr] -> ShowS
forall texpr. Show texpr => CaseArgs texpr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall texpr. Show texpr => Int -> CaseArgs texpr -> ShowS
showsPrec :: Int -> CaseArgs texpr -> ShowS
$cshow :: forall texpr. Show texpr => CaseArgs texpr -> String
show :: CaseArgs texpr -> String
$cshowList :: forall texpr. Show texpr => [CaseArgs texpr] -> ShowS
showList :: [CaseArgs texpr] -> ShowS
Show, CaseArgs texpr -> CaseArgs texpr -> Bool
(CaseArgs texpr -> CaseArgs texpr -> Bool)
-> (CaseArgs texpr -> CaseArgs texpr -> Bool)
-> Eq (CaseArgs texpr)
forall texpr. Eq texpr => CaseArgs texpr -> CaseArgs texpr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall texpr. Eq texpr => CaseArgs texpr -> CaseArgs texpr -> Bool
== :: CaseArgs texpr -> CaseArgs texpr -> Bool
$c/= :: forall texpr. Eq texpr => CaseArgs texpr -> CaseArgs texpr -> Bool
/= :: CaseArgs texpr -> CaseArgs texpr -> Bool
Eq)

-- | Haskell type labeled field.
data Field texpr = Field
  { forall texpr. Field texpr -> Text
fieldName :: Text,
    forall texpr. Field texpr -> texpr
fieldType :: texpr
  }
  deriving (Int -> Field texpr -> ShowS
[Field texpr] -> ShowS
Field texpr -> String
(Int -> Field texpr -> ShowS)
-> (Field texpr -> String)
-> ([Field texpr] -> ShowS)
-> Show (Field texpr)
forall texpr. Show texpr => Int -> Field texpr -> ShowS
forall texpr. Show texpr => [Field texpr] -> ShowS
forall texpr. Show texpr => Field texpr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall texpr. Show texpr => Int -> Field texpr -> ShowS
showsPrec :: Int -> Field texpr -> ShowS
$cshow :: forall texpr. Show texpr => Field texpr -> String
show :: Field texpr -> String
$cshowList :: forall texpr. Show texpr => [Field texpr] -> ShowS
showList :: [Field texpr] -> ShowS
Show, Field texpr -> Field texpr -> Bool
(Field texpr -> Field texpr -> Bool)
-> (Field texpr -> Field texpr -> Bool) -> Eq (Field texpr)
forall texpr. Eq texpr => Field texpr -> Field texpr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall texpr. Eq texpr => Field texpr -> Field texpr -> Bool
== :: Field texpr -> Field texpr -> Bool
$c/= :: forall texpr. Eq texpr => Field texpr -> Field texpr -> Bool
/= :: Field texpr -> Field texpr -> Bool
Eq)

-- | Haskell type positional field.
newtype PositionalArg texpr = PositionalArg
  { forall texpr. PositionalArg texpr -> texpr
fieldType :: texpr
  }
  deriving (Int -> PositionalArg texpr -> ShowS
[PositionalArg texpr] -> ShowS
PositionalArg texpr -> String
(Int -> PositionalArg texpr -> ShowS)
-> (PositionalArg texpr -> String)
-> ([PositionalArg texpr] -> ShowS)
-> Show (PositionalArg texpr)
forall texpr. Show texpr => Int -> PositionalArg texpr -> ShowS
forall texpr. Show texpr => [PositionalArg texpr] -> ShowS
forall texpr. Show texpr => PositionalArg texpr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall texpr. Show texpr => Int -> PositionalArg texpr -> ShowS
showsPrec :: Int -> PositionalArg texpr -> ShowS
$cshow :: forall texpr. Show texpr => PositionalArg texpr -> String
show :: PositionalArg texpr -> String
$cshowList :: forall texpr. Show texpr => [PositionalArg texpr] -> ShowS
showList :: [PositionalArg texpr] -> ShowS
Show, PositionalArg texpr -> PositionalArg texpr -> Bool
(PositionalArg texpr -> PositionalArg texpr -> Bool)
-> (PositionalArg texpr -> PositionalArg texpr -> Bool)
-> Eq (PositionalArg texpr)
forall texpr.
Eq texpr =>
PositionalArg texpr -> PositionalArg texpr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall texpr.
Eq texpr =>
PositionalArg texpr -> PositionalArg texpr -> Bool
== :: PositionalArg texpr -> PositionalArg texpr -> Bool
$c/= :: forall texpr.
Eq texpr =>
PositionalArg texpr -> PositionalArg texpr -> Bool
/= :: PositionalArg texpr -> PositionalArg texpr -> Bool
Eq)

-- | Haskell type qualified name.
data QualifiedName = QualifiedName
  { QualifiedName -> Text
moduleName :: Text,
    QualifiedName -> Text
typeName :: Text
  }
  deriving (Int -> QualifiedName -> ShowS
[QualifiedName] -> ShowS
QualifiedName -> String
(Int -> QualifiedName -> ShowS)
-> (QualifiedName -> String)
-> ([QualifiedName] -> ShowS)
-> Show QualifiedName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QualifiedName -> ShowS
showsPrec :: Int -> QualifiedName -> ShowS
$cshow :: QualifiedName -> String
show :: QualifiedName -> String
$cshowList :: [QualifiedName] -> ShowS
showList :: [QualifiedName] -> ShowS
Show, QualifiedName -> QualifiedName -> Bool
(QualifiedName -> QualifiedName -> Bool)
-> (QualifiedName -> QualifiedName -> Bool) -> Eq QualifiedName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QualifiedName -> QualifiedName -> Bool
== :: QualifiedName -> QualifiedName -> Bool
$c/= :: QualifiedName -> QualifiedName -> Bool
/= :: QualifiedName -> QualifiedName -> Bool
Eq)

-- | Data types with a single constructor and labeled fields
-- | are considered record-like.
matchRecordLikeDataType :: TypeDef texpr -> Maybe (Text, [Field texpr])
matchRecordLikeDataType :: forall texpr. TypeDef texpr -> Maybe (Text, [Field texpr])
matchRecordLikeDataType (TypeDef {$sel:qualifiedName:TypeDef :: forall texpr. TypeDef texpr -> QualifiedName
qualifiedName = QualifiedName {Text
$sel:typeName:QualifiedName :: QualifiedName -> Text
typeName :: Text
typeName}, [Case texpr]
$sel:cases:TypeDef :: forall texpr. TypeDef texpr -> [Case texpr]
cases :: [Case texpr]
cases}) =
  case [Case texpr]
cases of
    [Case {Text
$sel:tagName:Case :: forall texpr. Case texpr -> Text
tagName :: Text
tagName, $sel:caseArgs:Case :: forall texpr. Case texpr -> Maybe (CaseArgs texpr)
caseArgs = Just (CaseFields [Field texpr]
fields)}]
      | Text
typeName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
tagName -> (Text, [Field texpr]) -> Maybe (Text, [Field texpr])
forall a. a -> Maybe a
Just (Text
typeName, [Field texpr]
fields)
    [Case texpr]
_ -> Maybe (Text, [Field texpr])
forall a. Maybe a
Nothing


-- | Data types with all of their constructors having no arguments
isEnumWithoutData :: TypeDef texpr -> Bool
isEnumWithoutData :: forall texpr. TypeDef texpr -> Bool
isEnumWithoutData (TypeDef {$sel:qualifiedName:TypeDef :: forall texpr. TypeDef texpr -> QualifiedName
qualifiedName = QualifiedName {Text
$sel:typeName:QualifiedName :: QualifiedName -> Text
typeName :: Text
typeName}, [Case texpr]
$sel:cases:TypeDef :: forall texpr. TypeDef texpr -> [Case texpr]
cases :: [Case texpr]
cases}) =
  (Case texpr -> Bool) -> [Case texpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Case texpr -> Bool
forall {texpr}. Case texpr -> Bool
isEnumCase [Case texpr]
cases
  where
    isEnumCase :: Case texpr -> Bool
isEnumCase (Case {$sel:caseArgs:Case :: forall texpr. Case texpr -> Maybe (CaseArgs texpr)
caseArgs = Maybe (CaseArgs texpr)
Nothing}) = Bool
True
    isEnumCase Case texpr
_ = Bool
False

---

-- | Like 'ToTypeDef' but for a list of types.
class ToTypeDefs (xs :: [Type]) texpr where
  toTypeDefs :: [TypeDef texpr]

instance ToTypeDefs '[] texpr where
  toTypeDefs :: [TypeDef texpr]
toTypeDefs = []

instance (ToTypeDef x texpr, ToTypeDefs xs texpr) => ToTypeDefs (x ': xs) texpr where
  toTypeDefs :: [TypeDef texpr]
toTypeDefs = forall {k} (a :: k) texpr. ToTypeDef a texpr => TypeDef texpr
forall a texpr. ToTypeDef a texpr => TypeDef texpr
toTypeDef @x @texpr TypeDef texpr -> [TypeDef texpr] -> [TypeDef texpr]
forall a. a -> [a] -> [a]
: forall (xs :: [*]) texpr. ToTypeDefs xs texpr => [TypeDef texpr]
toTypeDefs @xs @texpr

---

-- | A class of types which can be used as type expressions.
class IsTypeExpr texpr where
  typeRef :: QualifiedName -> texpr

instance IsTypeExpr Text where
  typeRef :: QualifiedName -> Text
typeRef (QualifiedName {Text
$sel:typeName:QualifiedName :: QualifiedName -> Text
typeName :: Text
typeName}) = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
typeName

--- ToTypeRef ---

-- | Describes how to convert a type to a type expression of a specific language.
class TypeExpr a texpr where
  typeExpr :: texpr
  default typeExpr ::
    (IsTypeExpr texpr, Generic a, GToTypeRef (Rep a)) => texpr
  typeExpr =
    QualifiedName -> texpr
forall texpr. IsTypeExpr texpr => QualifiedName -> texpr
typeRef (QualifiedName -> texpr) -> QualifiedName -> texpr
forall a b. (a -> b) -> a -> b
$ Rep a Any -> QualifiedName
forall a. Rep a a -> QualifiedName
forall {k} (rep :: k -> *) (a :: k).
GToTypeRef rep =>
rep a -> QualifiedName
gToTypeRef (Rep a Any -> QualifiedName) -> Rep a Any -> QualifiedName
forall a b. (a -> b) -> a -> b
$ Proxy a -> Rep a Any
forall (rep :: * -> *) a x.
(Generic a, Rep a ~ rep) =>
Proxy a -> rep x
getRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

class GToTypeRef rep where
  gToTypeRef :: rep a -> QualifiedName

-- Match Data Type
instance
  (KnownSymbol typeName, KnownSymbol moduleName) =>
  GToTypeRef
    (M1 {- MetaInfo -} D {- DataType -} ('MetaData typeName moduleName packageName isNewtype) cases)
  where
  gToTypeRef :: forall (a :: k).
M1 D ('MetaData typeName moduleName packageName isNewtype) cases a
-> QualifiedName
gToTypeRef M1 D ('MetaData typeName moduleName packageName isNewtype) cases a
_ = QualifiedName
result
    where
      moduleName :: Text
      moduleName :: Text
moduleName = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy moduleName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @moduleName)

      typeName :: Text
      typeName :: Text
typeName = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy typeName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @typeName)

      result :: QualifiedName
      result :: QualifiedName
result = QualifiedName {Text
$sel:moduleName:QualifiedName :: Text
moduleName :: Text
moduleName, Text
$sel:typeName:QualifiedName :: Text
typeName :: Text
typeName}

--- ToTypeDef ---

-- | Get the type definition of a type.
class ToTypeDef a texpr where
  toTypeDef :: TypeDef texpr

instance (Generic a, GToTypeDef (Rep a) (TypeDef texpr)) => ToTypeDef a texpr where
  toTypeDef :: TypeDef texpr
toTypeDef = Rep a Any -> TypeDef texpr
forall a. Rep a a -> TypeDef texpr
forall {k} (rep :: k -> *) def (a :: k).
GToTypeDef rep def =>
rep a -> def
gToTypeDef (Rep a Any -> TypeDef texpr) -> Rep a Any -> TypeDef texpr
forall a b. (a -> b) -> a -> b
$ Proxy a -> Rep a Any
forall (rep :: * -> *) a x.
(Generic a, Rep a ~ rep) =>
Proxy a -> rep x
getRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

class GToTypeDef rep def where
  gToTypeDef :: rep a -> def

-- Match Data Type
instance
  (GToTypeDef cases [Case texpr], KnownSymbol typeName, KnownSymbol moduleName) =>
  GToTypeDef
    (M1 {- MetaInfo -} D {- DataType -} ('MetaData typeName moduleName packageName isNewtype) cases)
    (TypeDef texpr)
  where
  gToTypeDef :: forall (a :: k).
M1 D ('MetaData typeName moduleName packageName isNewtype) cases a
-> TypeDef texpr
gToTypeDef M1 D ('MetaData typeName moduleName packageName isNewtype) cases a
_ = TypeDef texpr
result
    where
      cases :: [Case texpr]
      cases :: [Case texpr]
cases = cases Any -> [Case texpr]
forall (a :: k). cases a -> [Case texpr]
forall {k} (rep :: k -> *) def (a :: k).
GToTypeDef rep def =>
rep a -> def
gToTypeDef (Text -> cases x
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"no value" :: cases x)

      moduleName :: Text
      moduleName :: Text
moduleName = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy moduleName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @moduleName)

      typeName :: Text
      typeName :: Text
typeName = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy typeName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @typeName)

      qualifiedName :: QualifiedName
      qualifiedName :: QualifiedName
qualifiedName = QualifiedName {Text
$sel:moduleName:QualifiedName :: Text
moduleName :: Text
moduleName, Text
$sel:typeName:QualifiedName :: Text
typeName :: Text
typeName}

      result :: TypeDef texpr
      result :: TypeDef texpr
result = QualifiedName -> [Case texpr] -> TypeDef texpr
forall texpr. QualifiedName -> [Case texpr] -> TypeDef texpr
TypeDef QualifiedName
qualifiedName ([Case texpr] -> [Case texpr]
forall a b. Coercible a b => a -> b
coerce [Case texpr]
cases)

-- Match Sum
instance
  (GToTypeDef lhs [Case texpr], GToTypeDef rhs [Case texpr]) =>
  GToTypeDef
    (lhs :+: rhs)
    [Case texpr]
  where
  gToTypeDef :: forall (a :: k). (:+:) lhs rhs a -> [Case texpr]
gToTypeDef (:+:) lhs rhs a
_ = [Case texpr]
result
    where
      lhs :: [Case texpr]
      lhs :: [Case texpr]
lhs = lhs Any -> [Case texpr]
forall (a :: k). lhs a -> [Case texpr]
forall {k} (rep :: k -> *) def (a :: k).
GToTypeDef rep def =>
rep a -> def
gToTypeDef (Text -> lhs x
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"no value" :: lhs x)

      rhs :: [Case texpr]
      rhs :: [Case texpr]
rhs = rhs Any -> [Case texpr]
forall (a :: k). rhs a -> [Case texpr]
forall {k} (rep :: k -> *) def (a :: k).
GToTypeDef rep def =>
rep a -> def
gToTypeDef (Text -> rhs x
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"no value" :: rhs x)

      result :: [Case texpr]
      result :: [Case texpr]
result = [Case texpr]
lhs [Case texpr] -> [Case texpr] -> [Case texpr]
forall a. Semigroup a => a -> a -> a
<> [Case texpr]
rhs

-- Match Constructor with fields
instance
  {-# OVERLAPPABLE #-}
  (KnownSymbol ctorName, GToTypeDef fields [Field texpr]) =>
  GToTypeDef
    (M1 {- MetaInfo -} C {- Constructor -} ('MetaCons ctorName fixity 'True {- hasSelectors -}) fields)
    [Case texpr]
  where
  gToTypeDef :: forall (a :: k).
M1 C ('MetaCons ctorName fixity 'True) fields a -> [Case texpr]
gToTypeDef M1 C ('MetaCons ctorName fixity 'True) fields a
_ = [Case texpr]
result
    where
      fields :: [Field texpr]
      fields :: [Field texpr]
fields = fields Any -> [Field texpr]
forall (a :: k). fields a -> [Field texpr]
forall {k} (rep :: k -> *) def (a :: k).
GToTypeDef rep def =>
rep a -> def
gToTypeDef (Text -> fields x
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"no value" :: fields x)

      tagName :: Text
      tagName :: Text
tagName = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy ctorName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @ctorName)

      case_ :: Case texpr
      case_ :: Case texpr
case_ =
        Case
          { Text
$sel:tagName:Case :: Text
tagName :: Text
tagName,
            $sel:caseArgs:Case :: Maybe (CaseArgs texpr)
caseArgs = CaseArgs texpr -> Maybe (CaseArgs texpr)
forall a. a -> Maybe a
Just (CaseArgs texpr -> Maybe (CaseArgs texpr))
-> CaseArgs texpr -> Maybe (CaseArgs texpr)
forall a b. (a -> b) -> a -> b
$ [Field texpr] -> CaseArgs texpr
forall texpr. [Field texpr] -> CaseArgs texpr
CaseFields ([Field texpr] -> [Field texpr]
forall a b. Coercible a b => a -> b
coerce [Field texpr]
fields)
          }

      result :: [Case texpr]
      result :: [Case texpr]
result = [Case texpr] -> [Case texpr]
forall a b. Coercible a b => a -> b
coerce [Case texpr
case_]

-- Match Constructor with positional fields
instance
  {-# OVERLAPPABLE #-}
  (KnownSymbol ctorName, GToTypeDef fields [PositionalArg texpr]) =>
  GToTypeDef
    (M1 {- MetaInfo -} C {- Constructor -} ('MetaCons ctorName fixity 'False {- hasSelectors -}) fields)
    [Case texpr]
  where
  gToTypeDef :: forall (a :: k).
M1 C ('MetaCons ctorName fixity 'False) fields a -> [Case texpr]
gToTypeDef M1 C ('MetaCons ctorName fixity 'False) fields a
_ = [Case texpr]
result
    where
      tagName :: Text
      tagName :: Text
tagName = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy ctorName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @ctorName)

      fields :: [PositionalArg texpr]
      fields :: [PositionalArg texpr]
fields = fields Any -> [PositionalArg texpr]
forall (a :: k). fields a -> [PositionalArg texpr]
forall {k} (rep :: k -> *) def (a :: k).
GToTypeDef rep def =>
rep a -> def
gToTypeDef (Text -> fields x
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"no value" :: fields x)

      case_ :: Case texpr
      case_ :: Case texpr
case_ =
        Case
          { Text
$sel:tagName:Case :: Text
tagName :: Text
tagName,
            $sel:caseArgs:Case :: Maybe (CaseArgs texpr)
caseArgs = CaseArgs texpr -> Maybe (CaseArgs texpr)
forall a. a -> Maybe a
Just (CaseArgs texpr -> Maybe (CaseArgs texpr))
-> CaseArgs texpr -> Maybe (CaseArgs texpr)
forall a b. (a -> b) -> a -> b
$ [PositionalArg texpr] -> CaseArgs texpr
forall texpr. [PositionalArg texpr] -> CaseArgs texpr
CasePositionalArgs ([PositionalArg texpr] -> [PositionalArg texpr]
forall a b. Coercible a b => a -> b
coerce [PositionalArg texpr]
fields)
          }

      result :: [Case texpr]
      result :: [Case texpr]
result = [Case texpr] -> [Case texpr]
forall a b. Coercible a b => a -> b
coerce [Case texpr
case_]

-- Match Constructor without fields
instance
  {-# OVERLAPPABLE #-}
  (KnownSymbol ctorName) =>
  GToTypeDef
    (M1 {- MetaInfo -} C {- Constructor -} ('MetaCons ctorName fixity 'False {- hasSelectors -}) U1 {- Unit -})
    [Case texpr]
  where
  gToTypeDef :: forall (a :: k).
M1 C ('MetaCons ctorName fixity 'False) U1 a -> [Case texpr]
gToTypeDef M1 C ('MetaCons ctorName fixity 'False) U1 a
_ = [Case texpr]
result
    where
      tagName :: Text
      tagName :: Text
tagName = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy ctorName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @ctorName)

      case_ :: Case texpr
      case_ :: Case texpr
case_ = Case {Text
$sel:tagName:Case :: Text
tagName :: Text
tagName, $sel:caseArgs:Case :: Maybe (CaseArgs texpr)
caseArgs = Maybe (CaseArgs texpr)
forall a. Maybe a
Nothing}

      result :: [Case texpr]
      result :: [Case texpr]
result = [Case texpr] -> [Case texpr]
forall a b. Coercible a b => a -> b
coerce [Case texpr
case_]

-- Match Product
instance
  (GToTypeDef lhs fields, GToTypeDef rhs fields, Semigroup fields) =>
  GToTypeDef
    (lhs :*: rhs)
    fields
  where
  gToTypeDef :: forall (a :: k). (:*:) lhs rhs a -> fields
gToTypeDef (:*:) lhs rhs a
_ = fields
result
    where
      lhs :: fields
      lhs :: fields
lhs = lhs Any -> fields
forall (a :: k). lhs a -> fields
forall {k} (rep :: k -> *) def (a :: k).
GToTypeDef rep def =>
rep a -> def
gToTypeDef (Text -> lhs x
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"no value" :: lhs x)

      rhs :: fields
      rhs :: fields
rhs = rhs Any -> fields
forall (a :: k). rhs a -> fields
forall {k} (rep :: k -> *) def (a :: k).
GToTypeDef rep def =>
rep a -> def
gToTypeDef (Text -> rhs x
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"no value" :: rhs x)

      result :: fields
      result :: fields
result = fields
lhs fields -> fields -> fields
forall a. Semigroup a => a -> a -> a
<> fields
rhs

-- Match Field
instance
  {-# OVERLAPPABLE #-}
  (TypeExpr a texpr, KnownSymbol fieldName) =>
  GToTypeDef
    (M1 {- MetaInfo -} S {- Selector -} ('MetaSel ('Just fieldName) srcUnpackedness srcStrictness inferedStrictness) (K1 R a))
    [Field texpr]
  where
  gToTypeDef :: forall (a :: k).
M1
  S
  ('MetaSel
     ('Just fieldName) srcUnpackedness srcStrictness inferedStrictness)
  (K1 R a)
  a
-> [Field texpr]
gToTypeDef M1
  S
  ('MetaSel
     ('Just fieldName) srcUnpackedness srcStrictness inferedStrictness)
  (K1 R a)
  a
_ = [Field texpr]
result
    where
      fieldName :: Text
      fieldName :: Text
fieldName = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy fieldName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @fieldName)

      fieldType :: texpr
      fieldType :: texpr
fieldType = forall a texpr. TypeExpr a texpr => texpr
typeExpr @a @texpr

      field :: Field texpr
      field :: Field texpr
field = Field {Text
$sel:fieldName:Field :: Text
fieldName :: Text
fieldName, texpr
$sel:fieldType:Field :: texpr
fieldType :: texpr
fieldType}

      result :: [Field texpr]
      result :: [Field texpr]
result = [Field texpr] -> [Field texpr]
forall a b. Coercible a b => a -> b
coerce [Field texpr
field]

-- Match Positional Field
instance
  {-# OVERLAPPABLE #-}
  (TypeExpr a texpr) =>
  GToTypeDef
    (M1 {- MetaInfo -} S {- Selector -} ('MetaSel 'Nothing srcUnpackedness srcStrictness inferedStrictness) (K1 R a))
    [PositionalArg texpr]
  where
  gToTypeDef :: forall (a :: k).
M1
  S
  ('MetaSel 'Nothing srcUnpackedness srcStrictness inferedStrictness)
  (K1 R a)
  a
-> [PositionalArg texpr]
gToTypeDef M1
  S
  ('MetaSel 'Nothing srcUnpackedness srcStrictness inferedStrictness)
  (K1 R a)
  a
_ = [PositionalArg texpr]
result
    where
      fieldType :: texpr
      fieldType :: texpr
fieldType = forall a texpr. TypeExpr a texpr => texpr
typeExpr @a @texpr

      field :: PositionalArg texpr
      field :: PositionalArg texpr
field = PositionalArg {texpr
$sel:fieldType:PositionalArg :: texpr
fieldType :: texpr
fieldType}

      result :: [PositionalArg texpr]
      result :: [PositionalArg texpr]
result = [PositionalArg texpr] -> [PositionalArg texpr]
forall a b. Coercible a b => a -> b
coerce [PositionalArg texpr
field]

--- Utils ---

-- Function to get the Rep of a type without a value
getRep :: forall rep a x. (Generic a, Rep a ~ rep) => Proxy a -> rep x
getRep :: forall (rep :: * -> *) a x.
(Generic a, Rep a ~ rep) =>
Proxy a -> rep x
getRep Proxy a
_ = a -> Rep a x
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from (Text -> a
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"no value" :: a)