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

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