module DomainOptics.InstanceDecs where

import qualified DomainCore.Model as Model
import qualified DomainCore.TH as DomainTH
import DomainOptics.Prelude
import qualified DomainOptics.Util.OpticsTH as OpticsTH
import Language.Haskell.TH.Syntax
import THLego.Helpers

labelOptic :: TypeDec -> [Dec]
labelOptic (Model.TypeDec Text
typeName TypeDef
typeDef) =
  case TypeDef
typeDef of
    Model.ProductTypeDef [(Text, Type)]
members ->
      (Int -> (Text, Type) -> Dec) -> [Int] -> [(Text, Type)] -> [Dec]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (Text, Type) -> Dec
zipper (Int -> [Int]
forall a. Enum a => a -> [a]
enumFrom Int
0) [(Text, Type)]
members
      where
        membersLength :: Int
membersLength =
          [(Text, Type)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Type)]
members
        zipper :: Int -> (Text, Type) -> Dec
zipper Int
fieldIndex (Text
fieldName, Type
fieldType) =
          TyLit -> Name -> Type -> Int -> Int -> Dec
OpticsTH.fieldLensLabelOpticInstanceDec
            (Text -> TyLit
textTyLit Text
fieldName)
            (Text -> Name
textName Text
typeName)
            (Type -> Type
DomainTH.typeType Type
fieldType)
            Int
membersLength
            Int
fieldIndex
    Model.SumTypeDef [(Text, [Type])]
structure ->
      ((Text, [Type]) -> Dec) -> [(Text, [Type])] -> [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, [Type]) -> Dec
mapper [(Text, [Type])]
structure
      where
        mapper :: (Text, [Type]) -> Dec
mapper (Text
memberName, [Type]
subTypes) =
          TyLit -> Name -> Name -> [Type] -> Dec
OpticsTH.prismLabelOpticInstanceDec
            (Text -> TyLit
textTyLit Text
memberName)
            (Text -> Name
textName Text
typeName)
            (Text -> Text -> Name
DomainTH.sumConstructorName Text
typeName Text
memberName)
            ((Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
DomainTH.typeType [Type]
subTypes)