{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module Optics.TH.Internal.Product
  ( LensRules(..)
  , FieldNamer
  , DefName(..)
  , ClassyNamer
  , makeFieldOptics
  , makeFieldOpticsForDec
  , makeFieldOpticsForDec'
  , makeFieldLabelsWith
  , makeFieldLabelsForDec
  , HasFieldClasses
  ) where

import Control.Monad
import Control.Monad.State
import Data.Either
import Data.Maybe
import Language.Haskell.TH
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Traversable as T
import qualified Language.Haskell.TH.Datatype as D
import qualified Language.Haskell.TH.Syntax as TH

import Data.Either.Optics
import Data.Tuple.Optics
import Data.Set.Optics
import Language.Haskell.TH.Optics.Internal
import Optics.Core hiding (cons)
import Optics.Internal.Magic
import Optics.TH.Internal.Utils

------------------------------------------------------------------------
-- Utilities
------------------------------------------------------------------------

typeSelf :: Traversal' Type Type
typeSelf :: Traversal' Type Type
typeSelf = TraversalVL Type Type Type Type -> Traversal' Type Type
forall s t a b. TraversalVL s t a b -> Traversal s t a b
traversalVL (TraversalVL Type Type Type Type -> Traversal' Type Type)
-> TraversalVL Type Type Type Type -> Traversal' Type Type
forall a b. (a -> b) -> a -> b
$ \Type -> f Type
f -> \case
  ForallT [TyVarBndr Specificity]
tyVarBndrs [Type]
ctx Type
ty ->
#if MIN_VERSION_template_haskell(2,17,0)
    let go :: TyVarBndr Specificity -> f (TyVarBndr Specificity)
go (KindedTV Name
nam Specificity
flag Type
kind) = Name -> Specificity -> Type -> TyVarBndr Specificity
forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV (Name -> Specificity -> Type -> TyVarBndr Specificity)
-> f Name -> f (Specificity -> Type -> TyVarBndr Specificity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
nam f (Specificity -> Type -> TyVarBndr Specificity)
-> f Specificity -> f (Type -> TyVarBndr Specificity)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Specificity -> f Specificity
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Specificity
flag f (Type -> TyVarBndr Specificity)
-> f Type -> f (TyVarBndr Specificity)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> f Type
f Type
kind
        go (PlainTV Name
nam Specificity
flag)       = TyVarBndr Specificity -> f (TyVarBndr Specificity)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
nam Specificity
flag)
#else
    let go (KindedTV nam kind) = KindedTV <$> pure nam <*> f kind
        go (PlainTV nam)       = pure (PlainTV nam)
#endif
    in [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT ([TyVarBndr Specificity] -> [Type] -> Type -> Type)
-> f [TyVarBndr Specificity] -> f ([Type] -> Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr Specificity -> f (TyVarBndr Specificity))
-> [TyVarBndr Specificity] -> f [TyVarBndr Specificity]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse TyVarBndr Specificity -> f (TyVarBndr Specificity)
go [TyVarBndr Specificity]
tyVarBndrs f ([Type] -> Type -> Type) -> f [Type] -> f (Type -> Type)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> f Type) -> [Type] -> f [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> f Type
f [Type]
ctx f (Type -> Type) -> f Type -> f Type
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> f Type
f Type
ty
  AppT Type
ty1 Type
ty2              -> Type -> Type -> Type
AppT (Type -> Type -> Type) -> f Type -> f (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> f Type
f Type
ty1 f (Type -> Type) -> f Type -> f Type
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> f Type
f Type
ty2
  SigT Type
ty Type
kind              -> Type -> Type -> Type
SigT (Type -> Type -> Type) -> f Type -> f (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> f Type
f Type
ty f (Type -> Type) -> f Type -> f Type
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> f Type
f Type
kind
  InfixT Type
ty1 Name
nam Type
ty2        -> Type -> Name -> Type -> Type
InfixT (Type -> Name -> Type -> Type)
-> f Type -> f (Name -> Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> f Type
f Type
ty1 f (Name -> Type -> Type) -> f Name -> f (Type -> Type)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
nam f (Type -> Type) -> f Type -> f Type
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> f Type
f Type
ty2
  UInfixT Type
ty1 Name
nam Type
ty2       -> Type -> Name -> Type -> Type
UInfixT (Type -> Name -> Type -> Type)
-> f Type -> f (Name -> Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> f Type
f Type
ty1 f (Name -> Type -> Type) -> f Name -> f (Type -> Type)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
nam f (Type -> Type) -> f Type -> f Type
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> f Type
f Type
ty2
  ParensT Type
ty                -> Type -> Type
ParensT (Type -> Type) -> f Type -> f Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> f Type
f Type
ty
  Type
ty                        -> Type -> f Type
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty

------------------------------------------------------------------------
-- Field generation entry point
------------------------------------------------------------------------

-- | Compute the field optics for the type identified by the given type name.
-- Lenses will be computed when possible, Traversals otherwise.
makeFieldOptics :: LensRules -> Name -> DecsQ
makeFieldOptics :: LensRules -> Name -> DecsQ
makeFieldOptics LensRules
rules = (StateT (Set Name) Q [Dec] -> Set Name -> DecsQ
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` Set Name
forall a. Set a
S.empty) (StateT (Set Name) Q [Dec] -> DecsQ)
-> (DatatypeInfo -> StateT (Set Name) Q [Dec])
-> DatatypeInfo
-> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDatatype LensRules
rules (DatatypeInfo -> DecsQ)
-> (Name -> Q DatatypeInfo) -> Name -> DecsQ
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q DatatypeInfo
D.reifyDatatype

makeFieldOpticsForDec :: LensRules -> Dec -> DecsQ
makeFieldOpticsForDec :: LensRules -> Dec -> DecsQ
makeFieldOpticsForDec LensRules
rules = (StateT (Set Name) Q [Dec] -> Set Name -> DecsQ
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` Set Name
forall a. Set a
S.empty) (StateT (Set Name) Q [Dec] -> DecsQ)
-> (Dec -> StateT (Set Name) Q [Dec]) -> Dec -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensRules -> Dec -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDec' LensRules
rules

makeFieldOpticsForDec' :: LensRules -> Dec -> HasFieldClasses [Dec]
makeFieldOpticsForDec' :: LensRules -> Dec -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDec' LensRules
rules = LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDatatype LensRules
rules (DatatypeInfo -> StateT (Set Name) Q [Dec])
-> (Dec -> StateT (Set Name) Q DatatypeInfo)
-> Dec
-> StateT (Set Name) Q [Dec]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Q DatatypeInfo -> StateT (Set Name) Q DatatypeInfo
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q DatatypeInfo -> StateT (Set Name) Q DatatypeInfo)
-> (Dec -> Q DatatypeInfo)
-> Dec
-> StateT (Set Name) Q DatatypeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> Q DatatypeInfo
D.normalizeDec

-- | Compute the field optics for a deconstructed datatype Dec
-- When possible build an Iso otherwise build one optic per field.
makeFieldOpticsForDatatype :: LensRules -> D.DatatypeInfo -> HasFieldClasses [Dec]
makeFieldOpticsForDatatype :: LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDatatype LensRules
rules DatatypeInfo
info =
  do Map DefName (OpticStab, [(Name, Int, [Int])])
perDef <- Q (Map DefName (OpticStab, [(Name, Int, [Int])]))
-> StateT
     (Set Name) Q (Map DefName (OpticStab, [(Name, Int, [Int])]))
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q (Map DefName (OpticStab, [(Name, Int, [Int])]))
 -> StateT
      (Set Name) Q (Map DefName (OpticStab, [(Name, Int, [Int])])))
-> Q (Map DefName (OpticStab, [(Name, Int, [Int])]))
-> StateT
     (Set Name) Q (Map DefName (OpticStab, [(Name, Int, [Int])]))
forall a b. (a -> b) -> a -> b
$ do
       [(Name, [(Maybe Name, Type)])]
fieldCons <- (ConstructorInfo -> Q (Name, [(Maybe Name, Type)]))
-> [ConstructorInfo] -> Q [(Name, [(Maybe Name, Type)])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DatatypeInfo -> ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
normalizeConstructor DatatypeInfo
info) [ConstructorInfo]
cons
       let allFields :: [Name]
allFields  = Optic' A_Fold NoIx [(Name, [(Maybe Name, Type)])] Name
-> [(Name, [(Maybe Name, Type)])] -> [Name]
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> [a]
toListOf (Fold [(Name, [(Maybe Name, Type)])] (Name, [(Maybe Name, Type)])
forall (f :: * -> *) a. Foldable f => Fold (f a) a
folded Fold [(Name, [(Maybe Name, Type)])] (Name, [(Maybe Name, Type)])
-> Optic
     A_Lens
     NoIx
     (Name, [(Maybe Name, Type)])
     (Name, [(Maybe Name, Type)])
     [(Maybe Name, Type)]
     [(Maybe Name, Type)]
-> Optic
     A_Fold
     NoIx
     [(Name, [(Maybe Name, Type)])]
     [(Name, [(Maybe Name, Type)])]
     [(Maybe Name, Type)]
     [(Maybe Name, Type)]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  (Name, [(Maybe Name, Type)])
  (Name, [(Maybe Name, Type)])
  [(Maybe Name, Type)]
  [(Maybe Name, Type)]
forall s t a b. Field2 s t a b => Lens s t a b
_2 Optic
  A_Fold
  NoIx
  [(Name, [(Maybe Name, Type)])]
  [(Name, [(Maybe Name, Type)])]
  [(Maybe Name, Type)]
  [(Maybe Name, Type)]
-> Optic
     A_Fold
     NoIx
     [(Maybe Name, Type)]
     [(Maybe Name, Type)]
     (Maybe Name, Type)
     (Maybe Name, Type)
-> Optic
     A_Fold
     NoIx
     [(Name, [(Maybe Name, Type)])]
     [(Name, [(Maybe Name, Type)])]
     (Maybe Name, Type)
     (Maybe Name, Type)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Fold
  NoIx
  [(Maybe Name, Type)]
  [(Maybe Name, Type)]
  (Maybe Name, Type)
  (Maybe Name, Type)
forall (f :: * -> *) a. Foldable f => Fold (f a) a
folded Optic
  A_Fold
  NoIx
  [(Name, [(Maybe Name, Type)])]
  [(Name, [(Maybe Name, Type)])]
  (Maybe Name, Type)
  (Maybe Name, Type)
-> Optic
     A_Lens
     NoIx
     (Maybe Name, Type)
     (Maybe Name, Type)
     (Maybe Name)
     (Maybe Name)
-> Optic
     A_Fold
     NoIx
     [(Name, [(Maybe Name, Type)])]
     [(Name, [(Maybe Name, Type)])]
     (Maybe Name)
     (Maybe Name)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  (Maybe Name, Type)
  (Maybe Name, Type)
  (Maybe Name)
  (Maybe Name)
forall s t a b. Field1 s t a b => Lens s t a b
_1 Optic
  A_Fold
  NoIx
  [(Name, [(Maybe Name, Type)])]
  [(Name, [(Maybe Name, Type)])]
  (Maybe Name)
  (Maybe Name)
-> Optic A_Fold NoIx (Maybe Name) (Maybe Name) Name Name
-> Optic' A_Fold NoIx [(Name, [(Maybe Name, Type)])] Name
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Fold NoIx (Maybe Name) (Maybe Name) Name Name
forall (f :: * -> *) a. Foldable f => Fold (f a) a
folded) [(Name, [(Maybe Name, Type)])]
fieldCons
       let defCons :: [(Name, [([DefName], Type)])]
defCons    = Optic
  A_Traversal
  NoIx
  [(Name, [(Maybe Name, Type)])]
  [(Name, [([DefName], Type)])]
  (Maybe Name)
  [DefName]
-> (Maybe Name -> [DefName])
-> [(Name, [(Maybe Name, Type)])]
-> [(Name, [([DefName], Type)])]
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic
  A_Traversal
  NoIx
  [(Name, [(Maybe Name, Type)])]
  [(Name, [([DefName], Type)])]
  (Maybe Name)
  [DefName]
forall a b.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels (LensRules
-> Name -> [ConstructorInfo] -> [Name] -> Maybe Name -> [DefName]
expandName LensRules
rules Name
tyName [ConstructorInfo]
cons [Name]
allFields) [(Name, [(Maybe Name, Type)])]
fieldCons
           allDefs :: Set DefName
allDefs    = Optic' A_Fold NoIx [(Name, [([DefName], Type)])] DefName
-> [(Name, [([DefName], Type)])] -> Set DefName
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf (Traversal
  [(Name, [([DefName], Type)])]
  [(Name, [([DefName], Type)])]
  [DefName]
  [DefName]
forall a b.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels Traversal
  [(Name, [([DefName], Type)])]
  [(Name, [([DefName], Type)])]
  [DefName]
  [DefName]
-> Optic A_Fold NoIx [DefName] [DefName] DefName DefName
-> Optic' A_Fold NoIx [(Name, [([DefName], Type)])] DefName
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Fold NoIx [DefName] [DefName] DefName DefName
forall (f :: * -> *) a. Foldable f => Fold (f a) a
folded) [(Name, [([DefName], Type)])]
defCons
       Map DefName (Q (OpticStab, [(Name, Int, [Int])]))
-> Q (Map DefName (OpticStab, [(Name, Int, [Int])]))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
Map DefName (f a) -> f (Map DefName a)
T.sequenceA ((DefName -> Q (OpticStab, [(Name, Int, [Int])]))
-> Set DefName -> Map DefName (Q (OpticStab, [(Name, Int, [Int])]))
forall k a. (k -> a) -> Set k -> Map k a
M.fromSet (Bool
-> LensRules
-> Type
-> [(Name, [([DefName], Type)])]
-> DefName
-> Q (OpticStab, [(Name, Int, [Int])])
buildScaffold Bool
False LensRules
rules Type
s [(Name, [([DefName], Type)])]
defCons) Set DefName
allDefs)

     let defs :: [(DefName, (OpticStab, [(Name, Int, [Int])]))]
defs = Map DefName (OpticStab, [(Name, Int, [Int])])
-> [(DefName, (OpticStab, [(Name, Int, [Int])]))]
forall k a. Map k a -> [(k, a)]
M.toList Map DefName (OpticStab, [(Name, Int, [Int])])
perDef
     case LensRules -> ClassyNamer
_classyLenses LensRules
rules Name
tyName of
       Just (Name
className, Name
methodName) ->
         LensRules
-> Name
-> Name
-> Type
-> [(DefName, (OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q [Dec]
makeClassyDriver LensRules
rules Name
className Name
methodName Type
s [(DefName, (OpticStab, [(Name, Int, [Int])]))]
defs
       Maybe (Name, Name)
Nothing -> do
         Bool -> StateT (Set Name) Q () -> StateT (Set Name) Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Optic'
  A_Traversal
  NoIx
  [(DefName, (OpticStab, [(Name, Int, [Int])]))]
  (Name, Name)
-> [(DefName, (OpticStab, [(Name, Int, [Int])]))] -> Bool
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Bool
has (Traversal
  [(DefName, (OpticStab, [(Name, Int, [Int])]))]
  [(DefName, (OpticStab, [(Name, Int, [Int])]))]
  (DefName, (OpticStab, [(Name, Int, [Int])]))
  (DefName, (OpticStab, [(Name, Int, [Int])]))
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed Traversal
  [(DefName, (OpticStab, [(Name, Int, [Int])]))]
  [(DefName, (OpticStab, [(Name, Int, [Int])]))]
  (DefName, (OpticStab, [(Name, Int, [Int])]))
  (DefName, (OpticStab, [(Name, Int, [Int])]))
-> Optic
     A_Lens
     NoIx
     (DefName, (OpticStab, [(Name, Int, [Int])]))
     (DefName, (OpticStab, [(Name, Int, [Int])]))
     DefName
     DefName
-> Optic
     A_Traversal
     NoIx
     [(DefName, (OpticStab, [(Name, Int, [Int])]))]
     [(DefName, (OpticStab, [(Name, Int, [Int])]))]
     DefName
     DefName
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  (DefName, (OpticStab, [(Name, Int, [Int])]))
  (DefName, (OpticStab, [(Name, Int, [Int])]))
  DefName
  DefName
forall s t a b. Field1 s t a b => Lens s t a b
_1 Optic
  A_Traversal
  NoIx
  [(DefName, (OpticStab, [(Name, Int, [Int])]))]
  [(DefName, (OpticStab, [(Name, Int, [Int])]))]
  DefName
  DefName
-> Optic A_Prism NoIx DefName DefName (Name, Name) (Name, Name)
-> Optic'
     A_Traversal
     NoIx
     [(DefName, (OpticStab, [(Name, Int, [Int])]))]
     (Name, Name)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Prism NoIx DefName DefName (Name, Name) (Name, Name)
_MethodName) [(DefName, (OpticStab, [(Name, Int, [Int])]))]
defs) (StateT (Set Name) Q () -> StateT (Set Name) Q ())
-> StateT (Set Name) Q () -> StateT (Set Name) Q ()
forall a b. (a -> b) -> a -> b
$ do
           Q () -> StateT (Set Name) Q ()
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q ()
requireExtensionsForFields
         [[Dec]]
decss <- ((DefName, (OpticStab, [(Name, Int, [Int])]))
 -> StateT (Set Name) Q [Dec])
-> [(DefName, (OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (LensRules
-> (DefName, (OpticStab, [(Name, Int, [Int])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules) [(DefName, (OpticStab, [(Name, Int, [Int])]))]
defs
         [Dec] -> StateT (Set Name) Q [Dec]
forall a. a -> StateT (Set Name) Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decss)

  where
  tyName :: Name
tyName = DatatypeInfo -> Name
D.datatypeName DatatypeInfo
info
  s :: Type
s      = DatatypeInfo -> Type -> Type
addKindInfo DatatypeInfo
info (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> Type
D.datatypeType DatatypeInfo
info
  cons :: [ConstructorInfo]
cons   = DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
info

  -- Traverse the field labels of a normalized constructor
  normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b
  normFieldLabels :: forall a b.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels = Traversal
  [(Name, [(a, Type)])]
  [(Name, [(b, Type)])]
  (Name, [(a, Type)])
  (Name, [(b, Type)])
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed Traversal
  [(Name, [(a, Type)])]
  [(Name, [(b, Type)])]
  (Name, [(a, Type)])
  (Name, [(b, Type)])
-> Optic
     A_Lens
     NoIx
     (Name, [(a, Type)])
     (Name, [(b, Type)])
     [(a, Type)]
     [(b, Type)]
-> Optic
     A_Traversal
     NoIx
     [(Name, [(a, Type)])]
     [(Name, [(b, Type)])]
     [(a, Type)]
     [(b, Type)]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  (Name, [(a, Type)])
  (Name, [(b, Type)])
  [(a, Type)]
  [(b, Type)]
forall s t a b. Field2 s t a b => Lens s t a b
_2 Optic
  A_Traversal
  NoIx
  [(Name, [(a, Type)])]
  [(Name, [(b, Type)])]
  [(a, Type)]
  [(b, Type)]
-> Optic
     A_Traversal NoIx [(a, Type)] [(b, Type)] (a, Type) (b, Type)
-> Optic
     A_Traversal
     NoIx
     [(Name, [(a, Type)])]
     [(Name, [(b, Type)])]
     (a, Type)
     (b, Type)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Traversal NoIx [(a, Type)] [(b, Type)] (a, Type) (b, Type)
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed Optic
  A_Traversal
  NoIx
  [(Name, [(a, Type)])]
  [(Name, [(b, Type)])]
  (a, Type)
  (b, Type)
-> Optic A_Lens NoIx (a, Type) (b, Type) a b
-> Optic
     A_Traversal NoIx [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx (a, Type) (b, Type) a b
forall s t a b. Field1 s t a b => Lens s t a b
_1

-- | Map a (possibly missing) field's name to zero-to-many optic definitions
expandName :: LensRules -> Name -> [D.ConstructorInfo] -> [Name] -> Maybe Name -> [DefName]
expandName :: LensRules
-> Name -> [ConstructorInfo] -> [Name] -> Maybe Name -> [DefName]
expandName LensRules
rules Name
tyName [ConstructorInfo]
cons [Name]
allFields =
    (Name -> [DefName]) -> [Name] -> [DefName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LensRules -> FieldNamer
_fieldToDef LensRules
rules Name
tyName [Name]
allFields (Name -> [DefName]) -> (Name -> Name) -> Name -> [DefName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic A_Lens NoIx Name Name String String
-> (String -> String) -> Name -> Name
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic A_Lens NoIx Name Name String String
nameString String -> String
stripSel) ([Name] -> [DefName])
-> (Maybe Name -> [Name]) -> Maybe Name -> [DefName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Name -> [Name]
forall a. Maybe a -> [a]
maybeToList
  where
    -- When DuplicateRecordFields is enabled, reified datatypes contain
    -- "mangled" field names that look like $sel:foo:MkT where foo is the field
    -- name and MkT is the first data constructor of the type (regardless of
    -- whether that constructor contains the field or not).  If they are both
    -- present, we strip off the prefix and suffix to get back to the underlying
    -- field name.  See #323.
    stripSel :: String -> String
    stripSel :: String -> String
stripSel String
n = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
n (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix (Char
':'Char -> String -> String
forall a. a -> [a] -> [a]
:String
first_con_name)
                           (String -> Maybe String) -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
L.stripPrefix String
"$sel:" String
n

    stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
    stripSuffix :: forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix [a]
suffix = ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> [a]
forall a. [a] -> [a]
reverse (Maybe [a] -> Maybe [a]) -> ([a] -> Maybe [a]) -> [a] -> Maybe [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
L.stripPrefix ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
suffix) ([a] -> Maybe [a]) -> ([a] -> [a]) -> [a] -> Maybe [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse

    -- We have to look up the actual name of the first constructor, rather than
    -- trying to split the string on colons, because either the field name or
    -- the constructor name might themselves contain colons.
    first_con_name :: String
first_con_name = case [ConstructorInfo]
cons of
      ConstructorInfo
con:[ConstructorInfo]
_ -> Optic A_Lens NoIx Name Name String String -> Name -> String
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic A_Lens NoIx Name Name String String
nameString (ConstructorInfo -> Name
D.constructorName ConstructorInfo
con)
      []    -> String -> String
forall a. HasCallStack => String -> a
error String
"expandName: impossible for a record type with fields to have no constructors!"

nameString :: Lens' Name String
nameString :: Optic A_Lens NoIx Name Name String String
nameString = (Name -> String)
-> (Name -> String -> Name)
-> Optic A_Lens NoIx Name Name String String
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\ (TH.Name (TH.OccName String
s) NameFlavour
_) -> String
s)
                  (\ (TH.Name OccName
_ NameFlavour
f) String
s -> OccName -> NameFlavour -> Name
TH.Name (String -> OccName
TH.OccName String
s) NameFlavour
f)

makeFieldLabelsForDec :: LensRules -> Dec -> DecsQ
makeFieldLabelsForDec :: LensRules -> Dec -> DecsQ
makeFieldLabelsForDec LensRules
rules = LensRules -> DatatypeInfo -> DecsQ
makeFieldLabelsForDatatype LensRules
rules (DatatypeInfo -> DecsQ) -> (Dec -> Q DatatypeInfo) -> Dec -> DecsQ
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Dec -> Q DatatypeInfo
D.normalizeDec

-- | Build field optics as labels with a custom configuration.
makeFieldLabelsWith :: LensRules -> Name -> DecsQ
makeFieldLabelsWith :: LensRules -> Name -> DecsQ
makeFieldLabelsWith LensRules
rules = Name -> Q DatatypeInfo
D.reifyDatatype (Name -> Q DatatypeInfo)
-> (DatatypeInfo -> DecsQ) -> Name -> DecsQ
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> LensRules -> DatatypeInfo -> DecsQ
makeFieldLabelsForDatatype LensRules
rules

-- | Compute the field optics for a deconstructed datatype Dec
-- When possible build an Iso otherwise build one optic per field.
makeFieldLabelsForDatatype :: LensRules -> D.DatatypeInfo -> Q [Dec]
makeFieldLabelsForDatatype :: LensRules -> DatatypeInfo -> DecsQ
makeFieldLabelsForDatatype LensRules
rules DatatypeInfo
info = do
  Q ()
requireExtensionsForLabels
  Map DefName (OpticStab, [(Name, Int, [Int])])
perDef <- do
    [(Name, [(Maybe Name, Type)])]
fieldCons <- (ConstructorInfo -> Q (Name, [(Maybe Name, Type)]))
-> [ConstructorInfo] -> Q [(Name, [(Maybe Name, Type)])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DatatypeInfo -> ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
normalizeConstructor DatatypeInfo
info) [ConstructorInfo]
cons
    let allFields :: [Name]
allFields  = Optic' A_Fold NoIx [(Name, [(Maybe Name, Type)])] Name
-> [(Name, [(Maybe Name, Type)])] -> [Name]
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> [a]
toListOf (Fold [(Name, [(Maybe Name, Type)])] (Name, [(Maybe Name, Type)])
forall (f :: * -> *) a. Foldable f => Fold (f a) a
folded Fold [(Name, [(Maybe Name, Type)])] (Name, [(Maybe Name, Type)])
-> Optic
     A_Lens
     NoIx
     (Name, [(Maybe Name, Type)])
     (Name, [(Maybe Name, Type)])
     [(Maybe Name, Type)]
     [(Maybe Name, Type)]
-> Optic
     A_Fold
     NoIx
     [(Name, [(Maybe Name, Type)])]
     [(Name, [(Maybe Name, Type)])]
     [(Maybe Name, Type)]
     [(Maybe Name, Type)]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  (Name, [(Maybe Name, Type)])
  (Name, [(Maybe Name, Type)])
  [(Maybe Name, Type)]
  [(Maybe Name, Type)]
forall s t a b. Field2 s t a b => Lens s t a b
_2 Optic
  A_Fold
  NoIx
  [(Name, [(Maybe Name, Type)])]
  [(Name, [(Maybe Name, Type)])]
  [(Maybe Name, Type)]
  [(Maybe Name, Type)]
-> Optic
     A_Fold
     NoIx
     [(Maybe Name, Type)]
     [(Maybe Name, Type)]
     (Maybe Name, Type)
     (Maybe Name, Type)
-> Optic
     A_Fold
     NoIx
     [(Name, [(Maybe Name, Type)])]
     [(Name, [(Maybe Name, Type)])]
     (Maybe Name, Type)
     (Maybe Name, Type)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Fold
  NoIx
  [(Maybe Name, Type)]
  [(Maybe Name, Type)]
  (Maybe Name, Type)
  (Maybe Name, Type)
forall (f :: * -> *) a. Foldable f => Fold (f a) a
folded Optic
  A_Fold
  NoIx
  [(Name, [(Maybe Name, Type)])]
  [(Name, [(Maybe Name, Type)])]
  (Maybe Name, Type)
  (Maybe Name, Type)
-> Optic
     A_Lens
     NoIx
     (Maybe Name, Type)
     (Maybe Name, Type)
     (Maybe Name)
     (Maybe Name)
-> Optic
     A_Fold
     NoIx
     [(Name, [(Maybe Name, Type)])]
     [(Name, [(Maybe Name, Type)])]
     (Maybe Name)
     (Maybe Name)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  (Maybe Name, Type)
  (Maybe Name, Type)
  (Maybe Name)
  (Maybe Name)
forall s t a b. Field1 s t a b => Lens s t a b
_1 Optic
  A_Fold
  NoIx
  [(Name, [(Maybe Name, Type)])]
  [(Name, [(Maybe Name, Type)])]
  (Maybe Name)
  (Maybe Name)
-> Optic A_Fold NoIx (Maybe Name) (Maybe Name) Name Name
-> Optic' A_Fold NoIx [(Name, [(Maybe Name, Type)])] Name
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Fold NoIx (Maybe Name) (Maybe Name) Name Name
forall (f :: * -> *) a. Foldable f => Fold (f a) a
folded) [(Name, [(Maybe Name, Type)])]
fieldCons
    let defCons :: [(Name, [([DefName], Type)])]
defCons    = Optic
  A_Traversal
  NoIx
  [(Name, [(Maybe Name, Type)])]
  [(Name, [([DefName], Type)])]
  (Maybe Name)
  [DefName]
-> (Maybe Name -> [DefName])
-> [(Name, [(Maybe Name, Type)])]
-> [(Name, [([DefName], Type)])]
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic
  A_Traversal
  NoIx
  [(Name, [(Maybe Name, Type)])]
  [(Name, [([DefName], Type)])]
  (Maybe Name)
  [DefName]
forall a b.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels (LensRules
-> Name -> [ConstructorInfo] -> [Name] -> Maybe Name -> [DefName]
expandName LensRules
rules Name
tyName [ConstructorInfo]
cons [Name]
allFields) [(Name, [(Maybe Name, Type)])]
fieldCons
        allDefs :: Set DefName
allDefs    = Optic' A_Fold NoIx [(Name, [([DefName], Type)])] DefName
-> [(Name, [([DefName], Type)])] -> Set DefName
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf (Traversal
  [(Name, [([DefName], Type)])]
  [(Name, [([DefName], Type)])]
  [DefName]
  [DefName]
forall a b.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels Traversal
  [(Name, [([DefName], Type)])]
  [(Name, [([DefName], Type)])]
  [DefName]
  [DefName]
-> Optic A_Fold NoIx [DefName] [DefName] DefName DefName
-> Optic' A_Fold NoIx [(Name, [([DefName], Type)])] DefName
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Fold NoIx [DefName] [DefName] DefName DefName
forall (f :: * -> *) a. Foldable f => Fold (f a) a
folded) [(Name, [([DefName], Type)])]
defCons
    Map DefName (Q (OpticStab, [(Name, Int, [Int])]))
-> Q (Map DefName (OpticStab, [(Name, Int, [Int])]))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
Map DefName (f a) -> f (Map DefName a)
T.sequenceA ((DefName -> Q (OpticStab, [(Name, Int, [Int])]))
-> Set DefName -> Map DefName (Q (OpticStab, [(Name, Int, [Int])]))
forall k a. (k -> a) -> Set k -> Map k a
M.fromSet (Bool
-> LensRules
-> Type
-> [(Name, [([DefName], Type)])]
-> DefName
-> Q (OpticStab, [(Name, Int, [Int])])
buildScaffold Bool
True LensRules
rules Type
s [(Name, [([DefName], Type)])]
defCons) Set DefName
allDefs)
  let defs :: [(DefName, (OpticStab, [(Name, Int, [Int])]))]
defs = Map DefName (OpticStab, [(Name, Int, [Int])])
-> [(DefName, (OpticStab, [(Name, Int, [Int])]))]
forall k a. Map k a -> [(k, a)]
M.toList Map DefName (OpticStab, [(Name, Int, [Int])])
perDef
  ((DefName, (OpticStab, [(Name, Int, [Int])])) -> Q Dec)
-> [(DefName, (OpticStab, [(Name, Int, [Int])]))] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DatatypeInfo
-> LensRules
-> (DefName, (OpticStab, [(Name, Int, [Int])]))
-> Q Dec
makeFieldLabel DatatypeInfo
info LensRules
rules) [(DefName, (OpticStab, [(Name, Int, [Int])]))]
defs
  where
    tyName :: Name
tyName = DatatypeInfo -> Name
D.datatypeName DatatypeInfo
info
    s :: Type
s      = DatatypeInfo -> Type -> Type
addKindInfo DatatypeInfo
info (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> Type
D.datatypeType DatatypeInfo
info
    cons :: [ConstructorInfo]
cons   = DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
info

    -- Traverse the field labels of a normalized constructor
    normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b
    normFieldLabels :: forall a b.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels = Traversal
  [(Name, [(a, Type)])]
  [(Name, [(b, Type)])]
  (Name, [(a, Type)])
  (Name, [(b, Type)])
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed Traversal
  [(Name, [(a, Type)])]
  [(Name, [(b, Type)])]
  (Name, [(a, Type)])
  (Name, [(b, Type)])
-> Optic
     A_Lens
     NoIx
     (Name, [(a, Type)])
     (Name, [(b, Type)])
     [(a, Type)]
     [(b, Type)]
-> Optic
     A_Traversal
     NoIx
     [(Name, [(a, Type)])]
     [(Name, [(b, Type)])]
     [(a, Type)]
     [(b, Type)]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  (Name, [(a, Type)])
  (Name, [(b, Type)])
  [(a, Type)]
  [(b, Type)]
forall s t a b. Field2 s t a b => Lens s t a b
_2 Optic
  A_Traversal
  NoIx
  [(Name, [(a, Type)])]
  [(Name, [(b, Type)])]
  [(a, Type)]
  [(b, Type)]
-> Optic
     A_Traversal NoIx [(a, Type)] [(b, Type)] (a, Type) (b, Type)
-> Optic
     A_Traversal
     NoIx
     [(Name, [(a, Type)])]
     [(Name, [(b, Type)])]
     (a, Type)
     (b, Type)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Traversal NoIx [(a, Type)] [(b, Type)] (a, Type) (b, Type)
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed Optic
  A_Traversal
  NoIx
  [(Name, [(a, Type)])]
  [(Name, [(b, Type)])]
  (a, Type)
  (b, Type)
-> Optic A_Lens NoIx (a, Type) (b, Type) a b
-> Optic
     A_Traversal NoIx [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx (a, Type) (b, Type) a b
forall s t a b. Field1 s t a b => Lens s t a b
_1

makeFieldLabel
  :: D.DatatypeInfo
  -> LensRules
  -> (DefName, (OpticStab, [(Name, Int, [Int])]))
  -> Q Dec
makeFieldLabel :: DatatypeInfo
-> LensRules
-> (DefName, (OpticStab, [(Name, Int, [Int])]))
-> Q Dec
makeFieldLabel DatatypeInfo
info LensRules
rules (DefName
defName, (OpticStab
defType, [(Name, Int, [Int])]
cons)) = do
  (Q [Type]
context, Q Type
instHead) <- case OpticStab
defType of
    OpticSa [TyVarBndr Specificity]
vs [Type]
cx OpticType
otype Type
s Type
a0 -> do
      -- 'tv' might have info about type variables of 'a' that need filling in.
      let a :: Type
a = [Type] -> DatatypeInfo -> Type -> Type
addKindInfo' ((TyVarBndr Specificity -> Type)
-> [TyVarBndr Specificity] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr Specificity -> Type
forall flag. TyVarBndr_ flag -> Type
tyVarBndrToType [TyVarBndr Specificity]
vs) DatatypeInfo
info Type
a0
      (Type
k,  Type
cxtK) <- Type -> String -> Q (Type, Type)
eqSubst (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ OpticType -> Name
opticTypeToTag OpticType
otype) String
"k"
      (Type
a', Type
cxtA) <- Type -> String -> Q (Type, Type)
eqSubst Type
a String
"a"
      (Type
b', Type
cxtB) <- Type -> String -> Q (Type, Type)
eqSubst Type
a String
"b"
      let tyArgs :: [Type]
tyArgs = [TyLit -> Type
LitT (String -> TyLit
StrTyLit String
fieldName), Type
k, Type
s, Type
s, Type
a', Type
b']
          context :: [Type]
context = [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ -- If the field is polymorphic, the instance is dysfunctional.
              if [TyVarBndr Specificity] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr Specificity]
vs then [] else [Name -> [Type] -> Type
conAppsT ''Dysfunctional [Type]
tyArgs]
            , [Type
cxtK, Type
cxtA, Type
cxtB]
            , [Type]
cx
            ]
      (Q [Type], Q Type) -> Q (Q [Type], Q Type)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type] -> Q [Type]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
context, Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Type
conAppsT ''LabelOptic [Type]
tyArgs)
    OpticStab Bool
tvsCovered OpticType
otype Type
s Type
t Type
a Type
b -> do
      (Type
k,  Type
cxtK) <- Type -> String -> Q (Type, Type)
eqSubst (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ OpticType -> Name
opticTypeToTag OpticType
otype) String
"k"
      (Type
a', Type
cxtA) <- Type -> String -> Q (Type, Type)
eqSubst Type
a String
"a"
      (Type
b', Type
cxtB) <- Type -> String -> Q (Type, Type)
eqSubst Type
b String
"b"
      let tyArgs :: [Type]
tyArgs = [TyLit -> Type
LitT (String -> TyLit
StrTyLit String
fieldName), Type
k, Type
s, Type
t, Type
a', Type
b']
          context :: [Type]
context = [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ -- If some of the type variables are not covered, the instance is
              -- dysfunctional.
              if Bool
tvsCovered then [] else [Name -> [Type] -> Type
conAppsT ''Dysfunctional [Type]
tyArgs]
            , [Type
cxtK, Type
cxtA, Type
cxtB]
            ]
      (Q [Type], Q Type) -> Q (Q [Type], Q Type)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type] -> Q [Type]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
context, Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Type
conAppsT ''LabelOptic [Type]
tyArgs)
  Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD Q [Type]
context Q Type
instHead (Name -> [Q Dec]
fun 'labelOptic)
  where
    opticTypeToTag :: OpticType -> Name
opticTypeToTag OpticType
AffineFoldType      = ''An_AffineFold
    opticTypeToTag OpticType
AffineTraversalType = ''An_AffineTraversal
    opticTypeToTag OpticType
FoldType            = ''A_Fold
    opticTypeToTag OpticType
GetterType          = ''A_Getter
    opticTypeToTag OpticType
IsoType             = ''An_Iso
    opticTypeToTag OpticType
LensType            = ''A_Lens
    opticTypeToTag OpticType
TraversalType       = ''A_Traversal

    fieldName :: String
fieldName = case DefName
defName of
      TopName Name
fname      -> Name -> String
nameBase Name
fname
      MethodName Name
_ Name
fname -> Name -> String
nameBase Name
fname

    fun :: Name -> [DecQ]
    fun :: Name -> [Q Dec]
fun Name
n = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
n [Q Clause
funDef] Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: Name -> [Q Dec]
inlinePragma Name
n

    funDef :: ClauseQ
    funDef :: Q Clause
funDef = LensRules -> OpticType -> [(Name, Int, [Int])] -> Q Clause
makeFieldClause LensRules
rules (OpticStab -> OpticType
stabToOpticType OpticStab
defType) [(Name, Int, [Int])]
cons

-- | Normalized the Con type into a uniform positional representation,
-- eliminating the variance between records, infix constructors, and normal
-- constructors.
normalizeConstructor ::
  D.DatatypeInfo    ->
  D.ConstructorInfo ->
  Q (Name, [(Maybe Name, Type)]) -- ^ constructor name, field name, field type

normalizeConstructor :: DatatypeInfo -> ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
normalizeConstructor DatatypeInfo
info ConstructorInfo
con =
  (Name, [(Maybe Name, Type)]) -> Q (Name, [(Maybe Name, Type)])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstructorInfo -> Name
D.constructorName ConstructorInfo
con,
          (Maybe Name -> Type -> (Maybe Name, Type))
-> [Maybe Name] -> [Type] -> [(Maybe Name, Type)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe Name -> Type -> (Maybe Name, Type)
checkForExistentials [Maybe Name]
fieldNames (ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
con))
  where
    fieldNames :: [Maybe Name]
fieldNames =
      case ConstructorInfo -> ConstructorVariant
D.constructorVariant ConstructorInfo
con of
        D.RecordConstructor [Name]
xs -> (Name -> Maybe Name) -> [Name] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Maybe Name
forall a. a -> Maybe a
Just [Name]
xs
        ConstructorVariant
D.NormalConstructor    -> Maybe Name -> [Maybe Name]
forall a. a -> [a]
repeat Maybe Name
forall a. Maybe a
Nothing
        ConstructorVariant
D.InfixConstructor     -> Maybe Name -> [Maybe Name]
forall a. a -> [a]
repeat Maybe Name
forall a. Maybe a
Nothing

    -- Fields mentioning existentially quantified types are not
    -- elligible for TH generated optics.
    checkForExistentials :: Maybe Name -> Type -> (Maybe Name, Type)
checkForExistentials Maybe Name
_ Type
fieldtype
      | (TyVarBndr_ () -> Bool) -> [TyVarBndr_ ()] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TyVarBndr_ ()
tv -> TyVarBndr_ () -> Name
forall flag. TyVarBndr_ flag -> Name
D.tvName TyVarBndr_ ()
tv Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Name
used) [TyVarBndr_ ()]
unallowable
      = (Maybe Name
forall a. Maybe a
Nothing, DatatypeInfo -> Type -> Type
addKindInfo DatatypeInfo
info Type
fieldtype)
      where
        used :: Set Name
used        = Optic' A_Traversal NoIx Type Name -> Type -> Set Name
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf Optic' A_Traversal NoIx Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
fieldtype
        unallowable :: [TyVarBndr_ ()]
unallowable = ConstructorInfo -> [TyVarBndr_ ()]
D.constructorVars ConstructorInfo
con
    checkForExistentials Maybe Name
fieldname Type
fieldtype = (Maybe Name
fieldname, DatatypeInfo -> Type -> Type
addKindInfo DatatypeInfo
info Type
fieldtype)

-- | Compute the positional location of the fields involved in
-- each constructor for a given optic definition as well as the
-- type of clauses to generate and the type to annotate the declaration
-- with.
buildScaffold ::
  Bool                              {- ^ for class instance?              -} ->
  LensRules                                                                  ->
  Type                              {- ^ outer type                       -} ->
  [(Name, [([DefName], Type)])]     {- ^ normalized constructors          -} ->
  DefName                           {- ^ target definition                -} ->
  Q (OpticStab, [(Name, Int, [Int])])
              {- ^ optic type, definition type, field count, target fields -}
buildScaffold :: Bool
-> LensRules
-> Type
-> [(Name, [([DefName], Type)])]
-> DefName
-> Q (OpticStab, [(Name, Int, [Int])])
buildScaffold Bool
forClassInstance LensRules
rules Type
s [(Name, [([DefName], Type)])]
cons DefName
defName =

  do (Type
t,Type
a,Type
b, Bool
tvsCovered) <- Bool -> Type -> [Either Type Type] -> Q (Type, Type, Type, Bool)
buildTab Bool
forClassInstance Type
s ([Either Type Type] -> Q (Type, Type, Type, Bool))
-> [Either Type Type] -> Q (Type, Type, Type, Bool)
forall a b. (a -> b) -> a -> b
$
       ((Name, [Either Type Type]) -> [Either Type Type])
-> [(Name, [Either Type Type])] -> [Either Type Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, [Either Type Type]) -> [Either Type Type]
forall a b. (a, b) -> b
snd [(Name, [Either Type Type])]
consForDef

     let defType :: OpticStab
defType
           | Just ([TyVarBndr Specificity]
tyvars, [Type]
cx, Type
a') <- Optic' A_Prism NoIx Type ([TyVarBndr Specificity], [Type], Type)
-> Type -> Maybe ([TyVarBndr Specificity], [Type], Type)
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' A_Prism NoIx Type ([TyVarBndr Specificity], [Type], Type)
_ForallT Type
a =
               let optic :: OpticType
optic | Bool
lensCase   = OpticType
GetterType
                         | Bool
affineCase = OpticType
AffineFoldType
                         | Bool
otherwise  = OpticType
FoldType
               in [TyVarBndr Specificity]
-> [Type] -> OpticType -> Type -> Type -> OpticStab
OpticSa [TyVarBndr Specificity]
tyvars [Type]
cx OpticType
optic Type
s Type
a'

           -- Getter and Fold are always simple
           | Bool -> Bool
not (LensRules -> Bool
_allowUpdates LensRules
rules) =
               let optic :: OpticType
optic | Bool
lensCase   = OpticType
GetterType
                         | Bool
affineCase = OpticType
AffineFoldType
                         | Bool
otherwise  = OpticType
FoldType
               in [TyVarBndr Specificity]
-> [Type] -> OpticType -> Type -> Type -> OpticStab
OpticSa [] [] OpticType
optic Type
s Type
a

           -- Generate simple Lens and Traversal where possible
           | LensRules -> Bool
_simpleLenses LensRules
rules Bool -> Bool -> Bool
|| Type
s Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
t Bool -> Bool -> Bool
&& Type
a Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
b =
               let optic :: OpticType
optic | Bool
isoCase Bool -> Bool -> Bool
&& LensRules -> Bool
_allowIsos LensRules
rules = OpticType
IsoType
                         | Bool
lensCase                    = OpticType
LensType
                         | Bool
affineCase                  = OpticType
AffineTraversalType
                         | Bool
otherwise                   = OpticType
TraversalType
               in [TyVarBndr Specificity]
-> [Type] -> OpticType -> Type -> Type -> OpticStab
OpticSa [] [] OpticType
optic Type
s Type
a

           -- Generate type-changing Lens and Traversal otherwise
           | Bool
otherwise =
               let optic :: OpticType
optic | Bool
isoCase Bool -> Bool -> Bool
&& LensRules -> Bool
_allowIsos LensRules
rules = OpticType
IsoType
                         | Bool
lensCase                    = OpticType
LensType
                         | Bool
affineCase                  = OpticType
AffineTraversalType
                         | Bool
otherwise                   = OpticType
TraversalType
               in Bool -> OpticType -> Type -> Type -> Type -> Type -> OpticStab
OpticStab Bool
tvsCovered OpticType
optic Type
s Type
t Type
a Type
b

     (OpticStab, [(Name, Int, [Int])])
-> Q (OpticStab, [(Name, Int, [Int])])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (OpticStab
defType, [(Name, Int, [Int])]
scaffolds)
  where
    consForDef :: [(Name, [Either Type Type])]
    consForDef :: [(Name, [Either Type Type])]
consForDef = Optic
  A_Setter
  NoIx
  [(Name, [([DefName], Type)])]
  [(Name, [Either Type Type])]
  ([DefName], Type)
  (Either Type Type)
-> (([DefName], Type) -> Either Type Type)
-> [(Name, [([DefName], Type)])]
-> [(Name, [Either Type Type])]
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over (Setter
  [(Name, [([DefName], Type)])]
  [(Name, [Either Type Type])]
  (Name, [([DefName], Type)])
  (Name, [Either Type Type])
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped Setter
  [(Name, [([DefName], Type)])]
  [(Name, [Either Type Type])]
  (Name, [([DefName], Type)])
  (Name, [Either Type Type])
-> Optic
     A_Lens
     NoIx
     (Name, [([DefName], Type)])
     (Name, [Either Type Type])
     [([DefName], Type)]
     [Either Type Type]
-> Optic
     A_Setter
     NoIx
     [(Name, [([DefName], Type)])]
     [(Name, [Either Type Type])]
     [([DefName], Type)]
     [Either Type Type]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  (Name, [([DefName], Type)])
  (Name, [Either Type Type])
  [([DefName], Type)]
  [Either Type Type]
forall s t a b. Field2 s t a b => Lens s t a b
_2 Optic
  A_Setter
  NoIx
  [(Name, [([DefName], Type)])]
  [(Name, [Either Type Type])]
  [([DefName], Type)]
  [Either Type Type]
-> Optic
     A_Setter
     NoIx
     [([DefName], Type)]
     [Either Type Type]
     ([DefName], Type)
     (Either Type Type)
-> Optic
     A_Setter
     NoIx
     [(Name, [([DefName], Type)])]
     [(Name, [Either Type Type])]
     ([DefName], Type)
     (Either Type Type)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Setter
  NoIx
  [([DefName], Type)]
  [Either Type Type]
  ([DefName], Type)
  (Either Type Type)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) ([DefName], Type) -> Either Type Type
categorize [(Name, [([DefName], Type)])]
cons

    scaffolds :: [(Name, Int, [Int])]
    scaffolds :: [(Name, Int, [Int])]
scaffolds = [ (Name
n, [Either Type Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Type Type]
ts, [Either Type Type] -> [Int]
rightIndices [Either Type Type]
ts) | (Name
n,[Either Type Type]
ts) <- [(Name, [Either Type Type])]
consForDef ]

    rightIndices :: [Either Type Type] -> [Int]
    rightIndices :: [Either Type Type] -> [Int]
rightIndices = (Either Type Type -> Bool) -> [Either Type Type] -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
L.findIndices (Optic' A_Prism NoIx (Either Type Type) Type
-> Either Type Type -> Bool
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Bool
has Optic' A_Prism NoIx (Either Type Type) Type
forall a b c. Prism (Either a b) (Either a c) b c
_Right)

    -- Right: types for this definition
    -- Left : other types
    categorize :: ([DefName], Type) -> Either Type Type
    categorize :: ([DefName], Type) -> Either Type Type
categorize ([DefName]
defNames, Type
t)
      | DefName
defName DefName -> [DefName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DefName]
defNames = Type -> Either Type Type
forall a b. b -> Either a b
Right Type
t
      | Bool
otherwise               = Type -> Either Type Type
forall a b. a -> Either a b
Left  Type
t

    affectedFields :: [Int]
    affectedFields :: [Int]
affectedFields = Optic' A_Fold NoIx [(Name, Int, [Int])] Int
-> [(Name, Int, [Int])] -> [Int]
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> [a]
toListOf (Fold [(Name, Int, [Int])] (Name, Int, [Int])
forall (f :: * -> *) a. Foldable f => Fold (f a) a
folded Fold [(Name, Int, [Int])] (Name, Int, [Int])
-> Optic
     A_Lens NoIx (Name, Int, [Int]) (Name, Int, [Int]) [Int] [Int]
-> Optic
     A_Fold NoIx [(Name, Int, [Int])] [(Name, Int, [Int])] [Int] [Int]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx (Name, Int, [Int]) (Name, Int, [Int]) [Int] [Int]
forall s t a b. Field3 s t a b => Lens s t a b
_3 Optic
  A_Fold NoIx [(Name, Int, [Int])] [(Name, Int, [Int])] [Int] [Int]
-> Optic A_Getter NoIx [Int] [Int] Int Int
-> Optic' A_Fold NoIx [(Name, Int, [Int])] Int
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% ([Int] -> Int) -> Optic A_Getter NoIx [Int] [Int] Int Int
forall s a. (s -> a) -> Getter s a
to [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [(Name, Int, [Int])]
scaffolds

    lensCase :: Bool
    lensCase :: Bool
lensCase = (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) [Int]
affectedFields

    affineCase :: Bool
    affineCase :: Bool
affineCase = (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1) [Int]
affectedFields

    isoCase :: Bool
    isoCase :: Bool
isoCase = case [(Name, Int, [Int])]
scaffolds of
                [(Name
_,Int
1,[Int
0])] -> Bool
True
                [(Name, Int, [Int])]
_           -> Bool
False

data OpticType
  = AffineFoldType
  | AffineTraversalType
  | FoldType
  | GetterType
  | IsoType
  | LensType
  | TraversalType
  deriving Int -> OpticType -> String -> String
[OpticType] -> String -> String
OpticType -> String
(Int -> OpticType -> String -> String)
-> (OpticType -> String)
-> ([OpticType] -> String -> String)
-> Show OpticType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> OpticType -> String -> String
showsPrec :: Int -> OpticType -> String -> String
$cshow :: OpticType -> String
show :: OpticType -> String
$cshowList :: [OpticType] -> String -> String
showList :: [OpticType] -> String -> String
Show

opticTypeName :: Bool -> OpticType -> Name
opticTypeName :: Bool -> OpticType -> Name
opticTypeName Bool
typeChanging  OpticType
AffineTraversalType = if Bool
typeChanging
                                                  then ''AffineTraversal
                                                  else ''AffineTraversal'
opticTypeName Bool
_typeChanging OpticType
AffineFoldType      = ''AffineFold
opticTypeName Bool
_typeChanging OpticType
FoldType            = ''Fold
opticTypeName Bool
_typeChanging OpticType
GetterType          = ''Getter
opticTypeName Bool
typeChanging  OpticType
IsoType             = if Bool
typeChanging
                                                  then ''Iso
                                                  else ''Iso'
opticTypeName Bool
typeChanging  OpticType
LensType            = if Bool
typeChanging
                                                  then ''Lens
                                                  else ''Lens'
opticTypeName Bool
typeChanging  OpticType
TraversalType       = if Bool
typeChanging
                                                  then ''Traversal
                                                  else ''Traversal'

data OpticStab
  = OpticStab Bool              OpticType Type Type Type Type
  | OpticSa [TyVarBndrSpec] Cxt OpticType Type Type
  deriving Int -> OpticStab -> String -> String
[OpticStab] -> String -> String
OpticStab -> String
(Int -> OpticStab -> String -> String)
-> (OpticStab -> String)
-> ([OpticStab] -> String -> String)
-> Show OpticStab
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> OpticStab -> String -> String
showsPrec :: Int -> OpticStab -> String -> String
$cshow :: OpticStab -> String
show :: OpticStab -> String
$cshowList :: [OpticStab] -> String -> String
showList :: [OpticStab] -> String -> String
Show

stabToType :: OpticStab -> Type
stabToType :: OpticStab -> Type
stabToType (OpticStab Bool
_ OpticType
c Type
s Type
t Type
a Type
b) =
  [TyVarBndr Specificity] -> [Type] -> Type -> Type
quantifyType [] [] (Bool -> OpticType -> Name
opticTypeName Bool
True OpticType
c Name -> [Type] -> Type
`conAppsT` [Type
s,Type
t,Type
a,Type
b])
stabToType (OpticSa [TyVarBndr Specificity]
vs [Type]
cx OpticType
c Type
s Type
a) =
  [TyVarBndr Specificity] -> [Type] -> Type -> Type
quantifyType [TyVarBndr Specificity]
vs [Type]
cx (Bool -> OpticType -> Name
opticTypeName Bool
False OpticType
c Name -> [Type] -> Type
`conAppsT` [Type
s,Type
a])

stabToContext :: OpticStab -> Cxt
stabToContext :: OpticStab -> [Type]
stabToContext OpticStab{}          = []
stabToContext (OpticSa [TyVarBndr Specificity]
_ [Type]
cx OpticType
_ Type
_ Type
_) = [Type]
cx

stabToOpticType :: OpticStab -> OpticType
stabToOpticType :: OpticStab -> OpticType
stabToOpticType (OpticStab Bool
_ OpticType
c Type
_ Type
_ Type
_ Type
_) = OpticType
c
stabToOpticType (OpticSa [TyVarBndr Specificity]
_ [Type]
_ OpticType
c Type
_ Type
_) = OpticType
c

stabToOptic :: OpticStab -> Name
stabToOptic :: OpticStab -> Name
stabToOptic (OpticStab Bool
_ OpticType
c Type
_ Type
_ Type
_ Type
_) = Bool -> OpticType -> Name
opticTypeName Bool
True OpticType
c
stabToOptic (OpticSa [TyVarBndr Specificity]
_ [Type]
_ OpticType
c Type
_ Type
_) = Bool -> OpticType -> Name
opticTypeName Bool
False OpticType
c

stabToS :: OpticStab -> Type
stabToS :: OpticStab -> Type
stabToS (OpticStab Bool
_ OpticType
_ Type
s Type
_ Type
_ Type
_) = Type
s
stabToS (OpticSa [TyVarBndr Specificity]
_ [Type]
_ OpticType
_ Type
s Type
_) = Type
s

stabToA :: OpticStab -> Type
stabToA :: OpticStab -> Type
stabToA (OpticStab Bool
_ OpticType
_ Type
_ Type
_ Type
a Type
_) = Type
a
stabToA (OpticSa [TyVarBndr Specificity]
_ [Type]
_ OpticType
_ Type
_ Type
a) = Type
a

-- | Compute the t a b types given the outer type 's' and the
-- categorized field types. Left for fixed and Right for visited.
-- These types are "raw" and will be packaged into an 'OpticStab'
-- shortly after creation.
buildTab :: Bool -> Type -> [Either Type Type] -> Q (Type,Type,Type,Bool)
buildTab :: Bool -> Type -> [Either Type Type] -> Q (Type, Type, Type, Bool)
buildTab Bool
forClassInstance Type
s [Either Type Type]
categorizedFields = do
  -- Compute possible type changes and check whether we have to lift the
  -- coverage condition in case we're generating a class instance.
  (Set Name
unfixedTypeVars, Bool
tvsCovered) <- Q (Set Name, Bool)
mkUnfixedTypeVars
  Map Name Name
sub <- Map Name (Q Name) -> Q (Map Name Name)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
Map Name (f a) -> f (Map Name a)
T.sequenceA (Map Name (Q Name) -> Q (Map Name Name))
-> Map Name (Q Name) -> Q (Map Name Name)
forall a b. (a -> b) -> a -> b
$ (Name -> Q Name) -> Set Name -> Map Name (Q Name)
forall k a. (k -> a) -> Set k -> Map k a
M.fromSet (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> (Name -> String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) Set Name
unfixedTypeVars
  let (Type
t, Type
b) = Optic A_Traversal (WithIx Int) (Type, Type) (Type, Type) Type Type
-> (Type -> Type) -> (Type, Type) -> (Type, Type)
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic A_Traversal (WithIx Int) (Type, Type) (Type, Type) Type Type
forall i s t a b. Each i s t a b => IxTraversal i s t a b
each (Map Name Name -> Type -> Type
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub) (Type
s, Type
a)
  (Type, Type, Type, Bool) -> Q (Type, Type, Type, Bool)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
t, Type
a, Type
b, Bool
tvsCovered)
  where
    -- Just take the type of the first field and let GHC do the unification.
    a :: Type
a = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe
      (String -> Type
forall a. HasCallStack => String -> a
error String
"buildStab: unexpected empty list of fields")
      (Optic' An_AffineTraversal NoIx [Type] Type -> [Type] -> Maybe Type
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' An_AffineTraversal NoIx [Type] Type
forall s a. Cons s s a a => AffineTraversal' s a
_head [Type]
targetFields)

    phantomTypeVars :: Set Name
phantomTypeVars =
      let allTypeVars :: Optic
  A_Fold
  (Either () () : NoIx)
  [Either Type Type]
  [Either Type Type]
  Name
  Name
allTypeVars = Fold [Either Type Type] (Either Type Type)
forall (f :: * -> *) a. Foldable f => Fold (f a) a
folded Fold [Either Type Type] (Either Type Type)
-> Optic
     A_Lens
     (Either () () : NoIx)
     (Either Type Type)
     (Either Type Type)
     Type
     Type
-> Optic
     A_Fold
     (Either () () : NoIx)
     [Either Type Type]
     [Either Type Type]
     Type
     Type
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  (Either () () : NoIx)
  (Either Type Type)
  (Either Type Type)
  Type
  Type
forall a b. IxLens (Either () ()) (Either a a) (Either b b) a b
chosen Optic
  A_Fold
  (Either () () : NoIx)
  [Either Type Type]
  [Either Type Type]
  Type
  Type
-> Optic' A_Traversal NoIx Type Name
-> Optic
     A_Fold
     (Either () () : NoIx)
     [Either Type Type]
     [Either Type Type]
     Name
     Name
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic' A_Traversal NoIx Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars
      in Optic' A_Traversal NoIx Type Name -> Type -> Set Name
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf Optic' A_Traversal NoIx Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Optic
  A_Fold
  (Either () () : NoIx)
  [Either Type Type]
  [Either Type Type]
  Name
  Name
-> [Either Type Type] -> Set Name
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf Optic
  A_Fold
  (Either () () : NoIx)
  [Either Type Type]
  [Either Type Type]
  Name
  Name
allTypeVars [Either Type Type]
categorizedFields

    ([Type]
fixedFields, [Type]
targetFields) = [Either Type Type] -> ([Type], [Type])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Type Type]
categorizedFields

    mkUnfixedTypeVars :: Q (Set Name, Bool)
mkUnfixedTypeVars
      | Set Name -> Bool
forall a. Set a -> Bool
S.null Set Name
freeTypeVars =
        -- If there are no free type vars, don't bother searching for ambiguous
        -- type family applications because there are none.
        (Set Name, Bool) -> Q (Set Name, Bool)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set Name
forall a. Set a
S.empty, Bool
True)
      | Bool
forClassInstance = do
          Set Name
ambiguousTypeVars <- Q (Set Name)
getAmbiguousTypeFamilyTypeVars
          --runIO $ do
          --  putStrLn $ "S:         " ++ show s
          --  putStrLn $ "A:         " ++ show a
          --  putStrLn $ "FREE:      " ++ show freeTypeVars
          --  putStrLn $ "FIXED:     " ++ show fixedTypeVars
          --  putStrLn $ "PHANTOM:   " ++ show phantomTypeVars
          --  putStrLn $ "AMBIGUOUS: " ++ show ambiguousTypeVars
          (Set Name, Bool) -> Q (Set Name, Bool)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Set Name
freeTypeVars Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set Name
fixedTypeVars
               , Set Name -> Bool
forall a. Set a -> Bool
S.null Set Name
phantomTypeVars Bool -> Bool -> Bool
&& Set Name -> Bool
forall a. Set a -> Bool
S.null Set Name
ambiguousTypeVars
               )
      | Bool
otherwise = (Set Name, Bool) -> Q (Set Name, Bool)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set Name
freeTypeVars Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set Name
fixedTypeVars, Bool
True)
      where
        freeTypeVars :: Set Name
freeTypeVars  = Optic' A_Traversal NoIx Type Name -> Type -> Set Name
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf Optic' A_Traversal NoIx Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s
        fixedTypeVars :: Set Name
fixedTypeVars = Optic' A_Traversal NoIx [Type] Name -> [Type] -> Set Name
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf Optic' A_Traversal NoIx [Type] Name
forall t. HasTypeVars t => Traversal' t Name
typeVars [Type]
fixedFields

    getAmbiguousTypeFamilyTypeVars :: Q (Set Name)
getAmbiguousTypeFamilyTypeVars = do
      Type
a' <- Type -> Q Type
D.resolveTypeSynonyms Type
a
      StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
-> Set Name -> Q (Set Name)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
go Type
a') (Set Name -> Q (Set Name)) -> Set Name -> Q (Set Name)
forall a b. (a -> b) -> a -> b
$ Optic' A_Traversal NoIx Type Name -> Type -> Set Name
forall k a (is :: IxList) s.
(Is k A_Fold, Ord a) =>
Optic' k is s a -> s -> Set a
setOf Optic' A_Traversal NoIx Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
a'
      where
        go :: Type -> StateT (S.Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
        go :: Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
go (ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
ty)     = Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
go Type
ty
        go (ParensT Type
ty)         = Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
go Type
ty
        go (SigT Type
ty Type
kind)       = Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
go Type
ty StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a b.
StateT (Set Name) Q a
-> StateT (Set Name) Q b -> StateT (Set Name) Q b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
go Type
kind
        go (InfixT Type
ty1 Name
nm Type
ty2)  = Type -> Name -> Type -> StateT (Set Name) Q ()
procInfix Type
ty1 Name
nm Type
ty2 StateT (Set Name) Q ()
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a b.
StateT (Set Name) Q a
-> StateT (Set Name) Q b -> StateT (Set Name) Q b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe (Int, TypeFamilyHead, [Type])
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a. a -> StateT (Set Name) Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Int, TypeFamilyHead, [Type])
forall a. Maybe a
Nothing
        go (UInfixT Type
ty1 Name
nm Type
ty2) = Type -> Name -> Type -> StateT (Set Name) Q ()
procInfix Type
ty1 Name
nm Type
ty2 StateT (Set Name) Q ()
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a b.
StateT (Set Name) Q a
-> StateT (Set Name) Q b -> StateT (Set Name) Q b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe (Int, TypeFamilyHead, [Type])
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a. a -> StateT (Set Name) Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Int, TypeFamilyHead, [Type])
forall a. Maybe a
Nothing

        go (VarT Name
n) = (Set Name -> Set Name) -> StateT (Set Name) Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
S.delete Name
n) StateT (Set Name) Q ()
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a b.
StateT (Set Name) Q a
-> StateT (Set Name) Q b -> StateT (Set Name) Q b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe (Int, TypeFamilyHead, [Type])
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a. a -> StateT (Set Name) Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Int, TypeFamilyHead, [Type])
forall a. Maybe a
Nothing

        -- If a non-nullary type family is encountered, descend down and collect
        -- all of its arguments for processing.
        go (ConT Name
nm) = do
          let getVarLen :: AffineFold TypeFamilyHead (Int, TypeFamilyHead, [a])
getVarLen = (TypeFamilyHead -> Maybe (Int, TypeFamilyHead, [a]))
-> AffineFold TypeFamilyHead (Int, TypeFamilyHead, [a])
forall s a. (s -> Maybe a) -> AffineFold s a
afolding ((TypeFamilyHead -> Maybe (Int, TypeFamilyHead, [a]))
 -> AffineFold TypeFamilyHead (Int, TypeFamilyHead, [a]))
-> (TypeFamilyHead -> Maybe (Int, TypeFamilyHead, [a]))
-> AffineFold TypeFamilyHead (Int, TypeFamilyHead, [a])
forall a b. (a -> b) -> a -> b
$ \tf :: TypeFamilyHead
tf@(TypeFamilyHead Name
_ [TyVarBndr_ ()]
varBndrs FamilyResultSig
_ Maybe InjectivityAnn
_) ->
                if [TyVarBndr_ ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr_ ()]
varBndrs then Maybe (Int, TypeFamilyHead, [a])
forall a. Maybe a
Nothing else (Int, TypeFamilyHead, [a]) -> Maybe (Int, TypeFamilyHead, [a])
forall a. a -> Maybe a
Just ([TyVarBndr_ ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr_ ()]
varBndrs, TypeFamilyHead
tf, [])
          (Info -> Maybe (Int, TypeFamilyHead, [Type]))
-> Name
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a.
(Info -> Maybe a) -> Name -> StateT (Set Name) Q (Maybe a)
tryReify (Optic' An_AffineFold NoIx Info (Int, TypeFamilyHead, [Type])
-> Info -> Maybe (Int, TypeFamilyHead, [Type])
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Optic' An_AffineFold NoIx Info (Int, TypeFamilyHead, [Type])
 -> Info -> Maybe (Int, TypeFamilyHead, [Type]))
-> Optic' An_AffineFold NoIx Info (Int, TypeFamilyHead, [Type])
-> Info
-> Maybe (Int, TypeFamilyHead, [Type])
forall a b. (a -> b) -> a -> b
$ Prism' Info (Dec, [Dec])
_FamilyI Prism' Info (Dec, [Dec])
-> Optic A_Lens NoIx (Dec, [Dec]) (Dec, [Dec]) Dec Dec
-> Optic An_AffineTraversal NoIx Info Info Dec Dec
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx (Dec, [Dec]) (Dec, [Dec]) Dec Dec
forall s t a b. Field1 s t a b => Lens s t a b
_1 Optic An_AffineTraversal NoIx Info Info Dec Dec
-> Optic An_AffineFold NoIx Dec Dec TypeFamilyHead TypeFamilyHead
-> Optic An_AffineFold NoIx Info Info TypeFamilyHead TypeFamilyHead
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic An_AffineFold NoIx Dec Dec TypeFamilyHead TypeFamilyHead
typeFamilyHead Optic An_AffineFold NoIx Info Info TypeFamilyHead TypeFamilyHead
-> Optic
     An_AffineFold
     NoIx
     TypeFamilyHead
     TypeFamilyHead
     (Int, TypeFamilyHead, [Type])
     (Int, TypeFamilyHead, [Type])
-> Optic' An_AffineFold NoIx Info (Int, TypeFamilyHead, [Type])
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  An_AffineFold
  NoIx
  TypeFamilyHead
  TypeFamilyHead
  (Int, TypeFamilyHead, [Type])
  (Int, TypeFamilyHead, [Type])
forall {a}. AffineFold TypeFamilyHead (Int, TypeFamilyHead, [a])
getVarLen) Name
nm

        go (AppT Type
ty1 Type
ty2) = Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
go Type
ty1 StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
-> (Maybe (Int, TypeFamilyHead, [Type])
    -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type])))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a b.
StateT (Set Name) Q a
-> (a -> StateT (Set Name) Q b) -> StateT (Set Name) Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just (Int
n, TypeFamilyHead
tf, ![Type]
args)
            | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1     -> Maybe (Int, TypeFamilyHead, [Type])
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a. a -> StateT (Set Name) Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Int, TypeFamilyHead, [Type])
 -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type])))
-> Maybe (Int, TypeFamilyHead, [Type])
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a b. (a -> b) -> a -> b
$ (Int, TypeFamilyHead, [Type])
-> Maybe (Int, TypeFamilyHead, [Type])
forall a. a -> Maybe a
Just (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, TypeFamilyHead
tf, Type
ty2 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
args)
            | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1    -> TypeFamilyHead -> [Type] -> StateT (Set Name) Q ()
procTF TypeFamilyHead
tf ([Type] -> [Type]
forall a. [a] -> [a]
reverse ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ Type
ty2 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
args) StateT (Set Name) Q ()
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a b.
StateT (Set Name) Q a
-> StateT (Set Name) Q b -> StateT (Set Name) Q b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe (Int, TypeFamilyHead, [Type])
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a. a -> StateT (Set Name) Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Int, TypeFamilyHead, [Type])
forall a. Maybe a
Nothing
            | Bool
