-- |
-- Model-adapted instance declaration templates.
module Domain.TH.InstanceDec where

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

-- * HasField

-------------------------

enumHasField :: Text -> Text -> TH.Dec
enumHasField :: Text -> Text -> Dec
enumHasField Text
typeName Text
label =
  TyLit -> Type -> Name -> Dec
Instances.enumHasField TyLit
fieldLabel Type
ownerType Name
constructorName
  where
    fieldLabel :: TyLit
fieldLabel =
      Text -> TyLit
Helpers.textTyLit Text
label
    ownerType :: Type
ownerType =
      Name -> Type
TH.ConT (Text -> Name
Helpers.textName Text
typeName)
    constructorName :: Name
constructorName =
      Text -> Text -> Name
CoreTH.sumConstructorName Text
typeName Text
label

sumHasField :: Text -> Text -> [Type] -> TH.Dec
sumHasField :: Text -> Text -> [Type] -> Dec
sumHasField Text
typeName Text
label [Type]
memberTypes =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
memberTypes
    then TyLit -> Type -> Name -> Dec
Instances.enumHasField TyLit
thFieldLabel Type
thOwnerType Name
thConstructorName
    else TyLit -> Type -> Name -> [Type] -> Dec
Instances.sumHasField TyLit
thFieldLabel Type
thOwnerType Name
thConstructorName [Type]
thMemberTypes
  where
    thFieldLabel :: TyLit
thFieldLabel =
      Text -> TyLit
Helpers.textTyLit Text
label
    thOwnerType :: Type
thOwnerType =
      Name -> Type
TH.ConT (Text -> Name
Helpers.textName Text
typeName)
    thConstructorName :: Name
thConstructorName =
      Text -> Text -> Name
CoreTH.sumConstructorName Text
typeName Text
label
    thMemberTypes :: [Type]
thMemberTypes =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
CoreTH.typeType [Type]
memberTypes

productHasField :: Text -> Text -> Type -> Int -> Int -> TH.Dec
productHasField :: Text -> Text -> Type -> Int -> Int -> Dec
productHasField Text
typeName Text
fieldName Type
projectionType Int
numMemberTypes Int
offset =
  TyLit -> Type -> Type -> Name -> Int -> Int -> Dec
Instances.productHasField
    TyLit
thFieldLabel
    Type
thOwnerType
    Type
thProjectionType
    Name
thConstructorName
    Int
numMemberTypes
    Int
offset
  where
    thFieldLabel :: TyLit
thFieldLabel =
      Text -> TyLit
Helpers.textTyLit Text
fieldName
    thOwnerType :: Type
thOwnerType =
      Name -> Type
TH.ConT (Text -> Name
Helpers.textName Text
typeName)
    thProjectionType :: Type
thProjectionType =
      Type -> Type
CoreTH.typeType Type
projectionType
    thConstructorName :: Name
thConstructorName =
      Text -> Name
Helpers.textName Text
typeName

-- * IsLabel

-------------------------

-- ** Accessor

-------------------------

productAccessorIsLabel :: Text -> Text -> Type -> Int -> Int -> TH.Dec
productAccessorIsLabel :: Text -> Text -> Type -> Int -> Int -> Dec
productAccessorIsLabel Text
typeName Text
fieldName Type
projectionType Int
numMemberTypes Int
offset =
  TyLit -> Type -> Type -> Name -> Int -> Int -> Dec
Instances.productAccessorIsLabel
    TyLit
thFieldLabel
    Type
thOwnerType
    Type
thProjectionType
    Name
thConstructorName
    Int
numMemberTypes
    Int
offset
  where
    thFieldLabel :: TyLit
thFieldLabel =
      Text -> TyLit
Helpers.textTyLit Text
fieldName
    thOwnerType :: Type
thOwnerType =
      Name -> Type
TH.ConT (Text -> Name
Helpers.textName Text
typeName)
    thProjectionType :: Type
thProjectionType =
      Type -> Type
CoreTH.typeType Type
projectionType
    thConstructorName :: Name
thConstructorName =
      Text -> Name
Helpers.textName Text
typeName

sumAccessorIsLabel :: Text -> Text -> [Type] -> TH.Dec
sumAccessorIsLabel :: Text -> Text -> [Type] -> Dec
sumAccessorIsLabel Text
typeName Text
label [Type]
memberTypes =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
memberTypes
    then
      TyLit -> Type -> Name -> Dec
Instances.enumAccessorIsLabel
        TyLit
thFieldLabel
        Type
thOwnerType
        Name
thConstructorName
    else
      TyLit -> Type -> Name -> [Type] -> Dec
