{-# 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 = (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` forall a. Set a
Set.empty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDatatype LensRules
rules 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 = (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` forall a. Set a
Set.empty) 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 forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
       [(Name, [(Maybe Name, Type)])]
fieldCons <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
normalizeConstructor [ConstructorInfo]
cons
       let allFields :: [Name]
allFields  = forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded) [(Name, [(Maybe Name, Type)])]
fieldCons
       let defCons :: [(Name, [([(DefName, Maybe Name)], Type)])]
defCons    = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall a b.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels ([Name] -> Maybe Name -> [(DefName, Maybe Name)]
expandName [Name]
allFields) [(Name, [(Maybe Name, Type)])]
fieldCons
           allDefs :: Set DefName
allDefs    = forall a s. Getting (Set a) s a -> s -> Set a
setOf (forall a b.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1) [(Name, [([(DefName, Maybe Name)], Type)])]
defCons
       forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA (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 = 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 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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
                     forall (m :: * -> *) a. Monad m => a -> m a
return (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.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1

  -- Map a (possibly missing) field's name to zero-to-many optic definitions
  expandName :: [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)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Maybe a -> [a]
maybeToList Maybe Name
mName 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 =
  forall (m :: * -> *) a. Monad m => a -> m a
return (ConstructorInfo -> Name
D.constructorName ConstructorInfo
con,
          forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith 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 -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just [Name]
xs
        ConstructorVariant
D.NormalConstructor    -> forall a. a -> [a]
repeat forall a. Maybe a
Nothing
        ConstructorVariant
D.InfixConstructor     -> forall a. a -> [a]
repeat 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
      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TyVarBndr_ ()
tv -> forall flag. TyVarBndr_ flag -> Name
D.tvName TyVarBndr_ ()
tv forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
used) [TyVarBndr_ ()]
unallowable
      = (forall a. Maybe a
Nothing, b
fieldtype)
      where
        used :: Set Name
used        = forall a s. Getting (Set a) s a -> s -> Set a
setOf forall t. HasTypeVars t => Traversal' t 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 (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd ([(Name, [Either Type (Maybe Name, Type)])]
consForDef forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a b. Prism (Either c a) (Either c b) a b
_Right forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a b. (a, b) -> b
snd))

     let defType :: OpticStab
defType
           | Just ([TyVarBndrSpec]
_,[Type]
cx,Type
a') <- forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview 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' forall a. Eq a => a -> a -> Bool
== Type
t Bool -> Bool -> Bool
&& Type
a 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 | forall s a. Getting Any s a -> s -> Bool
has 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

     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 = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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, 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)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Either Type (Maybe Name, Type)]
ts forall s i a. s -> IndexedGetting i (Endo [(i, a)]) s a -> [(i, a)]
^@.. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded forall i (p :: * -> * -> *) s t r a b.
Indexable i p =>
(Indexed i s t -> r) -> ((a -> b) -> s -> t) -> p a b -> r
<. forall c a b. Prism (Either c a) (Either c b) a b
_Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_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 forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup DefName
defName [(DefName, Maybe Name)]
defNames of
    Just Maybe Name
c -> forall a b. b -> Either a b
Right (Maybe Name
c, Type
t)
    Maybe (Maybe Name)
Nothing -> forall a b. a -> Either a b
Left Type
t

  lensCase :: Bool
  lensCase :: Bool
lensCase = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Name, [Either Type (Maybe Name, Type)])
x -> forall s a. Getting (Endo (Endo Int)) s a -> s -> Int
lengthOf (forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a b. Prism (Either c a) (Either c b) a b
_Right) (Name, [Either Type (Maybe Name, Type)])
x 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 <- forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA (forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) Set Name
unfixedTypeVars)
     let (Type
t,Type
b) = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both (forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub) (Type
s',Type
a)

     forall (m :: * -> *) a. Monad m => a -> m a
return (Type
s',Type
t,Type
a,Type
b)

  where
  ([Type]
fixedFields, [Type]
targetFields) = 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 forall a b. (a -> b) -> a -> b
$ forall a s. Getting (Set a) s a -> s -> Set a
setOf forall t. HasTypeVars t => Traversal' t Name
typeVars [Type]
fixedFields
  unfixedTypeVars :: Set Name
unfixedTypeVars = forall a s. Getting (Set a) s a -> s -> Set a
setOf forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s 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 = forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
D.elimTV (\Name
n   -> (Name
n, forall a. Set a
Set.empty))
                           (\Name
n Type
k -> (Name
n, forall a s. Getting (Set a) s a -> s -> Set a
setOf forall t. HasTypeVars t => Traversal' t 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 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> (Name, Set Name)
kindVarsOfTvb forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndr_ ()]
D.freeVariablesWellScoped [Type
s]

  lookupSKindVars :: Name -> Set Name
  lookupSKindVars :: Name -> Set Name
lookupSKindVars Name
n = forall a. a -> Maybe a -> a
fromMaybe forall a. Set a
Set.empty forall a b. (a -> b) -> a -> b
$ 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Ord a => Set a -> Set a -> Set a
Set.union forall a. Set a
Set.empty (forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Name -> Set Name
lookupSKindVars Set Name
st) 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 <- forall s (m :: * -> *). MonadState s m => m s
get
  HasFieldClasses ()
addName
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do [DecQ]
cls <- Set Name -> Q [DecQ]
mkCls Set Name
locals
            forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA ([DecQ]
cls forall a. [a] -> [a] -> [a]
++ [DecQ]
sig 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 <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Maybe Name)
lookupTypeName (forall a. Show a => a -> String
show Name
c)
                     forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
classExists Bool -> Bool -> 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
_ -> 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
_              -> 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 -> [forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
n (forall (m :: * -> *) a. Monad m => a -> m a
return (OpticStab -> Type
stabToType OpticStab
defType))]
          MethodName{} -> []

  fun :: Name -> [DecQ]
fun Name
n = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
n [ClauseQ]
clauses 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 :: [ClauseQ]
clauses = LensRules
-> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [ClauseQ]
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 = forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA ([StateT (Set Name) Q Dec]
cls forall a. [a] -> [a] -> [a]
++ [StateT (Set Name) Q Dec]
inst)

  where
  cls :: [StateT (Set Name) Q Dec]
cls | LensRules -> Bool
_generateClasses LensRules
rules = [forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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   = forall a b. (a -> b) -> [a] -> [b]
map (OpticStab -> Type
stabToS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_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 forall a. a -> [a] -> [a]
: [Type]
ss)
  Name
c <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"c"
  let vars :: [TyVarBndr_ ()]
vars     = forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
D.changeTVFlags ()
bndrReq forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndr_ ()]
D.freeVariablesWellScoped [Type
s']
      varNames :: [Name]
varNames = forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
D.tvName [TyVarBndr_ ()]
vars
      fd :: [FunDep]
fd   | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr_ ()]
vars = []
           | Bool
otherwise = [[Name] -> [Name] -> FunDep
FunDep [Name
c] [Name]
varNames]


  forall (m :: * -> *).
Quote m =>
m [Type] -> Name -> [TyVarBndr_ ()] -> [FunDep] -> [m Dec] -> m Dec
classD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt[]) Name
className (Name -> TyVarBndr_ ()
D.plainTV Name
cforall a. a -> [a] -> [a]
:[TyVarBndr_ ()]
vars) [FunDep]
fd
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
methodName (forall (m :: * -> *) a. Monad m => a -> m a
return (Name
lens'TypeName Name -> [Type] -> Type
`conAppsT` [Name -> Type
VarT Name
c, Type
s']))
    forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
defName (forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)
        ,forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
defName) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
        ] 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 = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
methodName, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
defName]
      , let ty :: Type
ty   = Set Name -> [Type] -> Type -> Type
quantifyType' (forall a. Ord a => [a] -> Set a
Set.fromList (Name
cforall a. a -> [a] -> [a]
:[Name]
varNames))
                                 (OpticStab -> [Type]
stabToContext OpticStab
stab)
                 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 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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

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

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

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

makeFieldClass :: OpticStab -> Name -> Name -> DecQ
makeFieldClass :: OpticStab -> Name -> Name -> DecQ
makeFieldClass OpticStab
defType Name
className Name
methodName =
  forall (m :: * -> *).
Quote m =>
m [Type] -> Name -> [TyVarBndr_ ()] -> [FunDep] -> [m Dec] -> m Dec
classD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt []) Name
className [Name -> TyVarBndr_ ()
D.plainTV Name
s, Name -> TyVarBndr_ ()
D.plainTV Name
a] [[Name] -> [Name] -> FunDep
FunDep [Name
s] [Name
a]]
         [forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
methodName (forall (m :: * -> *) a. Monad m => a -> m a
return Type
methodType)]
  where
  methodType :: Type
methodType = Set Name -> [Type] -> Type -> Type
quantifyType' (forall a. Ord a => [a] -> Set a
Set.fromList [Name
s,Name
a])
                             (OpticStab -> [Type]
stabToContext OpticStab
defType)
             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 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 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.
      forall a. Q a -> Q a -> Q a
recover
        (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
        (forall s a. Getting Any s a -> s -> Bool
has (Prism' Info (Dec, [Dec])
_FamilyI forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Any Dec ()
_TypeFamilyD) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
nm)
    go Type
ty = forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Q Bool
go (Type
ty forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall a. Plated a => Traversal' a a
plate)

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

  pickInstanceDec :: Bool -> DecQ
pickInstanceDec Bool
hasFamilies
    | Bool
hasFamilies = do
        Type
placeholder <- Name -> Type
VarT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
        [Q Type] -> [Type] -> DecQ
mkInstanceDec
          [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 =
    forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt [Q Type]
context) (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)])] -> [ClauseQ]
makeFieldClauses LensRules
rules OpticType
opticType [(Name, Int, [(Maybe Name, Int)])]
cons =
  case OpticType
opticType of

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

    OpticType
GetterType -> [ Name -> Int -> [Int] -> ClauseQ
makeGetterClause Name
conName Int
fieldCount (forall a b. (a, b) -> b
snd 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 -> ClauseQ
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
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Int, [(Maybe Name, Int)])]
cons forall a. Eq a => a -> a -> Bool
== Int
1
      recSyn :: Bool
recSyn = LensRules -> Bool
_recordSyntax LensRules
rules Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Int, [(Maybe Name, Int)])]
cons 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 -> ClauseQ
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)
     forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs)]
            (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pureValName) (forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map 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] -> ClauseQ
makeGetterClause Name
conName Int
fieldCount []     = Name -> Int -> ClauseQ
makePureClause Name
conName Int
fieldCount
makeGetterClause Name
conName Int
fieldCount [Int]
fields =
  do Name
f  <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
     [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fields)
     NonEmpty Name
xs' <-
       case [Name]
xs of
         (Name
x:[Name]
xs') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
x forall a. a -> [a] -> NonEmpty a
:| [Name]
xs')
         []      -> 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
fields = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y forall a. a -> [a] -> [a]
: [Int] -> [Name] -> [m Pat]
pats [Int]
is [Name]
ys
           | Bool
otherwise = forall (m :: * -> *). Quote m => m Pat
wildP forall a. a -> [a] -> [a]
: [Int] -> [Name] -> [m Pat]
pats [Int]
is (Name
yforall a. a -> [a] -> [a]
:[Name]
ys)
         pats [Int]
is     [Name]
_  = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const forall (m :: * -> *). Quote m => m Pat
wildP) [Int]
is

         (Q Exp
fx :| [Q Exp]
fxs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => Name -> m Exp
varE) NonEmpty Name
xs'
         body :: Q Exp
body  = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
a Q Exp
b -> forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
apValName, Q Exp
a, Q Exp
b])
                       (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (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
     forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName (forall {m :: * -> *}. Quote m => [Int] -> [Name] -> [m Pat]
pats [Int
0..Int
fieldCount forall a. Num a => a -> a -> a
- Int
1] [Name]
xs)]
            (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 -> ClauseQ
makeFieldOpticClause Name
conName Int
fieldCount [] Bool
_ Bool
_ =
  Name -> Int -> ClauseQ
makePureClause Name
conName Int
fieldCount
makeFieldOpticClause Name
_ Int
_ [(Just Name
fieldName, Int
_)] Bool
_ Bool
True =
  do Name
f <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
     Name
r <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
     Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
     let body :: Q Exp
body = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ [| fmap |]
                      , forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x] (forall (m :: * -> *). Quote m => m Exp -> [m (Name, Exp)] -> m Exp
recUpdE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r) [(,) Name
fieldName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x])
                      , forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fieldName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r)
                      ]
     forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r] (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  <- 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 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe Name, Int)]
fieldsWithNames)

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

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

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

         body :: Q Exp
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
a Int
b -> forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
apValName, Q Exp
a, 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 forall (m :: * -> *). Quote m => m Pat -> m Pat
tildeP else forall a. a -> a
id

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


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

  construct :: Q Exp
construct = 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) = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1) (forall k a. Map k a
Map.empty, Type
x) [Type]
xs
unifyTypes []     = 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 <- 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 <- 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 forall a. Eq a => a -> a -> Bool
== Type
y = 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
     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)
  | forall a s. Eq a => Getting Any s a -> a -> s -> Bool
elemOf forall t. HasTypeVars t => Traversal' t Name
typeVars Name
y (Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub Type
x) =
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to unify types: occurs check"
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Eq a => [a] -> [a]
nub (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Map Name Type -> TyVarBndrSpec -> Q TyVarBndrSpec
limitedSubst Map Name Type
sub1) ([TyVarBndrSpec]
v1forall a. [a] -> [a] -> [a]
++[TyVarBndrSpec]
v2))
     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 = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Failed to unify types: " forall a. [a] -> [a] -> [a]
++ 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 <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (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 (forall flag. (Name -> Name) -> TyVarBndr_ flag -> TyVarBndr_ flag
D.mapTVName (forall a b. a -> b -> a
const Name
m) TyVarBndrSpec
tv)
         Type
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to unify exotic higher-rank type"
  | Bool
otherwise = 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 = forall a. Plated a => (a -> Maybe a) -> a -> a
rewrite Type -> Maybe Type
aux
  where
  aux :: Type -> Maybe Type
aux (VarT Name
n) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name Type
sub
  aux 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 -> ShowS
[DefName] -> ShowS
DefName -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefName] -> ShowS
$cshowList :: [DefName] -> ShowS
show :: DefName -> String
$cshow :: DefName -> String
showsPrec :: Int -> DefName -> ShowS
$cshowsPrec :: Int -> DefName -> ShowS
Show, DefName -> DefName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DefName -> DefName -> Bool
$c/= :: DefName -> DefName -> Bool
== :: DefName -> DefName -> Bool
$c== :: DefName -> DefName -> Bool
Eq, Eq DefName
DefName -> DefName -> Bool
DefName -> DefName -> Ordering
DefName -> DefName -> DefName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DefName -> DefName -> DefName
$cmin :: DefName -> DefName -> DefName
max :: DefName -> DefName -> DefName
$cmax :: DefName -> DefName -> DefName
>= :: DefName -> DefName -> Bool
$c>= :: DefName -> DefName -> Bool
> :: DefName -> DefName -> Bool
$c> :: DefName -> DefName -> Bool
<= :: DefName -> DefName -> Bool
$c<= :: DefName -> DefName -> Bool
< :: DefName -> DefName -> Bool
$c< :: DefName -> DefName -> Bool
compare :: DefName -> DefName -> Ordering
$ccompare :: DefName -> DefName -> Ordering
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 = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
Set.insert Name
n