otherwise -> String -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a. HasCallStack => String -> a
error String
"go: unreachable"
          Maybe (Int, TypeFamilyHead, [Type])
Nothing -> Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
go Type
ty2

        go Type
_ = Maybe (Int, TypeFamilyHead, [Type])
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a. a -> StateT (Set Name) Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Int, TypeFamilyHead, [Type])
forall a. Maybe a
Nothing

        procInfix :: Type -> Name -> Type -> StateT (Set Name) Q ()
procInfix Type
ty1 Name
nm Type
ty2 = do
          Maybe TypeFamilyHead
mtf <- (Info -> Maybe TypeFamilyHead)
-> Name -> StateT (Set Name) Q (Maybe TypeFamilyHead)
forall a.
(Info -> Maybe a) -> Name -> StateT (Set Name) Q (Maybe a)
tryReify (Optic An_AffineFold NoIx Info Info TypeFamilyHead TypeFamilyHead
-> Info -> Maybe TypeFamilyHead
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Optic An_AffineFold NoIx Info Info TypeFamilyHead TypeFamilyHead
 -> Info -> Maybe TypeFamilyHead)
-> Optic An_AffineFold NoIx Info Info TypeFamilyHead TypeFamilyHead
-> Info
-> Maybe TypeFamilyHead
forall a b. (a -> b) -> a -> b
$ Prism' Info (Dec, [Dec])
_FamilyI Prism' Info (Dec, [Dec])
-> Optic A_Lens NoIx (Dec, [Dec]) (Dec, [Dec]) Dec Dec
-> Optic An_AffineTraversal NoIx Info Info Dec Dec
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx (Dec, [Dec]) (Dec, [Dec]) Dec Dec
forall s t a b. Field1 s t a b => Lens s t a b
_1 Optic An_AffineTraversal NoIx Info Info Dec Dec
-> Optic An_AffineFold NoIx Dec Dec TypeFamilyHead TypeFamilyHead
-> Optic An_AffineFold NoIx Info Info TypeFamilyHead TypeFamilyHead
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic An_AffineFold NoIx Dec Dec TypeFamilyHead TypeFamilyHead
typeFamilyHead) Name
nm
          case Maybe TypeFamilyHead
