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)