{-|
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 :: 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
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
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