mtf of
            Just TypeFamilyHead
tf -> TypeFamilyHead -> [Type] -> StateT (Set Name) Q ()
procTF TypeFamilyHead
tf [Type
ty1, Type
ty2]
            Maybe TypeFamilyHead
Nothing -> Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
go Type
ty1 StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
forall a b.
StateT (Set Name) Q a
-> StateT (Set Name) Q b -> StateT (Set Name) Q b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
go Type
ty2 StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
-> StateT (Set Name) Q () -> StateT (Set Name) Q ()
forall a b.
StateT (Set Name) Q a
-> StateT (Set Name) Q b -> StateT (Set Name) Q b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> StateT (Set Name) Q ()
forall a. a -> StateT (Set Name) Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        -- If reification fails (e.g. because the type contains local names),
        -- assume there are no type families (the best we can do really).
        tryReify :: (Info -> Maybe a) -> Name -> StateT (S.Set Name) Q (Maybe a)
        tryReify :: forall a.
(Info -> Maybe a) -> Name -> StateT (Set Name) Q (Maybe a)
tryReify Info -> Maybe a
f Name
nm = Q (Maybe a) -> StateT (Set Name) Q (Maybe a)
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q (Maybe a) -> StateT (Set Name) Q (Maybe a))
-> Q (Maybe a) -> StateT (Set Name) Q (Maybe a)
forall a b. (a -> b) -> a -> b
$ Q (Maybe a) -> Q (Maybe a) -> Q (Maybe a)
forall a. Q a -> Q a -> Q a
recover (Maybe a -> Q (Maybe a)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing) (Info -> Maybe a
f (Info -> Maybe a) -> Q Info -> Q (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
nm)

        -- Once fully applied type family is collected, the only arguments that
        -- should be traversed further are these with injectivity annotation.
        procTF :: TypeFamilyHead -> [Type] -> StateT (S.Set Name) Q ()
        procTF :: TypeFamilyHead -> [Type] -> StateT (Set Name) Q ()
procTF TypeFamilyHead
tf [Type]
args = case TypeFamilyHead
tf of
          TypeFamilyHead Name
_ [TyVarBndr_ ()]
varBndrs FamilyResultSig
_ (Just (InjectivityAnn Name
_ [Name]
ins)) -> do
            let insSet :: Set Name
insSet = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList [Name]
ins
                vars :: [Name]
vars   = (TyVarBndr_ () -> Name) -> [TyVarBndr_ ()] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ () -> Name
forall flag. TyVarBndr_ flag -> Name
D.tvName [TyVarBndr_ ()]
varBndrs
            --lift . runIO $ do
            --  putStrLn $ "INS:  " ++ show ins
            --  putStrLn $ "VARS: " ++ show vars
            --  putStrLn $ "ARGS: " ++ show args
            [(Name, Type)]
-> ((Name, Type) -> StateT (Set Name) Q ())
-> StateT (Set Name) Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Name] -> [Type] -> [(Name, Type)]
forall {a} {b}. [a] -> [b] -> [(a, b)]
sameLenZip [Name]
vars [Type]
args) (((Name, Type) -> StateT (Set Name) Q ())
 -> StateT (Set Name) Q ())
