OpticsTH.hs

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

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


-- * 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 (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 (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