    {-# LANGUAGE CPP #-}
    #ifdef TRUSTWORTHY
    {-# LANGUAGE Trustworthy #-}
    #endif

    #if __GLASGOW_HASKELL__ >= 800
    {-# OPTIONS_GHC -Wno-trustworthy-safe #-}
    #endif

    #ifndef MIN_VERSION_template_haskell
    #define MIN_VERSION_template_haskell(x,y,z) 1
    #endif
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Control.Lens.Internal.PrismTH
    -- Copyright   :  (C) 2014-2016 Edward Kmett and Eric Mertens
    -- License     :  BSD-style (see the file LICENSE)
    -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
    -- Stability   :  experimental
    -- Portability :  non-portable
    --
    -----------------------------------------------------------------------------

    module Control.Lens.Internal.PrismTH
      ( makePrisms
      , makeClassyPrisms
      , makeDecPrisms
      ) where

    import Control.Applicative
    import Control.Lens.Fold
    import Control.Lens.Getter
    import Control.Lens.Internal.TH
    import Control.Lens.Lens
    import Control.Lens.Setter
    import Control.Monad
    import Data.Char (isUpper)
    import Data.List
    import Data.Set.Lens
    import Data.Traversable
    import Language.Haskell.TH
    import qualified Language.Haskell.TH.Datatype as D
    import Language.Haskell.TH.Lens
    import qualified Data.Map as Map
    import qualified Data.Set as Set
    import Prelude

    -- | Generate a 'Prism' for each constructor of a data type.
    -- Isos generated when possible.
    -- Reviews are created for constructors with existentially
    -- quantified constructors and GADTs.
    --
    -- /e.g./
    --
    -- @
    -- data FooBarBaz a
    --   = Foo Int
    --   | Bar a
    --   | Baz Int Char
    -- makePrisms ''FooBarBaz
    -- @
    --
    -- will create
    --
    -- @
    -- _Foo :: Prism' (FooBarBaz a) Int
    -- _Bar :: Prism (FooBarBaz a) (FooBarBaz b) a b
    -- _Baz :: Prism' (FooBarBaz a) (Int, Char)
    -- @
    makePrisms :: Name {- ^ Type constructor name -} -> DecsQ
    makePrisms :: Name -> DecsQ
    makePrisms = Bool -> Name -> DecsQ
    makePrisms' Bool
    True

    -- | Generate a 'Prism' for each constructor of a data type
    -- and combine them into a single class. No Isos are created.
    -- Reviews are created for constructors with existentially
    -- quantified constructors and GADTs.
    --
    -- /e.g./
    --
    -- @
    -- data FooBarBaz a
    --   = Foo Int
    --   | Bar a
    --   | Baz Int Char
    -- makeClassyPrisms ''FooBarBaz
    -- @
    --
    -- will create
    --
    -- @
    -- class AsFooBarBaz s a | s -> a where
    --   _FooBarBaz :: Prism' s (FooBarBaz a)
    --   _Foo :: Prism' s Int
    --   _Bar :: Prism' s a
    --   _Baz :: Prism' s (Int,Char)
    --
    --   _Foo = _FooBarBaz . _Foo
    --   _Bar = _FooBarBaz . _Bar
    --   _Baz = _FooBarBaz . _Baz
    --
    -- instance AsFooBarBaz (FooBarBaz a) a
    -- @
    --
    -- Generate an "As" class of prisms. Names are selected by prefixing the constructor
    -- name with an underscore.  Constructors with multiple fields will
    -- construct Prisms to tuples of those fields.
    --
    -- In the event that the name of a data type is also the name of one of its
    -- constructors, the name of the 'Prism' generated for the data type will be
    -- prefixed with an extra @_@ (if the data type name is prefix) or @.@ (if the
    -- name is infix) to disambiguate it from the 'Prism' for the corresponding
    -- constructor. For example, this code:
    --
    -- @
    -- data Quux = Quux Int | Fred Bool
    -- makeClassyPrisms ''Quux
    -- @
    --
    -- will create:
    --
    -- @
    -- class AsQuux s where
    --   __Quux :: Prism' s Quux -- Data type prism
    --   _Quux :: Prism' s Int   -- Constructor prism
    --   _Fred :: Prism' s Bool
    --
    --   _Quux = __Quux . _Quux
    --   _Fred = __Quux . _Fred
    --
    -- instance AsQuux Quux
    -- @
    makeClassyPrisms :: Name {- ^ Type constructor name -} -> DecsQ
    makeClassyPrisms :: Name -> DecsQ
    makeClassyPrisms = Bool -> Name -> DecsQ
    makePrisms' Bool
    False

    -- | Main entry point into Prism generation for a given type constructor name.
    makePrisms' :: Bool -> Name -> DecsQ
    makePrisms' :: Bool -> Name -> DecsQ
    makePrisms' normal :: Bool
    normal typeName :: Name
    typeName =
      do DatatypeInfo
    info <- Name -> Q DatatypeInfo
    D.reifyDatatype Name
    typeName
         let cls :: Maybe Name
    cls | Bool
    normal    = Maybe Name
    forall a. Maybe a
    Nothing
                 | Bool
    otherwise = Name -> Maybe Name
    forall a. a -> Maybe a
    Just (DatatypeInfo -> Name
    D.datatypeName DatatypeInfo
    info)
             cons :: [ConstructorInfo]
    cons = DatatypeInfo -> [ConstructorInfo]
    D.datatypeCons DatatypeInfo
    info
         Type -> [NCon] -> Maybe Name -> DecsQ
    makeConsPrisms (DatatypeInfo -> Type
    D.datatypeType DatatypeInfo
    info) ((ConstructorInfo -> NCon) -> [ConstructorInfo] -> [NCon]
    forall a b. (a -> b) -> [a] -> [b]
    map ConstructorInfo -> NCon
    normalizeCon [ConstructorInfo]
    cons) Maybe Name
    cls

    -- | Generate prisms for the given 'Dec'
    makeDecPrisms :: Bool {- ^ generate top-level definitions -} -> Dec -> DecsQ
    makeDecPrisms :: Bool -> Dec -> DecsQ
    makeDecPrisms normal :: Bool
    normal dec :: Dec
    dec =
      do DatatypeInfo
    info <- Dec -> Q DatatypeInfo
    D.normalizeDec Dec
    dec
         let cls :: Maybe Name
    cls | Bool
    normal    = Maybe Name
    forall a. Maybe a
    Nothing
                 | Bool
    otherwise = Name -> Maybe Name
    forall a. a -> Maybe a
    Just (DatatypeInfo -> Name
    D.datatypeName DatatypeInfo
    info)
             cons :: [ConstructorInfo]
    cons = DatatypeInfo -> [ConstructorInfo]
    D.datatypeCons DatatypeInfo
    info
         Type -> [NCon] -> Maybe Name -> DecsQ
    makeConsPrisms (DatatypeInfo -> Type
    D.datatypeType DatatypeInfo
    info) ((ConstructorInfo -> NCon) -> [ConstructorInfo] -> [NCon]
    forall a b. (a -> b) -> [a] -> [b]
    map ConstructorInfo -> NCon
    normalizeCon [ConstructorInfo]
    cons) Maybe Name
    cls

    -- | Generate prisms for the given type, normalized constructors, and
    -- an optional name to be used for generating a prism class.
    -- This function dispatches between Iso generation, normal top-level
    -- prisms, and classy prisms.
    makeConsPrisms :: Type -> [NCon] -> Maybe Name -> DecsQ

    -- special case: single constructor, not classy -> make iso
    makeConsPrisms :: Type -> [NCon] -> Maybe Name -> DecsQ
    makeConsPrisms t :: Type
    t [con :: NCon
    con@(NCon _ [] [] _)] Nothing = Type -> NCon -> DecsQ
    makeConIso Type
    t NCon
    con

    -- top-level definitions
    makeConsPrisms t :: Type
    t cons :: [NCon]
    cons Nothing =
      ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat (Q [[Dec]] -> DecsQ) -> Q [[Dec]] -> DecsQ
    forall a b. (a -> b) -> a -> b
    $ [NCon] -> (NCon -> DecsQ) -> Q [[Dec]]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    t a -> (a -> f b) -> f (t b)
    for [NCon]
    cons ((NCon -> DecsQ) -> Q [[Dec]]) -> (NCon -> DecsQ) -> Q [[Dec]]
    forall a b. (a -> b) -> a -> b
    $ \con :: NCon
    con ->
        do let conName :: Name
    conName = Getting Name NCon Name -> NCon -> Name
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Name NCon Name
    Lens' NCon Name
    nconName NCon
    con
           Stab
    stab <- Type -> [NCon] -> NCon -> Q Stab
    computeOpticType Type
    t [NCon]
    cons NCon
    con
           let n :: Name
    n = Name -> Name
    prismName Name
    conName
           [Q Dec] -> DecsQ
    forall (t :: * -> *) (f :: * -> *) a.
    (Traversable t, Applicative f) =>
    t (f a) -> f (t a)
    sequenceA
             ( [ Name -> TypeQ -> Q Dec
    sigD Name
    n (Type -> TypeQ
    close (Stab -> Type
    stabToType Stab
    stab))
               , PatQ -> BodyQ -> [Q Dec] -> Q Dec
    valD (Name -> PatQ
    varP Name
    n) (ExpQ -> BodyQ
    normalB (Stab -> [NCon] -> NCon -> ExpQ
    makeConOpticExp Stab
    stab [NCon]
    cons NCon
    con)) []
               ]
               [Q Dec] -> [Q Dec] -> [Q Dec]
    forall a. [a] -> [a] -> [a]
    ++ Name -> [Q Dec]
    inlinePragma Name
    n
             )

    -- classy prism class and instance
    makeConsPrisms t :: Type
    t cons :: [NCon]
    cons (Just typeName :: Name
    typeName) =
      [Q Dec] -> DecsQ
    forall (t :: * -> *) (f :: * -> *) a.
    (Traversable t, Applicative f) =>
    t (f a) -> f (t a)
    sequenceA
        [ Type -> Name -> Name -> [NCon] -> Q Dec
    makeClassyPrismClass Type
    t Name
    className Name
    methodName [NCon]
    cons
        , Type -> Name -> Name -> [NCon] -> Q Dec
    makeClassyPrismInstance Type
    t Name
    className Name
    methodName [NCon]
    cons
        ]
      where
      typeNameBase :: String
    typeNameBase = Name -> String
    nameBase Name
    typeName
      className :: Name
    className = String -> Name
    mkName ("As" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    typeNameBase)
      sameNameAsCon :: Bool
    sameNameAsCon = (NCon -> Bool) -> [NCon] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (\con :: NCon
    con -> Name -> String
    nameBase (Getting Name NCon Name -> NCon -> Name
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Name NCon Name
    Lens' NCon Name
    nconName NCon
    con) String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    typeNameBase) [NCon]
    cons
      methodName :: Name
    methodName = Bool -> Name -> Name
    prismName' Bool
    sameNameAsCon Name
    typeName

    data OpticType = PrismType | ReviewType
    data Stab  = Stab Cxt OpticType Type Type Type Type

    simplifyStab :: Stab -> Stab
    simplifyStab :: Stab -> Stab
    simplifyStab (Stab cx :: Cxt
    cx ty :: OpticType
    ty _ t :: Type
    t _ b :: Type
    b) = Cxt -> OpticType -> Type -> Type -> Type -> Type -> Stab
    Stab Cxt
    cx OpticType
    ty Type
    t Type
    t Type
    b Type
    b
      -- simplification uses t and b because those types
      -- are interesting in the Review case

    stabSimple :: Stab -> Bool
    stabSimple :: Stab -> Bool
    stabSimple (Stab _ _ s :: Type
    s t :: Type
    t a :: Type
    a b :: Type
    b) = 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

    stabToType :: Stab -> Type
    stabToType :: Stab -> Type
    stabToType stab :: Stab
    stab@(Stab cx :: Cxt
    cx ty :: OpticType
    ty s :: Type
    s t :: Type
    t a :: Type
    a b :: Type
    b) = [TyVarBndr] -> Cxt -> Type -> Type
    ForallT [TyVarBndr]
    vs Cxt
    cx (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $
      case OpticType
    ty of
        PrismType  | Stab -> Bool
    stabSimple Stab
    stab -> Name
    prism'TypeName  Name -> Cxt -> Type
    `conAppsT` [Type
    t,Type
    b]
                   | Bool
    otherwise       -> Name
    prismTypeName   Name -> Cxt -> Type
    `conAppsT` [Type
    s,Type
    t,Type
    a,Type
    b]
        ReviewType                   -> Name
    reviewTypeName  Name -> Cxt -> Type
    `conAppsT` [Type
    t,Type
    b]

      where
      vs :: [TyVarBndr]
    vs = (Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> TyVarBndr
    PlainTV
         ([Name] -> [TyVarBndr]) -> [Name] -> [TyVarBndr]
    forall a b. (a -> b) -> a -> b
    $ [Name] -> [Name]
    forall a. Eq a => [a] -> [a]
    nub -- stable order
         ([Name] -> [Name]) -> [Name] -> [Name]
    forall a b. (a -> b) -> a -> b
    $ Getting (Endo [Name]) Cxt Name -> Cxt -> [Name]
    forall a s. Getting (Endo [a]) s a -> s -> [a]
    toListOf Getting (Endo [Name]) Cxt Name
    forall t. HasTypeVars t => Traversal' t Name
    typeVars Cxt
    cx

    stabType :: Stab -> OpticType
    stabType :: Stab -> OpticType
    stabType (Stab _ o :: OpticType
    o _ _ _ _) = OpticType
    o

    computeOpticType :: Type -> [NCon] -> NCon -> Q Stab
    computeOpticType :: Type -> [NCon] -> NCon -> Q Stab
    computeOpticType t :: Type
    t cons :: [NCon]
    cons con :: NCon
    con =
      do let cons' :: [NCon]
    cons' = NCon -> [NCon] -> [NCon]
    forall a. Eq a => a -> [a] -> [a]
    delete NCon
    con [NCon]
    cons
         if [Name] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (NCon -> [Name]
    _nconVars NCon
    con)
             then Type -> Cxt -> [NCon] -> NCon -> Q Stab
    computePrismType Type
    t (Getting Cxt NCon Cxt -> NCon -> Cxt
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Cxt NCon Cxt
    Lens' NCon Cxt
    nconCxt NCon
    con) [NCon]
    cons' NCon
    con
             else Type -> Cxt -> Cxt -> Q Stab
    computeReviewType Type
    t (Getting Cxt NCon Cxt -> NCon -> Cxt
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Cxt NCon Cxt
    Lens' NCon Cxt
    nconCxt NCon
    con) (Getting Cxt NCon Cxt -> NCon -> Cxt
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Cxt NCon Cxt
    Lens' NCon Cxt
    nconTypes NCon
    con)

    computeReviewType :: Type -> Cxt -> [Type] -> Q Stab
    computeReviewType :: Type -> Cxt -> Cxt -> Q Stab
    computeReviewType s' :: Type
    s' cx :: Cxt
    cx tys :: Cxt
    tys =
      do let t :: Type
    t = Type
    s'
         Type
    s <- (Name -> Type) -> Q Name -> TypeQ
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Name -> Type
    VarT (String -> Q Name
    newName "s")
         Type
    a <- (Name -> Type) -> Q Name -> TypeQ
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Name -> Type
    VarT (String -> Q Name
    newName "a")
         Type
    b <- [TypeQ] -> TypeQ
    toTupleT ((Type -> TypeQ) -> Cxt -> [TypeQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return Cxt
    tys)
         Stab -> Q Stab
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Cxt -> OpticType -> Type -> Type -> Type -> Type -> Stab
    Stab Cxt
    cx OpticType
    ReviewType Type
    s Type
    t Type
    a Type
    b)

    -- | Compute the full type-changing Prism type given an outer type,
    -- list of constructors, and target constructor name. Additionally
    -- return 'True' if the resulting type is a "simple" prism.
    computePrismType :: Type -> Cxt -> [NCon] -> NCon -> Q Stab
    computePrismType :: Type -> Cxt -> [NCon] -> NCon -> Q Stab
    computePrismType t :: Type
    t cx :: Cxt
    cx cons :: [NCon]
    cons con :: NCon
    con =
      do let ts :: Cxt
    ts      = Getting Cxt NCon Cxt -> NCon -> Cxt
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Cxt NCon Cxt
    Lens' NCon Cxt
    nconTypes NCon
    con
             unbound :: Set Name
    unbound = 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
    typeVars Type
    t Set Name -> Set Name -> Set Name
    forall a. Ord a => Set a -> Set a -> Set a
    Set.\\ Getting (Set Name) [NCon] Name -> [NCon] -> Set Name
    forall a s. Getting (Set a) s a -> s -> Set a
    setOf Getting (Set Name) [NCon] Name
    forall t. HasTypeVars t => Traversal' t Name
    typeVars [NCon]
    cons
         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)
    sequenceA ((Name -> Q Name) -> Set Name -> Map Name (Q Name)
    forall k v. (k -> v) -> Set k -> Map k v
    fromSet (String -> Q Name
    newName (String -> Q Name) -> (Name -> String) -> Name -> Q Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> String
    nameBase) Set Name
    unbound)
         Type
    b   <- [TypeQ] -> TypeQ
    toTupleT ((Type -> TypeQ) -> Cxt -> [TypeQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return Cxt
    ts)
         Type
    a   <- [TypeQ] -> TypeQ
    toTupleT ((Type -> TypeQ) -> Cxt -> [TypeQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Map Name Name -> Cxt -> Cxt
    forall t. HasTypeVars t => Map Name Name -> t -> t
    substTypeVars Map Name Name
    sub Cxt
    ts))
         let s :: Type
    s = Map Name Name -> Type -> Type
    forall t. HasTypeVars t => Map Name Name -> t -> t
    substTypeVars Map Name Name
    sub Type
    t
         Stab -> Q Stab
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Cxt -> OpticType -> Type -> Type -> Type -> Type -> Stab
    Stab Cxt
    cx OpticType
    PrismType Type
    s Type
    t Type
    a Type
    b)

    computeIsoType :: Type -> [Type] -> TypeQ
    computeIsoType :: Type -> Cxt -> TypeQ
    computeIsoType t' :: Type
    t' fields :: Cxt
    fields =
      do 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)
    sequenceA ((Name -> Q Name) -> Set Name -> Map Name (Q Name)
    forall k v. (k -> v) -> Set k -> Map k v
    fromSet (String -> Q Name
    newName (String -> Q Name) -> (Name -> String) -> Name -> Q Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> String
    nameBase) (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
    typeVars Type
    t'))
         let t :: TypeQ
    t = Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return                    Type
    t'
             s :: TypeQ
    s = Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Map Name Name -> Type -> Type
    forall t. HasTypeVars t => Map Name Name -> t -> t
    substTypeVars Map Name Name
    sub Type
    t')
             b :: TypeQ
    b = [TypeQ] -> TypeQ
    toTupleT ((Type -> TypeQ) -> Cxt -> [TypeQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return                    Cxt
    fields)
             a :: TypeQ
    a = [TypeQ] -> TypeQ
    toTupleT ((Type -> TypeQ) -> Cxt -> [TypeQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Map Name Name -> Cxt -> Cxt
    forall t. HasTypeVars t => Map Name Name -> t -> t
    substTypeVars Map Name Name
    sub Cxt
    fields))

    #ifndef HLINT
             ty :: TypeQ
    ty | Map Name Name -> Bool
    forall k a. Map k a -> Bool
    Map.null Map Name Name
    sub = TypeQ -> [TypeQ] -> TypeQ
    appsT (Name -> TypeQ
    conT Name
    iso'TypeName) [TypeQ
    t,TypeQ
    b]
                | Bool
    otherwise    = TypeQ -> [TypeQ] -> TypeQ
    appsT (Name -> TypeQ
    conT Name
    isoTypeName) [TypeQ
    s,TypeQ
    t,TypeQ
    a,TypeQ
    b]
    #endif

         Type -> TypeQ
    close (Type -> TypeQ) -> TypeQ -> TypeQ
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< TypeQ
    ty

    -- | Construct either a Review or Prism as appropriate
    makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ
    makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ
    makeConOpticExp stab :: Stab
    stab cons :: [NCon]
    cons con :: NCon
    con =
      case Stab -> OpticType
    stabType Stab
    stab of
        PrismType  -> Stab -> [NCon] -> NCon -> ExpQ
    makeConPrismExp Stab
    stab [NCon]
    cons NCon
    con
        ReviewType -> NCon -> ExpQ
    makeConReviewExp NCon
    con

    -- | Construct an iso declaration
    makeConIso :: Type -> NCon -> DecsQ
    makeConIso :: Type -> NCon -> DecsQ
    makeConIso s :: Type
    s con :: NCon
    con =
      do let ty :: TypeQ
    ty      = Type -> Cxt -> TypeQ
    computeIsoType Type
    s (Getting Cxt NCon Cxt -> NCon -> Cxt
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Cxt NCon Cxt
    Lens' NCon Cxt
    nconTypes NCon
    con)
             defName :: Name
    defName = Name -> Name
    prismName (Getting Name NCon Name -> NCon -> Name
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Name NCon Name
    Lens' NCon Name
    nconName NCon
    con)
         [Q Dec] -> DecsQ
    forall (t :: * -> *) (f :: * -> *) a.
    (Traversable t, Applicative f) =>
    t (f a) -> f (t a)
    sequenceA
           ( [ Name -> TypeQ -> Q Dec
    sigD       Name
    defName  TypeQ
    ty
             , PatQ -> BodyQ -> [Q Dec] -> Q Dec
    valD (Name -> PatQ
    varP Name
    defName) (ExpQ -> BodyQ
    normalB (NCon -> ExpQ
    makeConIsoExp NCon
    con)) []
             ] [Q Dec] -> [Q Dec] -> [Q Dec]
    forall a. [a] -> [a] -> [a]
    ++
             Name -> [Q Dec]
    inlinePragma Name
    defName
           )

    -- | Construct prism expression
    --
    -- prism <<reviewer>> <<remitter>>
    makeConPrismExp ::
      Stab ->
      [NCon] {- ^ constructors       -} ->
      NCon   {- ^ target constructor -} ->
      ExpQ
    makeConPrismExp :: Stab -> [NCon] -> NCon -> ExpQ
    makeConPrismExp stab :: Stab
    stab cons :: [NCon]
    cons con :: NCon
    con = [ExpQ] -> ExpQ
    appsE [Name -> ExpQ
    varE Name
    prismValName, ExpQ
    reviewer, ExpQ
    remitter]
      where
      ts :: Cxt
    ts = Getting Cxt NCon Cxt -> NCon -> Cxt
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Cxt NCon Cxt
    Lens' NCon Cxt
    nconTypes NCon
    con
      fields :: Int
    fields  = Cxt -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length Cxt
    ts
      conName :: Name
    conName = Getting Name NCon Name -> NCon -> Name
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Name NCon Name
    Lens' NCon Name
    nconName NCon
    con

      reviewer :: ExpQ
    reviewer                   = Name -> Int -> ExpQ
    makeReviewer       Name
    conName Int
    fields
      remitter :: ExpQ
    remitter | Stab -> Bool
    stabSimple Stab
    stab = Name -> Int -> Int -> ExpQ
    makeSimpleRemitter Name
    conName ([NCon] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [NCon]
    cons) Int
    fields
               | Bool
    otherwise       = [NCon] -> Name -> ExpQ
    makeFullRemitter [NCon]
    cons Name
    conName

    -- | Construct an Iso expression
    --
    -- iso <<reviewer>> <<remitter>>
    makeConIsoExp :: NCon -> ExpQ
    makeConIsoExp :: NCon -> ExpQ
    makeConIsoExp con :: NCon
    con = [ExpQ] -> ExpQ
    appsE [Name -> ExpQ
    varE Name
    isoValName, ExpQ
    remitter, ExpQ
    reviewer]
      where
      conName :: Name
    conName = Getting Name NCon Name -> NCon -> Name
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Name NCon Name
    Lens' NCon Name
    nconName NCon
    con
      fields :: Int
    fields  = Cxt -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length (Getting Cxt NCon Cxt -> NCon -> Cxt
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Cxt NCon Cxt
    Lens' NCon Cxt
    nconTypes NCon
    con)

      reviewer :: ExpQ
    reviewer = Name -> Int -> ExpQ
    makeReviewer    Name
    conName Int
    fields
      remitter :: ExpQ
    remitter = Name -> Int -> ExpQ
    makeIsoRemitter Name
    conName Int
    fields

    -- | Construct a Review expression
    --
    -- unto (\(x,y,z) -> Con x y z)
    makeConReviewExp :: NCon -> ExpQ
    makeConReviewExp :: NCon -> ExpQ
    makeConReviewExp con :: NCon
    con = ExpQ -> ExpQ -> ExpQ
    appE (Name -> ExpQ
    varE Name
    untoValName) ExpQ
    reviewer
      where
      conName :: Name
    conName = Getting Name NCon Name -> NCon -> Name
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Name NCon Name
    Lens' NCon Name
    nconName NCon
    con
      fields :: Int
    fields  = Cxt -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length (Getting Cxt NCon Cxt -> NCon -> Cxt
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Cxt NCon Cxt
    Lens' NCon Cxt
    nconTypes NCon
    con)

      reviewer :: ExpQ
    reviewer = Name -> Int -> ExpQ
    makeReviewer Name
    conName Int
    fields

    ------------------------------------------------------------------------
    -- Prism and Iso component builders
    ------------------------------------------------------------------------

    -- | Construct the review portion of a prism.
    --
    -- (\(x,y,z) -> Con x y z) :: b -> t
    makeReviewer :: Name -> Int -> ExpQ
    makeReviewer :: Name -> Int -> ExpQ
    makeReviewer conName :: Name
    conName fields :: Int
    fields =
      do [Name]
    xs <- String -> Int -> Q [Name]
    newNames "x" Int
    fields
         PatQ -> ExpQ -> ExpQ
    lam1E ([PatQ] -> PatQ
    toTupleP ((Name -> PatQ) -> [Name] -> [PatQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> PatQ
    varP [Name]
    xs))
               (Name -> ExpQ
    conE Name
    conName ExpQ -> [ExpQ] -> ExpQ
    `appsE1` (Name -> ExpQ) -> [Name] -> [ExpQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> ExpQ
    varE [Name]
    xs)

    -- | Construct the remit portion of a prism.
    -- Pattern match only target constructor, no type changing
    --
    -- (\x -> case s of
    --          Con x y z -> Right (x,y,z)
    --          _         -> Left x
    -- ) :: s -> Either s a
    makeSimpleRemitter ::
      Name {- The name of the constructor on which this prism focuses -} ->
      Int  {- The number of constructors the parent data type has     -} ->
      Int  {- The number of fields the constructor has                -} ->
      ExpQ
    makeSimpleRemitter :: Name -> Int -> Int -> ExpQ
    makeSimpleRemitter conName :: Name
    conName numCons :: Int
    numCons fields :: Int
    fields =
      do Name
    x  <- String -> Q Name
    newName "x"
         [Name]
    xs <- String -> Int -> Q [Name]
    newNames "y" Int
    fields
         let matches :: [MatchQ]
    matches =
               [ PatQ -> BodyQ -> [Q Dec] -> MatchQ
    match (Name -> [PatQ] -> PatQ
    conP Name
    conName ((Name -> PatQ) -> [Name] -> [PatQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> PatQ
    varP [Name]
    xs))
                       (ExpQ -> BodyQ
    normalB (ExpQ -> ExpQ -> ExpQ
    appE (Name -> ExpQ
    conE Name
    rightDataName) ([ExpQ] -> ExpQ
    toTupleE ((Name -> ExpQ) -> [Name] -> [ExpQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> ExpQ
    varE [Name]
    xs))))
                       []
               ] [MatchQ] -> [MatchQ] -> [MatchQ]
    forall a. [a] -> [a] -> [a]
    ++
               [ PatQ -> BodyQ -> [Q Dec] -> MatchQ
    match PatQ
    wildP (ExpQ -> BodyQ
    normalB (ExpQ -> ExpQ -> ExpQ
    appE (Name -> ExpQ
    conE Name
    leftDataName) (Name -> ExpQ
    varE Name
    x))) []
               | Int
    numCons Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > 1 -- Only generate a catch-all case if there is at least
                             -- one constructor besides the one being focused on.
               ]
         PatQ -> ExpQ -> ExpQ
    lam1E (Name -> PatQ
    varP Name
    x) (ExpQ -> [MatchQ] -> ExpQ
    caseE (Name -> ExpQ
    varE Name
    x) [MatchQ]
    matches)

    -- | Pattern match all constructors to enable type-changing
    --
    -- (\x -> case s of
    --          Con x y z -> Right (x,y,z)
    --          Other_n w   -> Left (Other_n w)
    -- ) :: s -> Either t a
    makeFullRemitter :: [NCon] -> Name -> ExpQ
    makeFullRemitter :: [NCon] -> Name -> ExpQ
    makeFullRemitter cons :: [NCon]
    cons target :: Name
    target =
      do Name
    x <- String -> Q Name
    newName "x"
         PatQ -> ExpQ -> ExpQ
    lam1E (Name -> PatQ
    varP Name
    x) (ExpQ -> [MatchQ] -> ExpQ
    caseE (Name -> ExpQ
    varE Name
    x) ((NCon -> MatchQ) -> [NCon] -> [MatchQ]
    forall a b. (a -> b) -> [a] -> [b]
    map NCon -> MatchQ
    mkMatch [NCon]
    cons))
      where
      mkMatch :: NCon -> MatchQ
    mkMatch (NCon conName :: Name
    conName _ _ n :: Cxt
    n) =
        do [Name]
    xs <- String -> Int -> Q [Name]
    newNames "y" (Cxt -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length Cxt
    n)
           PatQ -> BodyQ -> [Q Dec] -> MatchQ
    match (Name -> [PatQ] -> PatQ
    conP Name
    conName ((Name -> PatQ) -> [Name] -> [PatQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> PatQ
    varP [Name]
    xs))
                 (ExpQ -> BodyQ
    normalB
                   (if Name
    conName Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    target
                      then ExpQ -> ExpQ -> ExpQ
    appE (Name -> ExpQ
    conE Name
    rightDataName) ([ExpQ] -> ExpQ
    toTupleE ((Name -> ExpQ) -> [Name] -> [ExpQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> ExpQ
    varE [Name]
    xs))
                      else ExpQ -> ExpQ -> ExpQ
    appE (Name -> ExpQ
    conE Name
    leftDataName) (Name -> ExpQ
    conE Name
    conName ExpQ -> [ExpQ] -> ExpQ
    `appsE1` (Name -> ExpQ) -> [Name] -> [ExpQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> ExpQ
    varE [Name]
    xs)))
                 []

    -- | Construct the remitter suitable for use in an 'Iso'
    --
    -- (\(Con x y z) -> (x,y,z)) :: s -> a
    makeIsoRemitter :: Name -> Int -> ExpQ
    makeIsoRemitter :: Name -> Int -> ExpQ
    makeIsoRemitter conName :: Name
    conName fields :: Int
    fields =
      do [Name]
    xs <- String -> Int -> Q [Name]
    newNames "x" Int
    fields
         PatQ -> ExpQ -> ExpQ
    lam1E (Name -> [PatQ] -> PatQ
    conP Name
    conName ((Name -> PatQ) -> [Name] -> [PatQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> PatQ
    varP [Name]
    xs))
               ([ExpQ] -> ExpQ
    toTupleE ((Name -> ExpQ) -> [Name] -> [ExpQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> ExpQ
    varE [Name]
    xs))

    ------------------------------------------------------------------------
    -- Classy prisms
    ------------------------------------------------------------------------

    -- | Construct the classy prisms class for a given type and constructors.
    --
    -- class ClassName r <<vars in type>> | r -> <<vars in Type>> where
    --   topMethodName   :: Prism' r Type
    --   conMethodName_n :: Prism' r conTypes_n
    --   conMethodName_n = topMethodName . conMethodName_n
    makeClassyPrismClass ::
      Type   {- Outer type      -} ->
      Name   {- Class name      -} ->
      Name   {- Top method name -} ->
      [NCon] {- Constructors    -} ->
      DecQ
    makeClassyPrismClass :: Type -> Name -> Name -> [NCon] -> Q Dec
    makeClassyPrismClass t :: Type
    t className :: Name
    className methodName :: Name
    methodName cons :: [NCon]
    cons =
      do Name
    r <- String -> Q Name
    newName "r"
    #ifndef HLINT
         let methodType :: TypeQ
    methodType = TypeQ -> [TypeQ] -> TypeQ
    appsT (Name -> TypeQ
    conT Name
    prism'TypeName) [Name -> TypeQ
    varT Name
    r,Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    t]
    #endif
         [[Dec]]
    methodss <- (NCon -> DecsQ) -> [NCon] -> Q [[Dec]]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse (Type -> NCon -> DecsQ
    mkMethod (Name -> Type
    VarT Name
    r)) [NCon]
    cons'
         CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [Q Dec] -> Q Dec
    classD ([TypeQ] -> CxtQ
    cxt[]) Name
    className ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> TyVarBndr
    PlainTV (Name
    r Name -> [Name] -> [Name]
    forall a. a -> [a] -> [a]
    : [Name]
    vs)) (Name -> [FunDep]
    fds Name
    r)
           ( Name -> TypeQ -> Q Dec
    sigD Name
    methodName TypeQ
    methodType
           Q Dec -> [Q Dec] -> [Q Dec]
    forall a. a -> [a] -> [a]
    : (Dec -> Q Dec) -> [Dec] -> [Q Dec]
    forall a b. (a -> b) -> [a] -> [b]
    map Dec -> Q Dec
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Dec]]
    methodss)
           )

      where
      mkMethod :: Type -> NCon -> DecsQ
    mkMethod r :: Type
    r con :: NCon
    con =
        do Stab cx :: Cxt
    cx o :: OpticType
    o _ _ _ b :: Type
    b <- Type -> [NCon] -> NCon -> Q Stab
    computeOpticType Type
    t [NCon]
    cons NCon
    con
           let stab' :: Stab
    stab' = Cxt -> OpticType -> Type -> Type -> Type -> Type -> Stab
    Stab Cxt
    cx OpticType
    o Type
    r Type
    r Type
    b Type
    b
               defName :: Name
    defName = Getting Name NCon Name -> NCon -> Name
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Name NCon Name
    Lens' NCon Name
    nconName NCon
    con
               body :: ExpQ
    body    = [ExpQ] -> ExpQ
    appsE [Name -> ExpQ
    varE Name
    composeValName, Name -> ExpQ
    varE Name
    methodName, Name -> ExpQ
    varE Name
    defName]
           [Q Dec] -> DecsQ
    forall (t :: * -> *) (f :: * -> *) a.
    (Traversable t, Applicative f) =>
    t (f a) -> f (t a)
    sequenceA
             [ Name -> TypeQ -> Q Dec
    sigD Name
    defName        (Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Stab -> Type
    stabToType Stab
    stab'))
             , PatQ -> BodyQ -> [Q Dec] -> Q Dec
    valD (Name -> PatQ
    varP Name
    defName) (ExpQ -> BodyQ
    normalB ExpQ
    body) []
             ]

      cons' :: [NCon]
    cons'         = (NCon -> NCon) -> [NCon] -> [NCon]
    forall a b. (a -> b) -> [a] -> [b]
    map (ASetter NCon NCon Name Name -> (Name -> Name) -> NCon -> NCon
    forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
    over ASetter NCon NCon Name Name
    Lens' NCon Name
    nconName Name -> Name
    prismName) [NCon]
    cons
      vs :: [Name]
    vs            = Set Name -> [Name]
    forall a. Set a -> [a]
    Set.toList (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
    typeVars Type
    t)
      fds :: Name -> [FunDep]
    fds r :: Name
    r
        | [Name] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Name]
    vs   = []
        | Bool
    otherwise = [[Name] -> [Name] -> FunDep
    FunDep [Name
    r] [Name]
    vs]

    -- | Construct the classy prisms instance for a given type and constructors.
    --
    -- instance Classname OuterType where
    --   topMethodName = id
    --   conMethodName_n = <<prism>>
    makeClassyPrismInstance ::
      Type ->
      Name     {- Class name      -} ->
      Name     {- Top method name -} ->
      [NCon] {- Constructors    -} ->
      DecQ
    makeClassyPrismInstance :: Type -> Name -> Name -> [NCon] -> Q Dec
    makeClassyPrismInstance s :: Type
    s className :: Name
    className methodName :: Name
    methodName cons :: [NCon]
    cons =
      do let vs :: [Name]
    vs = Set Name -> [Name]
    forall a. Set a -> [a]
    Set.toList (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
    typeVars Type
    s)
             cls :: Type
    cls = Name
    className Name -> Cxt -> Type
    `conAppsT` (Type
    s Type -> Cxt -> Cxt
    forall a. a -> [a] -> [a]
    : (Name -> Type) -> [Name] -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Type
    VarT [Name]
    vs)

         CxtQ -> TypeQ -> [Q Dec] -> Q Dec
    instanceD ([TypeQ] -> CxtQ
    cxt[]) (Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    cls)
           (   PatQ -> BodyQ -> [Q Dec] -> Q Dec
    valD (Name -> PatQ
    varP Name
    methodName)
                    (ExpQ -> BodyQ
    normalB (Name -> ExpQ
    varE Name
    idValName)) []
           Q Dec -> [Q Dec] -> [Q Dec]
    forall a. a -> [a] -> [a]
    : [ do Stab
    stab <- Type -> [NCon] -> NCon -> Q Stab
    computeOpticType Type
    s [NCon]
    cons NCon
    con
                  let stab' :: Stab
    stab' = Stab -> Stab
    simplifyStab Stab
    stab
                  PatQ -> BodyQ -> [Q Dec] -> Q Dec
    valD (Name -> PatQ
    varP (Name -> Name
    prismName Name
    conName))
                    (ExpQ -> BodyQ
    normalB (Stab -> [NCon] -> NCon -> ExpQ
    makeConOpticExp Stab
    stab' [NCon]
    cons NCon
    con)) []
               | NCon
    con <- [NCon]
    cons
               , let conName :: Name
    conName = Getting Name NCon Name -> NCon -> Name
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
    view Getting Name NCon Name
    Lens' NCon Name
    nconName NCon
    con
               ]
           )

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

    -- | Normalized constructor
    data NCon = NCon
      { NCon -> Name
    _nconName :: Name
      , NCon -> [Name]
    _nconVars :: [Name]
      , NCon -> Cxt
    _nconCxt  :: Cxt
      , NCon -> Cxt
    _nconTypes :: [Type]
      }
      deriving (NCon -> NCon -> Bool
    (NCon -> NCon -> Bool) -> (NCon -> NCon -> Bool) -> Eq NCon
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: NCon -> NCon -> Bool
    $c/= :: NCon -> NCon -> Bool
    == :: NCon -> NCon -> Bool
    $c== :: NCon -> NCon -> Bool
    Eq)

    instance HasTypeVars NCon where
      typeVarsEx :: Set Name -> Traversal' NCon Name
    typeVarsEx s :: Set Name
    s f :: Name -> f Name
    f (NCon x :: Name
    x vars :: [Name]
    vars y :: Cxt
    y z :: Cxt
    z) = Name -> [Name] -> Cxt -> Cxt -> NCon
    NCon Name
    x [Name]
    vars (Cxt -> Cxt -> NCon) -> f Cxt -> f (Cxt -> NCon)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Set Name -> (Name -> f Name) -> Cxt -> f Cxt
    forall t. HasTypeVars t => Set Name -> Traversal' t Name
    typeVarsEx Set Name
    s' Name -> f Name
    f Cxt
    y f (Cxt -> NCon) -> f Cxt -> f NCon
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Set Name -> (Name -> f Name) -> Cxt -> f Cxt
    forall t. HasTypeVars t => Set Name -> Traversal' t Name
    typeVarsEx Set Name
    s' Name -> f Name
    f Cxt
    z
        where s' :: Set Name
    s' = (Set Name -> Name -> Set Name) -> Set Name -> [Name] -> Set Name
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' ((Name -> Set Name -> Set Name) -> Set Name -> Name -> Set Name
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Name -> Set Name -> Set Name
    forall a. Ord a => a -> Set a -> Set a
    Set.insert) Set Name
    s [Name]
    vars

    nconName :: Lens' NCon Name
    nconName :: (Name -> f Name) -> NCon -> f NCon
    nconName f :: Name -> f Name
    f x :: NCon
    x = (Name -> NCon) -> f Name -> f NCon
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\y :: Name
    y -> NCon
    x {_nconName :: Name
    _nconName = Name
    y}) (Name -> f Name
    f (NCon -> Name
    _nconName NCon
    x))

    nconCxt :: Lens' NCon Cxt
    nconCxt :: (Cxt -> f Cxt) -> NCon -> f NCon
    nconCxt f :: Cxt -> f Cxt
    f x :: NCon
    x = (Cxt -> NCon) -> f Cxt -> f NCon
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\y :: Cxt
    y -> NCon
    x {_nconCxt :: Cxt
    _nconCxt = Cxt
    y}) (Cxt -> f Cxt
    f (NCon -> Cxt
    _nconCxt NCon
    x))

    nconTypes :: Lens' NCon [Type]
    nconTypes :: (Cxt -> f Cxt) -> NCon -> f NCon
    nconTypes f :: Cxt -> f Cxt
    f x :: NCon
    x = (Cxt -> NCon) -> f Cxt -> f NCon
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\y :: Cxt
    y -> NCon
    x {_nconTypes :: Cxt
    _nconTypes = Cxt
    y}) (Cxt -> f Cxt
    f (NCon -> Cxt
    _nconTypes NCon
    x))

    -- | Normalize a single 'Con' to its constructor name and field types.
    normalizeCon :: D.ConstructorInfo -> NCon
    normalizeCon :: ConstructorInfo -> NCon
    normalizeCon info :: ConstructorInfo
    info = Name -> [Name] -> Cxt -> Cxt -> NCon
    NCon (ConstructorInfo -> Name
    D.constructorName ConstructorInfo
    info)
                             (TyVarBndr -> Name
    D.tvName (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ConstructorInfo -> [TyVarBndr]
    D.constructorVars ConstructorInfo
    info)
                             (ConstructorInfo -> Cxt
    D.constructorContext ConstructorInfo
    info)
                             (ConstructorInfo -> Cxt
    D.constructorFields ConstructorInfo
    info)

    -- | Compute a prism's name by prefixing an underscore for normal
    -- constructors and period for operators.
    prismName :: Name -> Name
    prismName :: Name -> Name
    prismName = Bool -> Name -> Name
    prismName' Bool
    False

    -- | Compute a prism's name with a special case for when the type
    -- constructor matches one of the value constructors.
    --
    -- The overlapping flag wil be 'True' in the event that:
    --
    -- 1. We are generating the name of a classy prism for a
    --    data type, and
    -- 2. The data type shares a name with one of its
    --    constructors (e.g., @data A = A@).
    --
    -- In such a scenario, we take care not to generate the same
    -- prism name that the constructor receives (e.g., @_A@).
    -- For prefix names, we accomplish this by adding an extra
    -- underscore; for infix names, an extra dot.
    prismName' ::
      Bool {- ^ overlapping constructor -} ->
      Name {- ^ type constructor        -} ->
      Name {- ^ prism name              -}
    prismName' :: Bool -> Name -> Name
    prismName' sameNameAsCon :: Bool
    sameNameAsCon n :: Name
    n =
      case Name -> String
    nameBase Name
    n of
        [] -> String -> Name
    forall a. HasCallStack => String -> a
    error "prismName: empty name base?"
        nb :: String
    nb@(x :: Char
    x:_) | Char -> Bool
    isUpper Char
    x -> String -> Name
    mkName (Char -> String -> String
    prefix '_' String
    nb)
                 | Bool
    otherwise -> String -> Name
    mkName (Char -> String -> String
    prefix '.' String
    nb) -- operator
      where
        prefix :: Char -> String -> String
        prefix :: Char -> String -> String
    prefix char :: Char
    char str :: String
    str | Bool
    sameNameAsCon = Char
    charChar -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    charChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    str
                        | Bool
    otherwise     =      Char
    charChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    str

    -- | Quantify all the free variables in a type.
    close :: Type -> TypeQ
    close :: Type -> TypeQ
    close t :: Type
    t = [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
    forallT ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> TyVarBndr
    PlainTV (Set Name -> [Name]
    forall a. Set a -> [a]
    Set.toList Set Name
    vs)) ([TypeQ] -> CxtQ
    cxt[]) (Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    t)
      where
      vs :: Set Name
    vs = 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
    typeVars Type
    t