OpticsTH.hs

-- |
-- TH utils for optics.
module DomainOptics.Util.OpticsTH where

import qualified Data.Text as Text
import DomainOptics.Prelude
import Language.Haskell.TH
import qualified Optics.Core as Optics
import THLego.Helpers
import qualified THLego.Lambdas as Lambdas
import qualified TemplateHaskell.Compat.V0208 as Compat

-- * Optics

productLensVlE :: Name -> Int -> Int -> Exp
productLensVlE conName numMembers index =
  AppE (VarE 'Optics.lensVL) (Lambdas.vlLens conName numMembers index)

productLensE :: Name -> Int -> Int -> Exp
productLensE conName numMembers index =
  AppE (AppE (VarE 'Optics.lens) getterE) setterE
  where
    getterE =
      Lambdas.productGetter conName numMembers index
    setterE =
      Lambdas.productSetter conName numMembers index

-- |
-- >prism' Dog (\ case
-- >  Dog a -> Just a
-- >  _ -> Nothing)
singleMemberPrismE :: Name -> Exp
singleMemberPrismE conName =
  AppE
    (AppE (VarE 'Optics.prism') (ConE conName))
    ( LamE
        [VarP aName]
        ( CaseE
            (VarE aName)
            [ Match (Compat.conp conName [VarP bName]) (NormalB (AppE (ConE 'Just) (VarE bName))) [],
              Match WildP (NormalB (ConE 'Nothing)) []
            ]
        )
    )

-- |
-- Prism to a tuple of members.
prismE :: Name -> Int -> Exp
prismE conName numMembers =
  multiAppE
    (VarE 'Optics.prism')
    [ Lambdas.tupleOrSingletonToProduct conName numMembers,
      Lambdas.adtConstructorNarrower conName numMembers
    ]

emptyConLensE :: Name -> Exp
emptyConLensE conName =
  AppE (AppE (VarE 'Optics.lens) getterE) setterE
  where
    getterE =
      LamE
        [VarP aName]
        ( CaseE
            (VarE aName)
            [ Match (Compat.conp conName []) (NormalB (ConE 'True)) [],
              Match WildP (NormalB (ConE 'False)) []
            ]
        )
    setterE =
      LamE [VarP aName, VarP bName] (CondE (VarE bName) (ConE conName) (VarE aName))

namedFieldLensE :: Name -> Exp
namedFieldLensE fieldName =
  AppE (AppE (VarE 'Optics.lens) getterE) setterE
  where
    getterE =
      VarE fieldName
    setterE =
      Lambdas.namedFieldSetter fieldName

-- * LabelOptic instances

-- |
-- General definition helper.
labelOpticInstanceD :: TyLit -> Name -> Name -> Type -> Exp -> Dec
labelOpticInstanceD lit opticType typeName aAndBType exp =
  InstanceD Nothing cxt headType [labelOpticDec]
  where
    cxt =
      [aPred, bPred, cPred]
      where
        aPred =
          eqConstraintT aName aAndBType
        bPred =
          eqConstraintT bName aAndBType
        cPred =
          eqConstraintT cName (ConT opticType)
    headType =
      foldl'
        AppT
        (ConT ''Optics.LabelOptic)
        [ LitT lit,
          VarT cName,
          ConT typeName,
          ConT typeName,
          VarT aName,
          VarT bName
        ]
    labelOpticDec =
      FunD 'Optics.labelOptic [Clause [] (NormalB exp) []]

-- |
-- >instance (k ~ A_Lens, a ~ String, b ~ String) => LabelOptic "name" k Human Human a b where
-- >  labelOptic = lensVL $ \f s -> (\v -> s { humanName = v }) <$> f (humanName s)
fieldLensLabelOpticInstanceDec :: TyLit -> Name -> Type -> Int -> Int -> Dec
fieldLensLabelOpticInstanceDec lit typeName aAndBType numMembers index =
  labelOpticInstanceD
    lit
    ''Optics.A_Lens
    typeName
    aAndBType
    (productLensVlE typeName numMembers index)

-- |
-- >instance (k ~ A_Prism, a ~ String, b ~ String) => LabelOptic "dog" k Pet Pet a b where
-- >  labelOptic =
-- >    prism' Dog (\ case
-- >      Dog a -> Just a
-- >      _ -> Nothing)
prismLabelOpticInstanceDec :: TyLit -> Name -> Name -> [Type] -> Dec
prismLabelOpticInstanceDec lit typeName conName memberTypes =
  labelOpticInstanceD lit ''Optics.A_Prism typeName aAndBType exp
  where
    aAndBType =
      appliedTupleOrSingletonT memberTypes
    exp =
      prismE conName (length memberTypes)

emptyConLensLabelOpticInstanceDec :: TyLit -> Name -> Name -> Dec
emptyConLensLabelOpticInstanceDec lit typeName conName =
  labelOpticInstanceD lit ''Optics.A_Lens typeName aAndBType exp
  where
    aAndBType =
      ConT ''Bool
    exp =
      emptyConLensE conName