{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
#ifdef TRUSTWORTHY
# if MIN_VERSION_template_haskell(2,12,0)
{-# LANGUAGE Safe #-}
# else
{-# LANGUAGE Trustworthy #-}
# endif
#endif

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Internal.FieldTH
-- Copyright   :  (C) 2014-2016 Edward Kmett, (C) 2014 Eric Mertens
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-----------------------------------------------------------------------------

module Control.Lens.Internal.FieldTH
  ( LensRules(..)
  , FieldNamer
  , DefName(..)
  , ClassyNamer
  , makeFieldOptics
  , makeFieldOpticsForDec
  , makeFieldOpticsForDec'
  , HasFieldClasses
  ) where

import Prelude ()

import Control.Lens.At
import Control.Lens.Fold
import Control.Lens.Indexed
import Control.Lens.Internal.TH
import Control.Lens.Internal.Prelude
import Control.Lens.Lens
import Control.Lens.Plated
import Control.Lens.Prism
import Control.Lens.Setter
import Control.Lens.Getter
import Control.Lens.Tuple
import Control.Lens.Traversal
import Control.Monad
import Control.Monad.State
import Language.Haskell.TH.Lens
import Language.Haskell.TH
import qualified Language.Haskell.TH.Datatype as D
import qualified Language.Haskell.TH.Datatype.TyVarBndr as D
import Data.Maybe (fromMaybe,isJust,maybeToList)
import Data.List (nub)
import Data.Either (partitionEithers)
import Data.Semigroup (Any (..))
import Data.Set.Lens
import           Data.Map ( Map )
import           Data.Set ( Set )
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Traversable as T

------------------------------------------------------------------------
-- 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
Set.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
Set.empty) (StateT (Set Name) Q [Dec] -> DecsQ)
-> (Dec -> StateT (Set Name) Q [Dec]) -> Dec -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensRules -> Dec -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDec' LensRules
rules

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

-- | Compute the field optics for a deconstructed datatype Dec
-- When possible build an Iso otherwise build one optic per field.
makeFieldOpticsForDatatype :: LensRules -> D.DatatypeInfo -> HasFieldClasses [Dec]
makeFieldOpticsForDatatype :: LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDatatype LensRules
rules DatatypeInfo
info =
  do Map
  DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
perDef <- Q (Map
     DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT
     (Set Name)
     Q
     (Map
        DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q (Map
      DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
 -> StateT
      (Set Name)
      Q
      (Map
         DefName
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])))
-> Q (Map
        DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT
     (Set Name)
     Q
     (Map
        DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
forall a b. (a -> b) -> a -> b
$ do
       [(Name, [(Maybe Name, Type)])]
fieldCons <- (ConstructorInfo -> Q (Name, [(Maybe Name, Type)]))
-> [ConstructorInfo] -> Q [(Name, [(Maybe Name, Type)])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
normalizeConstructor [ConstructorInfo]
cons
       let allFields :: [Name]
allFields  = Getting (Endo [Name]) [(Name, [(Maybe Name, Type)])] Name
-> [(Name, [(Maybe Name, Type)])] -> [Name]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (((Name, [(Maybe Name, Type)])
 -> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
-> [(Name, [(Maybe Name, Type)])]
-> Const (Endo [Name]) [(Name, [(Maybe Name, Type)])]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold
  Int [(Name, [(Maybe Name, Type)])] (Name, [(Maybe Name, Type)])
folded (((Name, [(Maybe Name, Type)])
  -> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
 -> [(Name, [(Maybe Name, Type)])]
 -> Const (Endo [Name]) [(Name, [(Maybe Name, Type)])])
-> ((Name -> Const (Endo [Name]) Name)
    -> (Name, [(Maybe Name, Type)])
    -> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
-> Getting (Endo [Name]) [(Name, [(Maybe Name, Type)])] Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Maybe Name, Type)] -> Const (Endo [Name]) [(Maybe Name, Type)])
-> (Name, [(Maybe Name, Type)])
-> Const (Endo [Name]) (Name, [(Maybe Name, Type)])
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (Name, [(Maybe Name, Type)])
  (Name, [(Maybe Name, Type)])
  [(Maybe Name, Type)]
  [(Maybe Name, Type)]
_2 (([(Maybe Name, Type)] -> Const (Endo [Name]) [(Maybe Name, Type)])
 -> (Name, [(Maybe Name, Type)])
 -> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
-> ((Name -> Const (Endo [Name]) Name)
    -> [(Maybe Name, Type)]
    -> Const (Endo [Name]) [(Maybe Name, Type)])
-> (Name -> Const (Endo [Name]) Name)
-> (Name, [(Maybe Name, Type)])
-> Const (Endo [Name]) (Name, [(Maybe Name, Type)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
-> [(Maybe Name, Type)] -> Const (Endo [Name]) [(Maybe Name, Type)]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int [(Maybe Name, Type)] (Maybe Name, Type)
folded (((Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
 -> [(Maybe Name, Type)]
 -> Const (Endo [Name]) [(Maybe Name, Type)])
-> ((Name -> Const (Endo [Name]) Name)
    -> (Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
-> (Name -> Const (Endo [Name]) Name)
-> [(Maybe Name, Type)]
-> Const (Endo [Name]) [(Maybe Name, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Name -> Const (Endo [Name]) (Maybe Name))
-> (Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type)
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (Maybe Name, Type) (Maybe Name, Type) (Maybe Name) (Maybe Name)
_1 ((Maybe Name -> Const (Endo [Name]) (Maybe Name))
 -> (Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
-> ((Name -> Const (Endo [Name]) Name)
    -> Maybe Name -> Const (Endo [Name]) (Maybe Name))
-> (Name -> Const (Endo [Name]) Name)
-> (Maybe Name, Type)
-> Const (Endo [Name]) (Maybe Name, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Const (Endo [Name]) Name)
-> Maybe Name -> Const (Endo [Name]) (Maybe Name)
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int (Maybe Name) Name
folded) [(Name, [(Maybe Name, Type)])]
fieldCons
       let defCons :: [(Name, [([(DefName, Maybe Name)], Type)])]
defCons    = ASetter
  [(Name, [(Maybe Name, Type)])]
  [(Name, [([(DefName, Maybe Name)], Type)])]
  (Maybe Name)
  [(DefName, Maybe Name)]
-> (Maybe Name -> [(DefName, Maybe Name)])
-> [(Name, [(Maybe Name, Type)])]
-> [(Name, [([(DefName, Maybe Name)], Type)])]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  [(Name, [(Maybe Name, Type)])]
  [(Name, [([(DefName, Maybe Name)], Type)])]
  (Maybe Name)
  [(DefName, Maybe Name)]
forall a b (f :: * -> *).
Applicative f =>
(a -> f b) -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
normFieldLabels ([Name] -> Maybe Name -> [(DefName, Maybe Name)]
expandName [Name]
allFields) [(Name, [(Maybe Name, Type)])]
fieldCons
           allDefs :: Set DefName
allDefs    = Getting
  (Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])] DefName
-> [(Name, [([(DefName, Maybe Name)], Type)])] -> Set DefName
forall a s. Getting (Set a) s a -> s -> Set a
setOf (([(DefName, Maybe Name)]
 -> Const (Set DefName) [(DefName, Maybe Name)])
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> Const (Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])]
forall a b (f :: * -> *).
Applicative f =>
(a -> f b) -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
normFieldLabels (([(DefName, Maybe Name)]
  -> Const (Set DefName) [(DefName, Maybe Name)])
 -> [(Name, [([(DefName, Maybe Name)], Type)])]
 -> Const (Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])])
-> ((DefName -> Const (Set DefName) DefName)
    -> [(DefName, Maybe Name)]
    -> Const (Set DefName) [(DefName, Maybe Name)])
-> Getting
     (Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])] DefName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DefName, Maybe Name)
 -> Const (Set DefName) (DefName, Maybe Name))
-> [(DefName, Maybe Name)]
-> Const (Set DefName) [(DefName, Maybe Name)]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int [(DefName, Maybe Name)] (DefName, Maybe Name)
folded (((DefName, Maybe Name)
  -> Const (Set DefName) (DefName, Maybe Name))
 -> [(DefName, Maybe Name)]
 -> Const (Set DefName) [(DefName, Maybe Name)])
-> ((DefName -> Const (Set DefName) DefName)
    -> (DefName, Maybe Name)
    -> Const (Set DefName) (DefName, Maybe Name))
-> (DefName -> Const (Set DefName) DefName)
-> [(DefName, Maybe Name)]
-> Const (Set DefName) [(DefName, Maybe Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DefName -> Const (Set DefName) DefName)
-> (DefName, Maybe Name)
-> Const (Set DefName) (DefName, Maybe Name)
forall s t a b. Field1 s t a b => Lens s t a b
Lens (DefName, Maybe Name) (DefName, Maybe Name) DefName DefName
_1) [(Name, [([(DefName, Maybe Name)], Type)])]
defCons
       Map
  DefName
  (Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Q (Map
        DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
Map DefName (f a) -> f (Map DefName a)
T.sequenceA ((DefName
 -> Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Set DefName
-> Map
     DefName
     (Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (LensRules
-> Type
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> DefName
-> Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
buildScaffold LensRules
rules Type
s [(Name, [([(DefName, Maybe Name)], Type)])]
defCons) Set DefName
allDefs)

     let defs :: [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs = Map
  DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
-> [(DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
forall k a. Map k a -> [(k, a)]
Map.toList Map
  DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
perDef
     case LensRules -> ClassyNamer
_classyLenses LensRules
rules Name
tyName of
       Just (Name
className, Name
methodName) ->
         LensRules
-> Name
-> Name
-> Type
-> [(DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> StateT (Set Name) Q [Dec]
makeClassyDriver LensRules
rules Name
className Name
methodName Type
s [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs
       Maybe (Name, Name)
Nothing -> do [[Dec]]
decss <- ((DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
 -> StateT (Set Name) Q [Dec])
-> [(DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> StateT (Set Name) Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (LensRules
-> (DefName,
    (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules) [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs
                     [Dec] -> StateT (Set Name) Q [Dec]
forall a. a -> StateT (Set Name) Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decss)

  where
  tyName :: Name
tyName = DatatypeInfo -> Name
D.datatypeName     DatatypeInfo
info
  s :: Type
s      = DatatypeInfo -> Type
datatypeTypeKinded DatatypeInfo
info
  cons :: [ConstructorInfo]
cons   = DatatypeInfo -> [ConstructorInfo]
D.datatypeCons     DatatypeInfo
info

  -- Traverse the field labels of a normalized constructor
  normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b
  normFieldLabels :: forall a b (f :: * -> *).
Applicative f =>
(a -> f b) -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
normFieldLabels = ((Name, [(a, Type)]) -> f (Name, [(b, Type)]))
-> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (((Name, [(a, Type)]) -> f (Name, [(b, Type)]))
 -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])])
-> ((a -> f b) -> (Name, [(a, Type)]) -> f (Name, [(b, Type)]))
-> (a -> f b)
-> [(Name, [(a, Type)])]
-> f [(Name, [(b, Type)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(a, Type)] -> f [(b, Type)])
-> (Name, [(a, Type)]) -> f (Name, [(b, Type)])
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (Name, [(a, Type)]) (Name, [(b, Type)]) [(a, Type)] [(b, Type)]
_2 (([(a, Type)] -> f [(b, Type)])
 -> (Name, [(a, Type)]) -> f (Name, [(b, Type)]))
-> ((a -> f b) -> [(a, Type)] -> f [(b, Type)])
-> (a -> f b)
-> (Name, [(a, Type)])
-> f (Name, [(b, Type)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Type) -> f (b, Type)) -> [(a, Type)] -> f [(b, Type)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (((a, Type) -> f (b, Type)) -> [(a, Type)] -> f [(b, Type)])
-> ((a -> f b) -> (a, Type) -> f (b, Type))
-> (a -> f b)
-> [(a, Type)]
-> f [(b, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> (a, Type) -> f (b, Type)
forall s t a b. Field1 s t a b => Lens s t a b
Lens (a, Type) (b, Type) a b
_1

  -- Map a (possibly missing) field's name to zero-to-many optic definitions
  expandName :: [Name] -> Maybe Name -> [(DefName, Maybe Name)]
  expandName :: [Name] -> Maybe Name -> [(DefName, Maybe Name)]
expandName [Name]
allFields Maybe Name
mName = (\DefName
x -> (DefName
x, Maybe Name
mName)) (DefName -> (DefName, Maybe Name))
-> [DefName] -> [(DefName, Maybe Name)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Name -> [Name]
forall a. Maybe a -> [a]
maybeToList Maybe Name
mName [Name] -> (Name -> [DefName]) -> [DefName]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LensRules -> FieldNamer
_fieldToDef LensRules
rules Name
tyName [Name]
allFields)

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

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

    -- Fields mentioning existentially quantified types are not
    -- elligible for TH generated optics.
    checkForExistentials :: Maybe a -> b -> (Maybe a, b)
checkForExistentials Maybe a
_ b
fieldtype
      | (TyVarBndr_ () -> Bool) -> [TyVarBndr_ ()] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TyVarBndr_ ()
tv -> TyVarBndr_ () -> Name
forall flag. TyVarBndr_ flag -> Name
D.tvName TyVarBndr_ ()
tv Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
used) [TyVarBndr_ ()]
unallowable
      = (Maybe a
forall a. Maybe a
Nothing, b
fieldtype)
      where
        used :: Set Name
used        = Getting (Set Name) b Name -> b -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) b Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' b Name
typeVars b
fieldtype
        unallowable :: [TyVarBndr_ ()]
unallowable = ConstructorInfo -> [TyVarBndr_ ()]
D.constructorVars ConstructorInfo
con
    checkForExistentials Maybe a
fieldname b
fieldtype = (Maybe a
fieldname, b
fieldtype)

data OpticType = GetterType | LensType | IsoType

-- | 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 ::
  LensRules                                                                            ->
  Type                                        {- ^ outer type                       -} ->
  [(Name, [([(DefName, Maybe Name)], Type)])] {- ^ normalized constructors          -} ->
  DefName                                     {- ^ target definition                -} ->
  Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
              {- ^ optic type, definition type, field count, target fields -}
buildScaffold :: LensRules
-> Type
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> DefName
-> Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
buildScaffold LensRules
rules Type
s [(Name, [([(DefName, Maybe Name)], Type)])]
cons DefName
defName =

  do (Type
s',Type
t,Type
a,Type
b) <- Type -> [Either Type Type] -> Q (Type, Type, Type, Type)
buildStab Type
s (((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 (Maybe Name, Type)])]
consForDef [(Name, [Either Type (Maybe Name, Type)])]
-> ((Name, [Either Type (Maybe Name, Type)])
    -> (Name, [Either Type Type]))
-> [(Name, [Either Type Type])]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ([Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
-> (Name, [Either Type (Maybe Name, Type)])
-> Identity (Name, [Either Type Type])
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (Name, [Either Type (Maybe Name, Type)])
  (Name, [Either Type Type])
  [Either Type (Maybe Name, Type)]
  [Either Type Type]
_2 (([Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
 -> (Name, [Either Type (Maybe Name, Type)])
 -> Identity (Name, [Either Type Type]))
-> (((Maybe Name, Type) -> Identity Type)
    -> [Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
-> ((Maybe Name, Type) -> Identity Type)
-> (Name, [Either Type (Maybe Name, Type)])
-> Identity (Name, [Either Type Type])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Type (Maybe Name, Type) -> Identity (Either Type Type))
-> [Either Type (Maybe Name, Type)] -> Identity [Either Type Type]
Setter
  [Either Type (Maybe Name, Type)]
  [Either Type Type]
  (Either Type (Maybe Name, Type))
  (Either Type Type)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped ((Either Type (Maybe Name, Type) -> Identity (Either Type Type))
 -> [Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
-> (((Maybe Name, Type) -> Identity Type)
    -> Either Type (Maybe Name, Type) -> Identity (Either Type Type))
-> ((Maybe Name, Type) -> Identity Type)
-> [Either Type (Maybe Name, Type)]
-> Identity [Either Type Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Name, Type) -> Identity Type)
-> Either Type (Maybe Name, Type) -> Identity (Either Type Type)
forall c a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Either c a) (f (Either c b))
_Right (((Maybe Name, Type) -> Identity Type)
 -> (Name, [Either Type (Maybe Name, Type)])
 -> Identity (Name, [Either Type Type]))
-> ((Maybe Name, Type) -> Type)
-> (Name, [Either Type (Maybe Name, Type)])
-> (Name, [Either Type Type])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Maybe Name, Type) -> Type
forall a b. (a, b) -> b
snd))

     let defType :: OpticStab
defType
           | Just ([TyVarBndrSpec]
_,[Type]
cx,Type
a') <- Getting
  (First ([TyVarBndrSpec], [Type], Type))
  Type
  ([TyVarBndrSpec], [Type], Type)
-> Type -> Maybe ([TyVarBndrSpec], [Type], Type)
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting
  (First ([TyVarBndrSpec], [Type], Type))
  Type
  ([TyVarBndrSpec], [Type], Type)
Prism' Type ([TyVarBndrSpec], [Type], Type)
_ForallT Type
a =
               let optic :: Name
optic | Bool
lensCase  = Name
getterTypeName
                         | Bool
otherwise = Name
foldTypeName
               in [Type] -> Name -> Type -> Type -> OpticStab
OpticSa [Type]
cx Name
optic Type
s' Type
a'

           -- Getter and Fold are always simple
           | Bool -> Bool
not (LensRules -> Bool
_allowUpdates LensRules
rules) =
               let optic :: Name
optic | Bool
lensCase  = Name
getterTypeName
                         | Bool
otherwise = Name
foldTypeName
               in [Type] -> Name -> Type -> Type -> OpticStab
OpticSa [] Name
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 :: Name
optic | Bool
isoCase Bool -> Bool -> Bool
&& LensRules -> Bool
_allowIsos LensRules
rules = Name
iso'TypeName
                         | Bool
lensCase                    = Name
lens'TypeName
                         | Bool
otherwise                   = Name
traversal'TypeName
               in [Type] -> Name -> Type -> Type -> OpticStab
OpticSa [] Name
optic Type
s' Type
a

           -- Generate type-changing Lens and Traversal otherwise
           | Bool
otherwise =
               let optic :: Name
optic | Bool
isoCase Bool -> Bool -> Bool
&& LensRules -> Bool
_allowIsos LensRules
rules = Name
isoTypeName
                         | Bool
lensCase                    = Name
lensTypeName
                         | Bool
otherwise                   = Name
traversalTypeName
               in Name -> Type -> Type -> Type -> Type -> OpticStab
OpticStab Name
optic Type
s' Type
t Type
a Type
b

         opticType :: OpticType
opticType | Getting Any Type ([TyVarBndrSpec], [Type], Type) -> Type -> Bool
forall s a. Getting Any s a -> s -> Bool
has Getting Any Type ([TyVarBndrSpec], [Type], Type)
Prism' Type ([TyVarBndrSpec], [Type], Type)
_ForallT Type
a            = OpticType
GetterType
                   | Bool -> Bool
not (LensRules -> Bool
_allowUpdates LensRules
rules) = OpticType
GetterType
                   | Bool
isoCase                   = OpticType
IsoType
                   | Bool
otherwise                 = OpticType
LensType

     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
-> Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (OpticType
opticType, OpticStab
defType, [(Name, Int, [(Maybe Name, Int)])]
scaffolds)
  where
  consForDef :: [(Name, [Either Type (Maybe Name, Type)])]
  consForDef :: [(Name, [Either Type (Maybe Name, Type)])]
consForDef = ASetter
  [(Name, [([(DefName, Maybe Name)], Type)])]
  [(Name, [Either Type (Maybe Name, Type)])]
  ([(DefName, Maybe Name)], Type)
  (Either Type (Maybe Name, Type))
-> (([(DefName, Maybe Name)], Type)
    -> Either Type (Maybe Name, Type))
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> [(Name, [Either Type (Maybe Name, Type)])]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (((Name, [([(DefName, Maybe Name)], Type)])
 -> Identity (Name, [Either Type (Maybe Name, Type)]))
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> Identity [(Name, [Either Type (Maybe Name, Type)])]
Setter
  [(Name, [([(DefName, Maybe Name)], Type)])]
  [(Name, [Either Type (Maybe Name, Type)])]
  (Name, [([(DefName, Maybe Name)], Type)])
  (Name, [Either Type (Maybe Name, Type)])
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped (((Name, [([(DefName, Maybe Name)], Type)])
  -> Identity (Name, [Either Type (Maybe Name, Type)]))
 -> [(Name, [([(DefName, Maybe Name)], Type)])]
 -> Identity [(Name, [Either Type (Maybe Name, Type)])])
-> ((([(DefName, Maybe Name)], Type)
     -> Identity (Either Type (Maybe Name, Type)))
    -> (Name, [([(DefName, Maybe Name)], Type)])
    -> Identity (Name, [Either Type (Maybe Name, Type)]))
-> ASetter
     [(Name, [([(DefName, Maybe Name)], Type)])]
     [(Name, [Either Type (Maybe Name, Type)])]
     ([(DefName, Maybe Name)], Type)
     (Either Type (Maybe Name, Type))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([([(DefName, Maybe Name)], Type)]
 -> Identity [Either Type (Maybe Name, Type)])
-> (Name, [([(DefName, Maybe Name)], Type)])
-> Identity (Name, [Either Type (Maybe Name, Type)])
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (Name, [([(DefName, Maybe Name)], Type)])
  (Name, [Either Type (Maybe Name, Type)])
  [([(DefName, Maybe Name)], Type)]
  [Either Type (Maybe Name, Type)]
_2 (([([(DefName, Maybe Name)], Type)]
  -> Identity [Either Type (Maybe Name, Type)])
 -> (Name, [([(DefName, Maybe Name)], Type)])
 -> Identity (Name, [Either Type (Maybe Name, Type)]))
-> ((([(DefName, Maybe Name)], Type)
     -> Identity (Either Type (Maybe Name, Type)))
    -> [([(DefName, Maybe Name)], Type)]
    -> Identity [Either Type (Maybe Name, Type)])
-> (([(DefName, Maybe Name)], Type)
    -> Identity (Either Type (Maybe Name, Type)))
-> (Name, [([(DefName, Maybe Name)], Type)])
-> Identity (Name, [Either Type (Maybe Name, Type)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([(DefName, Maybe Name)], Type)
 -> Identity (Either Type (Maybe Name, Type)))
-> [([(DefName, Maybe Name)], Type)]
-> Identity [Either Type (Maybe Name, Type)]
Setter
  [([(DefName, Maybe Name)], Type)]
  [Either Type (Maybe Name, Type)]
  ([(DefName, Maybe Name)], Type)
  (Either Type (Maybe Name, Type))
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) ([(DefName, Maybe Name)], Type) -> Either Type (Maybe Name, Type)
categorize [(Name, [([(DefName, Maybe Name)], Type)])]
cons

  scaffolds :: [(Name, Int, [(Maybe Name, Int)])]
  scaffolds :: [(Name, Int, [(Maybe Name, Int)])]
scaffolds = [ (Name
n, [Either Type (Maybe Name, Type)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Type (Maybe Name, Type)]
ts, (\(Int
a, Maybe Name
b) -> (Maybe Name
b, Int
a)) ((Int, Maybe Name) -> (Maybe Name, Int))
-> [(Int, Maybe Name)] -> [(Maybe Name, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Either Type (Maybe Name, Type)]
ts [Either Type (Maybe Name, Type)]
-> IndexedGetting
     Int
     (Endo [(Int, Maybe Name)])
     [Either Type (Maybe Name, Type)]
     (Maybe Name)
-> [(Int, Maybe Name)]
forall s i a. s -> IndexedGetting i (Endo [(i, a)]) s a -> [(i, a)]
^@.. Indexed
  Int
  (Either Type (Maybe Name, Type))
  (Const (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
-> [Either Type (Maybe Name, Type)]
-> Const
     (Endo [(Int, Maybe Name)]) [Either Type (Maybe Name, Type)]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold
  Int
  [Either Type (Maybe Name, Type)]
  (Either Type (Maybe Name, Type))
folded (Indexed
   Int
   (Either Type (Maybe Name, Type))
   (Const (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
 -> [Either Type (Maybe Name, Type)]
 -> Const
      (Endo [(Int, Maybe Name)]) [Either Type (Maybe Name, Type)])
-> ((Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
    -> Either Type (Maybe Name, Type)
    -> Const
         (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
-> IndexedGetting
     Int
     (Endo [(Int, Maybe Name)])
     [Either Type (Maybe Name, Type)]
     (Maybe Name)
forall i (p :: * -> * -> *) s t r a b.
Indexable i p =>
(Indexed i s t -> r) -> ((a -> b) -> s -> t) -> p a b -> r
<. ((Maybe Name, Type)
 -> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type))
-> Either Type (Maybe Name, Type)
-> Const
     (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type))
forall c a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Either c a) (f (Either c b))
_Right (((Maybe Name, Type)
  -> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type))
 -> Either Type (Maybe Name, Type)
 -> Const
      (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
-> ((Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
    -> (Maybe Name, Type)
    -> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type))
-> (Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
-> Either Type (Maybe Name, Type)
-> Const
     (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
-> (Maybe Name, Type)
-> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type)
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (Maybe Name, Type) (Maybe Name, Type) (Maybe Name) (Maybe Name)
_1) | (Name
n,[Either Type (Maybe Name, Type)]
ts) <- [(Name, [Either Type (Maybe Name, Type)])]
consForDef ]

  -- Right: types for this definition
  -- Left : other types
  categorize :: ([(DefName, Maybe Name)], Type) -> Either Type (Maybe Name, Type)
  categorize :: ([(DefName, Maybe Name)], Type) -> Either Type (Maybe Name, Type)
categorize ([(DefName, Maybe Name)]
defNames, Type
t) =
    case DefName -> [(DefName, Maybe Name)] -> Maybe (Maybe Name)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup DefName
defName [(DefName, Maybe Name)]
defNames of
    Just Maybe Name
c -> (Maybe Name, Type) -> Either Type (Maybe Name, Type)
forall a b. b -> Either a b
Right (Maybe Name
c, Type
t)
    Maybe (Maybe Name)
Nothing -> Type -> Either Type (Maybe Name, Type)
forall a b. a -> Either a b
Left Type
t

  lensCase :: Bool
  lensCase :: Bool
lensCase = ((Name, [Either Type (Maybe Name, Type)]) -> Bool)
-> [(Name, [Either Type (Maybe Name, Type)])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Name, [Either Type (Maybe Name, Type)])
x -> Getting
  (Endo (Endo Int))
  (Name, [Either Type (Maybe Name, Type)])
  (Maybe Name, Type)
-> (Name, [Either Type (Maybe Name, Type)]) -> Int
forall s a. Getting (Endo (Endo Int)) s a -> s -> Int
lengthOf (([Either Type (Maybe Name, Type)]
 -> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)])
-> (Name, [Either Type (Maybe Name, Type)])
-> Const (Endo (Endo Int)) (Name, [Either Type (Maybe Name, Type)])
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (Name, [Either Type (Maybe Name, Type)])
  (Name, [Either Type (Maybe Name, Type)])
  [Either Type (Maybe Name, Type)]
  [Either Type (Maybe Name, Type)]
_2 (([Either Type (Maybe Name, Type)]
  -> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)])
 -> (Name, [Either Type (Maybe Name, Type)])
 -> Const
      (Endo (Endo Int)) (Name, [Either Type (Maybe Name, Type)]))
-> (((Maybe Name, Type)
     -> Const (Endo (Endo Int)) (Maybe Name, Type))
    -> [Either Type (Maybe Name, Type)]
    -> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)])
-> Getting
     (Endo (Endo Int))
     (Name, [Either Type (Maybe Name, Type)])
     (Maybe Name, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Type (Maybe Name, Type)
 -> Const (Endo (Endo Int)) (Either Type (Maybe Name, Type)))
-> [Either Type (Maybe Name, Type)]
-> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold
  Int
  [Either Type (Maybe Name, Type)]
  (Either Type (Maybe Name, Type))
folded ((Either Type (Maybe Name, Type)
  -> Const (Endo (Endo Int)) (Either Type (Maybe Name, Type)))
 -> [Either Type (Maybe Name, Type)]
 -> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)])
-> (((Maybe Name, Type)
     -> Const (Endo (Endo Int)) (Maybe Name, Type))
    -> Either Type (Maybe Name, Type)
    -> Const (Endo (Endo Int)) (Either Type (Maybe Name, Type)))
-> ((Maybe Name, Type)
    -> Const (Endo (Endo Int)) (Maybe Name, Type))
-> [Either Type (Maybe Name, Type)]
-> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Name, Type) -> Const (Endo (Endo Int)) (Maybe Name, Type))
-> Either Type (Maybe Name, Type)
-> Const (Endo (Endo Int)) (Either Type (Maybe Name, Type))
forall c a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Either c a) (f (Either c b))
_Right) (Name, [Either Type (Maybe Name, Type)])
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) [(Name, [Either Type (Maybe Name, Type)])]
consForDef

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


data OpticStab = OpticStab     Name Type Type Type Type
               | OpticSa   Cxt Name Type Type

stabToType :: OpticStab -> Type
stabToType :: OpticStab -> Type
stabToType (OpticStab  Name
c Type
s Type
t Type
a Type
b) = [Type] -> Type -> Type
quantifyType [] (Name
c Name -> [Type] -> Type
`conAppsT` [Type
s,Type
t,Type
a,Type
b])
stabToType (OpticSa [Type]
cx Name
c Type
s   Type
a  ) = [Type] -> Type -> Type
quantifyType [Type]
cx (Name
c Name -> [Type] -> Type
`conAppsT` [Type
s,Type
a])

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

stabToOptic :: OpticStab -> Name
stabToOptic :: OpticStab -> Name
stabToOptic (OpticStab Name
c Type
_ Type
_ Type
_ Type
_) = Name
c
stabToOptic (OpticSa [Type]
_ Name
c Type
_ Type
_) = Name
c

stabToS :: OpticStab -> Type
stabToS :: OpticStab -> Type
stabToS (OpticStab Name
_ Type
s Type
_ Type
_ Type
_) = Type
s
stabToS (OpticSa [Type]
_ Name
_ Type
s Type
_) = Type
s

stabToA :: OpticStab -> Type
stabToA :: OpticStab -> Type
stabToA (OpticStab Name
_ Type
_ Type
_ Type
a Type
_) = Type
a
stabToA (OpticSa [Type]
_ Name
_ Type
_ Type
a) = Type
a

-- | Compute the s 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.
buildStab :: Type -> [Either Type Type] -> Q (Type,Type,Type,Type)
buildStab :: Type -> [Either Type Type] -> Q (Type, Type, Type, Type)
buildStab Type
s [Either Type Type]
categorizedFields =
  do (Map Name Type
subA,Type
a) <- [Type] -> Q (Map Name Type, Type)
unifyTypes [Type]
targetFields
     let s' :: Type
s' = Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
subA Type
s

     -- compute possible type changes
     Map Name Name
sub <- Map Name (Q Name) -> Q (Map Name Name)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
Map Name (f a) -> f (Map Name a)
T.sequenceA ((Name -> Q Name) -> Set Name -> Map Name (Q Name)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> (Name -> String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) Set Name
unfixedTypeVars)
     let (Type
t,Type
b) = ASetter (Type, Type) (Type, Type) Type Type
-> (Type -> Type) -> (Type, Type) -> (Type, Type)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Type, Type) (Type, Type) Type Type
Traversal (Type, Type) (Type, Type) Type Type
forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both (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, Type) -> Q (Type, Type, Type, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
s',Type
t,Type
a,Type
b)

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

  fixedTypeVars, unfixedTypeVars :: Set Name
  fixedTypeVars :: Set Name
fixedTypeVars   = Set Name -> Set Name
closeOverKinds (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$ Getting (Set Name) [Type] Name -> [Type] -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) [Type] Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' [Type] Name
typeVars [Type]
fixedFields
  unfixedTypeVars :: Set Name
unfixedTypeVars = Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' Type Name
typeVars Type
s Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set Name
fixedTypeVars

  -- Compute the kind variables that appear in the kind of a type variable
  -- binder. For example, @kindVarsOfTvb (x :: (a, b)) = (x, {a, b})@. If a
  -- type variable binder lacks an explicit kind annotation, this
  -- conservatively assumes that there are no kind variables. For example,
  -- @kindVarsOfTvb (y) = (y, {})@.
  kindVarsOfTvb :: D.TyVarBndr_ flag -> (Name, Set Name)
  kindVarsOfTvb :: forall flag. TyVarBndr_ flag -> (Name, Set Name)
kindVarsOfTvb = (Name -> (Name, Set Name))
-> (Name -> Type -> (Name, Set Name))
-> TyVarBndr_ flag
-> (Name, Set Name)
forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
D.elimTV (\Name
n   -> (Name
n, Set Name
forall a. Set a
Set.empty))
                           (\Name
n Type
k -> (Name
n, Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' Type Name
typeVars Type
k))

  -- For each type variable name that appears in @s@, map to the kind variables
  -- that appear in that type variable's kind.
  sKindVarMap :: Map Name (Set Name)
  sKindVarMap :: Map Name (Set Name)
sKindVarMap = [(Name, Set Name)] -> Map Name (Set Name)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Set Name)] -> Map Name (Set Name))
-> [(Name, Set Name)] -> Map Name (Set Name)
forall a b. (a -> b) -> a -> b
$ (TyVarBndr_ () -> (Name, Set Name))
-> [TyVarBndr_ ()] -> [(Name, Set Name)]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ () -> (Name, Set Name)
forall flag. TyVarBndr_ flag -> (Name, Set Name)
kindVarsOfTvb ([TyVarBndr_ ()] -> [(Name, Set Name)])
-> [TyVarBndr_ ()] -> [(Name, Set Name)]
forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndr_ ()]
D.freeVariablesWellScoped [Type
s]

  lookupSKindVars :: Name -> Set Name
  lookupSKindVars :: Name -> Set Name
lookupSKindVars Name
n = Set Name -> Maybe (Set Name) -> Set Name
forall a. a -> Maybe a -> a
fromMaybe Set Name
forall a. Set a
Set.empty (Maybe (Set Name) -> Set Name) -> Maybe (Set Name) -> Set Name
forall a b. (a -> b) -> a -> b
$ Name -> Map Name (Set Name) -> Maybe (Set Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name (Set Name)
sKindVarMap

  -- Consider this example (adapted from #972):
  --
  --   data Dart (s :: k) = Dart { _arc :: Proxy s, _direction :: Int }
  --   $(makeLenses ''Dart)
  --
  -- When generating a Lens for `direction`, the type variable `s` should be
  -- fixed. But note that (s :: k), and as a result, the kind variable `k`
  -- needs to be fixed as well. This is because a type like this would be
  -- ill kinded:
  --
  --   direction :: Lens (Dart (s :: k1)) (Dart (s :: k2)) Direction Direction
  --
  -- However, only `s` is mentioned syntactically in the type of `_arc`, so we
  -- have to infer that `k` is mentioned in the kind of `s`. We accomplish this
  -- with `closeOverKinds`, which does the following:
  --
  -- 1. Use freeVariablesWellScoped to compute the free type variables of
  --    `Dart (s :: k)`, which gives us `(s :: k)`.
  -- 2. For each type variable name in `Proxy s`, the type of `_arc`, look up
  --    the kind variables in the type variable's kind. In the case of `s`,
  --    the only kind variable is `k`.
  -- 3. Add these kind variables to the set of fixed type variables.
  closeOverKinds :: Set Name -> Set Name
  closeOverKinds :: Set Name -> Set Name
closeOverKinds Set Name
st = (Set Name -> Set Name -> Set Name)
-> Set Name -> Set (Set Name) -> Set Name
forall b a. (b -> a -> b) -> b -> Set a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Name
forall a. Set a
Set.empty ((Name -> Set Name) -> Set Name -> Set (Set Name)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Name -> Set Name
lookupSKindVars Set Name
st) Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Name
st

-- | 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, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])) ->
  HasFieldClasses [Dec]
makeFieldOptic :: LensRules
-> (DefName,
    (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules (DefName
defName, (OpticType
opticType, OpticStab
defType, [(Name, Int, [(Maybe Name, Int)])]
cons)) = do
  Set Name
locals <- StateT (Set Name) Q (Set Name)
forall s (m :: * -> *). MonadState s m => m s
get
  HasFieldClasses ()
addName
  DecsQ -> StateT (Set Name) Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> StateT (Set Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DecsQ -> StateT (Set Name) Q [Dec])
-> DecsQ -> StateT (Set Name) Q [Dec]
forall a b. (a -> b) -> a -> b
$ do [DecQ]
cls <- Set Name -> Q [DecQ]
mkCls Set Name
locals
            [DecQ] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
T.sequenceA ([DecQ]
cls [DecQ] -> [DecQ] -> [DecQ]
forall a. [a] -> [a] -> [a]
++ [DecQ]
sig [DecQ] -> [DecQ] -> [DecQ]
forall a. [a] -> [a] -> [a]
++ [DecQ]
def)
  where
  mkCls :: Set Name -> Q [DecQ]
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)
                     [DecQ] -> Q [DecQ]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
classExists Bool -> Bool -> Bool
|| Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Name
c Set Name
locals then [] else [OpticStab -> Name -> Name -> DecQ
makeFieldClass OpticStab
defType Name
c Name
n])
                 DefName
_ -> [DecQ] -> Q [DecQ]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []

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

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

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

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

  clauses :: [Q Clause]
clauses = LensRules
-> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [Q Clause]
makeFieldClauses LensRules
rules OpticType
opticType [(Name, Int, [(Maybe Name, Int)])]
cons

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


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

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

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


makeClassyClass ::
  Name ->
  Name ->
  Type {- ^ Outer 's' type -} ->
  [(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] ->
  DecQ
makeClassyClass :: Name
-> Name
-> Type
-> [(DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> DecQ
makeClassyClass Name
className Name
methodName Type
s [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs = do
  let ss :: [Type]
ss   = ((DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
 -> Type)
-> [(DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (OpticStab -> Type
stabToS (OpticStab -> Type)
-> ((DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
    -> OpticStab)
-> (DefName,
    (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  OpticStab
  (DefName,
   (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
  OpticStab
-> (DefName,
    (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> OpticStab
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (((OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
 -> Const
      OpticStab
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> (DefName,
    (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Const
     OpticStab
     (DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (DefName,
   (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
  (DefName,
   (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
_2 (((OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
  -> Const
       OpticStab
       (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
 -> (DefName,
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
 -> Const
      OpticStab
      (DefName,
       (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])))
-> ((OpticStab -> Const OpticStab OpticStab)
    -> (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
    -> Const
         OpticStab
         (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Getting
     OpticStab
     (DefName,
      (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
     OpticStab
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OpticStab -> Const OpticStab OpticStab)
-> (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
-> Const
     OpticStab
     (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
  OpticStab
  OpticStab
_2)) [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs
  (Map Name Type
sub,Type
s') <- [Type] -> Q (Map Name Type, Type)
unifyTypes (Type
s Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
ss)
  Name
c <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"c"
  let vars :: [TyVarBndr_ BndrVis]
vars     = BndrVis -> [TyVarBndr_ ()] -> [TyVarBndr_ BndrVis]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
D.changeTVFlags BndrVis
bndrReq ([TyVarBndr_ ()] -> [TyVarBndr_ BndrVis])
-> [TyVarBndr_ ()] -> [TyVarBndr_ BndrVis]
forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndr_ ()]
D.freeVariablesWellScoped [Type
s']
      varNames :: [Name]
varNames = (TyVarBndr_ BndrVis -> Name) -> [TyVarBndr_ BndrVis] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ BndrVis -> Name
forall flag. TyVarBndr_ flag -> Name
D.tvName [TyVarBndr_ BndrVis]
vars
      fd :: [FunDep]
fd   | [TyVarBndr_ BndrVis] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr_ BndrVis]
vars = []
           | Bool
otherwise = [[Name] -> [Name] -> FunDep
FunDep [Name
c] [Name]
varNames]


  Q [Type]
-> Name -> [TyVarBndr_ BndrVis] -> [FunDep] -> [DecQ] -> DecQ
forall (m :: * -> *).
Quote m =>
m [Type]
-> Name -> [TyVarBndr_ BndrVis] -> [FunDep] -> [m Dec] -> m Dec
classD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt[]) Name
className (Name -> TyVarBndr_ BndrVis
forall flag. DefaultBndrFlag flag => Name -> TyVarBndr flag
D.plainTV Name
cTyVarBndr_ BndrVis -> [TyVarBndr_ BndrVis] -> [TyVarBndr_ BndrVis]
forall a. a -> [a] -> [a]
:[TyVarBndr_ BndrVis]
vars) [FunDep]
fd
    ([DecQ] -> DecQ) -> [DecQ] -> DecQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Type -> DecQ
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
methodName (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
lens'TypeName Name -> [Type] -> Type
`conAppsT` [Name -> Type
VarT Name
c, Type
s']))
    DecQ -> [DecQ] -> [DecQ]
forall a. a -> [a] -> [a]
: [[DecQ]] -> [DecQ]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Name -> Q Type -> DecQ
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
defName (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)
        ,Q Pat -> Q Body -> [DecQ] -> DecQ
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
defName) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
        ] [DecQ] -> [DecQ] -> [DecQ]
forall a. [a] -> [a] -> [a]
++
        Name -> [DecQ]
inlinePragma Name
defName
      | (TopName Name
defName, (OpticType
_, OpticStab
stab, [(Name, Int, [(Maybe Name, Int)])]
_)) <- [(DefName,
  (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs
      , let body :: Q Exp
body = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
methodName, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
defName]
      , let ty :: Type
ty   = Set Name -> [Type] -> Type -> Type
quantifyType' ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList (Name
cName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
varNames))
                                 (OpticStab -> [Type]
stabToContext OpticStab
stab)
                 (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ OpticStab -> Name
stabToOptic OpticStab
stab Name -> [Type] -> Type
`conAppsT`
                       [Name -> Type
VarT Name
c, Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub (OpticStab -> Type
stabToA OpticStab
stab)]
      ]


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

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

  where
  instanceHead :: Type
instanceHead = Name
className Name -> [Type] -> Type
`conAppsT` (Type
s Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: (TyVarBndr_ () -> Type) -> [TyVarBndr_ ()] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ () -> Type
forall flag. TyVarBndr_ flag -> Type
tvbToType [TyVarBndr_ ()]
vars)
  vars :: [TyVarBndr_ ()]
vars         = [Type] -> [TyVarBndr_ ()]
D.freeVariablesWellScoped [Type
s]
  rules' :: LensRules
rules'       = LensRules
rules { _generateSigs    = False
                       , _generateClasses = False
                       }

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

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

-- | Build an instance for a field. If the field’s type contains any type
-- families, will produce an equality constraint to avoid a type family
-- application in the instance head.
makeFieldInstance :: OpticStab -> Name -> [DecQ] -> DecQ
makeFieldInstance :: OpticStab -> Name -> [DecQ] -> DecQ
makeFieldInstance OpticStab
defType Name
className [DecQ]
decs =
  Type -> Q Bool
containsTypeFamilies Type
a Q Bool -> (Bool -> DecQ) -> DecQ
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> DecQ
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 :: Type -> Q Bool
go (ConT Name
nm) =
      -- Note that the call to `reify` can fail if `nm` is not yet defined.
      -- (This can actually happen if `nm` is declared in a Template Haskell
      -- quote.) If this fails, there is no way to tell if the type contains
      -- type families, so we recover and conservatively assume that is does not
      -- contain any.
      Q Bool -> Q Bool -> Q Bool
forall a. Q a -> Q a -> Q a
recover
        (Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
        (Getting Any Info () -> Info -> Bool
forall s a. Getting Any s a -> s -> Bool
has (((Dec, [Dec]) -> Const Any (Dec, [Dec])) -> Info -> Const Any Info
Prism' Info (Dec, [Dec])
_FamilyI (((Dec, [Dec]) -> Const Any (Dec, [Dec]))
 -> Info -> Const Any Info)
-> ((() -> Const Any ()) -> (Dec, [Dec]) -> Const Any (Dec, [Dec]))
-> Getting Any Info ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dec -> Const Any Dec) -> (Dec, [Dec]) -> Const Any (Dec, [Dec])
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Dec, [Dec]) (Dec, [Dec]) Dec Dec
_1 ((Dec -> Const Any Dec) -> (Dec, [Dec]) -> Const Any (Dec, [Dec]))
-> Getting Any Dec ()
-> (() -> Const Any ())
-> (Dec, [Dec])
-> Const Any (Dec, [Dec])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Any Dec ()
_TypeFamilyD) (Info -> Bool) -> Q Info -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
nm)
    go Type
ty = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> Q [Bool] -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Q Bool) -> [Type] -> Q [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> Q Bool
go (Type
ty Type -> Getting (Endo [Type]) Type Type -> [Type]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Type]) Type Type
forall a. Plated a => Traversal' a a
Traversal' Type Type
plate)

    -- We want to catch type families, but not *data* families. See #799.
    _TypeFamilyD :: Getting Any Dec ()
    _TypeFamilyD :: Getting Any Dec ()
_TypeFamilyD = (TypeFamilyHead -> Const Any TypeFamilyHead)
-> Dec -> Const Any Dec
Prism' Dec TypeFamilyHead
_OpenTypeFamilyD((TypeFamilyHead -> Const Any TypeFamilyHead)
 -> Dec -> Const Any Dec)
-> ((() -> Const Any ())
    -> TypeFamilyHead -> Const Any TypeFamilyHead)
-> Getting Any Dec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(() -> Const Any ()) -> TypeFamilyHead -> Const Any TypeFamilyHead
forall a (f :: * -> *). Functor f => (() -> f ()) -> a -> f a
united Getting Any Dec () -> Getting Any Dec () -> Getting Any Dec ()
forall a. Semigroup a => a -> a -> a
<> ((TypeFamilyHead, [TySynEqn])
 -> Const Any (TypeFamilyHead, [TySynEqn]))
-> Dec -> Const Any Dec
Prism' Dec (TypeFamilyHead, [TySynEqn])
_ClosedTypeFamilyD(((TypeFamilyHead, [TySynEqn])
  -> Const Any (TypeFamilyHead, [TySynEqn]))
 -> Dec -> Const Any Dec)
-> ((() -> Const Any ())
    -> (TypeFamilyHead, [TySynEqn])
    -> Const Any (TypeFamilyHead, [TySynEqn]))
-> Getting Any Dec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(() -> Const Any ())
-> (TypeFamilyHead, [TySynEqn])
-> Const Any (TypeFamilyHead, [TySynEqn])
forall a (f :: * -> *). Functor f => (() -> f ()) -> a -> f a
united

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

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

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


makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [ClauseQ]
makeFieldClauses :: LensRules
-> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [Q Clause]
makeFieldClauses LensRules
rules OpticType
opticType [(Name, Int, [(Maybe Name, Int)])]
cons =
  case OpticType
opticType of

    OpticType
IsoType    -> [ Name -> Q Clause
makeIsoClause Name
conName | (Name
conName, Int
_, [(Maybe Name, Int)]
_) <- [(Name, Int, [(Maybe Name, Int)])]
cons ]

    OpticType
GetterType -> [ Name -> Int -> [Int] -> Q Clause
makeGetterClause Name
conName Int
fieldCount ((Maybe Name, Int) -> Int
forall a b. (a, b) -> b
snd ((Maybe Name, Int) -> Int) -> [(Maybe Name, Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Name, Int)]
fields)
                    | (Name
conName, Int
fieldCount, [(Maybe Name, Int)]
fields) <- [(Name, Int, [(Maybe Name, Int)])]
cons ]

    OpticType
LensType   -> [ Name -> Int -> [(Maybe Name, Int)] -> Bool -> Bool -> Q Clause
makeFieldOpticClause Name
conName Int
fieldCount [(Maybe Name, Int)]
fields Bool
irref Bool
recSyn
                    | (Name
conName, Int
fieldCount, [(Maybe Name, Int)]
fields) <- [(Name, Int, [(Maybe Name, Int)])]
cons ]
      where
      irref :: Bool
irref = LensRules -> Bool
_lazyPatterns LensRules
rules
           Bool -> Bool -> Bool
&& [(Name, Int, [(Maybe Name, Int)])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Int, [(Maybe Name, Int)])]
cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
      recSyn :: Bool
recSyn = LensRules -> Bool
_recordSyntax LensRules
rules Bool -> Bool -> Bool
&& [(Name, Int, [(Maybe Name, Int)])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Int, [(Maybe Name, Int)])]
cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1



-- | Construct an optic clause that returns an unmodified value
-- given a constructor name and the number of fields on that
-- constructor.
makePureClause :: Name -> Int -> ClauseQ
makePureClause :: Name -> Int -> Q Clause
makePureClause Name
conName Int
fieldCount =
  do [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fieldCount
     -- clause: _ (Con x1..xn) = pure (Con x1..xn)
     [Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs)]
            (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pureValName) ([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
xs))))
            []


-- | Construct an optic clause suitable for a Getter or Fold
-- by visited the fields identified by their 0 indexed positions
makeGetterClause :: Name -> Int -> [Int] -> ClauseQ
makeGetterClause :: Name -> Int -> [Int] -> Q Clause
makeGetterClause Name
conName Int
fieldCount []     = Name -> Int -> Q Clause
makePureClause Name
conName Int
fieldCount
makeGetterClause Name
conName Int
fieldCount [Int]
fields =
  do Name
f  <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
     [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fields)
     NonEmpty Name
xs' <-
       case [Name]
xs of
         (Name
x:[Name]
xs') -> NonEmpty Name -> Q (NonEmpty Name)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
x Name -> [Name] -> NonEmpty Name
forall a. a -> [a] -> NonEmpty a
:| [Name]
xs')
         []      -> String -> Q (NonEmpty Name)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeGetterClause: Internal check failed"

     let pats :: [Int] -> [Name] -> [m Pat]
pats (Int
i:[Int]
is) (Name
y:[Name]
ys)
           | Int
i Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
fields = Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y m Pat -> [m Pat] -> [m Pat]
forall a. a -> [a] -> [a]
: [Int] -> [Name] -> [m Pat]
pats [Int]
is [Name]
ys
           | Bool
otherwise = m Pat
forall (m :: * -> *). Quote m => m Pat
wildP m Pat -> [m Pat] -> [m Pat]
forall a. a -> [a] -> [a]
: [Int] -> [Name] -> [m Pat]
pats [Int]
is (Name
yName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
ys)
         pats [Int]
is     [Name]
_  = (Int -> m Pat) -> [Int] -> [m Pat]
forall a b. (a -> b) -> [a] -> [b]
map (m Pat -> Int -> m Pat
forall a b. a -> b -> a
const m Pat
forall (m :: * -> *). Quote m => m Pat
wildP) [Int]
is

         (Q Exp
fx :| [Q Exp]
fxs) = (Name -> Q Exp) -> NonEmpty Name -> NonEmpty (Q Exp)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) (Q Exp -> Q Exp) -> (Name -> Q Exp) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE) NonEmpty Name
xs'
         body :: Q Exp
body  = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
a Q Exp
b -> [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
apValName, Q Exp
a, Q Exp
b])
                       (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
phantomValName) Q Exp
fx)
                       [Q Exp]
fxs

     -- clause f (Con x1..xn) = coerce (f x1) <*> ... <*> f xn
     [Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ([Int] -> [Name] -> [Q Pat]
forall {m :: * -> *}. Quote m => [Int] -> [Name] -> [m Pat]
pats [Int
0..Int
fieldCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] [Name]
xs)]
            (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body)
            []

-- | Build a clause that updates the field at the given indexes
-- When irref is 'True' the value with me matched with an irrefutable
-- pattern. This is suitable for Lens and Traversal construction
makeFieldOpticClause :: Name -> Int -> [(Maybe Name, Int)] -> Bool -> Bool -> ClauseQ
makeFieldOpticClause :: Name -> Int -> [(Maybe Name, Int)] -> Bool -> Bool -> Q Clause
makeFieldOpticClause Name
conName Int
fieldCount [] Bool
_ Bool
_ =
  Name -> Int -> Q Clause
makePureClause Name
conName Int
fieldCount
makeFieldOpticClause Name
_ Int
_ [(Just Name
fieldName, Int
_)] Bool
_ Bool
True =
  do Name
f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
     Name
r <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
     Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
     let body :: Q Exp
body = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ [| fmap |]
                      , [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x] (Q Exp -> [Q (Name, Exp)] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m (Name, Exp)] -> m Exp
recUpdE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r) [(,) Name
fieldName (Exp -> (Name, Exp)) -> Q Exp -> Q (Name, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x])
                      , Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fieldName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r)
                      ]
     [Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
makeFieldOpticClause Name
conName Int
fieldCount ((Maybe Name
_, Int
field):[(Maybe Name, Int)]
fieldsWithNames) Bool
irref Bool
_ =
  do Name
f  <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
     [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fieldCount
     [Name]
ys <- String -> Int -> Q [Name]
newNames String
"y" (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(Maybe Name, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe Name, Int)]
fieldsWithNames)

     let fields :: [Int]
fields = (Maybe Name, Int) -> Int
forall a b. (a, b) -> b
snd ((Maybe Name, Int) -> Int) -> [(Maybe Name, Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Name, Int)]
fieldsWithNames
         xs' :: [Name]
xs' = ((Int, Name) -> [Name] -> [Name])
-> [Name] -> [(Int, Name)] -> [Name]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int
i,Name
x) -> ASetter [Name] [Name] Name Name -> Name -> [Name] -> [Name]
forall s t a b. ASetter s t a b -> b -> s -> t
set (Index [Name] -> Traversal' [Name] (IxValue [Name])
forall m. Ixed m => Index m -> Traversal' 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
fieldInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
fields) [Name]
ys)

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

         body0 :: Q Exp
body0 = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fmapValName
                       , [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
ys) ([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
xs'))
                       , Int -> Q Exp
forall {m :: * -> *}. Quote m => Int -> m Exp
mkFx Int
field
                       ]

         body :: Q Exp
body = (Q Exp -> Int -> Q Exp) -> Q Exp -> [Int] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
a Int
b -> [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
apValName, Q Exp
a, Int -> Q Exp
forall {m :: * -> *}. Quote m => Int -> m Exp
mkFx Int
b]) Q Exp
body0 [Int]
fields

     let wrap :: Q Pat -> Q Pat
wrap = if Bool
irref then Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
tildeP else Q Pat -> Q Pat
forall a. a -> a
id

     [Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Q Pat -> Q Pat
wrap (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs))]
            (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body)
            []


-- | Build a clause that constructs an Iso
makeIsoClause :: Name -> ClauseQ
makeIsoClause :: Name -> Q Clause
makeIsoClause Name
conName = [Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
isoValName, Q Exp
destruct, Q Exp
construct])) []
  where
  destruct :: Q Exp
destruct  = do Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
                 Q Pat -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)

  construct :: Q Exp
construct = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName


------------------------------------------------------------------------
-- Unification logic
------------------------------------------------------------------------

-- The field-oriented optic generation supports incorporating fields
-- with distinct but unifiable types into a single definition.



-- | Unify the given list of types, if possible, and return the
-- substitution used to unify the types for unifying the outer
-- type when building a definition's type signature.
unifyTypes :: [Type] -> Q (Map Name Type, Type)
unifyTypes :: [Type] -> Q (Map Name Type, Type)
unifyTypes (Type
x:[Type]
xs) = ((Map Name Type, Type) -> Type -> Q (Map Name Type, Type))
-> (Map Name Type, Type) -> [Type] -> Q (Map Name Type, Type)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Map Name Type -> Type -> Type -> Q (Map Name Type, Type))
-> (Map Name Type, Type) -> Type -> Q (Map Name Type, Type)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1) (Map Name Type
forall k a. Map k a
Map.empty, Type
x) [Type]
xs
unifyTypes []     = String -> Q (Map Name Type, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unifyTypes: Bug: Unexpected empty list"


-- | Attempt to unify two given types using a running substitution
unify1 :: Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 :: Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub (VarT Name
x) Type
y
  | Just Type
r <- Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
x Map Name Type
sub = Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub Type
r Type
y
unify1 Map Name Type
sub Type
x (VarT Name
y)
  | Just Type
r <- Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
y Map Name Type
sub = Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub Type
x Type
r
unify1 Map Name Type
sub Type
x Type
y
  | Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
y = (Map Name Type, Type) -> Q (Map Name Type, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Type
sub, Type
x)
unify1 Map Name Type
sub (AppT Type
f1 Type
x1) (AppT Type
f2 Type
x2) =
  do (Map Name Type
sub1, Type
f) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub  Type
f1 Type
f2
     (Map Name Type
sub2, Type
x) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub1 Type
x1 Type
x2
     (Map Name Type, Type) -> Q (Map Name Type, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Type
sub2, Type -> Type -> Type
AppT (Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub2 Type
f) Type
x)
unify1 Map Name Type
sub Type
x (VarT Name
y)
  | Getting Any Type Name -> Name -> Type -> Bool
forall a s. Eq a => Getting Any s a -> a -> s -> Bool
elemOf Getting Any Type Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' Type Name
typeVars Name
y (Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub Type
x) =
      String -> Q (Map Name Type, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to unify types: occurs check"
  | Bool
otherwise = (Map Name Type, Type) -> Q (Map Name Type, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
y Type
x Map Name Type
sub, Type
x)
unify1 Map Name Type
sub (VarT Name
x) Type
y = Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub Type
y (Name -> Type
VarT Name
x)

-- TODO: Unify contexts
unify1 Map Name Type
sub (ForallT [TyVarBndrSpec]
v1 [] Type
t1) (ForallT [TyVarBndrSpec]
v2 [] Type
t2) =
     -- This approach works out because by the time this code runs
     -- all of the type variables have been renamed. No risk of shadowing.
  do (Map Name Type
sub1,Type
t) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub Type
t1 Type
t2
     [TyVarBndrSpec]
v <- ([TyVarBndrSpec] -> [TyVarBndrSpec])
-> Q [TyVarBndrSpec] -> Q [TyVarBndrSpec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. Eq a => [a] -> [a]
nub ((TyVarBndrSpec -> Q TyVarBndrSpec)
-> [TyVarBndrSpec] -> Q [TyVarBndrSpec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Map Name Type -> TyVarBndrSpec -> Q TyVarBndrSpec
limitedSubst Map Name Type
sub1) ([TyVarBndrSpec]
v1[TyVarBndrSpec] -> [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. [a] -> [a] -> [a]
++[TyVarBndrSpec]
v2))
     (Map Name Type, Type) -> Q (Map Name Type, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Type
sub1, [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT [TyVarBndrSpec]
v [] Type
t)

unify1 Map Name Type
_ Type
x Type
y = String -> Q (Map Name Type, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Failed to unify types: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Type, Type) -> String
forall a. Show a => a -> String
show (Type
x,Type
y))


-- | Perform a limited substitution on type variables. This is used
-- when unifying rank-2 fields when trying to achieve a Getter or Fold.
limitedSubst :: Map Name Type -> D.TyVarBndrSpec -> Q D.TyVarBndrSpec
limitedSubst :: Map Name Type -> TyVarBndrSpec -> Q TyVarBndrSpec
limitedSubst Map Name Type
sub TyVarBndrSpec
tv
  | Just Type
r <- Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (TyVarBndrSpec -> Name
forall flag. TyVarBndr_ flag -> Name
D.tvName TyVarBndrSpec
tv) Map Name Type
sub =
       case Type
r of
         VarT Name
m -> Map Name Type -> TyVarBndrSpec -> Q TyVarBndrSpec
limitedSubst Map Name Type
sub ((Name -> Name) -> TyVarBndrSpec -> TyVarBndrSpec
forall flag. (Name -> Name) -> TyVarBndr_ flag -> TyVarBndr_ flag
D.mapTVName (Name -> Name -> Name
forall a b. a -> b -> a
const Name
m) TyVarBndrSpec
tv)
         Type
_ -> String -> Q TyVarBndrSpec
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to unify exotic higher-rank type"
  | Bool
otherwise = TyVarBndrSpec -> Q TyVarBndrSpec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return TyVarBndrSpec
tv


-- | Apply a substitution to a type. This is used after unifying
-- the types of the fields in unifyTypes.
applyTypeSubst :: Map Name Type -> Type -> Type
applyTypeSubst :: Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub = (Type -> Maybe Type) -> Type -> Type
forall a. Plated a => (a -> Maybe a) -> a -> a
rewrite Type -> Maybe Type
aux
  where
  aux :: Type -> Maybe Type
aux (VarT Name
n) = Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name Type
sub
  aux Type
_        = Maybe Type
forall a. Maybe a
Nothing


------------------------------------------------------------------------
-- 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 -> Bool
_recordSyntax    :: Bool
  , LensRules -> FieldNamer
_fieldToDef      :: FieldNamer
       -- ^ Type Name -> Field Names -> Target Field Name -> Definition Names
  , LensRules -> ClassyNamer
_classyLenses    :: ClassyNamer
       -- type name to class name and top method
  }

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

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

-- | 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 (Set Name) Q

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