{-# 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 tyVarBndrs ctx ty ->
#if MIN_VERSION_template_haskell(2,17,0)
    let go (KindedTV nam flag kind) = KindedTV <$> pure nam <*> pure flag <*> f kind
        go (PlainTV nam flag)       = pure (PlainTV nam flag)
#else
    let go :: TyVarBndr -> f TyVarBndr
go (KindedTV Name
nam Type
kind) = Name -> Type -> TyVarBndr
KindedTV (Name -> Type -> TyVarBndr) -> f Name -> f (Type -> TyVarBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
nam f (Type -> TyVarBndr) -> f Type -> f TyVarBndr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> f Type
f Type
kind
        go (PlainTV Name
nam)       = TyVarBndr -> f TyVarBndr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> TyVarBndr
PlainTV Name
nam)
#endif
    in [TyVarBndr] -> Cxt -> Type -> Type
ForallT ([TyVarBndr] -> Cxt -> Type -> Type)
-> f [TyVarBndr] -> f (Cxt -> Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr -> f TyVarBndr) -> [TyVarBndr] -> f [TyVarBndr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TyVarBndr -> f TyVarBndr
go [TyVarBndr]
tyVarBndrs f (Cxt -> Type -> Type) -> f Cxt -> f (Type -> Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> f Type) -> Cxt -> f Cxt
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> f Type
f Cxt
ctx f (Type -> Type) -> f Type -> f Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> f Type
f Type
ty
  AppT ty1 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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> f Type
f Type
ty2
  SigT ty 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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> f Type
f Type
kind
  InfixT ty1 nam 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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> f Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
nam f (Type -> Type) -> f Type -> f Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> f Type
f Type
ty2
  UInfixT ty1 nam 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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> f Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
nam f (Type -> Type) -> f Type -> f Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> f Type
f Type
ty2
  ParensT 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 (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 (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 (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)
traverse (DatatypeInfo -> ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
normalizeConstructor DatatypeInfo
info) [ConstructorInfo]
cons
       let allFields :: [Name]
allFields  = Optic' A_Fold '[] [(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
     '[]
     (Name, [(Maybe Name, Type)])
     (Name, [(Maybe Name, Type)])
     [(Maybe Name, Type)]
     [(Maybe Name, Type)]
-> Optic
     A_Fold
     '[]
     [(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
  '[]
  (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
  '[]
  [(Name, [(Maybe Name, Type)])]
  [(Name, [(Maybe Name, Type)])]
  [(Maybe Name, Type)]
  [(Maybe Name, Type)]
-> Optic
     A_Fold
     '[]
     [(Maybe Name, Type)]
     [(Maybe Name, Type)]
     (Maybe Name, Type)
     (Maybe Name, Type)
-> Optic
     A_Fold
     '[]
     [(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
  '[]
  [(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
  '[]
  [(Name, [(Maybe Name, Type)])]
  [(Name, [(Maybe Name, Type)])]
  (Maybe Name, Type)
  (Maybe Name, Type)
-> Optic
     A_Lens
     '[]
     (Maybe Name, Type)
     (Maybe Name, Type)
     (Maybe Name)
     (Maybe Name)
-> Optic
     A_Fold
     '[]
     [(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
  '[]
  (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
  '[]
  [(Name, [(Maybe Name, Type)])]
  [(Name, [(Maybe Name, Type)])]
  (Maybe Name)
  (Maybe Name)
-> Optic A_Fold '[] (Maybe Name) (Maybe Name) Name Name
-> Optic' A_Fold '[] [(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 '[] (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
  '[]
  [(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
  '[]
  [(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 '[] [(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 '[] [DefName] [DefName] DefName DefName
-> Optic' A_Fold '[] [(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 '[] [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)
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
  '[]
  [(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
     '[]
     (DefName, (OpticStab, [(Name, Int, [Int])]))
     (DefName, (OpticStab, [(Name, Int, [Int])]))
     DefName
     DefName
-> Optic
     A_Traversal
     '[]
     [(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
  '[]
  (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
  '[]
  [(DefName, (OpticStab, [(Name, Int, [Int])]))]
  [(DefName, (OpticStab, [(Name, Int, [Int])]))]
  DefName
  DefName
-> Optic A_Prism '[] DefName DefName (Name, Name) (Name, Name)
-> Optic'
     A_Traversal
     '[]
     [(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 '[] 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 (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)
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 (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 :: 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
     '[]
     (Name, [(a, Type)])
     (Name, [(b, Type)])
     [(a, Type)]
     [(b, Type)]
-> Optic
     A_Traversal
     '[]
     [(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
  '[]
  (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
  '[]
  [(Name, [(a, Type)])]
  [(Name, [(b, Type)])]
  [(a, Type)]
  [(b, Type)]
-> Optic
     A_Traversal '[] [(a, Type)] [(b, Type)] (a, Type) (b, Type)
-> Optic
     A_Traversal
     '[]
     [(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 '[] [(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
  '[]
  [(Name, [(a, Type)])]
  [(Name, [(b, Type)])]
  (a, Type)
  (b, Type)
-> Optic A_Lens '[] (a, Type) (b, Type) a b
-> Traversal [(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 '[] (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 '[] 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 '[] 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 :: [a] -> [a] -> Maybe [a]
stripSuffix [a]
suffix = ([a] -> [a]) -> Maybe [a] -> Maybe [a]
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 '[] 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 '[] 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 '[] Name Name String String
nameString = (Name -> String)
-> (Name -> String -> Name)
-> Optic A_Lens '[] 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)
traverse (DatatypeInfo -> ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
normalizeConstructor DatatypeInfo
info) [ConstructorInfo]
cons
    let allFields :: [Name]
allFields  = Optic' A_Fold '[] [(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
     '[]
     (Name, [(Maybe Name, Type)])
     (Name, [(Maybe Name, Type)])
     [(Maybe Name, Type)]
     [(Maybe Name, Type)]
-> Optic
     A_Fold
     '[]
     [(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
  '[]
  (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
  '[]
  [(Name, [(Maybe Name, Type)])]
  [(Name, [(Maybe Name, Type)])]
  [(Maybe Name, Type)]
  [(Maybe Name, Type)]
-> Optic
     A_Fold
     '[]
     [(Maybe Name, Type)]
     [(Maybe Name, Type)]
     (Maybe Name, Type)
     (Maybe Name, Type)
-> Optic
     A_Fold
     '[]
     [(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
  '[]
  [(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
  '[]
  [(Name, [(Maybe Name, Type)])]
  [(Name, [(Maybe Name, Type)])]
  (Maybe Name, Type)
  (Maybe Name, Type)
-> Optic
     A_Lens
     '[]
     (Maybe Name, Type)
     (Maybe Name, Type)
     (Maybe Name)
     (Maybe Name)
-> Optic
     A_Fold
     '[]
     [(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
  '[]
  (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
  '[]
  [(Name, [(Maybe Name, Type)])]
  [(Name, [(Maybe Name, Type)])]
  (Maybe Name)
  (Maybe Name)
-> Optic A_Fold '[] (Maybe Name) (Maybe Name) Name Name
-> Optic' A_Fold '[] [(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 '[] (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
  '[]
  [(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
  '[]
  [(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 '[] [(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 '[] [DefName] [DefName] DefName DefName
-> Optic' A_Fold '[] [(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 '[] [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)
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)
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 :: 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
     '[]
     (Name, [(a, Type)])
     (Name, [(b, Type)])
     [(a, Type)]
     [(b, Type)]
-> Optic
     A_Traversal
     '[]
     [(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
  '[]
  (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
  '[]
  [(Name, [(a, Type)])]
  [(Name, [(b, Type)])]
  [(a, Type)]
  [(b, Type)]
-> Optic
     A_Traversal '[] [(a, Type)] [(b, Type)] (a, Type) (b, Type)
-> Optic
     A_Traversal
     '[]
     [(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 '[] [(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
  '[]
  [(Name, [(a, Type)])]
  [(Name, [(b, Type)])]
  (a, Type)
  (b, Type)
-> Optic A_Lens '[] (a, Type) (b, Type) a b
-> Traversal [(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 '[] (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 Cxt
context, Q Type
instHead) <- case OpticStab
defType of
    OpticSa [TyVarBndr]
vs Cxt
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 = Cxt -> DatatypeInfo -> Type -> Type
addKindInfo' ((TyVarBndr -> Type) -> [TyVarBndr] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
forall flag. TyVarBndr -> Type
tyVarBndrToType [TyVarBndr]
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 :: Cxt
tyArgs = [TyLit -> Type
LitT (String -> TyLit
StrTyLit String
fieldName), Type
k, Type
s, Type
s, Type
a', Type
b']
          context :: Cxt
context = [Cxt] -> Cxt
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ -- If the field is polymorphic, the instance is dysfunctional.
              if [TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr]
vs then [] else [Name -> Cxt -> Type
conAppsT ''Dysfunctional Cxt
tyArgs]
            , [Type
cxtK, Type
cxtA, Type
cxtB]
            , Cxt
cx
            ]
      (Q Cxt, Q Type) -> Q (Q Cxt, Q Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cxt -> Q Cxt
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
context, Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> Type
conAppsT ''LabelOptic Cxt
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 :: Cxt
tyArgs = [TyLit -> Type
LitT (String -> TyLit
StrTyLit String
fieldName), Type
k, Type
s, Type
t, Type
a', Type
b']
          context :: Cxt
context = [Cxt] -> Cxt
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 -> Cxt -> Type
conAppsT ''Dysfunctional Cxt
tyArgs]
            , [Type
cxtK, Type
cxtA, Type
cxtB]
            ]
      (Q Cxt, Q Type) -> Q (Q Cxt, Q Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cxt -> Q Cxt
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
context, Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> Type
conAppsT ''LabelOptic Cxt
tyArgs)
  Q Cxt -> Q Type -> [Q Dec] -> Q Dec
instanceD Q Cxt
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 -> [ClauseQ] -> Q Dec
funD Name
n [ClauseQ
funDef] Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: Name -> [Q Dec]
inlinePragma Name
n

    funDef :: ClauseQ
    funDef :: ClauseQ
funDef = LensRules -> OpticType -> [(Name, Int, [Int])] -> ClauseQ
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 (m :: * -> *) a. Monad m => a -> m a
return (ConstructorInfo -> Name
D.constructorName ConstructorInfo
con,
          (Maybe Name -> Type -> (Maybe Name, Type))
-> [Maybe Name] -> Cxt -> [(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 -> Cxt
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 (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 -> 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 '[] 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 '[] 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]
tyvars, Cxt
cx, Type
a') <- Optic' A_Prism '[] Type ([TyVarBndr], Cxt, Type)
-> Type -> Maybe ([TyVarBndr], Cxt, Type)
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' A_Prism '[] Type ([TyVarBndr], Cxt, Type)
_ForallT Type
a =
               let optic :: OpticType
optic | Bool
lensCase   = OpticType
GetterType
                         | Bool
affineCase = OpticType
AffineFoldType
                         | Bool
otherwise  = OpticType
FoldType
               in [TyVarBndr] -> Cxt -> OpticType -> Type -> Type -> OpticStab
OpticSa [TyVarBndr]
tyvars Cxt
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] -> Cxt -> 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] -> Cxt -> 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 (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
  '[]
  [(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
     '[]
     (Name, [([DefName], Type)])
     (Name, [Either Type Type])
     [([DefName], Type)]
     [Either Type Type]
-> Optic
     A_Setter
     '[]
     [(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
  '[]
  (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
  '[]
  [(Name, [([DefName], Type)])]
  [(Name, [Either Type Type])]
  [([DefName], Type)]
  [Either Type Type]
-> Optic
     A_Setter
     '[]
     [([DefName], Type)]
     [Either Type Type]
     ([DefName], Type)
     (Either Type Type)
-> Optic
     A_Setter
     '[]
     [(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
  '[]
  [([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 (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 '[] (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 '[] (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 (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 '[] [(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 '[] (Name, Int, [Int]) (Name, Int, [Int]) [Int] [Int]
-> Optic
     A_Fold '[] [(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 '[] (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 '[] [(Name, Int, [Int])] [(Name, Int, [Int])] [Int] [Int]
-> Optic A_Getter '[] [Int] [Int] Int Int
-> Optic' A_Fold '[] [(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 '[] [Int] [Int] Int Int
forall s a. (s -> a) -> Getter s a
to [Int] -> 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
showList :: [OpticType] -> String -> String
$cshowList :: [OpticType] -> String -> String
show :: OpticType -> String
$cshow :: OpticType -> String
showsPrec :: Int -> OpticType -> String -> String
$cshowsPrec :: Int -> 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
showList :: [OpticStab] -> String -> String
$cshowList :: [OpticStab] -> String -> String
show :: OpticStab -> String
$cshow :: OpticStab -> String
showsPrec :: Int -> OpticStab -> String -> String
$cshowsPrec :: Int -> OpticStab -> String -> String
Show

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

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

stabToOpticType :: OpticStab -> OpticType
stabToOpticType :: OpticStab -> OpticType
stabToOpticType (OpticStab Bool
_ OpticType
c Type
_ Type
_ Type
_ Type
_) = OpticType
c
stabToOpticType (OpticSa [TyVarBndr]
_ Cxt
_ 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]
_ Cxt
_ 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]
_ Cxt
_ 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]
_ Cxt
_ 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)
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
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 (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 '[] Cxt Type -> Cxt -> Maybe Type
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' An_AffineTraversal '[] Cxt Type
forall s a. Cons s s a a => AffineTraversal' s a
_head Cxt
targetFields)

    phantomTypeVars :: Set Name
phantomTypeVars =
      let allTypeVars :: Optic
  A_Fold
  '[Either () ()]
  [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 () ()]
     (Either Type Type)
     (Either Type Type)
     Type
     Type
-> Optic
     A_Fold
     '[Either () ()]
     [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 () ()]
  (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 () ()]
  [Either Type Type]
  [Either Type Type]
  Type
  Type
-> Optic' A_Traversal '[] Type Name
-> Optic
     A_Fold
     '[Either () ()]
     [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 '[] Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars
      in Optic' A_Traversal '[] 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 '[] 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 () ()]
  [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 () ()]
  [Either Type Type]
  [Either Type Type]
  Name
  Name
allTypeVars [Either Type Type]
categorizedFields

    (Cxt
fixedFields, Cxt
targetFields) = [Either Type Type] -> (Cxt, Cxt)
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 (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 (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 (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 '[] 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 '[] Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s
        fixedTypeVars :: Set Name
fixedTypeVars = Optic' A_Traversal '[] Cxt Name -> Cxt -> 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 '[] Cxt Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Cxt
fixedFields

    getAmbiguousTypeFamilyTypeVars :: Q (Set Name)
getAmbiguousTypeFamilyTypeVars = do
      Type
a' <- Type -> Q Type
D.resolveTypeSynonyms Type
a
      StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
-> 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, Cxt))
go Type
a') (Set Name -> Q (Set Name)) -> Set Name -> Q (Set Name)
forall a b. (a -> b) -> a -> b
$ Optic' A_Traversal '[] 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 '[] 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, Cxt))
go (ForallT [TyVarBndr]
_ Cxt
_ Type
ty)     = Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
go Type
ty
        go (ParensT Type
ty)         = Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
go Type
ty
        go (SigT Type
ty Type
kind)       = Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
go Type
ty StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
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, Cxt))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe (Int, TypeFamilyHead, Cxt)
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Int, TypeFamilyHead, Cxt)
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, Cxt))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe (Int, TypeFamilyHead, Cxt)
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Int, TypeFamilyHead, Cxt)
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, Cxt))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe (Int, TypeFamilyHead, Cxt)
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Int, TypeFamilyHead, Cxt)
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 (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 (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBndr]
varBndrs, TypeFamilyHead
tf, [])
          (Info -> Maybe (Int, TypeFamilyHead, Cxt))
-> Name -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
forall a.
(Info -> Maybe a) -> Name -> StateT (Set Name) Q (Maybe a)
tryReify (Optic' An_AffineFold '[] Info (Int, TypeFamilyHead, Cxt)
-> Info -> Maybe (Int, TypeFamilyHead, Cxt)
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Optic' An_AffineFold '[] Info (Int, TypeFamilyHead, Cxt)
 -> Info -> Maybe (Int, TypeFamilyHead, Cxt))
-> Optic' An_AffineFold '[] Info (Int, TypeFamilyHead, Cxt)
-> Info
-> Maybe (Int, TypeFamilyHead, Cxt)
forall a b. (a -> b) -> a -> b
$ Prism' Info (Dec, [Dec])
_FamilyI Prism' Info (Dec, [Dec])
-> Optic A_Lens '[] (Dec, [Dec]) (Dec, [Dec]) Dec Dec
-> Optic An_AffineTraversal '[] 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 '[] (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 '[] Info Info Dec Dec
-> Optic An_AffineFold '[] Dec Dec TypeFamilyHead TypeFamilyHead
-> Optic An_AffineFold '[] 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 '[] Dec Dec TypeFamilyHead TypeFamilyHead
typeFamilyHead Optic An_AffineFold '[] Info Info TypeFamilyHead TypeFamilyHead
-> Optic
     An_AffineFold
     '[]
     TypeFamilyHead
     TypeFamilyHead
     (Int, TypeFamilyHead, Cxt)
     (Int, TypeFamilyHead, Cxt)
-> Optic' An_AffineFold '[] Info (Int, TypeFamilyHead, Cxt)
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
  '[]
  TypeFamilyHead
  TypeFamilyHead
  (Int, TypeFamilyHead, Cxt)
  (Int, TypeFamilyHead, Cxt)
forall a. AffineFold TypeFamilyHead (Int, TypeFamilyHead, [a])
getVarLen) Name
nm

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

        go Type
_ = Maybe (Int, TypeFamilyHead, Cxt)
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Int, TypeFamilyHead, Cxt)
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 '[] 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 '[] Info Info TypeFamilyHead TypeFamilyHead
 -> Info -> Maybe TypeFamilyHead)
-> Optic An_AffineFold '[] 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 '[] (Dec, [Dec]) (Dec, [Dec]) Dec Dec
-> Optic An_AffineTraversal '[] 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 '[] (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 '[] Info Info Dec Dec
-> Optic An_AffineFold '[] Dec Dec TypeFamilyHead TypeFamilyHead
-> Optic An_AffineFold '[] 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 '[] Dec Dec TypeFamilyHead TypeFamilyHead
typeFamilyHead) Name
nm
          case Maybe TypeFamilyHead
mtf of
            Just TypeFamilyHead
tf -> TypeFamilyHead -> Cxt -> StateT (Set Name) Q ()
procTF TypeFamilyHead
tf [Type
ty1, Type
ty2]
            Maybe TypeFamilyHead
Nothing -> Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
go Type
ty1 StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
go Type
ty2 StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
-> StateT (Set Name) Q () -> StateT (Set Name) Q ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> StateT (Set Name) Q ()
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 :: (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 (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 (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 -> Cxt -> StateT (Set Name) Q ()
procTF TypeFamilyHead
tf Cxt
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 -> 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] -> Cxt -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
sameLenZip [Name]
vars Cxt
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, Cxt))
    -> StateT (Set Name) Q ())
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
-> StateT (Set Name) Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
-> StateT (Set Name) Q ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
 -> StateT (Set Name) Q ())
-> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
-> StateT (Set Name) Q ()
forall a b. (a -> b) -> a -> b
$ Type -> StateT (Set Name) Q (Maybe (Int, TypeFamilyHead, Cxt))
go Type
arg
          TypeFamilyHead
_ -> () -> StateT (Set Name) Q ()
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 (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)
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 (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 (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 (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
sigD Name
n (Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (OpticStab -> Type
stabToType OpticStab
defType))]
          MethodName{} -> []

  fun :: Name -> [Q Dec]
fun Name
n = Name -> [ClauseQ] -> Q Dec
funD Name
n [ClauseQ
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 :: ClauseQ
funDef = LensRules -> OpticType -> [(Name, Int, [Int])] -> ClauseQ
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)
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 (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
newName String
"c"
  let vars :: [Name]
vars = Optic' A_Traversal '[] 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 '[] Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s
      fd :: [FunDep]
fd   | [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
vars = []
           | Bool
otherwise = [[Name] -> [Name] -> FunDep
FunDep [Name
c] [Name]
vars]


  Q Cxt -> Name -> [TyVarBndr] -> [FunDep] -> [Q Dec] -> Q Dec
classD ([Q Type] -> Q Cxt
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
sigD Name
methodName (Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (''Lens' Name -> Cxt -> 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
sigD Name
defName (Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)
        ,PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
defName) (ExpQ -> BodyQ
normalB ExpQ
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 :: ExpQ
body = ExpQ -> ExpQ -> ExpQ -> ExpQ
infixApp (Name -> ExpQ
varE Name
methodName) (Name -> ExpQ
varE '(%)) (Name -> ExpQ
varE Name
defName)
      , let ty :: Type
ty   = Set Name -> [TyVarBndr] -> Cxt -> 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 -> Cxt
stabToContext OpticStab
stab)
                 (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ OpticStab -> Name
stabToOptic OpticStab
stab Name -> Cxt -> 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)
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 (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 Cxt -> Q Type -> [Q Dec] -> Q Dec
instanceD ([Q Type] -> Q Cxt
cxt[]) (Type -> Q Type
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
$ PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
methodName) (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE 'lensVL ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
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 (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 -> Cxt -> Type
`conAppsT` (Type
s Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: (Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
vars)
  vars :: [Name]
vars         = Optic' A_Traversal '[] 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 '[] Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s
  rules' :: LensRules
rules'       = LensRules
rules { _generateSigs :: Bool
_generateSigs    = Bool
False
                       , _generateClasses :: Bool
_generateClasses = Bool
False
                       }

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

makeFieldClass :: OpticStab -> Name -> Name -> DecQ
makeFieldClass :: OpticStab -> Name -> Name -> Q Dec
makeFieldClass OpticStab
defType Name
className Name
methodName =
  Q Cxt -> Name -> [TyVarBndr] -> [FunDep] -> [Q Dec] -> Q Dec
classD ([Q Type] -> Q Cxt
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
sigD Name
methodName (Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
methodType)]
  where
  methodType :: Type
methodType = Set Name -> [TyVarBndr] -> Cxt -> Type -> Type
quantifyType' ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList [Name
s,Name
a])
                             []
                             (OpticStab -> Cxt
stabToContext OpticStab
defType)
             (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ OpticStab -> Name
stabToOptic OpticStab
defType Name -> Cxt -> 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 (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 '[] 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 '[] (Dec, [Dec]) (Dec, [Dec]) Dec Dec
-> Optic An_AffineTraversal '[] 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 '[] (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 '[] Info Info Dec Dec
-> Optic An_AffineFold '[] Dec Dec TypeFamilyHead TypeFamilyHead
-> Optic An_AffineFold '[] 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 '[] 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) -> Cxt -> Q [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Q Bool
go (Traversal' Type Type -> Type -> Cxt
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
newName String
"a"
        [Q Type] -> Cxt -> Q Dec
mkInstanceDec
          [Type -> Q Type
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] -> Cxt -> Q Dec
mkInstanceDec [] [Type
s, Type
a]

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

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

makeFieldClause :: LensRules -> OpticType -> [(Name, Int, [Int])] -> ClauseQ
makeFieldClause :: LensRules -> OpticType -> [(Name, Int, [Int])] -> ClauseQ
makeFieldClause LensRules
rules OpticType
opticType [(Name, Int, [Int])]
cons =
  case OpticType
opticType of
    OpticType
AffineFoldType      -> [(Name, Int, [Int])] -> ClauseQ
makeAffineFoldClause [(Name, Int, [Int])]
cons
    OpticType
AffineTraversalType -> [(Name, Int, [Int])] -> Bool -> ClauseQ
makeAffineTraversalClause [(Name, Int, [Int])]
cons Bool
irref
    OpticType
FoldType            -> [(Name, Int, [Int])] -> ClauseQ
makeFoldClause [(Name, Int, [Int])]
cons
    OpticType
IsoType             -> [(Name, Int, [Int])] -> Bool -> ClauseQ
makeIsoClause [(Name, Int, [Int])]
cons Bool
irref
    OpticType
GetterType          -> [(Name, Int, [Int])] -> ClauseQ
makeGetterClause [(Name, Int, [Int])]
cons
    OpticType
LensType            -> [(Name, Int, [Int])] -> Bool -> ClauseQ
makeLensClause [(Name, Int, [Int])]
cons Bool
irref
    OpticType
TraversalType       -> [(Name, Int, [Int])] -> Bool -> ClauseQ
makeTraversalClause [(Name, Int, [Int])]
cons Bool
irref
  where
    irref :: Bool
irref = LensRules -> Bool
_lazyPatterns LensRules
rules Bool -> Bool -> Bool
&& [(Name, Int, [Int])] -> 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])] -> ClauseQ
makeAffineFoldClause [(Name, Int, [Int])]
cons = do
  Name
s <- String -> Q Name
newName String
"s"
  [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
    []
    (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ [ExpQ] -> ExpQ
appsE
      [ Name -> ExpQ
varE 'afolding
      , [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
s] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
s)
        [ Name -> Int -> [Int] -> MatchQ
makeAffineFoldMatch Name
conName Int
fieldCount [Int]
fields
        | (Name
conName, Int
fieldCount, [Int]
fields) <- [(Name, Int, [Int])]
cons
        ]
      ])
    []
  where
    makeAffineFoldMatch :: Name -> Int -> [Int] -> MatchQ
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 (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fields

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

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

      PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName [PatQ]
args)
            (ExpQ -> BodyQ
normalB ExpQ
body)
            []

makeFoldClause :: [(Name, Int, [Int])] -> ClauseQ
makeFoldClause :: [(Name, Int, [Int])] -> ClauseQ
makeFoldClause [(Name, Int, [Int])]
cons = do
  Name
f <- String -> Q Name
newName String
"f"
  Name
s <- String -> Q Name
newName String
"s"
  [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
    []
    (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ [ExpQ] -> ExpQ
appsE
      [ Name -> ExpQ
varE 'foldVL
      , [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
f, Name -> PatQ
varP Name
s] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
s)
        [ Name -> Name -> Int -> [Int] -> MatchQ
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] -> MatchQ
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 (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fields

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

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

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

      PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName [PatQ]
args)
            (ExpQ -> BodyQ
normalB ExpQ
body)
            []

-- | Build a getter clause that retrieves the field at the given index.
makeGetterClause :: [(Name, Int, [Int])] -> ClauseQ
makeGetterClause :: [(Name, Int, [Int])] -> ClauseQ
makeGetterClause [(Name, Int, [Int])]
cons = do
  Name
s <- String -> Q Name
newName String
"s"
  [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
    []
    (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ [ExpQ] -> ExpQ
appsE
      [ Name -> ExpQ
varE 'to
      , [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
s] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
s)
        [ Name -> Int -> [Int] -> MatchQ
makeGetterMatch Name
conName Int
fieldCount [Int]
fields
        | (Name
conName, Int
fieldCount, [Int]
fields) <- [(Name, Int, [Int])]
cons
        ]
      ])
    []
  where
    makeGetterMatch :: Name -> Int -> [Int] -> MatchQ
makeGetterMatch Name
conName Int
fieldCount = \case
      [Int
field] -> do
        Name
x <- String -> Q Name
newName String
"x"
        -- Con _ .. x_i .. _ -> x_i
        PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> ([PatQ] -> [PatQ]) -> [PatQ] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic An_AffineTraversal '[] [PatQ] [PatQ] PatQ PatQ
-> PatQ -> [PatQ] -> [PatQ]
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (Index [PatQ] -> Optic' (IxKind [PatQ]) '[] [PatQ] (IxValue [PatQ])
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Int
Index [PatQ]
field) (Name -> PatQ
varP Name
x) ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ Int -> PatQ -> [PatQ]
forall a. Int -> a -> [a]
replicate Int
fieldCount PatQ
wildP)
              (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE Name
x)
              []
      [Int]
_       -> String -> MatchQ
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 -> ClauseQ
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
newName String
"x"
    [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
           (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ [ExpQ] -> ExpQ
appsE
             [ Name -> ExpQ
varE 'iso
             , [PatQ] -> ExpQ -> ExpQ
lamE [PatQ -> PatQ
irrefP (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ Name -> [PatQ] -> PatQ
conP Name
conName [Name -> PatQ
varP Name
x]] (Name -> ExpQ
varE Name
x)
             , Name -> ExpQ
conE Name
conName
             ])
           []
  [(Name, Int, [Int])]
_ -> String -> ClauseQ
forall a. HasCallStack => String -> a
error String
"Iso works only for types with one constructor and one field"
  where
    irrefP :: PatQ -> PatQ
irrefP = if Bool
irref then PatQ -> PatQ
tildeP else PatQ -> PatQ
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 -> ClauseQ
makeLensClause [(Name, Int, [Int])]
cons Bool
irref = do
  Name
f <- String -> Q Name
newName String
"f"
  Name
s <- String -> Q Name
newName String
"s"
  [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
    []
    (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ [ExpQ] -> ExpQ
appsE
      [ Name -> ExpQ
varE 'lensVL
      , [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
f, Name -> PatQ
varP Name
s] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
s)
        [ (PatQ -> PatQ) -> Name -> Name -> Int -> [Int] -> MatchQ
makeLensMatch PatQ -> PatQ
irrefP Name
f Name
conName Int
fieldCount [Int]
fields
        | (Name
conName, Int
fieldCount, [Int]
fields) <- [(Name, Int, [Int])]
cons
        ]
      ])
    []
  where
    irrefP :: PatQ -> PatQ
irrefP = if Bool
irref then PatQ -> PatQ
tildeP else PatQ -> PatQ
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 :: (PatQ -> PatQ) -> Name -> Name -> Int -> [Int] -> MatchQ
makeLensMatch PatQ -> PatQ
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
newName String
"y"

    let body :: ExpQ
body = [ExpQ] -> ExpQ
appsE
          [ Name -> ExpQ
varE 'fmap
          , [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
y] (ExpQ -> ExpQ) -> ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ExpQ] -> ExpQ
appsE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$
            Name -> ExpQ
conE Name
conName ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE (Optic An_AffineTraversal '[] [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]) '[] [Name] (IxValue [Name])
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] m (IxValue m)
ix Int
Index [Name]
field) Name
y [Name]
xs)
          , ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
f) (ExpQ -> ExpQ) -> (Name -> ExpQ) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Name]
xs [Name] -> Int -> Name
forall a. [a] -> Int -> a
!! Int
field
          ]

    -- Con x_1 .. x_n -> fmap (\y_i -> Con x_1 .. y_i .. x_n) (f x_i)
    PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (PatQ -> PatQ
irrefP (PatQ -> PatQ) -> ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs)
          (ExpQ -> BodyQ
normalB ExpQ
body)
          []
  [Int]
_       -> String -> MatchQ
forall a. HasCallStack => String -> a
error String
"Lens focuses on exactly one field"

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

    makeAffineTraversalMatch :: Name -> Name -> Name -> Int -> [Int] -> MatchQ
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)
        PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (PatQ -> PatQ
irrefP (PatQ -> PatQ) -> ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs)
              (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE Name
point ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
appsE (Name -> ExpQ
conE Name
conName ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs))
              []
      [Int
field] -> (PatQ -> PatQ) -> Name -> Name -> Int -> [Int] -> MatchQ
makeLensMatch PatQ -> PatQ
irrefP Name
f Name
conName Int
fieldCount [Int
field]
      [Int]
_ -> String -> MatchQ
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 -> ClauseQ
makeTraversalClause [(Name, Int, [Int])]
cons Bool
irref = do
  Name
f <- String -> Q Name
newName String
"f"
  Name
s <- String -> Q Name
newName String
"s"
  [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
    []
    (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ [ExpQ] -> ExpQ
appsE
      [ Name -> ExpQ
varE 'traversalVL
      , [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
f, Name -> PatQ
varP Name
s] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
s)
        [ Name -> Name -> Int -> [Int] -> MatchQ
makeTraversalMatch Name
f Name
conName Int
fieldCount [Int]
fields
        | (Name
conName, Int
fieldCount, [Int]
fields) <- [(Name, Int, [Int])]
cons
        ]
      ])
    []
  where
    irrefP :: PatQ -> PatQ
irrefP = if Bool
irref then PatQ -> PatQ
tildeP else PatQ -> PatQ
forall a. a -> a
id

    makeTraversalMatch :: Name -> Name -> Int -> [Int] -> MatchQ
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)
          PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (PatQ -> PatQ
irrefP (PatQ -> PatQ) -> ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs)
                (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE 'pure ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
appsE (Name -> ExpQ
conE Name
conName ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
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 (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fields

          let xs' :: [Name]
xs' = ((Int, Name) -> [Name] -> [Name])
-> [Name] -> [(Int, Name)] -> [Name]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int
i, Name
x) -> Optic An_AffineTraversal '[] [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]) '[] [Name] (IxValue [Name])
forall m. Ixed m => Index m -> Optic' (IxKind m) '[] 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 -> ExpQ
mkFx Int
i = Name -> ExpQ
varE Name
f ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE ([Name]
xs [Name] -> Int -> Name
forall a. [a] -> Int -> a
!! Int
i)

              body0 :: ExpQ
body0 = [ExpQ] -> ExpQ
appsE
                [ Name -> ExpQ
varE 'pure
                , [PatQ] -> ExpQ -> ExpQ
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
ys) (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ [ExpQ] -> ExpQ
appsE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
conE Name
conName ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs'
                ]

              body :: ExpQ
body = (ExpQ -> Int -> ExpQ) -> ExpQ -> [Int] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
acc Int
i -> ExpQ -> ExpQ -> ExpQ -> ExpQ
infixApp ExpQ
acc (Name -> ExpQ
varE '(<*>)) (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ Int -> ExpQ
mkFx Int
i)
                           ExpQ
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
          PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (PatQ -> PatQ
irrefP (PatQ -> PatQ) -> ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs)
                (ExpQ -> BodyQ
normalB ExpQ
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
showList :: [DefName] -> String -> String
$cshowList :: [DefName] -> String -> String
show :: DefName -> String
$cshow :: DefName -> String
showsPrec :: Int -> DefName -> String -> String
$cshowsPrec :: Int -> 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
/= :: DefName -> DefName -> Bool
$c/= :: DefName -> DefName -> Bool
== :: DefName -> DefName -> Bool
$c== :: 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
min :: DefName -> DefName -> DefName
$cmin :: DefName -> DefName -> DefName
max :: DefName -> DefName -> DefName
$cmax :: DefName -> DefName -> DefName
>= :: DefName -> DefName -> Bool
$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
compare :: DefName -> DefName -> Ordering
$ccompare :: DefName -> DefName -> Ordering
$cp1Ord :: Eq DefName
Ord)

_MethodName :: Prism' DefName (Name, Name)
_MethodName :: Optic A_Prism '[] DefName DefName (Name, Name) (Name, Name)
_MethodName = ((Name, Name) -> DefName)
-> (DefName -> Maybe (Name, Name))
-> Optic A_Prism '[] 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 '[] DefName DefName (Name, Name) (Name, Name))
-> (DefName -> Maybe (Name, Name))
-> Optic A_Prism '[] 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 '[] Dec Dec TypeFamilyHead TypeFamilyHead
typeFamilyHead = Prism' Dec TypeFamilyHead
_OpenTypeFamilyD Prism' Dec TypeFamilyHead
-> Optic' An_AffineTraversal '[] Dec TypeFamilyHead
-> Optic An_AffineFold '[] 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
     '[]
     (TypeFamilyHead, [TySynEqn])
     (TypeFamilyHead, [TySynEqn])
     TypeFamilyHead
     TypeFamilyHead
-> Optic' An_AffineTraversal '[] 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
  '[]
  (TypeFamilyHead, [TySynEqn])
  (TypeFamilyHead, [TySynEqn])
  TypeFamilyHead
  TypeFamilyHead
forall s t a b. Field1 s t a b => Lens s t a b
_1