    {- |
    Template Haskell functions for automatically generating labels for algebraic
    datatypes, newtypes and GADTs. There are two basic modes of label generation,
    the `mkLabels` family of functions create labels (and optionally type
    signatures) in scope as top level funtions, the `getLabel` family of funtions
    create labels as expressions that can be named and typed manually.

    In the case of multi-constructor datatypes some fields might not always be
    available and the derived labels will be partial. Partial labels are provided
    with an additional type context that forces them to be only usable in the
    `Partial' or `Failing` context.
    -}

    {-# LANGUAGE
        DeriveFunctor
      , DeriveFoldable
      , TemplateHaskell
      , TypeOperators
      , CPP #-}

    module Data.Label.Derive
    (

    -- * Generate labels in scope.
      mkLabel
    , mkLabels
    , mkLabelsNamed

    -- * Produce labels as expressions.
    , getLabel

    -- * First class record labels.
    , fclabels

    -- * Low level derivation functions.
    , mkLabelsWith
    , getLabelWith
    , defaultNaming
    )
    where

    import Control.Applicative
    import Control.Arrow
    import Control.Category
    import Control.Monad
    import Data.Char (toLower, toUpper)
    #if MIN_VERSION_base(4,8,0)
    import Data.Foldable (toList)
    #else
    import Data.Foldable (Foldable, toList)
    #endif
    import Data.Label.Point
    import Data.List (groupBy, sortBy, delete, nub)
    import Data.Maybe (fromMaybe)
    import Data.Ord
    #if MIN_VERSION_template_haskell(2,10,0)
    import Language.Haskell.TH hiding (classP)
    #else
    import Language.Haskell.TH
    #endif
    import Prelude hiding ((.), id)

    import qualified Data.Label.Mono     as Mono
    import qualified Data.Label.Poly     as Poly

    -------------------------------------------------------------------------------
    -- Publicly exposed functions.

    -- | Derive labels including type signatures for all the record selectors for a
    -- collection of datatypes. The types will be polymorphic and can be used in an
    -- arbitrary context.

    mkLabels :: [Name] -> Q [Dec]
    mkLabels :: [Name] -> Q [Dec]
    mkLabels = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM [[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat (Q [[Dec]] -> Q [Dec])
    -> ([Name] -> Q [[Dec]]) -> [Name] -> Q [Dec]
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM ((String -> String)
    -> Bool -> Bool -> Bool -> Bool -> Name -> Q [Dec]
    mkLabelsWith String -> String
    defaultNaming Bool
    True Bool
    False Bool
    False Bool
    True)

    -- | Derive labels including type signatures for all the record selectors in a
    -- single datatype. The types will be polymorphic and can be used in an
    -- arbitrary context.

    mkLabel :: Name -> Q [Dec]
    mkLabel :: Name -> Q [Dec]
    mkLabel = [Name] -> Q [Dec]
    mkLabels ([Name] -> Q [Dec]) -> (Name -> [Name]) -> Name -> Q [Dec]
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . Name -> [Name]
    forall (m :: * -> *) a. Monad m => a -> m a
    return

    -- | Like `mkLabels`, but uses the specified function to produce custom names
    -- for the labels.
    --
    -- For instance, @(drop 1 . dropWhile (/='_'))@ creates a label
    -- @val@ from a record @Rec { rec_val :: X }@.

    mkLabelsNamed :: (String -> String) -> [Name] -> Q [Dec]
    mkLabelsNamed :: (String -> String) -> [Name] -> Q [Dec]
    mkLabelsNamed mk :: String -> String
    mk = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM [[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat (Q [[Dec]] -> Q [Dec])
    -> ([Name] -> Q [[Dec]]) -> [Name] -> Q [Dec]
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM ((String -> String)
    -> Bool -> Bool -> Bool -> Bool -> Name -> Q [Dec]
    mkLabelsWith String -> String
    mk Bool
    True Bool
    False Bool
    False Bool
    True)

    -- | Derive unnamed labels as n-tuples that can be named manually. The types
    -- will be polymorphic and can be used in an arbitrary context.
    --
    -- Example:
    --
    -- > (left, right) = $(getLabel ''Either)
    --
    -- The lenses can now also be typed manually:
    --
    -- > left  :: (Either a b -> Either c b) :~> (a -> c)
    -- > right :: (Either a b -> Either a c) :~> (b -> c)
    --
    -- Note: Because of the abstract nature of the generated lenses and the top
    -- level pattern match, it might be required to use 'NoMonomorphismRestriction'
    -- in some cases.

    getLabel :: Name -> Q Exp
    getLabel :: Name -> Q Exp
    getLabel = Bool -> Bool -> Bool -> Name -> Q Exp
    getLabelWith Bool
    True Bool
    False Bool
    False

    -- | Low level label as expression derivation function.

    getLabelWith
      :: Bool  -- ^ Generate type signatures or not.
      -> Bool  -- ^ Generate concrete type or abstract type. When true the
               --   signatures will be concrete and can only be used in the
               --   appropriate context. Total labels will use (`:->`) and partial
               --   labels will use either `Lens Partial` or `Lens Failing`
               --   dependent on the following flag:
      -> Bool  -- ^ Use `ArrowFail` for failure instead of `ArrowZero`.
      -> Name  -- ^ The type to derive labels for.
      -> Q Exp

    getLabelWith :: Bool -> Bool -> Bool -> Name -> Q Exp
    getLabelWith sigs :: Bool
    sigs concrete :: Bool
    concrete failing :: Bool
    failing name :: Name
    name =
      do Dec
    dec    <- Name -> Q Dec
    reifyDec Name
    name
         [Label]
    labels <- (String -> String) -> Bool -> Bool -> Dec -> Q [Label]
    generateLabels String -> String
    forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
    id Bool
    concrete Bool
    failing Dec
    dec
         let bodies :: [Q Exp]
    bodies  =        (Label -> Q Exp) -> [Label] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(LabelExpr _ _ _ b :: Q Exp
    b) -> Q Exp
    b) [Label]
    labels
             types :: [TypeQ]
    types   =        (Label -> TypeQ) -> [Label] -> [TypeQ]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(LabelExpr _ _ t :: TypeQ
    t _) -> TypeQ
    t) [Label]
    labels
             context :: CxtQ
    context = [CxtQ] -> CxtQ
    forall a. [a] -> a
    head ([CxtQ] -> CxtQ) -> [CxtQ] -> CxtQ
    forall a b. (a -> b) -> a -> b
    $ (Label -> CxtQ) -> [Label] -> [CxtQ]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(LabelExpr _ c :: CxtQ
    c _ _) -> CxtQ
    c) [Label]
    labels
             vars :: [TyVarBndr]
    vars    = [[TyVarBndr]] -> [TyVarBndr]
    forall a. [a] -> a
    head ([[TyVarBndr]] -> [TyVarBndr]) -> [[TyVarBndr]] -> [TyVarBndr]
    forall a b. (a -> b) -> a -> b
    $ (Label -> [TyVarBndr]) -> [Label] -> [[TyVarBndr]]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(LabelExpr v :: [TyVarBndr]
    v _ _ _) -> [TyVarBndr]
    v) [Label]
    labels
         case [Q Exp]
    bodies of
           [b :: Q Exp
    b] -> if Bool
    sigs then Q Exp
    b Q Exp -> TypeQ -> Q Exp
    `sigE` [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
    forallT [TyVarBndr]
    vars CxtQ
    context ([TypeQ] -> TypeQ
    forall a. [a] -> a
    head [TypeQ]
    types) else Q Exp
    b
           _   -> if Bool
    sigs
              then [Q Exp] -> Q Exp
    tupE [Q Exp]
    bodies Q Exp -> TypeQ -> Q Exp
    `sigE`
                   [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
    forallT [TyVarBndr]
    vars CxtQ
    context ((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl TypeQ -> TypeQ -> TypeQ
    appT (Int -> TypeQ
    tupleT ([Q Exp] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Q Exp]
    bodies)) [TypeQ]
    types)
              else [Q Exp] -> Q Exp
    tupE [Q Exp]
    bodies

    -- | Low level standalone label derivation function.

    mkLabelsWith
      :: (String -> String) -- ^ Supply a function to perform custom label naming.
      -> Bool               -- ^ Generate type signatures or not.
      -> Bool               -- ^ Generate concrete type or abstract type. When
                            --   true the signatures will be concrete and can only
                            --   be used in the appropriate context. Total labels
                            --   will use (`:->`) and partial labels will use
                            --   either `Lens Partial` or `Lens Failing` dependent
                            --   on the following flag:
      -> Bool               -- ^ Use `ArrowFail` for failure instead of `ArrowZero`.
      -> Bool               -- ^ Generate inline pragma or not.
      -> Name               -- ^ The type to derive labels for.
      -> Q [Dec]

    mkLabelsWith :: (String -> String)
    -> Bool -> Bool -> Bool -> Bool -> Name -> Q [Dec]
    mkLabelsWith mk :: String -> String
    mk sigs :: Bool
    sigs concrete :: Bool
    concrete failing :: Bool
    failing inl :: Bool
    inl name :: Name
    name =
      do Dec
    dec <- Name -> Q Dec
    reifyDec Name
    name
         (String -> String)
    -> Bool -> Bool -> Bool -> Bool -> Dec -> Q [Dec]
    mkLabelsWithForDec String -> String
    mk Bool
    sigs Bool
    concrete Bool
    failing Bool
    inl Dec
    dec

    -- | Default way of generating a label name from the Haskell record selector
    -- name. If the original selector starts with an underscore, remove it and make
    -- the next character lowercase. Otherwise, add 'l', and make the next
    -- character uppercase.

    defaultNaming :: String -> String
    defaultNaming :: String -> String
    defaultNaming field :: String
    field =
      case String
    field of
        '_' : c :: Char
    c : rest :: String
    rest -> Char -> Char
    toLower Char
    c Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rest
        f :: Char
    f : rest :: String
    rest       -> 'l' Char -> String -> String
    forall a. a -> [a] -> [a]
    : Char -> Char
    toUpper Char
    f Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rest
        n :: String
    n              -> String -> String
    forall a. String -> a
    fclError ("Cannot derive label for record selector with name: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    n)

    -- | Derive labels for all the record types in the supplied declaration. The
    -- record fields don't need an underscore prefix. Multiple data types /
    -- newtypes are allowed at once.
    --
    -- The advantage of this approach is that you don't need to explicitly hide the
    -- original record accessors from being exported and they won't show up in the
    -- derived `Show` instance.
    --
    -- Example:
    --
    -- > fclabels [d|
    -- >   data Record = Record
    -- >     { int  :: Int
    -- >     , bool :: Bool
    -- >     } deriving Show
    -- >   |]
    --
    -- > ghci> modify int (+2) (Record 1 False)
    -- > Record 3 False

    fclabels :: Q [Dec] -> Q [Dec]
    fclabels :: Q [Dec] -> Q [Dec]
    fclabels decls :: Q [Dec]
    decls =
      do [Dec]
    ds <- Q [Dec]
    decls
         [[Dec]]
    ls <- [Dec] -> (Dec -> Q [Dec]) -> Q [[Dec]]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM ([Dec]
    ds [Dec] -> (Dec -> [Dec]) -> [Dec]
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Dec -> [Dec]
    labels) ((String -> String)
    -> Bool -> Bool -> Bool -> Bool -> Dec -> Q [Dec]
    mkLabelsWithForDec String -> String
    forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
    id Bool
    True Bool
    False Bool
    False Bool
    False)
         [Dec] -> Q [Dec]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ((Dec -> Dec
    delabelize (Dec -> Dec) -> [Dec] -> [Dec]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Dec]
    ds) [Dec] -> [[Dec]] -> [[Dec]]
    forall a. a -> [a] -> [a]
    : [[Dec]]
    ls))
      where

      labels :: Dec -> [Dec]
      labels :: Dec -> [Dec]
    labels dec :: Dec
    dec =
        case Dec
    dec of
          DataD    {} -> [Dec
    dec]
          NewtypeD {} -> [Dec
    dec]
          _           -> []

      delabelize :: Dec -> Dec
      delabelize :: Dec -> Dec
    delabelize dec :: Dec
    dec =
        case Dec
    dec of
    #if MIN_VERSION_template_haskell(2,11,0)
          DataD    ctx :: Cxt
    ctx nm :: Name
    nm vars :: [TyVarBndr]
    vars mk :: Maybe Kind
    mk cs :: [Con]
    cs ns :: [DerivClause]
    ns -> Cxt
    -> Name
    -> [TyVarBndr]
    -> Maybe Kind
    -> [Con]
    -> [DerivClause]
    -> Dec
    DataD    Cxt
    ctx Name
    nm [TyVarBndr]
    vars Maybe Kind
    mk (Con -> Con
    con (Con -> Con) -> [Con] -> [Con]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Con]
    cs) [DerivClause]
    ns
          NewtypeD ctx :: Cxt
    ctx nm :: Name
    nm vars :: [TyVarBndr]
    vars mk :: Maybe Kind
    mk c :: Con
    c  ns :: [DerivClause]
    ns -> Cxt
    -> Name -> [TyVarBndr] -> Maybe Kind -> Con -> [DerivClause] -> Dec
    NewtypeD Cxt
    ctx Name
    nm [TyVarBndr]
    vars Maybe Kind
    mk (Con -> Con
    con Con
    c)      [DerivClause]
    ns
    #else
          DataD    ctx nm vars cs ns -> DataD    ctx nm vars (con <$> cs) ns
          NewtypeD ctx nm vars c  ns -> NewtypeD ctx nm vars (con c)      ns
    #endif
          rest :: Dec
    rest                       -> Dec
    rest
        where con :: Con -> Con
    con (RecC n :: Name
    n vst :: [VarBangType]
    vst) = Name -> [BangType] -> Con
    NormalC Name
    n ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(_, s :: Bang
    s, t :: Kind
    t) -> (Bang
    s, Kind
    t)) [VarBangType]
    vst)
    #if MIN_VERSION_template_haskell(2,11,0)
              con (RecGadtC ns :: [Name]
    ns vst :: [VarBangType]
    vst ty :: Kind
    ty) = [Name] -> [BangType] -> Kind -> Con
    GadtC [Name]
    ns ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(_, s :: Bang
    s, t :: Kind
    t) -> (Bang
    s, Kind
    t)) [VarBangType]
    vst) Kind
    ty
    #endif
              con c :: Con
    c            = Con
    c

    -------------------------------------------------------------------------------
    -- Intermediate data types.

    data Label
     = LabelDecl
         Name              -- The label name.
         DecQ              -- An INLINE pragma for the label.
         [TyVarBndr]       -- The type variables requiring forall.
         CxtQ              -- The context.
         TypeQ             -- The type.
         ExpQ              -- The label body.
     | LabelExpr
         [TyVarBndr]       -- The type variables requiring forall.
         CxtQ              -- The context.
         TypeQ             -- The type.
         ExpQ              -- The label body.

    data Field c = Field
      (Maybe Name)         -- Name of the field, when there is one.
      Bool                 -- Forced to be mono because of type shared with other fields.
      Type                 -- Type of the field.
      c                    -- Occurs in this/these constructors.
      deriving (Field c -> Field c -> Bool
    (Field c -> Field c -> Bool)
    -> (Field c -> Field c -> Bool) -> Eq (Field c)
    forall c. Eq c => Field c -> Field c -> Bool
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: Field c -> Field c -> Bool
    $c/= :: forall c. Eq c => Field c -> Field c -> Bool
    == :: Field c -> Field c -> Bool
    $c== :: forall c. Eq c => Field c -> Field c -> Bool
    Eq, a -> Field b -> Field a
    (a -> b) -> Field a -> Field b
    (forall a b. (a -> b) -> Field a -> Field b)
    -> (forall a b. a -> Field b -> Field a) -> Functor Field
    forall a b. a -> Field b -> Field a
    forall a b. (a -> b) -> Field a -> Field b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    <$ :: a -> Field b -> Field a
    $c<$ :: forall a b. a -> Field b -> Field a
    fmap :: (a -> b) -> Field a -> Field b
    $cfmap :: forall a b. (a -> b) -> Field a -> Field b
    Functor, Field a -> Bool
    (a -> m) -> Field a -> m
    (a -> b -> b) -> b -> Field a -> b
    (forall m. Monoid m => Field m -> m)
    -> (forall m a. Monoid m => (a -> m) -> Field a -> m)
    -> (forall m a. Monoid m => (a -> m) -> Field a -> m)
    -> (forall a b. (a -> b -> b) -> b -> Field a -> b)
    -> (forall a b. (a -> b -> b) -> b -> Field a -> b)
    -> (forall b a. (b -> a -> b) -> b -> Field a -> b)
    -> (forall b a. (b -> a -> b) -> b -> Field a -> b)
    -> (forall a. (a -> a -> a) -> Field a -> a)
    -> (forall a. (a -> a -> a) -> Field a -> a)
    -> (forall a. Field a -> [a])
    -> (forall a. Field a -> Bool)
    -> (forall a. Field a -> Int)
    -> (forall a. Eq a => a -> Field a -> Bool)
    -> (forall a. Ord a => Field a -> a)
    -> (forall a. Ord a => Field a -> a)
    -> (forall a. Num a => Field a -> a)
    -> (forall a. Num a => Field a -> a)
    -> Foldable Field
    forall a. Eq a => a -> Field a -> Bool
    forall a. Num a => Field a -> a
    forall a. Ord a => Field a -> a
    forall m. Monoid m => Field m -> m
    forall a. Field a -> Bool
    forall a. Field a -> Int
    forall a. Field a -> [a]
    forall a. (a -> a -> a) -> Field a -> a
    forall m a. Monoid m => (a -> m) -> Field a -> m
    forall b a. (b -> a -> b) -> b -> Field a -> b
    forall a b. (a -> b -> b) -> b -> Field a -> b
    forall (t :: * -> *).
    (forall m. Monoid m => t m -> m)
    -> (forall m a. Monoid m => (a -> m) -> t a -> m)
    -> (forall m a. Monoid m => (a -> m) -> t a -> m)
    -> (forall a b. (a -> b -> b) -> b -> t a -> b)
    -> (forall a b. (a -> b -> b) -> b -> t a -> b)
    -> (forall b a. (b -> a -> b) -> b -> t a -> b)
    -> (forall b a. (b -> a -> b) -> b -> t a -> b)
    -> (forall a. (a -> a -> a) -> t a -> a)
    -> (forall a. (a -> a -> a) -> t a -> a)
    -> (forall a. t a -> [a])
    -> (forall a. t a -> Bool)
    -> (forall a. t a -> Int)
    -> (forall a. Eq a => a -> t a -> Bool)
    -> (forall a. Ord a => t a -> a)
    -> (forall a. Ord a => t a -> a)
    -> (forall a. Num a => t a -> a)
    -> (forall a. Num a => t a -> a)
    -> Foldable t
    product :: Field a -> a
    $cproduct :: forall a. Num a => Field a -> a
    sum :: Field a -> a
    $csum :: forall a. Num a => Field a -> a
    minimum :: Field a -> a
    $cminimum :: forall a. Ord a => Field a -> a
    maximum :: Field a -> a
    $cmaximum :: forall a. Ord a => Field a -> a
    elem :: a -> Field a -> Bool
    $celem :: forall a. Eq a => a -> Field a -> Bool
    length :: Field a -> Int
    $clength :: forall a. Field a -> Int
    null :: Field a -> Bool
    $cnull :: forall a. Field a -> Bool
    toList :: Field a -> [a]
    $ctoList :: forall a. Field a -> [a]
    foldl1 :: (a -> a -> a) -> Field a -> a
    $cfoldl1 :: forall a. (a -> a -> a) -> Field a -> a
    foldr1 :: (a -> a -> a) -> Field a -> a
    $cfoldr1 :: forall a. (a -> a -> a) -> Field a -> a
    foldl' :: (b -> a -> b) -> b -> Field a -> b
    $cfoldl' :: forall b a. (b -> a -> b) -> b -> Field a -> b
    foldl :: (b -> a -> b) -> b -> Field a -> b
    $cfoldl :: forall b a. (b -> a -> b) -> b -> Field a -> b
    foldr' :: (a -> b -> b) -> b -> Field a -> b
    $cfoldr' :: forall a b. (a -> b -> b) -> b -> Field a -> b
    foldr :: (a -> b -> b) -> b -> Field a -> b
    $cfoldr :: forall a b. (a -> b -> b) -> b -> Field a -> b
    foldMap' :: (a -> m) -> Field a -> m
    $cfoldMap' :: forall m a. Monoid m => (a -> m) -> Field a -> m
    foldMap :: (a -> m) -> Field a -> m
    $cfoldMap :: forall m a. Monoid m => (a -> m) -> Field a -> m
    fold :: Field m -> m
    $cfold :: forall m. Monoid m => Field m -> m
    Foldable)

    type Subst = [(Type, Type)]

    data Context = Context
      Int                  -- Field index.
      Name                 -- Constructor name.
      Con                  -- Constructor.
      deriving (Context -> Context -> Bool
    (Context -> Context -> Bool)
    -> (Context -> Context -> Bool) -> Eq Context
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: Context -> Context -> Bool
    $c/= :: Context -> Context -> Bool
    == :: Context -> Context -> Bool
    $c== :: Context -> Context -> Bool
    Eq, Int -> Context -> String -> String
    [Context] -> String -> String
    Context -> String
    (Int -> Context -> String -> String)
    -> (Context -> String)
    -> ([Context] -> String -> String)
    -> Show Context
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    showList :: [Context] -> String -> String
    $cshowList :: [Context] -> String -> String
    show :: Context -> String
    $cshow :: Context -> String
    showsPrec :: Int -> Context -> String -> String
    $cshowsPrec :: Int -> Context -> String -> String
    Show)

    data Typing = Typing
      Bool                 -- Monomorphic type or polymorphic.
      TypeQ                -- The lens input type.
      TypeQ                -- The lens output type.
      [TyVarBndr]          -- All used type variables.

    -------------------------------------------------------------------------------

    mkLabelsWithForDec :: (String -> String) -> Bool -> Bool -> Bool -> Bool -> Dec -> Q [Dec]
    mkLabelsWithForDec :: (String -> String)
    -> Bool -> Bool -> Bool -> Bool -> Dec -> Q [Dec]
    mkLabelsWithForDec mk :: String -> String
    mk sigs :: Bool
    sigs concrete :: Bool
    concrete failing :: Bool
    failing inl :: Bool
    inl dec :: Dec
    dec =
      do [Label]
    labels <- (String -> String) -> Bool -> Bool -> Dec -> Q [Label]
    generateLabels String -> String
    mk Bool
    concrete Bool
    failing Dec
    dec
         [[Dec]]
    decls  <- [Label] -> (Label -> Q [Dec]) -> Q [[Dec]]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM [Label]
    labels ((Label -> Q [Dec]) -> Q [[Dec]])
    -> (Label -> Q [Dec]) -> Q [[Dec]]
    forall a b. (a -> b) -> a -> b
    $ \l :: Label
    l ->
           case Label
    l of
             LabelExpr {} -> [Dec] -> Q [Dec]
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
             LabelDecl n :: Name
    n i :: Q Dec
    i v :: [TyVarBndr]
    v c :: CxtQ
    c t :: TypeQ
    t b :: Q Exp
    b ->
               do [Dec]
    bdy <- Dec -> [Dec]
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Name -> [ClauseQ] -> Q Dec
    funD Name
    n [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
    clause [] (Q Exp -> BodyQ
    normalB Q Exp
    b) []]
                  [Dec]
    prg <- if Bool
    inl then Dec -> [Dec]
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Q Dec
    i else [Dec] -> Q [Dec]
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
                  [Dec]
    typ <- if Bool
    sigs
                           then Dec -> [Dec]
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Name -> TypeQ -> Q Dec
    sigD Name
    n ([TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
    forallT [TyVarBndr]
    v CxtQ
    c TypeQ
    t)
                           else [Dec] -> Q [Dec]
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
                  [Dec] -> Q [Dec]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Dec]
    prg, [Dec]
    typ, [Dec]
    bdy])
         [Dec] -> Q [Dec]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Dec]]
    decls)

    -- Generate the labels for all the record fields in the data type.

    generateLabels :: (String -> String) -> Bool -> Bool -> Dec -> Q [Label]
    generateLabels :: (String -> String) -> Bool -> Bool -> Dec -> Q [Label]
    generateLabels mk :: String -> String
    mk concrete :: Bool
    concrete failing :: Bool
    failing dec :: Dec
    dec =

     do -- Only process data and newtype declarations, filter out all
        -- constructors and the type variables.
        let (name :: Name
    name, cons :: [Con]
    cons, vars :: [TyVarBndr]
    vars) =
              case Dec
    dec of
    #if MIN_VERSION_template_haskell(2,11,0)
                DataD    _ n :: Name
    n vs :: [TyVarBndr]
    vs _ cs :: [Con]
    cs _ -> (Name
    n, [Con]
    cs,  [TyVarBndr]
    vs)
                NewtypeD _ n :: Name
    n vs :: [TyVarBndr]
    vs _ c :: Con
    c  _ -> (Name
    n, [Con
    c], [TyVarBndr]
    vs)
    #else
                DataD    _ n vs cs _ -> (n, cs,  vs)
                NewtypeD _ n vs c  _ -> (n, [c], vs)
    #endif
                _ -> String -> (Name, [Con], [TyVarBndr])
    forall a. String -> a
    fclError "Can only derive labels for datatypes and newtypes."

            -- We are only interested in lenses of record constructors.
            fields :: [Field ([Context], Subst)]
    fields = (String -> String)
    -> [TyVarBndr] -> [Con] -> [Field ([Context], Subst)]
    groupFields String -> String
    mk [TyVarBndr]
    vars [Con]
    cons

        [Field ([Context], Subst)]
    -> (Field ([Context], Subst) -> Q Label) -> Q [Label]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM [Field ([Context], Subst)]
    fields ((Field ([Context], Subst) -> Q Label) -> Q [Label])
    -> (Field ([Context], Subst) -> Q Label) -> Q [Label]
    forall a b. (a -> b) -> a -> b
    $ Bool
    -> Bool
    -> Name
    -> [TyVarBndr]
    -> [Con]
    -> Field ([Context], Subst)
    -> Q Label
    generateLabel Bool
    failing Bool
    concrete Name
    name [TyVarBndr]
    vars [Con]
    cons

    groupFields :: (String -> String) -> [TyVarBndr] -> [Con] -> [Field ([Context], Subst)]
    groupFields :: (String -> String)
    -> [TyVarBndr] -> [Con] -> [Field ([Context], Subst)]
    groupFields mk :: String -> String
    mk vs :: [TyVarBndr]
    vs
      = (Field ([Context], Subst) -> Field ([Context], Subst))
    -> [Field ([Context], Subst)] -> [Field ([Context], Subst)]
    forall a b. (a -> b) -> [a] -> [b]
    map ((String -> String)
    -> Field ([Context], Subst) -> Field ([Context], Subst)
    forall c. (String -> String) -> Field c -> Field c
    rename String -> String
    mk)
      ([Field ([Context], Subst)] -> [Field ([Context], Subst)])
    -> ([Con] -> [Field ([Context], Subst)])
    -> [Con]
    -> [Field ([Context], Subst)]
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . ([Field (Context, Subst)] -> [Field ([Context], Subst)])
    -> [[Field (Context, Subst)]] -> [Field ([Context], Subst)]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (\fs :: [Field (Context, Subst)]
    fs -> let vals :: [(Context, Subst)]
    vals  = [[(Context, Subst)]] -> [(Context, Subst)]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat (Field (Context, Subst) -> [(Context, Subst)]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    toList (Field (Context, Subst) -> [(Context, Subst)])
    -> [Field (Context, Subst)] -> [[(Context, Subst)]]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Field (Context, Subst)]
    fs)
                              cons :: [Context]
    cons  = (Context, Subst) -> Context
    forall a b. (a, b) -> a
    fst ((Context, Subst) -> Context) -> [(Context, Subst)] -> [Context]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [(Context, Subst)]
    vals
                              subst :: Subst
    subst = [Subst] -> Subst
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ((Context, Subst) -> Subst
    forall a b. (a, b) -> b
    snd ((Context, Subst) -> Subst) -> [(Context, Subst)] -> [Subst]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [(Context, Subst)]
    vals)
                           in [Field ([Context], Subst)] -> [Field ([Context], Subst)]
    forall a. Eq a => [a] -> [a]
    nub (((Context, Subst) -> ([Context], Subst))
    -> Field (Context, Subst) -> Field ([Context], Subst)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (([Context], Subst) -> (Context, Subst) -> ([Context], Subst)
    forall a b. a -> b -> a
    const ([Context]
    cons, Subst
    subst)) (Field (Context, Subst) -> Field ([Context], Subst))
    -> [Field (Context, Subst)] -> [Field ([Context], Subst)]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Field (Context, Subst)]
    fs)
                  )
      ([[Field (Context, Subst)]] -> [Field ([Context], Subst)])
    -> ([Con] -> [[Field (Context, Subst)]])
    -> [Con]
    -> [Field ([Context], Subst)]
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . (Field (Context, Subst) -> Field (Context, Subst) -> Bool)
    -> [Field (Context, Subst)] -> [[Field (Context, Subst)]]
    forall a. (a -> a -> Bool) -> [a] -> [[a]]
    groupBy Field (Context, Subst) -> Field (Context, Subst) -> Bool
    forall c c. Field c -> Field c -> Bool
    eq
      ([Field (Context, Subst)] -> [[Field (Context, Subst)]])
    -> ([Con] -> [Field (Context, Subst)])
    -> [Con]
    -> [[Field (Context, Subst)]]
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . (Field (Context, Subst) -> Field (Context, Subst) -> Ordering)
    -> [Field (Context, Subst)] -> [Field (Context, Subst)]
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy ((Field (Context, Subst) -> Maybe Name)
    -> Field (Context, Subst) -> Field (Context, Subst) -> Ordering
    forall a b. Ord a => (b -> a) -> b -> b -> Ordering
    comparing Field (Context, Subst) -> Maybe Name
    forall c. Field c -> Maybe Name
    name)
      ([Field (Context, Subst)] -> [Field (Context, Subst)])
    -> ([Con] -> [Field (Context, Subst)])
    -> [Con]
    -> [Field (Context, Subst)]
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . (Con -> [Field (Context, Subst)])
    -> [Con] -> [Field (Context, Subst)]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap ([TyVarBndr] -> Con -> [Field (Context, Subst)]
    constructorFields [TyVarBndr]
    vs)
      where name :: Field c -> Maybe Name
    name (Field n :: Maybe Name
    n _ _ _) = Maybe Name
    n
            eq :: Field c -> Field c -> Bool
    eq f :: Field c
    f g :: Field c
    g = Bool
    False Bool -> Maybe Bool -> Bool
    forall a. a -> Maybe a -> a
    `fromMaybe` (Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    (==) (Name -> Name -> Bool) -> Maybe Name -> Maybe (Name -> Bool)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Field c -> Maybe Name
    forall c. Field c -> Maybe Name
    name Field c
    f Maybe (Name -> Bool) -> Maybe Name -> Maybe Bool
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Field c -> Maybe Name
    forall c. Field c -> Maybe Name
    name Field c
    g)
            rename :: (String -> String) -> Field c -> Field c
    rename f :: String -> String
    f (Field n :: Maybe Name
    n a :: Bool
    a b :: Kind
    b c :: c
    c) =
              Maybe Name -> Bool -> Kind -> c -> Field c
    forall c. Maybe Name -> Bool -> Kind -> c -> Field c
    Field (String -> Name
    mkName (String -> Name) -> (Name -> String) -> Name -> Name
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . String -> String
    f (String -> String) -> (Name -> String) -> Name -> String
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . Name -> String
    nameBase (Name -> Name) -> Maybe Name -> Maybe Name
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Maybe Name
    n) Bool
    a Kind
    b c
    c

    constructorFields :: [TyVarBndr] -> Con -> [Field (Context, Subst)]
    constructorFields :: [TyVarBndr] -> Con -> [Field (Context, Subst)]
    constructorFields vs :: [TyVarBndr]
    vs con :: Con
    con =

      case Con
    con of

        NormalC c :: Name
    c fs :: [BangType]
    fs -> (Int, BangType) -> Field (Context, Subst)
    forall a. (Int, BangType) -> Field (Context, [a])
    one ((Int, BangType) -> Field (Context, Subst))
    -> [(Int, BangType)] -> [Field (Context, Subst)]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Int] -> [BangType] -> [(Int, BangType)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [0..] [BangType]
    fs
          where one :: (Int, BangType) -> Field (Context, [a])
    one (i :: Int
    i, f :: BangType
    f@(_, ty :: Kind
    ty)) = Maybe Name
    -> Bool -> Kind -> (Context, [a]) -> Field (Context, [a])
    forall c. Maybe Name -> Bool -> Kind -> c -> Field c
    Field Maybe Name
    forall a. Maybe a
    Nothing Bool
    mono Kind
    ty (Int -> Name -> Con -> Context
    Context Int
    i Name
    c Con
    con, [])
                  where fsTys :: [[Name]]
    fsTys = (BangType -> [Name]) -> [BangType] -> [[Name]]
    forall a b. (a -> b) -> [a] -> [b]
    map (Kind -> [Name]
    typeVariables (Kind -> [Name]) -> (BangType -> Kind) -> BangType -> [Name]
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . BangType -> Kind
    forall a b. (a, b) -> b
    snd) (BangType -> [BangType] -> [BangType]
    forall a. Eq a => a -> [a] -> [a]
    delete BangType
    f [BangType]
    fs)
                        mono :: Bool
    mono  = (Name -> Bool) -> [Name] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (\x :: Name
    x -> ([Name] -> Bool) -> [[Name]] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Name -> [Name] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    elem Name
    x) [[Name]]
    fsTys) (Kind -> [Name]
    typeVariables Kind
    ty)

        RecC c :: Name
    c fs :: [VarBangType]
    fs -> (Int, VarBangType) -> Field (Context, Subst)
    forall a. (Int, VarBangType) -> Field (Context, [a])
    one ((Int, VarBangType) -> Field (Context, Subst))
    -> [(Int, VarBangType)] -> [Field (Context, Subst)]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Int] -> [VarBangType] -> [(Int, VarBangType)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [0..] [VarBangType]
    fs
          where one :: (Int, VarBangType) -> Field (Context, [a])
    one (i :: Int
    i, f :: VarBangType
    f@(n :: Name
    n, _, ty :: Kind
    ty)) = Maybe Name
    -> Bool -> Kind -> (Context, [a]) -> Field (Context, [a])
    forall c. Maybe Name -> Bool -> Kind -> c -> Field c
    Field (Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    n) Bool
    mono Kind
    ty (Int -> Name -> Con -> Context
    Context Int
    i Name
    c Con
    con, [])
                  where fsTys :: [[Name]]
    fsTys = (VarBangType -> [Name]) -> [VarBangType] -> [[Name]]
    forall a b. (a -> b) -> [a] -> [b]
    map (Kind -> [Name]
    typeVariables (Kind -> [Name]) -> (VarBangType -> Kind) -> VarBangType -> [Name]
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . VarBangType -> Kind
    forall a b c. (a, b, c) -> c
    trd) (VarBangType -> [VarBangType] -> [VarBangType]
    forall a. Eq a => a -> [a] -> [a]
    delete VarBangType
    f [VarBangType]
    fs)
                        mono :: Bool
    mono  = (Name -> Bool) -> [Name] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (\x :: Name
    x -> ([Name] -> Bool) -> [[Name]] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Name -> [Name] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    elem Name
    x) [[Name]]
    fsTys) (Kind -> [Name]
    typeVariables Kind
    ty)

        InfixC a :: BangType
    a c :: Name
    c b :: BangType
    b -> (Int, BangType) -> Field (Context, Subst)
    forall a a. (Int, (a, Kind)) -> Field (Context, [a])
    one ((Int, BangType) -> Field (Context, Subst))
    -> [(Int, BangType)] -> [Field (Context, Subst)]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [(0, BangType
    a), (1, BangType
    b)]
          where one :: (Int, (a, Kind)) -> Field (Context, [a])
    one (i :: Int
    i, (_, ty :: Kind
    ty)) = Maybe Name
    -> Bool -> Kind -> (Context, [a]) -> Field (Context, [a])
    forall c. Maybe Name -> Bool -> Kind -> c -> Field c
    Field Maybe Name
    forall a. Maybe a
    Nothing Bool
    mono Kind
    ty (Int -> Name -> Con -> Context
    Context Int
    i Name
    c Con
    con, [])
                  where fsTys :: [[Name]]
    fsTys = (BangType -> [Name]) -> [BangType] -> [[Name]]
    forall a b. (a -> b) -> [a] -> [b]
    map (Kind -> [Name]
    typeVariables (Kind -> [Name]) -> (BangType -> Kind) -> BangType -> [Name]
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . BangType -> Kind
    forall a b. (a, b) -> b
    snd) [BangType
    a, BangType
    b]
                        mono :: Bool
    mono  = (Name -> Bool) -> [Name] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (\x :: Name
    x -> ([Name] -> Bool) -> [[Name]] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Name -> [Name] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    elem Name
    x) [[Name]]
    fsTys) (Kind -> [Name]
    typeVariables Kind
    ty)

        ForallC x :: [TyVarBndr]
    x y :: Cxt
    y v :: Con
    v -> Field (Context, Subst) -> Field (Context, Subst)
    setEqs (Field (Context, Subst) -> Field (Context, Subst))
    -> [Field (Context, Subst)] -> [Field (Context, Subst)]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [TyVarBndr] -> Con -> [Field (Context, Subst)]
    constructorFields [TyVarBndr]
    vs Con
    v
    #if MIN_VERSION_template_haskell(2,10,0)
          where eqs :: Subst
    eqs = [ (Kind
    a, Kind
    b) | AppT (AppT EqualityT a :: Kind
    a) b :: Kind
    b <- Cxt
    y ]
    #else
          where eqs = [ (a, b) | EqualP a b <- y ]
    #endif
                setEqs :: Field (Context, Subst) -> Field (Context, Subst)
    setEqs (Field a :: Maybe Name
    a b :: Bool
    b c :: Kind
    c d :: (Context, Subst)
    d) = Maybe Name
    -> Bool -> Kind -> (Context, Subst) -> Field (Context, Subst)
    forall c. Maybe Name -> Bool -> Kind -> c -> Field c
    Field Maybe Name
    a Bool
    b Kind
    c ((Context -> Context) -> (Context, Subst) -> (Context, Subst)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (b, d) (c, d)
    first Context -> Context
    upd ((Context, Subst) -> (Context, Subst))
    -> ((Context, Subst) -> (Context, Subst))
    -> (Context, Subst)
    -> (Context, Subst)
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . (Subst -> Subst) -> (Context, Subst) -> (Context, Subst)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (d, b) (d, c)
    second (Subst
    eqs Subst -> Subst -> Subst
    forall a. [a] -> [a] -> [a]
    ++) ((Context, Subst) -> (Context, Subst))
    -> (Context, Subst) -> (Context, Subst)
    forall a b. (a -> b) -> a -> b
    $ (Context, Subst)
    d)
                upd :: Context -> Context
    upd (Context a :: Int
    a b :: Name
    b c :: Con
    c) = Int -> Name -> Con -> Context
    Context Int
    a Name
    b ([TyVarBndr] -> Cxt -> Con -> Con
    ForallC [TyVarBndr]
    x Cxt
    y Con
    c)
    #if MIN_VERSION_template_haskell(2,11,0)
        GadtC cs :: [Name]
    cs fs :: [BangType]
    fs resTy :: Kind
    resTy -> (Name -> [Field (Context, Subst)])
    -> [Name] -> [Field (Context, Subst)]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (\c :: Name
    c -> Name -> (Int, BangType) -> Field (Context, Subst)
    one Name
    c ((Int, BangType) -> Field (Context, Subst))
    -> [(Int, BangType)] -> [Field (Context, Subst)]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Int] -> [BangType] -> [(Int, BangType)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [0..] [BangType]
    fs) [Name]
    cs
          where one :: Name -> (Int, BangType) -> Field (Context, Subst)
    one c :: Name
    c (i :: Int
    i, f :: BangType
    f@(_, ty :: Kind
    ty)) = Maybe Name
    -> Bool -> Kind -> (Context, Subst) -> Field (Context, Subst)
    forall c. Maybe Name -> Bool -> Kind -> c -> Field c
    Field Maybe Name
    forall a. Maybe a
    Nothing Bool
    mono Kind
    ty (Int -> Name -> Con -> Context
    Context Int
    i Name
    c Con
    con, [TyVarBndr] -> Kind -> Subst
    mkSubst [TyVarBndr]
    vs Kind
    resTy)
                  where fsTys :: [[Name]]
    fsTys = (BangType -> [Name]) -> [BangType] -> [[Name]]
    forall a b. (a -> b) -> [a] -> [b]
    map (Kind -> [Name]
    typeVariables (Kind -> [Name]) -> (BangType -> Kind) -> BangType -> [Name]
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . BangType -> Kind
    forall a b. (a, b) -> b
    snd) (BangType -> [BangType] -> [BangType]
    forall a. Eq a => a -> [a] -> [a]
    delete BangType
    f [BangType]
    fs)
                        mono :: Bool
    mono  = (Name -> Bool) -> [Name] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (\x :: Name
    x -> ([Name] -> Bool) -> [[Name]] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Name -> [Name] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    elem Name
    x) [[Name]]
    fsTys) (Kind -> [Name]
    typeVariables Kind
    ty)
        RecGadtC cs :: [Name]
    cs fs :: [VarBangType]
    fs resTy :: Kind
    resTy -> (Name -> [Field (Context, Subst)])
    -> [Name] -> [Field (Context, Subst)]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (\c :: Name
    c -> Name -> (Int, VarBangType) -> Field (Context, Subst)
    one Name
    c ((Int, VarBangType) -> Field (Context, Subst))
    -> [(Int, VarBangType)] -> [Field (Context, Subst)]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Int] -> [VarBangType] -> [(Int, VarBangType)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [0..] [VarBangType]
    fs) [Name]
    cs
          where one :: Name -> (Int, VarBangType) -> Field (Context, Subst)
    one c :: Name
    c (i :: Int
    i, f :: VarBangType
    f@(n :: Name
    n, _, ty :: Kind
    ty)) = Maybe Name
    -> Bool -> Kind -> (Context, Subst) -> Field (Context, Subst)
    forall c. Maybe Name -> Bool -> Kind -> c -> Field c
    Field (Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    n) Bool
    mono Kind
    ty (Int -> Name -> Con -> Context
    Context Int
    i Name
    c Con
    con, [TyVarBndr] -> Kind -> Subst
    mkSubst [TyVarBndr]
    vs Kind
    resTy)
                  where fsTys :: [[Name]]
    fsTys = (VarBangType -> [Name]) -> [VarBangType] -> [[Name]]
    forall a b. (a -> b) -> [a] -> [b]
    map (Kind -> [Name]
    typeVariables (Kind -> [Name]) -> (VarBangType -> Kind) -> VarBangType -> [Name]
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . VarBangType -> Kind
    forall a b c. (a, b, c) -> c
    trd) (VarBangType -> [VarBangType] -> [VarBangType]
    forall a. Eq a => a -> [a] -> [a]
    delete VarBangType
    f [VarBangType]
    fs)
                        mono :: Bool
    mono  = (Name -> Bool) -> [Name] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (\x :: Name
    x -> ([Name] -> Bool) -> [[Name]] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Name -> [Name] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    elem Name
    x) [[Name]]
    fsTys) (Kind -> [Name]
    typeVariables Kind
    ty)

    mkSubst :: [TyVarBndr] -> Type -> Subst
    mkSubst :: [TyVarBndr] -> Kind -> Subst
    mkSubst vars :: [TyVarBndr]
    vars t :: Kind
    t = [TyVarBndr] -> Kind -> Subst
    go ([TyVarBndr] -> [TyVarBndr]
    forall a. [a] -> [a]
    reverse [TyVarBndr]
    vars) Kind
    t
      where
        go :: [TyVarBndr] -> Kind -> Subst
    go [] _ = []
        go (v :: TyVarBndr
    v:vs :: [TyVarBndr]
    vs) (AppT t1 :: Kind
    t1 t2 :: Kind
    t2) = (TyVarBndr -> Kind
    typeFromBinder TyVarBndr
    v, Kind
    t2) (Kind, Kind) -> Subst -> Subst
    forall a. a -> [a] -> [a]
    : [TyVarBndr] -> Kind -> Subst
    go [TyVarBndr]
    vs Kind
    t1
        go _  _ = String -> Subst
    forall a. String -> a
    fclError "Non-AppT with type variables in mkSubst. Please report this as a bug for fclabels."
    #endif

    prune :: [Context] -> [Con] -> [Con]
    prune :: [Context] -> [Con] -> [Con]
    prune contexts :: [Context]
    contexts allCons :: [Con]
    allCons =
      case [Context]
    contexts of
        (Context _ _ con :: Con
    con) : _
           -> (Con -> Bool) -> [Con] -> [Con]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Con -> Con -> Bool
    unifiableCon Con
    con) [Con]
    allCons
        [] -> []

    unifiableCon :: Con -> Con -> Bool
    unifiableCon :: Con -> Con -> Bool
    unifiableCon a :: Con
    a b :: Con
    b = [Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    and ((Kind -> Kind -> Bool) -> Cxt -> Cxt -> [Bool]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith Kind -> Kind -> Bool
    unifiable (Con -> Cxt
    indices Con
    a) (Con -> Cxt
    indices Con
    b))
      where indices :: Con -> Cxt
    indices con :: Con
    con =
              case Con
    con of
                NormalC {}      -> []
                RecC    {}      -> []
                InfixC  {}      -> []
    #if MIN_VERSION_template_haskell(2,11,0)
                ForallC _ _ ty :: Con
    ty  -> Con -> Cxt
    indices Con
    ty
    #elif MIN_VERSION_template_haskell(2,10,0)
                ForallC _ x _   -> [ c | AppT (AppT EqualityT _) c <- x ]
    #else
                ForallC _ x _   -> [ c | EqualP _ c <- x ]
    #endif
    #if MIN_VERSION_template_haskell(2,11,0)
                GadtC _ _ ty :: Kind
    ty    -> Kind -> Cxt
    conIndices Kind
    ty
                RecGadtC _ _ ty :: Kind
    ty -> Kind -> Cxt
    conIndices Kind
    ty
             where
               conIndices :: Kind -> Cxt
    conIndices (AppT (ConT _) ty :: Kind
    ty) = [Kind
    ty]
               conIndices (AppT rest :: Kind
    rest     ty :: Kind
    ty) = Kind -> Cxt
    conIndices Kind
    rest Cxt -> Cxt -> Cxt
    forall a. [a] -> [a] -> [a]
    ++ [Kind
    ty]
               conIndices _                  = String -> Cxt
    forall a. String -> a
    fclError "Non-AppT in conIndices. Please report this as a bug for fclabels."
    #endif

    unifiable :: Type -> Type -> Bool
    unifiable :: Kind -> Kind -> Bool
    unifiable x :: Kind
    x y :: Kind
    y =
      case (Kind
    x, Kind
    y) of
        ( VarT _        ,      _        ) -> Bool
    True
        ( _             , VarT _        ) -> Bool
    True
        ( AppT a :: Kind
    a b :: Kind
    b      , AppT c :: Kind
    c d :: Kind
    d      ) -> Kind -> Kind -> Bool
    unifiable Kind
    a Kind
    c Bool -> Bool -> Bool
    && Kind -> Kind -> Bool
    unifiable Kind
    b Kind
    d
        ( SigT t :: Kind
    t k :: Kind
    k      , SigT s :: Kind
    s j :: Kind
    j      ) -> Kind -> Kind -> Bool
    unifiable Kind
    t Kind
    s Bool -> Bool -> Bool
    && Kind
    k Kind -> Kind -> Bool
    forall a. Eq a => a -> a -> Bool
    == Kind
    j
        ( ForallT _ _ t :: Kind
    t , ForallT _ _ s :: Kind
    s ) -> Kind -> Kind -> Bool
    unifiable Kind
    t Kind
    s
        ( a :: Kind
    a             , b :: Kind
    b             ) -> Kind
    a Kind -> Kind -> Bool
    forall a. Eq a => a -> a -> Bool
    == Kind
    b

    generateLabel
      :: Bool
      -> Bool
      -> Name
      -> [TyVarBndr]
      -> [Con]
      -> Field ([Context], Subst)
      -> Q Label

    generateLabel :: Bool
    -> Bool
    -> Name
    -> [TyVarBndr]
    -> [Con]
    -> Field ([Context], Subst)
    -> Q Label
    generateLabel failing :: Bool
    failing concrete :: Bool
    concrete datatype :: Name
    datatype dtVars :: [TyVarBndr]
    dtVars allCons :: [Con]
    allCons
                  field :: Field ([Context], Subst)
    field@(Field name :: Maybe Name
    name forcedMono :: Bool
    forcedMono fieldtype :: Kind
    fieldtype (contexts :: [Context]
    contexts, subst :: Subst
    subst)) =

      do let total :: Bool
    total = [Context] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Context]
    contexts Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == [Con] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length ([Context] -> [Con] -> [Con]
    prune [Context]
    contexts [Con]
    allCons)

         (Typing mono :: Bool
    mono tyI :: TypeQ
    tyI tyO :: TypeQ
    tyO _)
            <- Bool -> Kind -> Name -> [TyVarBndr] -> Subst -> Q Typing
    computeTypes Bool
    forcedMono Kind
    fieldtype Name
    datatype [TyVarBndr]
    dtVars Subst
    subst

         let cat :: TypeQ
    cat     = Name -> TypeQ
    varT (String -> Name
    mkName "cat")
             failE :: Q Exp
    failE   = if Bool
    failing
                       then [| failArrow |]
                       else [| zeroArrow |]
             getT :: Q Exp
    getT    = [| arr $(getter failing total field) |]
             putT :: Q Exp
    putT    = [| arr $(setter failing total field) |]
             getP :: Q Exp
    getP    = [| $(failE) ||| id <<< $getT |]
             putP :: Q Exp
    putP    = [| $(failE) ||| id <<< $putT |]
             failP :: TypeQ
    failP   = if Bool
    failing
                       then Name -> [TypeQ] -> TypeQ
    classP ''ArrowFail [ [t| String |], TypeQ
    cat]
                       else Name -> [TypeQ] -> TypeQ
    classP ''ArrowZero [TypeQ
    cat]
             ctx :: CxtQ
    ctx     = if Bool
    total
                       then [TypeQ] -> CxtQ
    cxt [ Name -> [TypeQ] -> TypeQ
    classP ''ArrowApply  [TypeQ
    cat] ]
                       else [TypeQ] -> CxtQ
    cxt [ Name -> [TypeQ] -> TypeQ
    classP ''ArrowChoice [TypeQ
    cat]
                                , Name -> [TypeQ] -> TypeQ
    classP ''ArrowApply  [TypeQ
    cat]
                                , TypeQ
    failP
                                ]
             body :: Q Exp
    body    = if Bool
    total
                       then [| Poly.point $ Point $getT (modifier $getT $putT) |]
                       else [| Poly.point $ Point $getP (modifier $getP $putP) |]
             cont :: CxtQ
    cont    = if Bool
    concrete
                       then [TypeQ] -> CxtQ
    cxt []
                       else CxtQ
    ctx
             partial :: TypeQ
    partial = if Bool
    failing
                       then [t| Failing String |]
                       else [t| Partial |]
             concTy :: TypeQ
    concTy  = if Bool
    total
                       then if Bool
    mono
                            then [t| Mono.Lens Total $tyI $tyO |]
                            else [t| Poly.Lens Total $tyI $tyO |]
                       else if Bool
    mono
                            then [t| Mono.Lens $partial $tyI $tyO |]
                            else [t| Poly.Lens $partial $tyI $tyO |]
             ty :: TypeQ
    ty      = if Bool
    concrete
                       then TypeQ
    concTy
                       else if Bool
    mono
                            then [t| Mono.Lens $cat $tyI $tyO |]
                            else [t| Poly.Lens $cat $tyI $tyO |]

         [TyVarBndr]
    tvs <- [TyVarBndr] -> [TyVarBndr]
    forall a. Eq a => [a] -> [a]
    nub ([TyVarBndr] -> [TyVarBndr])
    -> (Kind -> [TyVarBndr]) -> Kind -> [TyVarBndr]
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . Kind -> [TyVarBndr]
    binderFromType (Kind -> [TyVarBndr]) -> TypeQ -> Q [TyVarBndr]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> TypeQ
    ty
         Label -> Q Label
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Label -> Q Label) -> Label -> Q Label
    forall a b. (a -> b) -> a -> b
    $
           case Maybe Name
    name of
             Nothing -> [TyVarBndr] -> CxtQ -> TypeQ -> Q Exp -> Label
    LabelExpr [TyVarBndr]
    tvs CxtQ
    cont TypeQ
    ty Q Exp
    body
             Just n :: Name
    n  ->

    #if MIN_VERSION_template_haskell(2,8,0)
               -- Generate an inline declaration for the label.
               -- Type of InlineSpec removed in TH-2.8.0 (GHC 7.6)
               let inline :: Pragma
    inline = Name -> Inline -> RuleMatch -> Phases -> Pragma
    InlineP Name
    n Inline
    Inline RuleMatch
    FunLike (Int -> Phases
    FromPhase 0)
    #else
               let inline = InlineP n (InlineSpec True True (Just (True, 0)))
    #endif
                in Name -> Q Dec -> [TyVarBndr] -> CxtQ -> TypeQ -> Q Exp -> Label
    LabelDecl Name
    n (Dec -> Q Dec
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Pragma -> Dec
    PragmaD Pragma
    inline)) [TyVarBndr]
    tvs CxtQ
    cont TypeQ
    ty Q Exp
    body

    -- Build a total polymorphic modification function from a getter and setter.

    modifier :: ArrowApply cat => cat f o -> cat (i, f) g -> cat (cat o i, f) g
    modifier :: cat f o -> cat (i, f) g -> cat (cat o i, f) g
    modifier g :: cat f o
    g m :: cat (i, f) g
    m = cat (i, f) g
    m cat (i, f) g -> cat (cat o i, f) (i, f) -> cat (cat o i, f) g
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . cat (cat o i, o) i -> cat ((cat o i, o), f) (i, f)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (b, d) (c, d)
    first cat (cat o i, o) i
    forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
    app cat ((cat o i, o), f) (i, f)
    -> cat (cat o i, f) ((cat o i, o), f) -> cat (cat o i, f) (i, f)
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . ((cat o i, (f, o)) -> ((cat o i, o), f))
    -> cat (cat o i, (f, o)) ((cat o i, o), f)
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr (\(n :: cat o i
    n, (f :: f
    f, o :: o
    o)) -> ((cat o i
    n, o
    o), f
    f)) cat (cat o i, (f, o)) ((cat o i, o), f)
    -> cat (cat o i, f) (cat o i, (f, o))
    -> cat (cat o i, f) ((cat o i, o), f)
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . cat f (f, o) -> cat (cat o i, f) (cat o i, (f, o))
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (d, b) (d, c)
    second (cat f f
    forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
    id cat f f -> cat f o -> cat f (f, o)
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& cat f o
    g)
    {-# INLINE modifier #-}

    -------------------------------------------------------------------------------

    getter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp
    getter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp
    getter failing :: Bool
    failing total :: Bool
    total (Field mn :: Maybe Name
    mn _ _ (cons :: [Context]
    cons, _)) =
      do let pt :: Name
    pt = String -> Name
    mkName "f"
             nm :: Q Exp
    nm = Q Exp -> (Name -> Q Exp) -> Maybe Name -> Q Exp
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe ([Q Exp] -> Q Exp
    tupE []) (Lit -> Q Exp
    litE (Lit -> Q Exp) -> (Name -> Lit) -> Name -> Q Exp
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . String -> Lit
    StringL (String -> Lit) -> (Name -> String) -> Name -> Lit
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . Name -> String
    nameBase) (Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard Bool
    failing Maybe () -> Maybe Name -> Maybe Name
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Maybe Name
    mn)
             wild :: [MatchQ]
    wild = if Bool
    total then [] else [PatQ -> BodyQ -> [Q Dec] -> MatchQ
    match PatQ
    wildP (Q Exp -> BodyQ
    normalB [| Left $(nm) |]) []]
             rght :: Q Exp -> Q Exp
    rght = if Bool
    total then Q Exp -> Q Exp
    forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
    id else Q Exp -> Q Exp -> Q Exp
    appE [| Right |]
             mkCase :: Context -> [MatchQ]
    mkCase (Context i :: Int
    i _ c :: Con
    c) = ((PatQ, Q Exp) -> MatchQ) -> [(PatQ, Q Exp)] -> [MatchQ]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(pat :: PatQ
    pat, var :: Q Exp
    var) -> PatQ -> BodyQ -> [Q Dec] -> MatchQ
    match PatQ
    pat (Q Exp -> BodyQ
    normalB (Q Exp -> Q Exp
    rght Q Exp
    var)) []) (Int -> Con -> [(PatQ, Q Exp)]
    case1 Int
    i Con
    c)
         [PatQ] -> Q Exp -> Q Exp
    lamE [Name -> PatQ
    varP Name
    pt]
              (Q Exp -> [MatchQ] -> Q Exp
    caseE (Name -> Q Exp
    varE Name
    pt) ((Context -> [MatchQ]) -> [Context] -> [MatchQ]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap Context -> [MatchQ]
    mkCase [Context]
    cons [MatchQ] -> [MatchQ] -> [MatchQ]
    forall a. [a] -> [a] -> [a]
    ++ [MatchQ]
    wild))
      where
      case1 :: Int -> Con -> [(Q Pat, Q Exp)]
      case1 :: Int -> Con -> [(PatQ, Q Exp)]
    case1 i :: Int
    i con :: Con
    con =
        case Con
    con of
          NormalC  c :: Name
    c  fs :: [BangType]
    fs   -> [[BangType] -> Name -> (PatQ, Q Exp)
    forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
    one [BangType]
    fs Name
    c]
          RecC     c :: Name
    c  fs :: [VarBangType]
    fs   -> [[VarBangType] -> Name -> (PatQ, Q Exp)
    forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
    one [VarBangType]
    fs Name
    c]
          InfixC   _  c :: Name
    c  _ -> [(PatQ -> Name -> PatQ -> PatQ
    infixP ([PatQ]
    pats [PatQ] -> Int -> PatQ
    forall a. [a] -> Int -> a
    !! 0) Name
    c ([PatQ]
    pats [PatQ] -> Int -> PatQ
    forall a. [a] -> Int -> a
    !! 1), Q Exp
    var)]
          ForallC  _  _  c :: Con
    c -> Int -> Con -> [(PatQ, Q Exp)]
    case1 Int
    i Con
    c
    #if MIN_VERSION_template_haskell(2,11,0)
          GadtC    cs :: [Name]
    cs fs :: [BangType]
    fs _ -> (Name -> (PatQ, Q Exp)) -> [Name] -> [(PatQ, Q Exp)]
    forall a b. (a -> b) -> [a] -> [b]
    map ([BangType] -> Name -> (PatQ, Q Exp)
    forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
    one [BangType]
    fs) [Name]
    cs
          RecGadtC cs :: [Name]
    cs fs :: [VarBangType]
    fs _ -> (Name -> (PatQ, Q Exp)) -> [Name] -> [(PatQ, Q Exp)]
    forall a b. (a -> b) -> [a] -> [b]
    map ([VarBangType] -> Name -> (PatQ, Q Exp)
    forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
    one [VarBangType]
    fs) [Name]
    cs
    #endif
        where fresh :: [Name]
    fresh = String -> Name
    mkName (String -> Name) -> [String] -> [Name]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> [String] -> [String]
    forall a. Eq a => a -> [a] -> [a]
    delete "f" [String]
    freshNames
              pats1 :: [PatQ]
    pats1 = Name -> PatQ
    varP (Name -> PatQ) -> [Name] -> [PatQ]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Name]
    fresh
              pats :: [PatQ]
    pats  = Int -> PatQ -> [PatQ]
    forall a. Int -> a -> [a]
    replicate Int
    i PatQ
    wildP [PatQ] -> [PatQ] -> [PatQ]
    forall a. [a] -> [a] -> [a]
    ++ [[PatQ]
    pats1 [PatQ] -> Int -> PatQ
    forall a. [a] -> Int -> a
    !! Int
    i] [PatQ] -> [PatQ] -> [PatQ]
    forall a. [a] -> [a] -> [a]
    ++ PatQ -> [PatQ]
    forall a. a -> [a]
    repeat PatQ
    wildP
              var :: Q Exp
    var   = Name -> Q Exp
    varE ([Name]
    fresh [Name] -> Int -> Name
    forall a. [a] -> Int -> a
    !! Int
    i)
              one :: t a -> Name -> (PatQ, Q Exp)
    one fs :: t a
    fs c :: Name
    c = let s :: [a] -> [a]
    s = Int -> [a] -> [a]
    forall a. Int -> [a] -> [a]
    take (t a -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length t a
    fs) in (Name -> [PatQ] -> PatQ
    conP Name
    c ([PatQ] -> [PatQ]
    forall a. [a] -> [a]
    s [PatQ]
    pats), Q Exp
    var)

    setter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp
    setter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp
    setter failing :: Bool
    failing total :: Bool
    total (Field mn :: Maybe Name
    mn _ _ (cons :: [Context]
    cons, _)) =
      do let pt :: Name
    pt = String -> Name
    mkName "f"
             md :: Name
    md = String -> Name
    mkName "v"
             nm :: Q Exp
    nm = Q Exp -> (Name -> Q Exp) -> Maybe Name -> Q Exp
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe ([Q Exp] -> Q Exp
    tupE []) (Lit -> Q Exp
    litE (Lit -> Q Exp) -> (Name -> Lit) -> Name -> Q Exp
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . String -> Lit
    StringL (String -> Lit) -> (Name -> String) -> Name -> Lit
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . Name -> String
    nameBase) (Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard Bool
    failing Maybe () -> Maybe Name -> Maybe Name
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Maybe Name
    mn)
             wild :: [MatchQ]
    wild = if Bool
    total then [] else [PatQ -> BodyQ -> [Q Dec] -> MatchQ
    match PatQ
    wildP (Q Exp -> BodyQ
    normalB [| Left $(nm) |]) []]
             rght :: Q Exp -> Q Exp
    rght = if Bool
    total then Q Exp -> Q Exp
    forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
    id else Q Exp -> Q Exp -> Q Exp
    appE [| Right |]
             mkCase :: Context -> [MatchQ]
    mkCase (Context i :: Int
    i _ c :: Con
    c) = ((PatQ, Q Exp) -> MatchQ) -> [(PatQ, Q Exp)] -> [MatchQ]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(pat :: PatQ
    pat, var :: Q Exp
    var) -> PatQ -> BodyQ -> [Q Dec] -> MatchQ
    match PatQ
    pat (Q Exp -> BodyQ
    normalB (Q Exp -> Q Exp
    rght Q Exp
    var)) []) (Int -> Con -> [(PatQ, Q Exp)]
    case1 Int
    i Con
    c)
         [PatQ] -> Q Exp -> Q Exp
    lamE [[PatQ] -> PatQ
    tupP [Name -> PatQ
    varP Name
    md, Name -> PatQ
    varP Name
    pt]]
              (Q Exp -> [MatchQ] -> Q Exp
    caseE (Name -> Q Exp
    varE Name
    pt) ((Context -> [MatchQ]) -> [Context] -> [MatchQ]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap Context -> [MatchQ]
    mkCase [Context]
    cons [MatchQ] -> [MatchQ] -> [MatchQ]
    forall a. [a] -> [a] -> [a]
    ++ [MatchQ]
    wild))
      where
      case1 :: Int -> Con -> [(PatQ, Q Exp)]
    case1 i :: Int
    i con :: Con
    con =
        case Con
    con of
          NormalC  c :: Name
    c  fs :: [BangType]
    fs   -> [[BangType] -> Name -> (PatQ, Q Exp)
    forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
    one [BangType]
    fs Name
    c]
          RecC     c :: Name
    c  fs :: [VarBangType]
    fs   -> [[VarBangType] -> Name -> (PatQ, Q Exp)
    forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
    one [VarBangType]
    fs Name
    c]
          InfixC   _  c :: Name
    c  _ -> [( PatQ -> Name -> PatQ -> PatQ
    infixP ([PatQ]
    pats [PatQ] -> Int -> PatQ
    forall a. [a] -> Int -> a
    !! 0) Name
    c ([PatQ]
    pats [PatQ] -> Int -> PatQ
    forall a. [a] -> Int -> a
    !! 1)
                              , Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
    infixE (Q Exp -> Maybe (Q Exp)
    forall a. a -> Maybe a
    Just ([Q Exp]
    vars [Q Exp] -> Int -> Q Exp
    forall a. [a] -> Int -> a
    !! 0)) (Name -> Q Exp
    conE Name
    c) (Q Exp -> Maybe (Q Exp)
    forall a. a -> Maybe a
    Just ([Q Exp]
    vars [Q Exp] -> Int -> Q Exp
    forall a. [a] -> Int -> a
    !! 1))
                              )
                             ]
          ForallC  _  _  c :: Con
    c -> Int -> Con -> [(PatQ, Q Exp)]
    case1 Int
    i Con
    c
    #if MIN_VERSION_template_haskell(2,11,0)
          GadtC    cs :: [Name]
    cs fs :: [BangType]
    fs _ -> (Name -> (PatQ, Q Exp)) -> [Name] -> [(PatQ, Q Exp)]
    forall a b. (a -> b) -> [a] -> [b]
    map ([BangType] -> Name -> (PatQ, Q Exp)
    forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
    one [BangType]
    fs) [Name]
    cs
          RecGadtC cs :: [Name]
    cs fs :: [VarBangType]
    fs _ -> (Name -> (PatQ, Q Exp)) -> [Name] -> [(PatQ, Q Exp)]
    forall a b. (a -> b) -> [a] -> [b]
    map ([VarBangType] -> Name -> (PatQ, Q Exp)
    forall (t :: * -> *) a. Foldable t => t a -> Name -> (PatQ, Q Exp)
    one [VarBangType]
    fs) [Name]
    cs
    #endif
        where fresh :: [Name]
    fresh     = String -> Name
    mkName (String -> Name) -> [String] -> [Name]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> [String] -> [String]
    forall a. Eq a => a -> [a] -> [a]
    delete "f" (String -> [String] -> [String]
    forall a. Eq a => a -> [a] -> [a]
    delete "v" [String]
    freshNames)
              pats1 :: [PatQ]
    pats1     = Name -> PatQ
    varP (Name -> PatQ) -> [Name] -> [PatQ]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Name]
    fresh
              pats :: [PatQ]
    pats      = Int -> [PatQ] -> [PatQ]
    forall a. Int -> [a] -> [a]
    take Int
    i [PatQ]
    pats1 [PatQ] -> [PatQ] -> [PatQ]
    forall a. [a] -> [a] -> [a]
    ++ [PatQ
    wildP] [PatQ] -> [PatQ] -> [PatQ]
    forall a. [a] -> [a] -> [a]
    ++ Int -> [PatQ] -> [PatQ]
    forall a. Int -> [a] -> [a]
    drop (Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + 1) [PatQ]
    pats1
              vars1 :: [Q Exp]
    vars1     = Name -> Q Exp
    varE (Name -> Q Exp) -> [Name] -> [Q Exp]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Name]
    fresh
              v :: Q Exp
    v         = Name -> Q Exp
    varE (String -> Name
    mkName "v")
              vars :: [Q Exp]
    vars      = Int -> [Q Exp] -> [Q Exp]
    forall a. Int -> [a] -> [a]
    take Int
    i [Q Exp]
    vars1 [Q Exp] -> [Q Exp] -> [Q Exp]
    forall a. [a] -> [a] -> [a]
    ++ [Q Exp
    v] [Q Exp] -> [Q Exp] -> [Q Exp]
    forall a. [a] -> [a] -> [a]
    ++ Int -> [Q Exp] -> [Q Exp]
    forall a. Int -> [a] -> [a]
    drop (Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + 1) [Q Exp]
    vars1
              apps :: Q Exp -> t (Q Exp) -> Q Exp
    apps f :: Q Exp
    f as :: t (Q Exp)
    as = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> t (Q Exp) -> Q Exp
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Q Exp -> Q Exp -> Q Exp
    appE Q Exp
    f t (Q Exp)
    as
              one :: t a -> Name -> (PatQ, Q Exp)
    one fs :: t a
    fs c :: Name
    c  = let s :: [a] -> [a]
    s = Int -> [a] -> [a]
    forall a. Int -> [a] -> [a]
    take (t a -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length t a
    fs) in (Name -> [PatQ] -> PatQ
    conP Name
    c ([PatQ] -> [PatQ]
    forall a. [a] -> [a]
    s [PatQ]
    pats), Q Exp -> [Q Exp] -> Q Exp
    forall (t :: * -> *). Foldable t => Q Exp -> t (Q Exp) -> Q Exp
    apps (Name -> Q Exp
    conE Name
    c) ([Q Exp] -> [Q Exp]
    forall a. [a] -> [a]
    s [Q Exp]
    vars))

    freshNames :: [String]
    freshNames :: [String]
    freshNames = (Char -> String) -> String -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> String
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ['a'..'z'] [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ (Integer -> String) -> [Integer] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (('a'Char -> String -> String
    forall a. a -> [a] -> [a]
    :) (String -> String) -> (Integer -> String) -> Integer -> String
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . Integer -> String
    forall a. Show a => a -> String
    show) [0 :: Integer ..]

    -------------------------------------------------------------------------------

    computeTypes :: Bool -> Type -> Name -> [TyVarBndr] -> Subst -> Q Typing
    computeTypes :: Bool -> Kind -> Name -> [TyVarBndr] -> Subst -> Q Typing
    computeTypes forcedMono :: Bool
    forcedMono fieldtype :: Kind
    fieldtype datatype :: Name
    datatype dtVars_ :: [TyVarBndr]
    dtVars_ subst :: Subst
    subst =

      do let fieldVars :: [Name]
    fieldVars = Kind -> [Name]
    typeVariables Kind
    fieldtype
             tyO :: TypeQ
    tyO       = Kind -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return Kind
    fieldtype
             dtTypes :: Cxt
    dtTypes   = Subst -> Kind -> Kind
    substitute Subst
    subst (Kind -> Kind) -> (TyVarBndr -> Kind) -> TyVarBndr -> Kind
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . TyVarBndr -> Kind
    typeFromBinder (TyVarBndr -> Kind) -> [TyVarBndr] -> Cxt
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [TyVarBndr]
    dtVars_
             dtBinders :: [TyVarBndr]
    dtBinders = (Kind -> [TyVarBndr]) -> Cxt -> [TyVarBndr]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap Kind -> [TyVarBndr]
    binderFromType Cxt
    dtTypes
             varNames :: [Name]
    varNames  = TyVarBndr -> Name
    nameFromBinder (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [TyVarBndr]
    dtBinders
             usedVars :: [Name]
    usedVars  = (Name -> Bool) -> [Name] -> [Name]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Name -> [Name] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Name]
    fieldVars) [Name]
    varNames
             tyI :: TypeQ
    tyI       = Kind -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Kind -> TypeQ) -> Kind -> TypeQ
    forall a b. (a -> b) -> a -> b
    $ (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr ((Kind -> Kind -> Kind) -> Kind -> Kind -> Kind
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Kind -> Kind -> Kind
    AppT) (Name -> Kind
    ConT Name
    datatype) (Cxt -> Cxt
    forall a. [a] -> [a]
    reverse Cxt
    dtTypes)
             pretties :: [TyVarBndr]
    pretties  = (Name -> Name) -> TyVarBndr -> TyVarBndr
    mapTyVarBndr Name -> Name
    pretty (TyVarBndr -> TyVarBndr) -> [TyVarBndr] -> [TyVarBndr]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [TyVarBndr]
    dtBinders
             mono :: Bool
    mono      = Bool
    forcedMono Bool -> Bool -> Bool
    || Kind -> [TyVarBndr] -> Bool
    isMonomorphic Kind
    fieldtype [TyVarBndr]
    dtBinders

         if Bool
    mono
           then Typing -> Q Typing
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Typing -> Q Typing) -> Typing -> Q Typing
    forall a b. (a -> b) -> a -> b
    $ Bool -> TypeQ -> TypeQ -> [TyVarBndr] -> Typing
    Typing
                   Bool
    mono
                   (Kind -> Kind
    prettyType (Kind -> Kind) -> TypeQ -> TypeQ
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> TypeQ
    tyI)
                   (Kind -> Kind
    prettyType (Kind -> Kind) -> TypeQ -> TypeQ
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> TypeQ
    tyO)
                   ([TyVarBndr] -> [TyVarBndr]
    forall a. Eq a => [a] -> [a]
    nub [TyVarBndr]
    pretties)
           else
             do let names :: [String]
    names = Char -> String
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Char -> String) -> String -> [String]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ['a'..'z']
                    used :: [String]
    used  = Name -> String
    forall a. Show a => a -> String
    show (Name -> String) -> (Name -> Name) -> Name -> String
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . Name -> Name
    pretty (Name -> String) -> [Name] -> [String]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Name]
    varNames
                    free :: [String]
    free  = (String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . (String -> [String] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [String]
    used)) [String]
    names
                [(Name, Name)]
    subs <- [(Name, String)]
    -> ((Name, String) -> Q (Name, Name)) -> Q [(Name, Name)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM ([Name] -> [String] -> [(Name, String)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Name]
    usedVars [String]
    free) (\(a :: Name
    a, b :: String
    b) -> (,) Name
    a (Name -> (Name, Name)) -> Q Name -> Q (Name, Name)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Q Name
    newName String
    b)
                let rename :: Kind -> Kind
    rename = (Name -> Name) -> Kind -> Kind
    mapTypeVariables (\a :: Name
    a -> Name
    a Name -> Maybe Name -> Name
    forall a. a -> Maybe a -> a
    `fromMaybe` Name -> [(Name, Name)] -> Maybe Name
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Name
    a [(Name, Name)]
    subs)

                Typing -> Q Typing
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Typing -> Q Typing) -> Typing -> Q Typing
    forall a b. (a -> b) -> a -> b
    $ Bool -> TypeQ -> TypeQ -> [TyVarBndr] -> Typing
    Typing
                  Bool
    mono
                  (Kind -> Kind
    prettyType (Kind -> Kind) -> TypeQ -> TypeQ
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [t| $tyI -> $(rename <$> tyI) |])
                  (Kind -> Kind
    prettyType (Kind -> Kind) -> TypeQ -> TypeQ
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [t| $tyO -> $(rename <$> tyO) |])
                  ([TyVarBndr] -> [TyVarBndr]
    forall a. Eq a => [a] -> [a]
    nub ([TyVarBndr]
    pretties [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
    forall a. [a] -> [a] -> [a]
    ++ (TyVarBndr -> TyVarBndr) -> [TyVarBndr] -> [TyVarBndr]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Name -> Name) -> TyVarBndr -> TyVarBndr
    mapTyVarBndr Name -> Name
    pretty) (Name -> TyVarBndr
    PlainTV (Name -> TyVarBndr)
    -> ((Name, Name) -> Name) -> (Name, Name) -> TyVarBndr
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . (Name, Name) -> Name
    forall a b. (a, b) -> b
    snd ((Name, Name) -> TyVarBndr) -> [(Name, Name)] -> [TyVarBndr]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [(Name, Name)]
    subs)))

    isMonomorphic :: Type -> [TyVarBndr] -> Bool
    isMonomorphic :: Kind -> [TyVarBndr] -> Bool
    isMonomorphic field :: Kind
    field vars :: [TyVarBndr]
    vars =
      let fieldVars :: [Name]
    fieldVars = Kind -> [Name]
    typeVariables Kind
    field
          varNames :: [Name]
    varNames  = TyVarBndr -> Name
    nameFromBinder (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [TyVarBndr]
    vars
          usedVars :: [Name]
    usedVars  = (Name -> Bool) -> [Name] -> [Name]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Name -> [Name] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Name]
    fieldVars) [Name]
    varNames
       in [Name] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Name]
    usedVars

    -------------------------------------------------------------------------------
    -- Generic helper functions dealing with Template Haskell

    typeVariables :: Type -> [Name]
    typeVariables :: Kind -> [Name]
    typeVariables = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr -> Name
    nameFromBinder ([TyVarBndr] -> [Name]) -> (Kind -> [TyVarBndr]) -> Kind -> [Name]
    forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
    Category cat =>
    cat b c -> cat a b -> cat a c
    . Kind -> [TyVarBndr]
    binderFromType

    typeFromBinder :: TyVarBndr -> Type
    typeFromBinder :: TyVarBndr -> Kind
    typeFromBinder (PlainTV  tv :: Name
    tv      ) = Name -> Kind
    VarT Name
    tv
    #if MIN_VERSION_template_haskell(2,8,0)
    typeFromBinder (KindedTV tv :: Name
    tv StarT) = Name -> Kind
    VarT Name
    tv
    #else
    typeFromBinder (KindedTV tv StarK) = VarT tv
    #endif
    typeFromBinder (KindedTV tv :: Name
    tv kind :: Kind
    kind ) = Kind -> Kind -> Kind
    SigT (Name -> Kind
    VarT Name
    tv) Kind
    kind

    binderFromType :: Type -> [TyVarBndr]
    binderFromType :: Kind -> [TyVarBndr]
    binderFromType = Kind -> [TyVarBndr]
    go
      where
      go :: Kind -> [TyVarBndr]
    go ty :: Kind
    ty =
        case Kind
    ty of
          ForallT ts :: [TyVarBndr]
    ts _ _ -> [TyVarBndr]
    ts
          AppT a :: Kind
    a b :: Kind
    b       -> Kind -> [TyVarBndr]
    go Kind
    a [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
    forall a. [a] -> [a] -> [a]
    ++ Kind -> [TyVarBndr]
    go Kind
    b
          SigT t :: Kind
    t _       -> Kind -> [TyVarBndr]
    go Kind
    t
          VarT n :: Name
    n         -> [Name -> TyVarBndr
    PlainTV Name
    n]
          _              -> []

    mapTypeVariables :: (Name -> Name) -> Type -> Type
    mapTypeVariables :: (Name -> Name) -> Kind -> Kind
    mapTypeVariables f :: Name -> Name
    f = Kind -> Kind
    go
      where
      go :: Kind -> Kind
    go ty :: Kind
    ty =
        case Kind
    ty of
          ForallT ts :: [TyVarBndr]
    ts a :: Cxt
    a b :: Kind
    b -> [TyVarBndr] -> Cxt -> Kind -> Kind
    ForallT ((Name -> Name) -> TyVarBndr -> TyVarBndr
    mapTyVarBndr Name -> Name
    f (TyVarBndr -> TyVarBndr) -> [TyVarBndr] -> [TyVarBndr]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [TyVarBndr]
    ts)
                                    ((Name -> Name) -> Kind -> Kind
    mapPred Name -> Name
    f (Kind -> Kind) -> Cxt -> Cxt
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Cxt
    a) (Kind -> Kind
    go Kind
    b)
          AppT a :: Kind
    a b :: Kind
    b       -> Kind -> Kind -> Kind
    AppT (Kind -> Kind
    go Kind
    a) (Kind -> Kind
    go Kind
    b)
          SigT t :: Kind
    t a :: Kind
    a       -> Kind -> Kind -> Kind
    SigT (Kind -> Kind
    go Kind
    t) Kind
    a
          VarT n :: Name
    n         -> Name -> Kind
    VarT (Name -> Name
    f Name
    n)
          t :: Kind
    t              -> Kind
    t

    mapType :: (Type -> Type) -> Type -> Type
    mapType :: (Kind -> Kind) -> Kind -> Kind
    mapType f :: Kind -> Kind
    f = Kind -> Kind
    go
      where
      go :: Kind -> Kind
    go ty :: Kind
    ty =
        case Kind
    ty of
          ForallT v :: [TyVarBndr]
    v c :: Cxt
    c t :: Kind
    t -> Kind -> Kind
    f ([TyVarBndr] -> Cxt -> Kind -> Kind
    ForallT [TyVarBndr]
    v Cxt
    c (Kind -> Kind
    go Kind
    t))
          AppT a :: Kind
    a b :: Kind
    b      -> Kind -> Kind
    f (Kind -> Kind -> Kind
    AppT (Kind -> Kind
    go Kind
    a) (Kind -> Kind
    go Kind
    b))
          SigT t :: Kind
    t k :: Kind
    k      -> Kind -> Kind
    f (Kind -> Kind -> Kind
    SigT (Kind -> Kind
    go Kind
    t) Kind
    k)
          _             -> Kind -> Kind
    f Kind
    ty

    substitute :: Subst -> Type -> Type
    substitute :: Subst -> Kind -> Kind
    substitute env :: Subst
    env = (Kind -> Kind) -> Kind -> Kind
    mapType Kind -> Kind
    sub
      where sub :: Kind -> Kind
    sub v :: Kind
    v = case Kind -> Subst -> Maybe Kind
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Kind
    v Subst
    env of
                      Nothing -> Kind
    v
                      Just w :: Kind
    w  -> Kind
    w

    nameFromBinder :: TyVarBndr -> Name
    nameFromBinder :: TyVarBndr -> Name
    nameFromBinder (PlainTV  n :: Name
    n  ) = Name
    n
    nameFromBinder (KindedTV n :: Name
    n _) = Name
    n

    mapPred :: (Name -> Name) -> Pred -> Pred
    #if MIN_VERSION_template_haskell(2,10,0)
    mapPred :: (Name -> Name) -> Kind -> Kind
    mapPred = (Name -> Name) -> Kind -> Kind
    mapTypeVariables
    #else
    mapPred f (ClassP n ts) = ClassP (f n) (mapTypeVariables f <$> ts)
    mapPred f (EqualP t x ) = EqualP (mapTypeVariables f t) (mapTypeVariables f x)
    #endif

    mapTyVarBndr :: (Name -> Name) -> TyVarBndr -> TyVarBndr
    mapTyVarBndr :: (Name -> Name) -> TyVarBndr -> TyVarBndr
    mapTyVarBndr f :: Name -> Name
    f (PlainTV  n :: Name
    n  ) = Name -> TyVarBndr
    PlainTV (Name -> Name
    f Name
    n)
    mapTyVarBndr f :: Name -> Name
    f (KindedTV n :: Name
    n a :: Kind
    a) = Name -> Kind -> TyVarBndr
    KindedTV (Name -> Name
    f Name
    n) Kind
    a

    -- Prettify a TH name.

    pretty :: Name -> Name
    pretty :: Name -> Name
    pretty tv :: Name
    tv = String -> Name
    mkName ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= '_') (Name -> String
    forall a. Show a => a -> String
    show Name
    tv))

    -- Prettify a type.

    prettyType :: Type -> Type
    prettyType :: Kind -> Kind
    prettyType = (Name -> Name) -> Kind -> Kind
    mapTypeVariables Name -> Name
    pretty

    -- Reify a name into a declaration.

    reifyDec :: Name -> Q Dec
    reifyDec :: Name -> Q Dec
    reifyDec name :: Name
    name =
      do Info
    info <- Name -> Q Info
    reify Name
    name
         case Info
    info of
           TyConI dec :: Dec
    dec -> Dec -> Q Dec
    forall (m :: * -> *) a. Monad m => a -> m a
    return Dec
    dec
           _ -> String -> Q Dec
    forall a. String -> a
    fclError "Info must be type declaration type."

    -- Throw a fclabels specific error.

    fclError :: String -> a
    fclError :: String -> a
    fclError err :: String
    err = String -> a
    forall a. HasCallStack => String -> a
    error ("Data.Label.Derive: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    err)

    #if MIN_VERSION_template_haskell(2,10,0)
    classP :: Name -> [Q Type] -> Q Pred
    classP :: Name -> [TypeQ] -> TypeQ
    classP cla :: Name
    cla tys :: [TypeQ]
    tys
      = do Cxt
    tysl <- [TypeQ] -> CxtQ
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence [TypeQ]
    tys
           Kind -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Kind -> Kind -> Kind
    AppT (Name -> Kind
    ConT Name
    cla) Cxt
    tysl)
    #endif

    trd :: (a, b, c) -> c
    trd :: (a, b, c) -> c
    trd (_, _, x :: c
    x) = c
    x