module Domain.TH.InstanceDecs
where

import Domain.Prelude
import DomainCore.Model
import qualified Domain.TH.InstanceDec as InstanceDec
import qualified Language.Haskell.TH as TH (Dec, Name)


hasField :: TypeDec -> [TH.Dec]
hasField :: TypeDec -> [Dec]
hasField (TypeDec Text
typeName TypeDef
typeDef) =
  case TypeDef
typeDef of
    ProductTypeDef [(Text, Type)]
members ->
      forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (Text, Type) -> Dec
zipper (forall a. Enum a => a -> [a]
enumFrom Int
0) [(Text, Type)]
members
      where
        numMembers :: Int
numMembers =
          forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Type)]
members
        zipper :: Int -> (Text, Type) -> Dec
zipper Int
offset (Text
fieldName, Type
fieldType) =
          Text -> Text -> Type -> Int -> Int -> Dec
InstanceDec.productHasField Text
typeName Text
fieldName Type
fieldType Int
numMembers Int
offset
    SumTypeDef [(Text, [Type])]
variants ->
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, [Type]) -> Dec
mapper [(Text, [Type])]
variants
      where
        mapper :: (Text, [Type]) -> Dec
mapper (Text
variantName, [Type]
memberTypes) =
          Text -> Text -> [Type] -> Dec
InstanceDec.sumHasField Text
typeName Text
variantName [Type]
memberTypes

accessorIsLabel :: TypeDec -> [TH.Dec]
accessorIsLabel :: TypeDec -> [Dec]
accessorIsLabel (TypeDec Text
typeName TypeDef
typeDef) =
  case TypeDef
typeDef of
    ProductTypeDef [(Text, Type)]
members ->
      forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (Text, Type) -> Dec
zipper (forall a. Enum a => a -> [a]
enumFrom Int
0) [(Text, Type)]
members
      where
        numMembers :: Int
numMembers =
          forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Type)]
members
        zipper :: Int -> (Text, Type) -> Dec
zipper Int
offset (Text
fieldName, Type
fieldType) =
          Text -> Text -> Type -> Int -> Int -> Dec
InstanceDec.productAccessorIsLabel Text
typeName Text
fieldName Type
fieldType Int
numMembers Int
offset
    SumTypeDef [(Text, [Type])]
variants ->
      [(Text, [Type])]
variants forall a b. a -> (a -> b) -> b
&
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (Text
variantName, [Type]
memberTypes) ->
        Text -> Text -> [Type] -> Dec
InstanceDec.sumAccessorIsLabel Text
typeName Text
variantName [Type]
memberTypes
        )

constructorIsLabel :: TypeDec -> [TH.Dec]
constructorIsLabel :: TypeDec -> [Dec]
constructorIsLabel (TypeDec Text
typeName TypeDef
typeDef) =
  case TypeDef
typeDef of
    ProductTypeDef [(Text, Type)]
members ->
      []
    SumTypeDef [(Text, [Type])]
variants ->
      [(Text, [Type])]
variants forall a b. a -> (a -> b) -> b
&
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (Text
variantName, [Type]
memberTypes) ->
        Text -> Text -> [Type] -> Dec
InstanceDec.curriedSumConstructorIsLabel Text
typeName Text
variantName [Type]
memberTypes)

variantConstructorIsLabel :: Text -> (Text, [Type]) -> [TH.Dec]
variantConstructorIsLabel :: Text -> (Text, [Type]) -> [Dec]
variantConstructorIsLabel Text
typeName (Text
variantName, [Type]
memberTypes) =
  let
    curried :: Dec
curried =
      Text -> Text -> [Type] -> Dec
InstanceDec.curriedSumConstructorIsLabel Text
typeName Text
variantName [Type]
memberTypes
    uncurried :: Dec
uncurried =
      Text -> Text -> [Type] -> Dec
InstanceDec.uncurriedSumConstructorIsLabel Text
typeName Text
variantName [Type]
memberTypes
    in case [Type]
memberTypes of
      [] ->
        [Dec
curried]
      [Type
_] ->
        [Dec
curried]
      [Type]
_ ->
        [Dec
curried, Dec
uncurried]

