-- |
-- 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 :: Name -> Int -> Int -> Exp
productLensVlE Name
conName Int
numMembers Int
index =
  Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Optics.lensVL) (Name -> Int -> Int -> Exp
Lambdas.vlLens Name
conName Int
numMembers Int
index)

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

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

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

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

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

-- * LabelOptic instances

-- |
-- General definition helper.
labelOpticInstanceD :: TyLit -> Name -> Name -> Type -> Exp -> Dec
labelOpticInstanceD :: TyLit -> Name -> Name -> Type -> Exp -> Dec
labelOpticInstanceD TyLit
lit Name
opticType Name
typeName Type
aAndBType Exp
exp =
  Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing Cxt
cxt Type
headType [Dec
labelOpticDec]
  where
    cxt :: Cxt
cxt =
      [Type
aPred, Type
bPred, Type
cPred]
      where
        aPred :: Type
aPred =
          Name -> Type -> Type
eqConstraintT Name
aName Type
aAndBType
        bPred :: Type
bPred =
          Name -> Type -> Type
eqConstraintT Name
bName Type
aAndBType
        cPred :: Type
cPred =
          Name -> Type -> Type
eqConstraintT Name
cName (Name -> Type
ConT Name
opticType)
    headType :: Type
headType =
      (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
        Type -> Type -> Type
AppT
        (Name -> Type
ConT ''Optics.LabelOptic)
        [ TyLit -> Type
LitT TyLit
lit,
          Name -> Type
VarT Name
cName,
          Name -> Type
ConT Name
typeName,
          Name -> Type
ConT Name
typeName,
          Name -> Type
VarT Name
aName,
          Name -> Type
VarT Name
bName
        ]
    labelOpticDec :: Dec
labelOpticDec =
      Name -> [Clause] -> Dec
FunD 'Optics.labelOptic [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
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 :: TyLit -> Name -> Type -> Int -> Int -> Dec
fieldLensLabelOpticInstanceDec TyLit
lit Name
typeName Type
aAndBType Int
numMembers Int
index =
  TyLit -> Name -> Name -> Type -> Exp -> Dec
labelOpticInstanceD
    TyLit
lit
    ''Optics.A_Lens
    Name
typeName
    Type
aAndBType
    (Name -> Int -> Int -> Exp
productLensVlE Name
typeName Int
numMembers Int
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 :: TyLit -> Name -> Name -> Cxt -> Dec
prismLabelOpticInstanceDec TyLit
lit Name
typeName Name
conName Cxt
memberTypes =
  TyLit -> Name -> Name -> Type -> Exp -> Dec
labelOpticInstanceD TyLit
lit ''Optics.A_Prism Name
typeName Type
aAndBType Exp
exp
  where
    aAndBType :: Type
aAndBType =
      Cxt -> Type
appliedTupleOrSingletonT Cxt
memberTypes
    exp :: Exp
exp =
      Name -> Int -> Exp
prismE Name
conName (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
memberTypes)

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