Instances.sumAccessorIsLabel
        TyLit
thFieldLabel
        Type
thOwnerType
        Name
thConstructorName
        [Type]
thMemberTypes
  where
    thFieldLabel :: TyLit
thFieldLabel =
      Text -> TyLit
Helpers.textTyLit Text
label
    thOwnerType :: Type
thOwnerType =
      Name -> Type
TH.ConT (Text -> Name
Helpers.textName Text
typeName)
    thConstructorName :: Name
thConstructorName =
      Text -> Text -> Name
CoreTH.sumConstructorName Text
typeName Text
label
    thMemberTypes :: [Type]
thMemberTypes =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
CoreTH.typeType [Type]
memberTypes

enumAccessorIsLabel :: Text -> Text -> TH.Dec
enumAccessorIsLabel :: Text -> Text -> Dec
enumAccessorIsLabel Text
typeName Text
label =
  TyLit -> Type -> Name -> Dec
Instances.enumAccessorIsLabel
    TyLit
thFieldLabel
    Type
thOwnerType
    Name
thConstructorName
  where
    thFieldLabel :: TyLit
thFieldLabel =
      Text -> TyLit
Helpers.textTyLit Text
label
    thOwnerType :: Type
thOwnerType =
      Name -> Type
TH.ConT (Text -> Name
Helpers.textName Text
typeName)
    thConstructorName :: Name
thConstructorName =
      Text -> Text -> Name
CoreTH.sumConstructorName Text
typeName Text
label

-- ** Constructor

-------------------------

curriedSumConstructorIsLabel :: Text -> Text -> [Type] -> TH.Dec
curriedSumConstructorIsLabel :: Text -> Text -> [Type] -> Dec
curriedSumConstructorIsLabel Text
typeName Text
label [Type]
memberTypes =
  TyLit -> Type -> Name -> [Type] -> Dec
Instances.sumConstructorIsLabel
    TyLit
thFieldLabel
    Type
thOwnerType
    Name
thConstructorName
    [Type]
thMemberTypes
  where
    thFieldLabel :: TyLit
thFieldLabel =
      Text -> TyLit
Helpers.textTyLit Text
label
    thOwnerType :: Type
thOwnerType =
      Name -> Type
TH.ConT (Text -> Name
Helpers.textName Text
typeName)
    thConstructorName :: Name
thConstructorName =
      Text -> Text -> Name
CoreTH.sumConstructorName Text
typeName Text
label
    thMemberTypes :: [Type]
thMemberTypes =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
CoreTH.typeType [Type]
memberTypes

uncurriedSumConstructorIsLabel :: Text -> Text -> [Type] -> TH.Dec
uncurriedSumConstructorIsLabel :: Text -> Text -> [Type] -> Dec
uncurriedSumConstructorIsLabel Text
typeName Text
label [Type]
memberTypes =
  TyLit -> Type -> Name -> [Type] -> Dec
Instances.tupleAdtConstructorIsLabel
    TyLit
thFieldLabel
    Type
thOwnerType
    Name
thConstructorName
    [Type]
thMemberTypes
  where
    thFieldLabel :: TyLit
thFieldLabel =
      Text -> TyLit
Helpers.textTyLit Text
label
    thOwnerType :: Type
thOwnerType =
      Name -> Type
TH.ConT (Text -> Name
Helpers.textName Text
typeName)
    thConstructorName :: Name
thConstructorName =
      Text -> Text -> Name
CoreTH.sumConstructorName Text
typeName Text
label
    thMemberTypes :: [Type]
thMemberTypes =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
CoreTH.typeType [Type]
memberTypes

enumConstructorIsLabel :: Text -> Text -> TH.Dec
enumConstructorIsLabel :: Text -> Text -> Dec
enumConstructorIsLabel Text
typeName Text
label =
  TyLit -> Type -> Name -> Dec
Instances.enumConstructorIsLabel
    TyLit
thFieldLabel
    Type
thOwnerType
    Name
thConstructorName
  where
    thFieldLabel :: TyLit
thFieldLabel =
      Text -> TyLit
Helpers.textTyLit Text
label
    thOwnerType :: Type
thOwnerType =
      Name -> Type
TH.ConT (Text -> Name
Helpers.textName Text
typeName)
    thConstructorName :: Name
thConstructorName =
      Text -> Text -> Name
CoreTH.sumConstructorName Text
typeName Text
label

wrapperConstructorIsLabel :: Text -> Type -> TH.Dec
wrapperConstructorIsLabel :: Text -> Type -> Dec
wrapperConstructorIsLabel Text
typeName Type
memberType =
  TyLit -> Type -> Name -> Type -> Dec