-> ((Name, Type) -> StateT (Set Name) Q ())
-> StateT (Set Name) Q ()
forall a b. (a -> b) -> a -> b
$ \(Name
var, Type
arg) ->
              Bool -> StateT (Set Name) Q () -> StateT (Set Name) Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
var Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Name
insSet) (StateT (Set Name) Q () -> StateT (Set Name) Q ())
-> (StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
    -> StateT (Set Name) Q ())
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
-> StateT (Set Name) Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
-> StateT (Set Name) Q ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
 -> StateT (Set Name) Q ())
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
-> StateT (Set Name) Q ()
forall a b. (a -> b) -> a -> b
$ Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, [Type]))
go Type
arg
          TypeFamilyHead
_ -> () -> StateT (Set Name) Q ()
forall a. a -> StateT (Set Name) Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          where
            sameLenZip :: [a] -> [b] -> [(a, b)]
sameLenZip (a
x : [a]
xs) (b
y : [b]
ys) = (a
x, b
y) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [(a, b)]
sameLenZip [a]
xs [b]
ys
            sameLenZip []        []      = []
            sameLenZip [a]
_         [b]
_       = String -> [(a, b)]
forall a. HasCallStack => String -> a
error String
"sameLenZip: different lengths"


-- | Build the signature and definition for a single field optic.
-- In the case of a singleton constructor irrefutable matches are
-- used to enable the resulting lenses to be used on a bottom value.
makeFieldOptic ::
  LensRules ->
  (DefName, (OpticStab, [(Name, Int, [Int])])) ->
  HasFieldClasses [Dec]
