module Domain.TH.TypeDec
where

import Domain.Prelude
import DomainCore.Model
import qualified Language.Haskell.TH as TH
import qualified THLego.Helpers as TH
import qualified DomainCore.TH as CoreTH


typeDec :: Maybe (Bool, Bool) -> TypeDec -> Dec
typeDec Maybe (Bool, Bool)
fieldNaming (TypeDec Text
a TypeDef
b) =
  case TypeDef
b of
    SumTypeDef [(Text, [Type])]
b ->
      Name -> [(Name, [Type])] -> Dec
TH.sumAdtDec (Text -> Name
TH.textName Text
a) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Text -> Text -> Name
CoreTH.sumConstructorName Text
a) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
CoreTH.typeType)) [(Text, [Type])]
b)
    ProductTypeDef [(Text, Type)]
fields ->
      case Maybe (Bool, Bool)
fieldNaming of
        Just (Bool
underscore, Bool
prefixWithTypeName) ->
          case [(Text, Type)]
fields of
            [(Text
memberName, Type
memberType)] ->
              Name -> Name -> Type -> Dec
TH.recordNewtypeDec (Text -> Name
TH.textName Text
a) (Bool -> Bool -> Text -> Text -> Name
CoreTH.recordFieldName Bool
underscore Bool
prefixWithTypeName Text
a Text
memberName) (Type -> Type
CoreTH.typeType Type
memberType)
            [(Text, Type)]
_ ->
              Name -> [(Name, Type)] -> Dec
TH.recordAdtDec (Text -> Name
TH.textName Text
a) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Bool -> Bool -> Text -> Text -> Name
CoreTH.recordFieldName Bool
underscore Bool
prefixWithTypeName Text
a) Type -> Type
CoreTH.typeType) [(Text, Type)]
fields)
        Maybe (Bool, Bool)
Nothing ->
          case [(Text, Type)]
fields of
            [(Text
_, Type
memberType)] ->
              Name -> Type -> Dec
TH.normalNewtypeDec (Text -> Name
TH.textName Text
a) (Type -> Type
CoreTH.typeType Type
memberType)
            [(Text, Type)]
_ ->
              Name -> [Type] -> Dec
TH.productAdtDec (Text -> Name
TH.textName Text
a) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Type -> Type
CoreTH.typeType forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (a, b) -> b
snd) [(Text, Type)]
fields)