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)