makeFieldOptic :: LensRules
-> (DefName, (OpticStab, [(Name, Int, [Int])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules (DefName
defName, (OpticStab
defType, [(Name, Int, [Int])]
cons)) = do
  Set Name
locals <- StateT (Set Name) Q (Set Name)
forall s (m :: * -> *). MonadState s m => m s
get
  StateT (Set Name) Q ()
addName
  DecsQ -> StateT (Set Name) Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DecsQ -> StateT (Set Name) Q [Dec])
-> DecsQ -> StateT (Set Name) Q [Dec]
forall a b. (a -> b) -> a -> b
$ do [Q Dec]
cls <- Set Name -> Q [Q Dec]
mkCls Set Name
locals
            [Q Dec] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
T.sequenceA ([Q Dec]
cls [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ [Q Dec]
sig [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ [Q Dec]
def)
  where
  mkCls :: Set Name -> Q [Q Dec]
mkCls Set Name
locals = case DefName
defName of
                 MethodName Name
c Name
n | LensRules -> Bool
_generateClasses LensRules
rules ->
                  do Bool
classExists <- Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Name -> Bool) -> Q (Maybe Name) -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Maybe Name)
lookupTypeName (Name -> String
forall a. Show a => a -> String
show Name
c)
                     [Q Dec] -> Q [Q Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
classExists Bool -> Bool -> Bool
|| Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Name
c Set Name
locals then [] else [OpticStab -> Name -> Name -> Q Dec
makeFieldClass OpticStab
defType Name
c Name
n])
                 DefName
_ -> [Q Dec] -> Q [Q Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []

  addName :: StateT (Set Name) Q ()
addName = case DefName
defName of
            MethodName Name
c Name
_ -> Name -> StateT (Set Name) Q ()
addFieldClassName Name
c
            DefName
_              -> () -> StateT (Set Name) Q ()
forall a. a -> StateT (Set Name) Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  sig :: [Q Dec]
sig = case DefName
defName of
          DefName
_ | Bool -> Bool
not (LensRules -> Bool
_generateSigs LensRules
rules) -> []
          TopName Name
n -> [Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
n (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (OpticStab -> Type
stabToType OpticStab
defType))]
          MethodName{} -> []

  fun :: Name -> [Q Dec]
fun Name
n = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
n [Q Clause
funDef] Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: Name -> [Q Dec]
inlinePragma Name
n

  def :: [Q Dec]
def = case DefName
defName of
          TopName Name
n      -> Name -> [Q Dec]
fun Name
n
          MethodName Name
c Name
n -> [OpticStab -> Name -> [Q Dec] -> Q Dec
makeFieldInstance OpticStab
defType Name
c (Name -> [Q Dec]
fun Name
n)]

  funDef :: Q Clause
funDef = LensRules -> OpticType -> [(Name, Int, [Int])] -> Q Clause
makeFieldClause LensRules
rules (OpticStab -> OpticType
stabToOpticType OpticStab
defType) [(Name, Int, [Int])]
cons

------------------------------------------------------------------------
-- Classy class generator
------------------------------------------------------------------------


makeClassyDriver ::
  LensRules ->
  Name ->
  Name ->
  Type {- ^ Outer 's' type -} ->
  [(DefName, (OpticStab, [(Name, Int, [Int])]))] ->
  HasFieldClasses [Dec]
makeClassyDriver :: LensRules
-> Name
-> Name
-> Type
-> [(DefName, (OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q [Dec]
makeClassyDriver LensRules
rules Name
className Name
methodName Type
s [(DefName, (OpticStab, [(Name, Int, [Int])]))]
defs = [StateT (Set Name) Q Dec] -> StateT (Set Name) Q [Dec]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
T.sequenceA ([StateT (Set Name) Q Dec]
cls [StateT (Set Name) Q Dec]
-> [StateT (Set Name) Q Dec] -> [StateT (Set Name) Q Dec]
forall a. [a] -> [a] -> [a]
++ [StateT (Set Name) Q Dec]
inst)

  where
  cls :: [StateT (Set Name) Q Dec]
cls | LensRules -> Bool
_generateClasses LensRules
rules = [Q Dec -> StateT (Set Name) Q Dec
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Dec -> StateT (Set Name) Q Dec)
-> Q Dec -> StateT (Set Name) Q Dec
forall a b. (a -> b) -> a -> b
$ Name
-> Name
-> Type
-> [(DefName, (OpticStab, [(Name, Int, [Int])]))]
-> Q Dec
makeClassyClass Name
className Name
methodName Type
s [(DefName, (OpticStab, [(Name, Int, [Int])]))]
defs]
      | Bool
otherwise = []

  inst :: [StateT (Set Name) Q Dec]
inst = [LensRules
-> Name
-> Name
-> Type
-> [(DefName, (OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q Dec
makeClassyInstance LensRules
rules Name
className Name
methodName Type
s [(DefName, (OpticStab, [(Name, Int, [Int])]))]
defs]


makeClassyClass ::
  Name ->
  Name ->
  Type {- ^ Outer 's' type -} ->
  [(DefName, (OpticStab, [(Name, Int, [Int])]))] ->
  DecQ
makeClassyClass :: Name
-> Name
-> Type
-> [(DefName, (OpticStab, [(Name, Int, [Int])]))]
-> Q Dec
makeClassyClass Name
className Name
methodName Type
s [(DefName, (OpticStab, [(Name, Int, [Int])]))]
defs = do
  Name
c <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"c"
  let vars :: [Name]
vars = Optic' A_Traversal NoIx Type Name -> Type -> [Name]
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> [a]
toListOf Optic' A_Traversal NoIx Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s
      fd :: [FunDep]
fd   | [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
vars = []
           | Bool
otherwise = [[Name] -> [Name] -> FunDep
FunDep [Name
c] [Name]
vars]


  Q [Type] -> Name -> [TyVarBndr_ ()] -> [FunDep] -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> Name -> [TyVarBndr_ ()] -> [FunDep] -> [m Dec] -> m Dec
classD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt[]) Name
className ((Name -> TyVarBndr_ ()) -> [Name] -> [TyVarBndr_ ()]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr_ ()
plainTV (Name
cName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
vars)) [FunDep]
fd
    ([Q Dec] -> Q Dec) -> [Q Dec] -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
methodName (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (''Lens' Name -> [Type] -> Type
`conAppsT` [Name -> Type
VarT Name
c, Type
s]))
    Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: [[Q Dec]] -> [Q Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
defName (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)
        ,Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
defName) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
        ] [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++
        Name -> [Q Dec]
inlinePragma Name
defName
      | (TopName Name
defName, (OpticStab
stab, [(Name, Int, [Int])]
_)) <- [(DefName, (OpticStab, [(Name, Int, [Int])]))]
defs
      , let body :: Q Exp
body = Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
methodName) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(%)) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
defName)
      , let ty :: Type
ty   = Set Name -> [TyVarBndr Specificity] -> [Type] -> Type -> Type
quantifyType' ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList (Name
cName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
vars))
                                 []
                                 (OpticStab -> [Type]
stabToContext OpticStab
stab)
                 (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ OpticStab -> Name
stabToOptic OpticStab
stab Name -> [Type] -> Type
`conAppsT`
                       [Name -> Type
VarT Name
c, OpticStab -> Type
stabToA OpticStab
stab]
      ]


makeClassyInstance ::
  LensRules ->
  Name ->
  Name ->
  Type {- ^ Outer 's' type -} ->
  [(DefName, (OpticStab, [(Name, Int, [Int])]))] ->
  HasFieldClasses Dec
makeClassyInstance :: LensRules
-> Name
-> Name
-> Type
-> [(DefName, (OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q Dec
makeClassyInstance LensRules
rules Name
className Name
methodName Type
s [(DefName, (OpticStab, [(Name, Int, [Int])]))]
defs = do
  [[Dec]]
methodss <- ((DefName, (OpticStab, [(Name, Int, [Int])]))
 -> StateT (Set Name) Q [Dec])
-> [(DefName, (OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (LensRules
-> (DefName, (OpticStab, [(Name, Int, [Int])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules') [(DefName, (OpticStab, [(Name, Int, [Int])]))]
defs

  Q Dec -> StateT (Set Name) Q Dec
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Dec -> StateT (Set Name) Q Dec)
-> Q Dec -> StateT (Set Name) Q Dec
forall a b. (a -> b) -> a -> b
$ Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt[]) (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceHead)
           ([Q Dec] -> Q Dec) -> [Q Dec] -> Q Dec
forall a b. (a -> b) -> a -> b
$ Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
methodName) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'lensVL Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'id)) []
           Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
methodss)

  where
  instanceHead :: Type
instanceHead = Name
className Name -> [Type] -> Type
`conAppsT` (Type
s Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
vars)
  vars :: [Name]
vars         = Optic' A_Traversal NoIx Type Name -> Type -> [Name]
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> [a]
toListOf Optic' A_Traversal NoIx Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s
  rules' :: LensRules
rules'       = LensRules
rules { _generateSigs    = False
                       , _generateClasses = False
                       }

------------------------------------------------------------------------
-- Field class generation
------------------------------------------------------------------------

makeFieldClass :: OpticStab -> Name -> Name -> DecQ
makeFieldClass :: OpticStab -> Name -> Name -> Q Dec
makeFieldClass OpticStab
defType Name
className Name
methodName =
  Q [Type] -> Name -> [TyVarBndr_ ()] -> [FunDep] -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> Name -> [TyVarBndr_ ()] -> [FunDep] -> [m Dec] -> m Dec
classD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt []) Name
className [Name -> TyVarBndr_ ()
plainTV Name
s, Name -> TyVarBndr_ ()
plainTV Name
a] [[Name] -> [Name] -> FunDep
FunDep [Name
s] [Name
a]]
         [Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
methodName (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
methodType)]
  where
  methodType :: Type
methodType = Set Name -> [TyVarBndr Specificity] -> [Type] -> Type -> Type
quantifyType' ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList [Name
s,Name
a])
                             []
                             (OpticStab -> [Type]
stabToContext OpticStab
defType)
             (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ OpticStab -> Name
stabToOptic OpticStab
defType Name -> [Type] -> Type
`conAppsT` [Name -> Type
VarT Name
s,Name -> Type
VarT Name
a]
  s :: Name
s = String -> Name
mkName String
"s"
  a :: Name
a = String -> Name
mkName String
"a"

-- | Build an instance for a field. If the field’s type contains any type
-- families, will produce an equality constraint to avoid a type family
-- application in the instance head.
makeFieldInstance :: OpticStab -> Name -> [DecQ] -> DecQ
makeFieldInstance :: OpticStab -> Name -> [Q Dec] -> Q Dec
makeFieldInstance OpticStab
defType Name
className [Q Dec]
decs =
  Type -> Q Bool
containsTypeFamilies Type
a Q Bool -> (Bool -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Q Dec
pickInstanceDec
  where
  s :: Type
s = OpticStab -> Type
stabToS OpticStab
defType
  a :: Type
a = OpticStab -> Type
stabToA OpticStab
defType

  containsTypeFamilies :: Type -> Q Bool
containsTypeFamilies = Type -> Q Bool
go (Type -> Q Bool) -> (Type -> Q Type) -> Type -> Q Bool
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Type -> Q Type
D.resolveTypeSynonyms
    where
    go :: Type -> Q Bool
go (ConT Name
nm) = Optic An_AffineFold NoIx Info Info TypeFamilyHead TypeFamilyHead
-> Info -> Bool
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> Bool
has (Prism' Info (Dec, [Dec])
_FamilyI Prism' Info (Dec, [Dec])
-> Optic A_Lens NoIx (Dec, [Dec]) (Dec, [Dec]) Dec Dec
-> Optic An_AffineTraversal NoIx Info Info Dec Dec
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx (Dec, [Dec]) (Dec, [Dec]) Dec Dec
forall s t a b. Field1 s t a b => Lens s t a b
_1 Optic An_AffineTraversal NoIx Info Info Dec Dec
-> Optic An_AffineFold NoIx Dec Dec TypeFamilyHead TypeFamilyHead
-> Optic An_AffineFold NoIx Info Info TypeFamilyHead TypeFamilyHead
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic An_AffineFold NoIx Dec Dec TypeFamilyHead TypeFamilyHead
typeFamilyHead) (Info -> Bool) -> Q Info -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
nm
    go Type
ty = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> Q [Bool] -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Q Bool) -> [Type] -> Q [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> Q Bool
go (Traversal' Type Type -> Type -> [Type]
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> [a]
toListOf Traversal' Type Type
typeSelf Type
ty)

  pickInstanceDec :: Bool -> Q Dec
pickInstanceDec Bool
hasFamilies
    | Bool
hasFamilies = do
        Type
placeholder <- Name -> Type
VarT (Name -> Type) -> Q Name -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
        [Q Type] -> [Type] -> Q Dec
mkInstanceDec
          [Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Type
D.equalPred Type
placeholder Type
a)]
          [Type
s, Type
placeholder]
    | Bool
otherwise = [Q Type] -> [Type] -> Q Dec
mkInstanceDec [] [Type
s, Type
a]

  mkInstanceDec :: [Q Type] -> [Type] -> Q Dec
mkInstanceDec [Q Type]
context [Type]
headTys =
    Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt [Q Type]
context) (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
className Name -> [Type] -> Type
`conAppsT` [Type]
headTys)) [Q Dec]
decs

------------------------------------------------------------------------
-- Optic clause generators
------------------------------------------------------------------------

makeFieldClause :: LensRules -> OpticType -> [(Name, Int, [Int])] -> ClauseQ
makeFieldClause :: LensRules -> OpticType -> [(Name, Int, [Int])] -> Q Clause
makeFieldClause LensRules
rules OpticType
opticType [(Name, Int, [Int])]
cons =
  case OpticType
opticType of
    OpticType
AffineFoldType      -> [(Name, Int, [Int])] -> Q Clause
makeAffineFoldClause [(Name, Int, [Int])]
cons
    OpticType
AffineTraversalType -> [(Name, Int, [Int])] -> Bool -> Q Clause
makeAffineTraversalClause [(Name, Int, [Int])]
cons Bool
irref
    OpticType
FoldType            -> [(Name, Int, [Int])] -> Q Clause
makeFoldClause [(Name, Int, [Int])]
cons
    OpticType
IsoType             -> [(Name, Int, [Int])] -> Bool -> Q Clause
makeIsoClause [(Name, Int, [Int])]
cons Bool
irref
    OpticType
GetterType          -> [(Name, Int, [Int])] -> Q Clause
makeGetterClause [(Name, Int, [Int])]
cons
    OpticType
LensType            -> [(Name, Int, [Int])] -> Bool -> Q Clause
makeLensClause [(Name, Int, [Int])]
cons Bool
irref
    OpticType
TraversalType       -> [(Name, Int, [Int])] -> Bool -> Q Clause
makeTraversalClause [(Name, Int, [Int])]
cons Bool
irref
  where
    irref :: Bool
irref = LensRules -> Bool
_lazyPatterns LensRules
rules Bool -> Bool -> Bool
&& [(Name, Int, [Int])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Int, [Int])]
cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1

makeAffineFoldClause :: [(Name, Int, [Int])] -> ClauseQ
makeAffineFoldClause :: [(Name, Int, [Int])] -> Q Clause
makeAffineFoldClause [(Name, Int, [Int])]
cons = do
  Name
s <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"s"
  [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
    []
    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
      [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'afolding
      , [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
s] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
s)
        [ Name -> Int -> [Int] -> Q Match
makeAffineFoldMatch Name
conName Int
fieldCount [Int]
fields
        | (Name
conName, Int
fieldCount, [Int]
fields) <- [(Name, Int, [Int])]
cons
        ]
      ])
    []
  where
    makeAffineFoldMatch :: Name -> Int -> [Int] -> Q Match
makeAffineFoldMatch Name
conName Int
fieldCount [Int]
fields = do
      [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fields

      let args :: [Q Pat]
args = ((Int, Name) -> [Q Pat] -> [Q Pat])
-> [Q Pat] -> [(Int, Name)] -> [Q Pat]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int
i, Name
x) -> Optic An_AffineTraversal NoIx [Q Pat] [Q Pat] (Q Pat) (Q Pat)
-> Q Pat -> [Q Pat] -> [Q Pat]
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (Index [Q Pat]
-> Optic' (IxKind [Q Pat]) NoIx [Q Pat] (IxValue [Q Pat])
forall m. Ixed m => Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix Int
Index [Q Pat]
i) (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x))
                       (Int -> Q Pat -> [Q Pat]
forall a. Int -> a -> [a]
replicate Int
fieldCount Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP)
                       ([Int] -> [Name] -> [(Int, Name)]
forall {a} {b}. [a] -> [b] -> [(a, b)]
zip [Int]
fields [Name]
xs)

          body :: Q Exp