Instances.newtypeConstructorIsLabel
    TyLit
thFieldLabel
    Type
thOwnerType
    Name
thConstructorName
    Type
thMemberType
  where
    thFieldLabel :: TyLit
thFieldLabel =
      String -> TyLit
TH.StrTyLit String
"value"
    thOwnerType :: Type
thOwnerType =
      Name -> Type
TH.ConT (Text -> Name
Helpers.textName Text
typeName)
    thConstructorName :: Name
thConstructorName =
      Text -> Name
Helpers.textName Text
typeName
    thMemberType :: Type
thMemberType =
      Type -> Type
CoreTH.typeType Type
memberType

-- ** Mapper

-------------------------

wrapperMapperIsLabel :: Text -> Type -> TH.Dec
wrapperMapperIsLabel :: Text -> Type -> Dec
wrapperMapperIsLabel Text
typeName Type
memberType =
  TyLit -> Type -> Type -> Name -> Int -> Int -> Dec
Instances.productMapperIsLabel
    TyLit
thFieldLabel
    Type
thOwnerType
    Type
thMemberType
    Name
thConstructorName
    Int
1
    Int
0
  where
    thFieldLabel :: TyLit
thFieldLabel =
      String -> TyLit
TH.StrTyLit String
"value"
    thOwnerType :: Type
thOwnerType =
      Name -> Type
TH.ConT (Text -> Name
Helpers.textName Text
typeName)
    thConstructorName :: Name
thConstructorName =
      Text -> Name
Helpers.textName Text
typeName
    thMemberType :: Type
thMemberType =
      Type -> Type
CoreTH.typeType Type
memberType

productMapperIsLabel :: Text -> Text -> Type -> Int -> Int -> TH.Dec
productMapperIsLabel :: Text -> Text -> Type -> Int -> Int -> Dec
productMapperIsLabel Text
typeName Text
fieldName Type
projectionType Int
numMemberTypes Int
offset =
  TyLit -> Type -> Type -> Name -> Int -> Int -> Dec
Instances.productMapperIsLabel
    TyLit
thFieldLabel
    Type
thOwnerType
    Type
thProjectionType
    Name
thConstructorName
    Int
numMemberTypes
    Int
offset
  where
    thFieldLabel :: TyLit
thFieldLabel =
      Text -> TyLit
Helpers.textTyLit Text
fieldName
    thOwnerType :: Type
thOwnerType =
      Name -> Type
TH.ConT (Text -> Name
Helpers.textName Text
typeName)
    thProjectionType :: Type
thProjectionType =
      Type -> Type
CoreTH.typeType Type
projectionType
    thConstructorName :: Name
thConstructorName =
      Text -> Name
Helpers.textName Text
typeName

sumMapperIsLabel :: Text -> Text -> [Type] -> TH.Dec
sumMapperIsLabel :: Text -> Text -> [Type] -> Dec
sumMapperIsLabel Text
typeName Text
label [Type]
memberTypes =
  TyLit -> Type -> Name -> [Type] -> Dec
Instances.sumMapperIsLabel
    TyLit
thFieldLabel
    Type
thOwnerType
    Name
thConstructorName
    [Type]
thMemberTypes
  where
    thFieldLabel :: TyLit
thFieldLabel =
      Text -> TyLit
Helpers.textTyLit Text
label
    thOwnerType :: Type
thOwnerType =
      Name -> Type
TH.ConT (Text -> Name
Helpers.textName Text
typeName)
    thConstructorName :: Name
thConstructorName =
      Text -> Text -> Name
CoreTH.sumConstructorName Text
typeName Text
label
    thMemberTypes :: [Type]
thMemberTypes =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
CoreTH.typeType [Type]
memberTypes

-------------------------

deriving_ :: TH.Name -> Text -> TH.Dec
deriving_ :: Name -> Text -> Dec
deriving_ Name
className Text
typeNameText =
  Maybe DerivStrategy -> [Type] -> Type -> Dec
TH.StandaloneDerivD forall a. Maybe a
Nothing [] Type
headType
  where
    headType :: Type
headType =
      Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT Name
className) (Name -> Type
TH.ConT (Text -> Name
Helpers.textName Text
typeNameText))

empty :: TH.Name -> Text -> TH.Dec
empty :: Name -> Text -> Dec
empty Name
className Text
typeNameText =
  Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
TH.InstanceD forall a. Maybe a
Nothing [] Type
headType []
  where
    headType :: Type
headType =
      Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT Name
className) (Name -> Type
TH.ConT (Text -> Name
Helpers.textName Text
typeNameText))