module DomainCore.TH
where

import DomainCore.Prelude
import DomainCore.Model
import qualified Language.Haskell.TH as TH
import qualified THLego.Helpers as TH
import qualified DomainCore.Text as Text
import qualified Data.Text as Text
import qualified Data.Char as Char


{-|
Convert a model type definition into Template Haskell.
-}
typeType ::
  {-| Model type. -}
  Type ->
  {-| Template Haskell type. -}
  TH.Type
typeType :: Type -> Type
typeType =
  \ case
    AppType NonEmpty Type
a ->
      forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Type -> Type -> Type
TH.AppT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
typeType NonEmpty Type
a)
    RefType Text
a ->
      Name -> Type
TH.ConT (Text -> Name
TH.textName Text
a)
    ListType Type
a ->
      Type -> Type -> Type
TH.AppT Type
TH.ListT (Type -> Type
typeType Type
a)
    TupleType [Type]
a ->
      Type -> [Type] -> Type
TH.multiAppT (Int -> Type
TH.TupleT (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
a)) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
typeType [Type]
a)

{-|
Assemble a record field name.
-}
recordFieldName ::
  {-| Prepend with underscore. -}
  Bool ->
  {-| Prefix with type name. -}
  Bool ->
  {-| Type name. -}
  Text ->
  {-| Label. -}
  Text ->
  {-| Template Haskell name. -}
  TH.Name
recordFieldName :: Bool -> Bool -> Text -> Text -> Name
recordFieldName Bool
underscore Bool
prefixWithTypeName Text
a Text
b =
  Text -> Name
TH.textName (Bool -> Bool -> Text -> Text -> Text
Text.recordField Bool
underscore Bool
prefixWithTypeName Text
a Text
b)

{-|
Assemble a sum constructor name.
-}
sumConstructorName ::
  {-| Type name. -}
  Text ->
  {-| Label. -}
  Text ->
  {-| Template Haskell name. -}
  TH.Name
sumConstructorName :: Text -> Text -> Name
sumConstructorName Text
a Text
b =
  Text -> Name
TH.textName (Text -> Text -> Text
Text.sumConstructor Text
a Text
b)