body = case [Name]
xs of
            -- Con _ .. _ -> Nothing
            []  -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Nothing
            -- Con _ .. x_i .. _ -> Just x_i
            [Name
x] -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Just Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x
            [Name]
_   -> String -> Q Exp
forall a. HasCallStack => String -> a
error String
"AffineFold focuses on at most one field"

      Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName [Q Pat]
args)
            (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body)
            []

makeFoldClause :: [(Name, Int, [Int])] -> ClauseQ
makeFoldClause :: [(Name, Int, [Int])] -> Q Clause
makeFoldClause [(Name, Int, [Int])]
cons = do
  Name
f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
  Name
s <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"s"
  [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
    []
    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
      [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'foldVL
      , [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
s] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
s)
        [ Name -> Name -> Int -> [Int] -> Q Match
makeFoldMatch Name
f Name
conName Int
fieldCount [Int]
fields
        | (Name
conName, Int
fieldCount, [Int]
fields) <- [(Name, Int, [Int])]
cons
        ]
      ])
    []
  where
    makeFoldMatch :: Name -> Name -> Int -> [Int] -> Q Match
makeFoldMatch Name
f Name
conName Int
fieldCount [Int]
fields = do
      [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fields

      let args :: [Q Pat]
args = ((Int, Name) -> [Q Pat] -> [Q Pat])
-> [Q Pat] -> [(Int, Name)] -> [Q Pat]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int
i, Name
x) -> Optic An_AffineTraversal NoIx [Q Pat] [Q Pat] (Q Pat) (Q Pat)
-> Q Pat -> [Q Pat] -> [Q Pat]
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (Index [Q Pat]
-> Optic' (IxKind [Q Pat]) NoIx [Q Pat] (IxValue [Q Pat])
forall m. Ixed m => Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix Int
Index [Q Pat]
i) (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x))
                       (Int -> Q Pat -> [Q Pat]
forall a. Int -> a -> [a]
replicate Int
fieldCount Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP)
                       ([Int] -> [Name] -> [(Int, Name)]
forall {a} {b}. [a] -> [b] -> [(a, b)]
zip [Int]
fields [Name]
xs)

          fxs :: [Q Exp]