mapperIsLabel :: TypeDec -> [TH.Dec]
mapperIsLabel :: TypeDec -> [Dec]
mapperIsLabel (TypeDec Text
typeName TypeDef
typeDef) =
  case TypeDef
typeDef of
    ProductTypeDef [(Text, Type)]
members ->
      forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (Text, Type) -> Dec
zipper (forall a. Enum a => a -> [a]
enumFrom Int
0) [(Text, Type)]
members
      where
        numMembers :: Int
numMembers =
          forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Type)]
members
        zipper :: Int -> (Text, Type) -> Dec
zipper Int
offset (Text
fieldName, Type
fieldType) =
          Text -> Text -> Type -> Int -> Int -> Dec
InstanceDec.productMapperIsLabel Text
typeName Text
fieldName Type
fieldType Int
numMembers Int
offset
    SumTypeDef [(Text, [Type])]
variants ->
      do
        (Text
variantName, [Type]
memberTypes) <- [(Text, [Type])]
variants
        if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
memberTypes
          then forall (f :: * -> *) a. Alternative f => f a
empty
          else forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text -> [Type] -> Dec
InstanceDec.sumMapperIsLabel Text
typeName Text
variantName [Type]
memberTypes)


-- * Deriving
-------------------------

byNonAliasName :: (Text -> TH.Dec) -> TypeDec -> [TH.Dec]
byNonAliasName :: (Text -> Dec) -> TypeDec -> [Dec]
byNonAliasName Text -> Dec
cont (TypeDec Text
a TypeDef
b) =
  [Text -> Dec
cont Text
a]

byEnumName :: (Text -> TH.Dec) -> TypeDec -> [TH.Dec]
byEnumName :: (Text -> Dec) -> TypeDec -> [Dec]
byEnumName Text -> Dec
cont (TypeDec Text
name TypeDef
def) =
  case TypeDef
def of
    SumTypeDef [(Text, [Type])]
variants | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. Foldable t => t a -> Bool
null 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])]
variants ->
      [Text -> Dec
cont Text
name]
    TypeDef
_ ->
      []

enum :: TypeDec -> [Dec]
enum =
  (Text -> Dec) -> TypeDec -> [Dec]
byEnumName (Name -> Text -> Dec
InstanceDec.deriving_ ''Enum)

bounded :: TypeDec -> [Dec]
bounded =
  (Text -> Dec) -> TypeDec -> [Dec]
byEnumName (Name -> Text -> Dec
InstanceDec.deriving_ ''Bounded)

show :: TypeDec -> [Dec]
show =
  (Text -> Dec) -> TypeDec -> [Dec]
byNonAliasName (Name -> Text -> Dec
InstanceDec.deriving_ ''Show)

eq :: TypeDec -> [Dec]
eq =
  (Text -> Dec) -> TypeDec -> [Dec]
byNonAliasName (Name -> Text -> Dec
InstanceDec.deriving_ ''Eq)

ord :: TypeDec -> [Dec]
ord =
  (Text -> Dec) -> TypeDec -> [Dec]
byNonAliasName (Name -> Text -> Dec
InstanceDec.deriving_ ''Ord)

generic :: TypeDec -> [Dec]
generic =
  (Text -> Dec) -> TypeDec -> [Dec]
byNonAliasName (Name -> Text -> Dec
InstanceDec.deriving_ ''Generic)

data_ :: TypeDec -> [Dec]
data_ =
  (Text -> Dec) -> TypeDec -> [Dec]
byNonAliasName (Name -> Text -> Dec
InstanceDec.deriving_ ''Data)

typeable :: TypeDec -> [Dec]
typeable =
  (Text -> Dec) -> TypeDec -> [Dec]
byNonAliasName (Name -> Text -> Dec
InstanceDec.deriving_ ''Typeable)

hashable :: TypeDec -> [Dec]
hashable =
  (Text -> Dec) -> TypeDec -> [Dec]
byNonAliasName (Name -> Text -> Dec
InstanceDec.empty ''Hashable)

lift :: TypeDec -> [Dec]
lift =
  (Text -> Dec) -> TypeDec -> [Dec]
byNonAliasName (Name -> Text -> Dec
InstanceDec.deriving_ ''Lift)