fxs = case [Name]
xs of
            [] -> [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'pure Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE '()]
            [Name]
_  -> (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
x -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) [Name]
xs

          -- Con _ .. x_1 .. _ .. x_k .. _ -> f x_1 *> .. f x_k
          body :: Q Exp
body = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
            [ (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Q Exp
fx -> Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
fx (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(*>))) [Q Exp]
fxs
            ]

      Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName [Q Pat]
args)
            (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body)
            []

-- | Build a getter clause that retrieves the field at the given index.
makeGetterClause :: [(Name, Int, [Int])] -> ClauseQ
makeGetterClause :: [(Name, Int, [Int])] -> Q Clause
makeGetterClause [(Name, Int, [Int])]
cons = do
  Name
s <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"s"
  [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
    []
    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
      [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'to
      , [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
s] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
s)
        [ Name -> Int -> [Int] -> Q Match
forall {m :: * -> *}. Quote m => Name -> Int -> [Int] -> m Match
makeGetterMatch Name
conName Int
fieldCount [Int]
fields
        | (Name
conName, Int
fieldCount, [Int]
fields) <- [(Name, Int, [Int])]
cons
        ]
      ])
    []
  where
    makeGetterMatch :: Name -> Int -> [Int] -> m Match
makeGetterMatch Name
conName Int
fieldCount = \case
      [Int
field] -> do
        Name
x <- String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
        -- Con _ .. x_i .. _ -> x_i
        m Pat -> m Body -> [m Dec] -> m Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [m Pat] -> m Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ([m Pat] -> m Pat) -> ([m Pat] -> [m Pat]) -> [m Pat] -> m Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic An_AffineTraversal NoIx [m Pat] [m Pat] (m Pat) (m Pat)
-> m Pat -> [m Pat] -> [m Pat]
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (Index [m Pat]
-> Optic' (IxKind [m Pat]) NoIx [m Pat] (IxValue [m Pat])
forall m. Ixed m => Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix Int
Index [m Pat]
field) (Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x) ([m Pat] -> m Pat) -> [m Pat] -> m Pat
forall a b. (a -> b) -> a -> b
$ Int -> m Pat -> [m Pat]
forall a. Int -> a -> [a]
replicate Int
fieldCount m Pat
forall (m :: * -> *). Quote m => m Pat
wildP)
              (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (m Exp -> m Body) -> m Exp -> m Body
forall a b. (a -> b) -> a -> b
$ Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)
              []
      [Int]
_       -> String -> m Match
forall a. HasCallStack => String -> a
error String
"Getter focuses on exactly one field"

-- | Build a clause that constructs an Iso.
makeIsoClause :: [(Name, Int, [Int])] -> Bool -> ClauseQ
makeIsoClause :: [(Name, Int, [Int])] -> Bool -> Q Clause
makeIsoClause [(Name, Int, [Int])]
fields Bool
irref = case [(Name, Int, [Int])]
fields of
  [(Name
conName, Int
1, [Int
0])] -> do
    Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
    [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
           (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
             [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'iso
             , [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat -> Q Pat
irrefP (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]] (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)
             , Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName
             ])
           []
  [(Name, Int, [Int])]
_ -> String -> Q Clause
forall a. HasCallStack => String -> a
error String
"Iso works only for types with one constructor and one field"
  where
    irrefP :: Q Pat -> Q Pat
irrefP = if Bool
irref then Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
tildeP else Q Pat -> Q Pat
forall a. a -> a
id

-- | Build a lens clause that updates the field at the given index. When irref
-- is 'True' the value with be matched with an irrefutable pattern.
makeLensClause :: [(Name, Int, [Int])] -> Bool -> ClauseQ
makeLensClause :: [(Name, Int, [Int])] -> Bool -> Q Clause
makeLensClause [(Name, Int, [Int])]
cons Bool
irref = do
  Name
f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
  Name
s <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"s"
  [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
    []
    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
      [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'lensVL
      , [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
s] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
s)
        [ (Q Pat -> Q Pat) -> Name -> Name -> Int -> [Int] -> Q Match
makeLensMatch Q Pat -> Q Pat
irrefP Name
f Name
conName Int
fieldCount [Int]
fields
        | (Name
conName, Int
fieldCount, [Int]
fields) <- [(Name, Int, [Int])]
cons
        ]
      ])
    []
  where
    irrefP :: Q Pat -> Q Pat
irrefP = if Bool
irref then Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
tildeP else Q Pat -> Q Pat
forall a. a -> a
id

-- | Make a lens match. Used for both lens and affine traversal generation.
makeLensMatch :: (PatQ -> PatQ) -> Name -> Name -> Int -> [Int] -> Q Match
makeLensMatch :: (Q Pat -> Q Pat) -> Name -> Name -> Int -> [Int] -> Q Match
makeLensMatch Q Pat -> Q Pat
irrefP Name
f Name
conName Int
fieldCount = \case
  [Int
field] -> do
    [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fieldCount
    Name
y  <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"y"

    let body :: Q Exp
body = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
          [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'fmap
          , [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y] (Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$
            Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Optic An_AffineTraversal NoIx [Name] [Name] Name Name
-> Name -> [Name] -> [Name]
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (Index [Name] -> Optic' (IxKind [Name]) NoIx [Name] (IxValue [Name])
forall m. Ixed m => Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix Int
Index [Name]
field) Name
y [Name]
xs)
          , Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) (Q Exp -> Q Exp) -> (Name -> Q Exp) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Name]
xs [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
field
          ]

    -- Con x_1 .. x_n -> fmap (\y_i -> Con x_1 .. y_i .. x_n) (f x_i)
    Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Q Pat -> Q Pat
irrefP (Q Pat -> Q Pat) -> ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs)
          (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body)
          []
  [Int]
_       -> String -> Q Match
forall a. HasCallStack => String -> a
error String
"Lens focuses on exactly one field"

makeAffineTraversalClause :: [(Name, Int, [Int])] -> Bool -> ClauseQ
makeAffineTraversalClause :: [(Name, Int, [Int])] -> Bool -> Q Clause
makeAffineTraversalClause [(Name, Int, [Int])]
cons Bool
irref = do
  Name
point <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"point"
  Name
f     <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
  Name
s     <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"s"
  [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
    []
    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
      [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'atraversalVL
      , [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
point, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
s] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
s)
        [ Name -> Name -> Name -> Int -> [Int] -> Q Match
makeAffineTraversalMatch Name
point Name
f Name
conName Int
fieldCount [Int]
fields
        | (Name
conName, Int
fieldCount, [Int]
fields) <- [(Name, Int, [Int])]
cons
        ]
      ])
    []
  where
    irrefP :: Q Pat -> Q Pat
irrefP = if Bool
irref then Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
tildeP else Q Pat -> Q Pat
forall a. a -> a
id

    makeAffineTraversalMatch :: Name -> Name -> Name -> Int -> [Int] -> Q Match
makeAffineTraversalMatch Name
point Name
f Name
conName Int
fieldCount = \case
      [] -> do
        [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fieldCount
        -- Con x_1 ... x_n -> point (Con x_1 .. x_n)
        Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Q Pat -> Q Pat
irrefP (Q Pat -> Q Pat) -> ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs)
              (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
point Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
xs))
              []
      [Int
field] -> (Q Pat -> Q Pat) -> Name -> Name -> Int -> [Int] -> Q Match
makeLensMatch Q Pat -> Q Pat
irrefP Name
f Name
conName Int
fieldCount [Int
field]
      [Int]
_ -> String -> Q Match
forall a. HasCallStack => String -> a
error String
"Affine traversal focuses on at most one field"

makeTraversalClause :: [(Name, Int, [Int])] -> Bool -> ClauseQ
makeTraversalClause :: [(Name, Int, [Int])] -> Bool -> Q Clause
makeTraversalClause [(Name, Int, [Int])]
cons Bool
irref = do
  Name
f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
  Name
s <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"s"
  [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
    []
    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
      [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'traversalVL
      , [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
s] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
s)
        [ Name -> Name -> Int -> [Int] -> Q Match
makeTraversalMatch Name
f Name
conName Int
fieldCount [Int]
fields
        | (Name
conName, Int
fieldCount, [Int]
fields) <- [(Name, Int, [Int])]
cons
        ]
      ])
    []
  where
    irrefP :: Q Pat -> Q Pat
irrefP = if Bool
irref then Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
tildeP else Q Pat -> Q Pat
forall a. a -> a
id

    makeTraversalMatch :: Name -> Name -> Int -> [Int] -> Q Match
makeTraversalMatch Name
f Name
conName Int
fieldCount [Int]
fields = do
      [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fieldCount
      case [Int]
fields of
        [] -> -- Con x_1 .. x_n -> pure (Con x_1 .. x_n)
          Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Q Pat -> Q Pat
irrefP (Q Pat -> Q Pat) -> ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs)
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'pure Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
xs))
                []
        [Int]
_ -> do
          [Name]
ys <- String -> Int -> Q [Name]
newNames String
"y" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fields

          let xs' :: [Name]
xs' = ((Int, Name) -> [Name] -> [Name])
-> [Name] -> [(Int, Name)] -> [Name]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int
i, Name
x) -> Optic An_AffineTraversal NoIx [Name] [Name] Name Name
-> Name -> [Name] -> [Name]
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (Index [Name] -> Optic' (IxKind [Name]) NoIx [Name] (IxValue [Name])
forall m. Ixed m => Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix Int
Index [Name]
i) Name
x) [Name]
xs ([Int] -> [Name] -> [(Int, Name)]
forall {a} {b}. [a] -> [b] -> [(a, b)]
zip [Int]
fields [Name]
ys)

              mkFx :: Int -> Q Exp
mkFx Int
i = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ([Name]
xs [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
i)

              body0 :: Q Exp
body0 = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
                [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'pure
                , [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
ys) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
xs'
                ]

              body :: Q Exp
body = (Q Exp -> Int -> Q Exp) -> Q Exp -> [Int] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
acc Int
i -> Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
acc (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(<*>)) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Int -> Q Exp
mkFx Int
i)
                           Q Exp
body0
                           [Int]
fields

          -- Con x_1 .. x_n ->
          --  pure (\y_1 .. y_k -> Con x_1 .. y_1 .. x_l .. y_k .. x_n)
          --    <*> f x_i_y_1 <*> .. <*> f x_i_y_k
          Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Q Pat -> Q Pat
irrefP (Q Pat -> Q Pat) -> ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs)
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body)
                []

------------------------------------------------------------------------
-- Field generation parameters
------------------------------------------------------------------------

-- | Rules to construct lenses for data fields.
data LensRules = LensRules
  { LensRules -> Bool
_simpleLenses    :: Bool
  , LensRules -> Bool
_generateSigs    :: Bool
  , LensRules -> Bool
_generateClasses :: Bool
  , LensRules -> Bool
_allowIsos       :: Bool
  , LensRules -> Bool
_allowUpdates    :: Bool -- ^ Allow Lens/Traversal (otherwise Getter/Fold)
  , LensRules -> Bool
_lazyPatterns    :: Bool
  , LensRules -> FieldNamer
_fieldToDef      :: FieldNamer
       -- ^ Type Name -> Field Names -> Target Field Name -> Definition Names
  , LensRules -> ClassyNamer
_classyLenses    :: ClassyNamer
       -- type name to class name and top method
  }

-- | The rule to create function names of lenses for data fields.
--
-- Although it's sometimes useful, you won't need the first two
-- arguments most of the time.
type FieldNamer = Name -- ^ Name of the data type that lenses are being generated for.
                  -> [Name] -- ^ Names of all fields (including the field being named) in the data type.
                  -> Name -- ^ Name of the field being named.
                  -> [DefName] -- ^ Name(s) of the lens functions. If empty, no lens is created for that field.

-- | Name to give to generated field optics.
data DefName
  = TopName Name -- ^ Simple top-level definition name
  | MethodName Name Name -- ^ makeFields-style class name and method name
  deriving (Int -> DefName -> String -> String
[DefName] -> String -> String
DefName -> String
(Int -> DefName -> String -> String)
-> (DefName -> String)
-> ([DefName] -> String -> String)
-> Show DefName
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DefName -> String -> String
showsPrec :: Int -> DefName -> String -> String
$cshow :: DefName -> String
show :: DefName -> String
$cshowList :: [DefName] -> String -> String
showList :: [DefName] -> String -> String
Show, DefName -> DefName -> Bool
(DefName -> DefName -> Bool)
-> (DefName -> DefName -> Bool) -> Eq DefName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DefName -> DefName -> Bool
== :: DefName -> DefName -> Bool
$c/= :: DefName -> DefName -> Bool
/= :: DefName -> DefName -> Bool
Eq, Eq DefName
Eq DefName =>
(DefName -> DefName -> Ordering)
-> (DefName -> DefName -> Bool)
-> (DefName -> DefName -> Bool)
-> (DefName -> DefName -> Bool)
-> (DefName -> DefName -> Bool)
-> (DefName -> DefName -> DefName)
-> (DefName -> DefName -> DefName)
-> Ord DefName
DefName -> DefName -> Bool
DefName -> DefName -> Ordering
DefName -> DefName -> DefName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DefName -> DefName -> Ordering
compare :: DefName -> DefName -> Ordering
$c< :: DefName -> DefName -> Bool
< :: DefName -> DefName -> Bool
$c<= :: DefName -> DefName -> Bool
<= :: DefName -> DefName -> Bool
$c> :: DefName -> DefName -> Bool
> :: DefName -> DefName -> Bool
$c>= :: DefName -> DefName -> Bool
>= :: DefName -> DefName -> Bool
$cmax :: DefName -> DefName -> DefName
max :: DefName -> DefName -> DefName
$cmin :: DefName -> DefName -> DefName
min :: DefName -> DefName -> DefName
Ord)

_MethodName :: Prism' DefName (Name, Name)
_MethodName :: Optic A_Prism NoIx DefName DefName (Name, Name) (Name, Name)
_MethodName = ((Name, Name) -> DefName)
-> (DefName -> Maybe (Name, Name))
-> Optic A_Prism NoIx DefName DefName (Name, Name) (Name, Name)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' ((Name -> Name -> DefName) -> (Name, Name) -> DefName
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Name -> DefName
MethodName) ((DefName -> Maybe (Name, Name))
 -> Optic A_Prism NoIx DefName DefName (Name, Name) (Name, Name))
-> (DefName -> Maybe (Name, Name))
-> Optic A_Prism NoIx DefName DefName (Name, Name) (Name, Name)
forall a b. (a -> b) -> a -> b
$ \case
  TopName{}      -> Maybe (Name, Name)
forall a. Maybe a
Nothing
  MethodName Name
c Name
n -> (Name, Name) -> Maybe (Name, Name)
forall a. a -> Maybe a
Just (Name
c, Name
n)

-- | The optional rule to create a class and method around a
-- monomorphic data type. If this naming convention is provided, it
-- generates a "classy" lens.
type ClassyNamer = Name -- ^ Name of the data type that lenses are being generated for.
                   -> Maybe (Name, Name) -- ^ Names of the class and the main method it generates, respectively.

-- | Tracks the field class 'Name's that have been created so far. We consult
-- these so that we may avoid creating duplicate classes.

-- See #643 for more information.
type HasFieldClasses = StateT (S.Set Name) Q

addFieldClassName :: Name -> HasFieldClasses ()
addFieldClassName :: Name -> StateT (Set Name) Q ()
addFieldClassName Name
n = (Set Name -> Set Name) -> StateT (Set Name) Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Set Name -> Set Name) -> StateT (Set Name) Q ())
-> (Set Name -> Set Name) -> StateT (Set Name) Q ()
forall a b. (a -> b) -> a -> b
$ Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
S.insert Name
n

------------------------------------------------------------------------
-- Miscellaneous utility functions
------------------------------------------------------------------------

-- We want to catch type families, but not *data* families. See #799.
typeFamilyHead :: AffineFold Dec TypeFamilyHead
typeFamilyHead :: Optic An_AffineFold NoIx Dec Dec TypeFamilyHead TypeFamilyHead
typeFamilyHead = Prism' Dec TypeFamilyHead
_OpenTypeFamilyD Prism' Dec TypeFamilyHead
-> Optic' An_AffineTraversal NoIx Dec TypeFamilyHead
-> Optic An_AffineFold NoIx Dec Dec TypeFamilyHead TypeFamilyHead
forall k l (is :: IxList) s a (js :: IxList).
(Is k An_AffineFold, Is l An_AffineFold) =>
Optic' k is s a -> Optic' l js s a -> AffineFold s a
`afailing` Prism' Dec (TypeFamilyHead, [TySynEqn])
_ClosedTypeFamilyD Prism' Dec (TypeFamilyHead, [TySynEqn])
-> Optic
     A_Lens
     NoIx
     (TypeFamilyHead, [TySynEqn])
     (TypeFamilyHead, [TySynEqn])
     TypeFamilyHead
     TypeFamilyHead
-> Optic' An_AffineTraversal NoIx Dec TypeFamilyHead
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  (TypeFamilyHead, [TySynEqn])
  (TypeFamilyHead, [TySynEqn])
  TypeFamilyHead
  TypeFamilyHead
forall s t a b. Field1 s t a b => Lens s t a b
_1