    {-# LANGUAGE CPP, PatternGuards, Rank2Types #-}
    {-# LANGUAGE TemplateHaskellQuotes #-}
    -- This OPTIONS_GHC line is a workaround for
    -- https://gitlab.haskell.org/ghc/ghc/-/issues/18320, a bug which only occurs
    -- when running specific TemplateHaskell code while both profiling and
    -- optimisations are enabled. The code in this file triggers the bug, so until
    -- it is fixed, we work around the issue by disabling optimisations in this
    -- file. The code in this file only runs at compile-time, the code _generated_
    -- by makeBaseFunctor will still get optimized if the file which calls
    -- makeBaseFunctor is optimized.
    {-# OPTIONS_GHC -O0 #-}
    module Data.Functor.Foldable.TH
      ( MakeBaseFunctor(..)
      , BaseRules
      , baseRules
      , baseRulesType
      , baseRulesCon
      , baseRulesField
      ) where

    import Control.Applicative as A
    import Control.Monad
    import Data.Traversable as T
    import Data.Functor.Identity
    import Language.Haskell.TH
    import Language.Haskell.TH.Datatype as TH.Abs
    import Language.Haskell.TH.Datatype.TyVarBndr
    import Data.Char (GeneralCategory (..), generalCategory)

    import Data.Functor.Foldable

    #if !MIN_VERSION_template_haskell(2,21,0) && !MIN_VERSION_th_abstraction(0,6,0)
    type TyVarBndrVis = TyVarBndrUnit
    #endif

    -- $setup
    -- >>> :set -XTemplateHaskell -XTypeFamilies -XDeriveTraversable -XScopedTypeVariables
    -- >>> import Data.Functor.Foldable
    -- >>> import Language.Haskell.TH (Q)
    -- >>> let asQ :: Q a -> Q a; asQ = id

    -- | Build base functor with a sensible default configuration.
    --
    -- /e.g./
    --
    -- @
    -- data Expr a
    --     = Lit a
    --     | Add (Expr a) (Expr a)
    --     | Expr a :* [Expr a]
    --   deriving (Show)
    --
    -- 'makeBaseFunctor' ''Expr
    -- @
    --
    -- will create
    --
    -- @
    -- data ExprF a x
    --     = LitF a
    --     | AddF x x
    --     | x :*$ [x]
    --   deriving ('Functor', 'Foldable', 'Traversable')
    --
    -- type instance 'Base' (Expr a) = ExprF a
    --
    -- instance 'Recursive' (Expr a) where
    --     'project' (Lit x)   = LitF x
    --     'project' (Add x y) = AddF x y
    --     'project' (x :* y)  = x :*$ y
    --
    -- instance 'Corecursive' (Expr a) where
    --     'embed' (LitF x)   = Lit x
    --     'embed' (AddF x y) = Add x y
    --     'embed' (x :*$ y)  = x :* y
    -- @
    --
    --
    -- /Notes:/
    --
    -- 'makeBaseFunctor' works properly only with ADTs.
    -- Existentials and GADTs aren't supported,
    -- as we don't try to do better than
    -- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#deriving-functor-instances GHC's DeriveFunctor>.
    --
    -- Allowing 'makeBaseFunctor' to take both 'Name's and 'Dec's as an argument is why it exists as a method in a type class.
    -- For trickier data-types, like rose-tree (see also 'Cofree'):
    --
    -- @
    -- data Rose f a = Rose a (f (Rose f a))
    -- @
    --
    -- we can invoke 'makeBaseFunctor' with an instance declaration
    -- to provide needed context for instances. (c.f. @StandaloneDeriving@)
    --
    -- @
    -- 'makeBaseFunctor' [d| instance Functor f => Recursive (Rose f a) |]
    -- @
    --
    -- will create
    --
    -- @
    -- data RoseF f a r = RoseF a (f fr)
    --   deriving ('Functor', 'Foldable', 'Traversable')
    --
    -- type instance 'Base' (Rose f a) = RoseF f a
    --
    -- instance Functor f => 'Recursive' (Rose f a) where
    --   'project' (Rose x xs) = RoseF x xs
    --
    -- instance Functor f => 'Corecursive' (Rose f a) where
    --   'embed' (RoseF x xs) = Rose x xs
    -- @
    --
    -- Some doctests:
    --
    -- >>> data Expr a = Lit a | Add (Expr a) (Expr a) | Expr a :* [Expr a]; makeBaseFunctor ''Expr
    --
    -- >>> :t AddF
    -- AddF :: r -> r -> ExprF a r
    --
    -- >>> data Rose f a = Rose a (f (Rose f a)); makeBaseFunctor $ asQ [d| instance Functor f => Recursive (Rose f a) |]
    --
    -- >>> :t RoseF
    -- RoseF :: a -> f r -> RoseF f a r
    --
    -- >>> let rose = Rose 1 (Just (Rose 2 (Just (Rose 3 Nothing))))
    -- >>> cata (\(RoseF x f) -> x + maybe 0 id f) rose
    -- 6
    --
    class MakeBaseFunctor a where
        -- |
        -- @
        -- 'makeBaseFunctor' = 'makeBaseFunctorWith' 'baseRules'
        -- @
        makeBaseFunctor :: a -> DecsQ
        makeBaseFunctor = BaseRules -> a -> DecsQ
    forall a. MakeBaseFunctor a => BaseRules -> a -> DecsQ
    makeBaseFunctorWith BaseRules
    baseRules

        -- | Build base functor with a custom configuration.
        makeBaseFunctorWith :: BaseRules -> a -> DecsQ

    instance MakeBaseFunctor a => MakeBaseFunctor [a] where
        makeBaseFunctorWith :: BaseRules -> [a] -> DecsQ
    makeBaseFunctorWith BaseRules
    rules [a]
    a = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ((a -> DecsQ) -> [a] -> Q [[Dec]]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> [a] -> f [b]
    T.traverse (BaseRules -> a -> DecsQ
    forall a. MakeBaseFunctor a => BaseRules -> a -> DecsQ
    makeBaseFunctorWith BaseRules
    rules) [a]
    a)

    instance MakeBaseFunctor a => MakeBaseFunctor (Q a) where
        makeBaseFunctorWith :: BaseRules -> Q a -> DecsQ
    makeBaseFunctorWith BaseRules
    rules Q a
    a = BaseRules -> a -> DecsQ
    forall a. MakeBaseFunctor a => BaseRules -> a -> DecsQ
    makeBaseFunctorWith BaseRules
    rules (a -> DecsQ) -> Q a -> DecsQ
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< Q a
    a

    instance MakeBaseFunctor Name where
        makeBaseFunctorWith :: BaseRules -> Name -> DecsQ
    makeBaseFunctorWith BaseRules
    rules Name
    name = Name -> Q DatatypeInfo
    reifyDatatype Name
    name Q DatatypeInfo -> (DatatypeInfo -> DecsQ) -> DecsQ
    forall a b. Q a -> (a -> Q b) -> Q b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= BaseRules -> Maybe (Name -> [Dec] -> Dec) -> DatatypeInfo -> DecsQ
    makePrimForDI BaseRules
    rules Maybe (Name -> [Dec] -> Dec)
    forall a. Maybe a
    Nothing

    -- | Expects declarations of 'Recursive' or 'Corecursive' instances, e.g.
    --
    -- @
    -- makeBaseFunctor [d| instance Functor f => Recursive (Rose f a) |]
    -- @
    --
    -- This way we can provide a context for generated instances.
    -- Note that this instance's 'makeBaseFunctor' still generates all of
    -- 'Base' type instance, 'Recursive' and 'Corecursive' instances.
    --
    instance MakeBaseFunctor Dec where
        makeBaseFunctorWith :: BaseRules -> Dec -> DecsQ
    makeBaseFunctorWith BaseRules
    rules (InstanceD Maybe Overlap
    overlaps Cxt
    ctx Type
    classHead []) = do
            let instanceFor :: Type -> [Dec] -> Dec
    instanceFor = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
    InstanceD Maybe Overlap
    overlaps Cxt
    ctx
            case Type
    classHead of
              ConT Name
    u `AppT` Type
    t | Name
    u Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    recursiveTypeName Bool -> Bool -> Bool
    || Name
    u Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    corecursiveTypeName -> do
                  name <- Type -> Q Name
    headOfType Type
    t
                  di <- reifyDatatype name
                  makePrimForDI rules (Just $ \Name
    n -> Type -> [Dec] -> Dec
    instanceFor (Name -> Type
    ConT Name
    n Type -> Type -> Type
    `AppT` Type
    t)) di
              Type
    _ -> String -> DecsQ
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> DecsQ) -> String -> DecsQ
    forall a b. (a -> b) -> a -> b
    $ String
    "makeBaseFunctor: expected an instance head like `ctx => Recursive (T a b ...)`, got " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Show a => a -> String
    show Type
    classHead

        makeBaseFunctorWith BaseRules
    _ Dec
    _ = String -> DecsQ
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "makeBaseFunctor(With): expected an empty instance declaration"

    -- | Rules of renaming data names
    data BaseRules = BaseRules
        { BaseRules -> Name -> Name
    _baseRulesType  :: Name -> Name
        , BaseRules -> Name -> Name
    _baseRulesCon   :: Name -> Name
        , BaseRules -> Name -> Name
    _baseRulesField :: Name -> Name
        }

    -- | Default 'BaseRules': append @F@ or @$@ to data type, constructors and field names.
    baseRules :: BaseRules
    baseRules :: BaseRules
    baseRules = BaseRules
        { _baseRulesType :: Name -> Name
    _baseRulesType  = Name -> Name
    toFName
        , _baseRulesCon :: Name -> Name
    _baseRulesCon   = Name -> Name
    toFName
        , _baseRulesField :: Name -> Name
    _baseRulesField = Name -> Name
    toFName
        }

    -- | How to name the base functor type.
    --
    -- Default is to append @F@ or @$@.
    baseRulesType :: Functor f => ((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules
    baseRulesType :: forall (f :: * -> *).
    Functor f =>
    ((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules
    baseRulesType (Name -> Name) -> f (Name -> Name)
    f BaseRules
    rules = (\Name -> Name
    x -> BaseRules
    rules { _baseRulesType = x }) ((Name -> Name) -> BaseRules) -> f (Name -> Name) -> f BaseRules
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Name -> Name) -> f (Name -> Name)
    f (BaseRules -> Name -> Name
    _baseRulesType BaseRules
    rules)

    -- | How to rename the base functor type constructors.
    --
    -- Default is to append @F@ or @$@.
    baseRulesCon :: Functor f => ((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules
    baseRulesCon :: forall (f :: * -> *).
    Functor f =>
    ((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules
    baseRulesCon (Name -> Name) -> f (Name -> Name)
    f BaseRules
    rules = (\Name -> Name
    x -> BaseRules
    rules { _baseRulesCon = x }) ((Name -> Name) -> BaseRules) -> f (Name -> Name) -> f BaseRules
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Name -> Name) -> f (Name -> Name)
    f (BaseRules -> Name -> Name
    _baseRulesCon BaseRules
    rules)

    -- | How to rename the base functor type field names (in records).
    --
    -- Default is to append @F@ or @$@.
    baseRulesField :: Functor f => ((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules
    baseRulesField :: forall (f :: * -> *).
    Functor f =>
    ((Name -> Name) -> f (Name -> Name)) -> BaseRules -> f BaseRules
    baseRulesField (Name -> Name) -> f (Name -> Name)
    f BaseRules
    rules = (\Name -> Name
    x -> BaseRules
    rules { _baseRulesField = x }) ((Name -> Name) -> BaseRules) -> f (Name -> Name) -> f BaseRules
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Name -> Name) -> f (Name -> Name)
    f (BaseRules -> Name -> Name
    _baseRulesField BaseRules
    rules)

    toFName :: Name -> Name
    toFName :: Name -> Name
    toFName = String -> Name
    mkName (String -> Name) -> (Name -> String) -> Name -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    f (String -> String) -> (Name -> String) -> Name -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> String
    nameBase
      where
        f :: String -> String
    f String
    name | String -> Bool
    isInfixName String
    name = String
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "$"
               | Bool
    otherwise        = String
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "F"

        isInfixName :: String -> Bool
        isInfixName :: String -> Bool
    isInfixName = (Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Char -> Bool
    isSymbolChar

    makePrimForDI :: BaseRules
                  -> Maybe (Name -> [Dec] -> Dec) -- ^ make instance
                  -> DatatypeInfo
                  -> DecsQ
    makePrimForDI :: BaseRules -> Maybe (Name -> [Dec] -> Dec) -> DatatypeInfo -> DecsQ
    makePrimForDI BaseRules
    rules Maybe (Name -> [Dec] -> Dec)
    mkInstance'
      (DatatypeInfo { datatypeName :: DatatypeInfo -> Name
    datatypeName      = Name
    tyName
                    , datatypeInstTypes :: DatatypeInfo -> Cxt
    datatypeInstTypes = Cxt
    instTys
                    , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
    datatypeCons      = [ConstructorInfo]
    cons
                    , datatypeVariant :: DatatypeInfo -> DatatypeVariant
    datatypeVariant   = DatatypeVariant
    variant }) = do
        Q ()
    checkAllowed
        BaseRules
    -> Maybe (Name -> [Dec] -> Dec)
    -> Bool
    -> Name
    -> [TyVarBndrVis]
    -> [ConstructorInfo]
    -> DecsQ
    makePrimForDI' BaseRules
    rules Maybe (Name -> [Dec] -> Dec)
    mkInstance'
                       (DatatypeVariant
    variant DatatypeVariant -> DatatypeVariant -> Bool
    forall a. Eq a => a -> a -> Bool
    == DatatypeVariant
    Newtype) Name
    tyName
                       ((Type -> TyVarBndrVis) -> Cxt -> [TyVarBndrVis]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> TyVarBndrVis
    toTyVarBndr Cxt
    instTys) [ConstructorInfo]
    cons
      where
        checkAllowed :: Q ()
    checkAllowed =
          case DatatypeVariant
    variant of
            DatatypeVariant
    Datatype        -> () -> Q ()
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
            DatatypeVariant
    Newtype         -> () -> Q ()
    forall a. a -> Q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
            DatatypeVariant
    DataInstance    -> Q ()
    forall {a}. Q a
    dataFamilyError
            DatatypeVariant
    NewtypeInstance -> Q ()
    forall {a}. Q a
    dataFamilyError
    #if MIN_VERSION_th_abstraction(0,5,0)
            DatatypeVariant
    TH.Abs.TypeData -> String -> Q ()
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "makeBaseFunctor: `type data` declarations are not supported."
    #endif

        dataFamilyError :: Q a
    dataFamilyError = String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "makeBaseFunctor: Data families are currently not supported."

        toTyVarBndr :: Type -> TyVarBndrVis
        toTyVarBndr :: Type -> TyVarBndrVis
    toTyVarBndr (VarT Name
    n)          = Name -> TyVarBndrVis
    forall flag. DefaultBndrFlag flag => Name -> TyVarBndr flag
    plainTV Name
    n
        toTyVarBndr (SigT (VarT Name
    n) Type
    k) = Name -> Type -> TyVarBndrVis
    forall flag. DefaultBndrFlag flag => Name -> Type -> TyVarBndr flag
    kindedTV Name
    n Type
    k
        toTyVarBndr Type
    _                 = String -> TyVarBndrVis
    forall a. HasCallStack => String -> a
    error String
    "toTyVarBndr"

    makePrimForDI' :: BaseRules
                   -> Maybe (Name -> [Dec] -> Dec) -- ^ make instance
                   -> Bool -> Name
                   -> [TyVarBndrVis]
                   -> [ConstructorInfo] -> DecsQ
    makePrimForDI' :: BaseRules
    -> Maybe (Name -> [Dec] -> Dec)
    -> Bool
    -> Name
    -> [TyVarBndrVis]
    -> [ConstructorInfo]
    -> DecsQ
    makePrimForDI' BaseRules
    rules Maybe (Name -> [Dec] -> Dec)
    mkInstance' Bool
    isNewtype Name
    tyName [TyVarBndrVis]
    vars [ConstructorInfo]
    cons = do
        -- variable parameters
        let vars' :: Cxt
    vars' = (Name -> Type) -> [Name] -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Type
    VarT ([TyVarBndrVis] -> [Name]
    forall flag. [TyVarBndr_ flag] -> [Name]
    typeVars [TyVarBndrVis]
    vars)
        -- Name of base functor
        let tyNameF :: Name
    tyNameF = BaseRules -> Name -> Name
    _baseRulesType BaseRules
    rules Name
    tyName
        -- Recursive type
        let s :: Type
    s = Name -> Cxt -> Type
    conAppsT Name
    tyName Cxt
    vars'
        -- Additional argument
        rName <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "r"
        let r = Name -> Type
    VarT Name
    rName
        -- Vars
        let varsF = [TyVarBndrVis]
    vars [TyVarBndrVis] -> [TyVarBndrVis] -> [TyVarBndrVis]
    forall a. [a] -> [a] -> [a]
    ++ [Name -> TyVarBndrVis
    forall flag. DefaultBndrFlag flag => Name -> TyVarBndr flag
    plainTV Name
    rName]

        -- #33
        cons' <- traverse (conTypeTraversal resolveTypeSynonyms) cons
        let consF
              = ConstructorInfo -> Con
    toCon
              (ConstructorInfo -> Con)
    -> (ConstructorInfo -> ConstructorInfo) -> ConstructorInfo -> Con
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Name -> Name) -> ConstructorInfo -> ConstructorInfo
    conNameMap (BaseRules -> Name -> Name
    _baseRulesCon BaseRules
    rules)
              (ConstructorInfo -> ConstructorInfo)
    -> (ConstructorInfo -> ConstructorInfo)
    -> ConstructorInfo
    -> ConstructorInfo
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Name -> Name) -> ConstructorInfo -> ConstructorInfo
    conFieldNameMap (BaseRules -> Name -> Name
    _baseRulesField BaseRules
    rules)
              (ConstructorInfo -> ConstructorInfo)
    -> (ConstructorInfo -> ConstructorInfo)
    -> ConstructorInfo
    -> ConstructorInfo
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Type -> Type) -> ConstructorInfo -> ConstructorInfo
    conTypeMap (Type -> Type -> Type -> Type
    substType Type
    s Type
    r)
              (ConstructorInfo -> Con) -> [ConstructorInfo] -> [Con]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [ConstructorInfo]
    cons'

        -- Data definition
    #if MIN_VERSION_template_haskell(2,12,0)
        derivStrat <- do
          e <- isExtEnabled DerivingStrategies
          pure $ if e then Just StockStrategy else Nothing
    #endif
        let dataDec = case [Con]
    consF of
                [Con
    conF] | Bool
    isNewtype ->
                    Cxt
    -> Name
    -> [TyVarBndrVis]
    -> Maybe Type
    -> Con
    -> [DerivClause]
    -> Dec
    NewtypeD [] Name
    tyNameF [TyVarBndrVis]
    varsF Maybe Type
    forall a. Maybe a
    Nothing Con
    conF [DerivClause]
    deriveds
                [Con]
    _ ->
                    Cxt
    -> Name
    -> [TyVarBndrVis]
    -> Maybe Type
    -> [Con]
    -> [DerivClause]
    -> Dec
    DataD [] Name
    tyNameF [TyVarBndrVis]
    varsF Maybe Type
    forall a. Maybe a
    Nothing [Con]
    consF [DerivClause]
    deriveds
              where
                deriveds :: [DerivClause]
    deriveds =
    #if MIN_VERSION_template_haskell(2,12,0)
                  [Maybe DerivStrategy -> Cxt -> DerivClause
    DerivClause Maybe DerivStrategy
    derivStrat
                    [ Name -> Type
    ConT Name
    functorTypeName
                    , Name -> Type
    ConT Name
    foldableTypeName
                    , Name -> Type
    ConT Name
    traversableTypeName ]]
    #else
                  [ ConT functorTypeName
                  , ConT foldableTypeName
                  , ConT traversableTypeName ]
    #endif

        -- type instance Base
        baseDec <- tySynInstDCompat baseTypeName Nothing
                                    [pure s] (pure $ conAppsT tyNameF vars')

        let mkInstance :: Name -> [Dec] -> Dec
            mkInstance = case Maybe (Name -> [Dec] -> Dec)
    mkInstance' of
                Just Name -> [Dec] -> Dec
    f  -> Name -> [Dec] -> Dec
    f
                Maybe (Name -> [Dec] -> Dec)
    Nothing -> \Name
    n ->
                    Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
    InstanceD Maybe Overlap
    forall a. Maybe a
    Nothing [] (Name -> Type
    ConT Name
    n Type -> Type -> Type
    `AppT` Type
    s)

        -- instance Recursive
        projDec <- FunD projectValName <$> mkMorphism id (_baseRulesCon rules) cons'
        let recursiveDec = Name -> [Dec] -> Dec
    mkInstance Name
    recursiveTypeName [Dec
    projDec]

        -- instance Corecursive
        embedDec <- FunD embedValName <$> mkMorphism (_baseRulesCon rules) id cons'
        let corecursiveDec = Name -> [Dec] -> Dec
    mkInstance Name
    corecursiveTypeName [Dec
    embedDec]

        -- Combine
        A.pure [dataDec, baseDec, recursiveDec, corecursiveDec]

    -- | makes clauses to rename constructors
    mkMorphism
        :: (Name -> Name)
        -> (Name -> Name)
        -> [ConstructorInfo]
        -> Q [Clause]
    mkMorphism :: (Name -> Name) -> (Name -> Name) -> [ConstructorInfo] -> Q [Clause]
    mkMorphism Name -> Name
    nFrom Name -> Name
    nTo [ConstructorInfo]
    args = [ConstructorInfo] -> (ConstructorInfo -> Q Clause) -> Q [Clause]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    t a -> (a -> f b) -> f (t b)
    for [ConstructorInfo]
    args ((ConstructorInfo -> Q Clause) -> Q [Clause])
    -> (ConstructorInfo -> Q Clause) -> Q [Clause]
    forall a b. (a -> b) -> a -> b
    $ \ConstructorInfo
    ci -> do
        let n :: Name
    n = ConstructorInfo -> Name
    constructorName ConstructorInfo
    ci
        fs <- Int -> Q Name -> Q [Name]
    forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
    replicateM (Cxt -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length (ConstructorInfo -> Cxt
    constructorFields ConstructorInfo
    ci)) (String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "x")
        clause [conP (nFrom n) (map varP fs)]                            -- patterns
                     (normalB $ foldl appE (conE $ nTo n) (map varE fs)) -- body
                     [] -- where dec

    -------------------------------------------------------------------------------
    -- Traversals
    -------------------------------------------------------------------------------

    conNameTraversal :: Traversal' ConstructorInfo Name
    conNameTraversal :: Traversal' ConstructorInfo Name
    conNameTraversal = (ConstructorInfo -> Name)
    -> (ConstructorInfo -> Name -> ConstructorInfo)
    -> Lens' ConstructorInfo Name
    forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
    lens ConstructorInfo -> Name
    constructorName (\ConstructorInfo
    s Name
    v -> ConstructorInfo
    s { constructorName = v })

    conFieldNameTraversal :: Traversal' ConstructorInfo Name
    conFieldNameTraversal :: Traversal' ConstructorInfo Name
    conFieldNameTraversal = (ConstructorInfo -> ConstructorVariant)
    -> (ConstructorInfo -> ConstructorVariant -> ConstructorInfo)
    -> Lens' ConstructorInfo ConstructorVariant
    forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
    lens ConstructorInfo -> ConstructorVariant
    constructorVariant (\ConstructorInfo
    s ConstructorVariant
    v -> ConstructorInfo
    s { constructorVariant = v })
                          ((ConstructorVariant -> f ConstructorVariant)
     -> ConstructorInfo -> f ConstructorInfo)
    -> ((Name -> f Name) -> ConstructorVariant -> f ConstructorVariant)
    -> (Name -> f Name)
    -> ConstructorInfo
    -> f ConstructorInfo
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Name -> f Name) -> ConstructorVariant -> f ConstructorVariant
    Traversal' ConstructorVariant Name
    conVariantTraversal
      where
        conVariantTraversal :: Traversal' ConstructorVariant Name
        conVariantTraversal :: Traversal' ConstructorVariant Name
    conVariantTraversal Name -> f Name
    _ ConstructorVariant
    NormalConstructor      = ConstructorVariant -> f ConstructorVariant
    forall a. a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ConstructorVariant
    NormalConstructor
        conVariantTraversal Name -> f Name
    _ ConstructorVariant
    InfixConstructor       = ConstructorVariant -> f ConstructorVariant
    forall a. a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ConstructorVariant
    InfixConstructor
        conVariantTraversal Name -> f Name
    f (RecordConstructor [Name]
    fs) = [Name] -> ConstructorVariant
    RecordConstructor ([Name] -> ConstructorVariant) -> f [Name] -> f ConstructorVariant
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Name -> f Name) -> [Name] -> f [Name]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> [a] -> f [b]
    traverse Name -> f Name
    f [Name]
    fs

    conTypeTraversal :: Traversal' ConstructorInfo Type
    conTypeTraversal :: Traversal' ConstructorInfo Type
    conTypeTraversal = (ConstructorInfo -> Cxt)
    -> (ConstructorInfo -> Cxt -> ConstructorInfo)
    -> Lens' ConstructorInfo Cxt
    forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
    lens ConstructorInfo -> Cxt
    constructorFields (\ConstructorInfo
    s Cxt
    v -> ConstructorInfo
    s { constructorFields = v })
                     ((Cxt -> f Cxt) -> ConstructorInfo -> f ConstructorInfo)
    -> ((Type -> f Type) -> Cxt -> f Cxt)
    -> (Type -> f Type)
    -> ConstructorInfo
    -> f ConstructorInfo
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Type -> f Type) -> Cxt -> f Cxt
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> [a] -> f [b]
    traverse

    conNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo
    conNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo
    conNameMap = Traversal' ConstructorInfo Name
    -> (Name -> Name) -> ConstructorInfo -> ConstructorInfo
    forall s a. Traversal' s a -> (a -> a) -> s -> s
    over (Name -> f Name) -> ConstructorInfo -> f ConstructorInfo
    Traversal' ConstructorInfo Name
    conNameTraversal

    conFieldNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo
    conFieldNameMap :: (Name -> Name) -> ConstructorInfo -> ConstructorInfo
    conFieldNameMap = Traversal' ConstructorInfo Name
    -> (Name -> Name) -> ConstructorInfo -> ConstructorInfo
    forall s a. Traversal' s a -> (a -> a) -> s -> s
    over (Name -> f Name) -> ConstructorInfo -> f ConstructorInfo
    Traversal' ConstructorInfo Name
    conFieldNameTraversal

    conTypeMap :: (Type -> Type) -> ConstructorInfo -> ConstructorInfo
    conTypeMap :: (Type -> Type) -> ConstructorInfo -> ConstructorInfo
    conTypeMap = Traversal' ConstructorInfo Type
    -> (Type -> Type) -> ConstructorInfo -> ConstructorInfo
    forall s a. Traversal' s a -> (a -> a) -> s -> s
    over (Type -> f Type) -> ConstructorInfo -> f ConstructorInfo
    Traversal' ConstructorInfo Type
    conTypeTraversal

    -------------------------------------------------------------------------------
    -- Lenses
    -------------------------------------------------------------------------------

    type Lens'      s a = forall f. Functor     f => (a -> f a) -> s -> f s
    type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s

    lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
    lens :: forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
    lens s -> a
    sa s -> a -> s
    sas a -> f a
    afa s
    s = s -> a -> s
    sas s
    s (a -> s) -> f a -> f s
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> a -> f a
    afa (s -> a
    sa s
    s)
    {-# INLINE lens #-}

    over :: Traversal' s a -> (a -> a) -> s -> s
    over :: forall s a. Traversal' s a -> (a -> a) -> s -> s
    over Traversal' s a
    l a -> a
    f = Identity s -> s
    forall a. Identity a -> a
    runIdentity (Identity s -> s) -> (s -> Identity s) -> s -> s
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (a -> Identity a) -> s -> Identity s
    Traversal' s a
    l (a -> Identity a
    forall a. a -> Identity a
    Identity (a -> Identity a) -> (a -> a) -> a -> Identity a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> a
    f)
    {-# INLINE over #-}

    -------------------------------------------------------------------------------
    -- Type mangling
    -------------------------------------------------------------------------------

    headOfType :: Type -> Q Name
    headOfType :: Type -> Q Name
    headOfType (AppT Type
    t Type
    _) = Type -> Q Name
    headOfType Type
    t
    headOfType (VarT Name
    n)   = Name -> Q Name
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Name
    n
    headOfType (ConT Name
    n)   = Name -> Q Name
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Name
    n
    headOfType Type
    t          = String -> Q Name
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q Name) -> String -> Q Name
    forall a b. (a -> b) -> a -> b
    $ String
    "headOfType: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Show a => a -> String
    show Type
    t

    -- | Extract type variables
    typeVars :: [TyVarBndr_ flag] -> [Name]
    typeVars :: forall flag. [TyVarBndr_ flag] -> [Name]
    typeVars = (TyVarBndr_ flag -> Name) -> [TyVarBndr_ flag] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndr_ flag -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName

    -- | Apply arguments to a type constructor.
    conAppsT :: Name -> [Type] -> Type
    conAppsT :: Name -> Cxt -> Type
    conAppsT Name
    conName = (Type -> Type -> Type) -> Type -> Cxt -> Type
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Type -> Type -> Type
    AppT (Name -> Type
    ConT Name
    conName)

    -- | Provides substitution for types
    substType
        :: Type
        -> Type
        -> Type
        -> Type
    substType :: Type -> Type -> Type -> Type
    substType Type
    a Type
    b = Type -> Type
    go
      where
        go :: Type -> Type
    go Type
    x | Type
    x Type -> Type -> Bool
    forall a. Eq a => a -> a -> Bool
    == Type
    a         = Type
    b
        go (VarT Name
    n)           = Name -> Type
    VarT Name
    n
        go (AppT Type
    l Type
    r)         = Type -> Type -> Type
    AppT (Type -> Type
    go Type
    l) (Type -> Type
    go Type
    r)
        go (ForallT [TyVarBndr Specificity]
    xs Cxt
    ctx Type
    t) = [TyVarBndr Specificity] -> Cxt -> Type -> Type
    ForallT [TyVarBndr Specificity]
    xs Cxt
    ctx (Type -> Type
    go Type
    t)
        -- This may fail with kind error
        go (SigT Type
    t Type
    k)         = Type -> Type -> Type
    SigT (Type -> Type
    go Type
    t) Type
    k
        go (InfixT Type
    l Name
    n Type
    r)     = Type -> Name -> Type -> Type
    InfixT (Type -> Type
    go Type
    l) Name
    n (Type -> Type
    go Type
    r)
        go (UInfixT Type
    l Name
    n Type
    r)    = Type -> Name -> Type -> Type
    UInfixT (Type -> Type
    go Type
    l) Name
    n (Type -> Type
    go Type
    r)
        go (ParensT Type
    t)        = Type -> Type
    ParensT (Type -> Type
    go Type
    t)
        -- Rest are unchanged
        go Type
    x = Type
    x

    toCon :: ConstructorInfo -> Con
    toCon :: ConstructorInfo -> Con
    toCon (ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName       = Name
    name
                           , constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
    constructorVars       = [TyVarBndrUnit]
    vars
                           , constructorContext :: ConstructorInfo -> Cxt
    constructorContext    = Cxt
    ctxt
                           , constructorFields :: ConstructorInfo -> Cxt
    constructorFields     = Cxt
    ftys
                           , constructorStrictness :: ConstructorInfo -> [FieldStrictness]
    constructorStrictness = [FieldStrictness]
    fstricts
                           , constructorVariant :: ConstructorInfo -> ConstructorVariant
    constructorVariant    = ConstructorVariant
    variant })
      | Bool -> Bool
    not ([TyVarBndrUnit] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TyVarBndrUnit]
    vars Bool -> Bool -> Bool
    && Cxt -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null Cxt
    ctxt)
      = String -> Con
    forall a. HasCallStack => String -> a
    error String
    "makeBaseFunctor: GADTs are not currently supported."
      | Bool
    otherwise
      = let bangs :: [Bang]
    bangs = (FieldStrictness -> Bang) -> [FieldStrictness] -> [Bang]
    forall a b. (a -> b) -> [a] -> [b]
    map FieldStrictness -> Bang
    toBang [FieldStrictness]
    fstricts
         in case ConstructorVariant
    variant of
              ConstructorVariant
    NormalConstructor        -> Name -> [BangType] -> Con
    NormalC Name
    name ([BangType] -> Con) -> [BangType] -> Con
    forall a b. (a -> b) -> a -> b
    $ [Bang] -> Cxt -> [BangType]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Bang]
    bangs Cxt
    ftys
              RecordConstructor [Name]
    fnames -> Name -> [VarBangType] -> Con
    RecC Name
    name ([VarBangType] -> Con) -> [VarBangType] -> Con
    forall a b. (a -> b) -> a -> b
    $ [Name] -> [Bang] -> Cxt -> [VarBangType]
    forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
    zip3 [Name]
    fnames [Bang]
    bangs Cxt
    ftys
              ConstructorVariant
    InfixConstructor
                |  [Bang
    bang1, Bang
    bang2] <- [Bang]
    bangs
                ,  [Type
    fty1,  Type
    fty2]  <- Cxt
    ftys
                -> BangType -> Name -> BangType -> Con
    InfixC (Bang
    bang1, Type
    fty1) Name
    name (Bang
    bang2, Type
    fty2)

                |  Bool
    otherwise
                -> String -> Con
    forall a. HasCallStack => String -> a
    error (String -> Con) -> String -> Con
    forall a b. (a -> b) -> a -> b
    $ String
    "makeBaseFunctor: Encountered an InfixConstructor "
                        String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "without exactly two fields"
      where
        toBang :: FieldStrictness -> Bang
    toBang (FieldStrictness Unpackedness
    upkd Strictness
    strct) = SourceUnpackedness -> SourceStrictness -> Bang
    Bang (Unpackedness -> SourceUnpackedness
    toSourceUnpackedness Unpackedness
    upkd)
                                                   (Strictness -> SourceStrictness
    toSourceStrictness Strictness
    strct)
          where
            toSourceUnpackedness :: Unpackedness -> SourceUnpackedness
            toSourceUnpackedness :: Unpackedness -> SourceUnpackedness
    toSourceUnpackedness Unpackedness
    UnspecifiedUnpackedness = SourceUnpackedness
    NoSourceUnpackedness
            toSourceUnpackedness Unpackedness
    NoUnpack                = SourceUnpackedness
    SourceNoUnpack
            toSourceUnpackedness Unpackedness
    Unpack                  = SourceUnpackedness
    SourceUnpack

            toSourceStrictness :: Strictness -> SourceStrictness
            toSourceStrictness :: Strictness -> SourceStrictness
    toSourceStrictness Strictness
    UnspecifiedStrictness = SourceStrictness
    NoSourceStrictness
            toSourceStrictness Strictness
    Lazy                  = SourceStrictness
    SourceLazy
            toSourceStrictness Strictness
    TH.Abs.Strict         = SourceStrictness
    SourceStrict

    -------------------------------------------------------------------------------
    -- Compat from base-4.9
    -------------------------------------------------------------------------------

    isSymbolChar :: Char -> Bool
    isSymbolChar :: Char -> Bool
    isSymbolChar Char
    c = Bool -> Bool
    not (Char -> Bool
    isPuncChar Char
    c) Bool -> Bool -> Bool
    && case Char -> GeneralCategory
    generalCategory Char
    c of
        GeneralCategory
    MathSymbol              -> Bool
    True
        GeneralCategory
    CurrencySymbol          -> Bool
    True
        GeneralCategory
    ModifierSymbol          -> Bool
    True
        GeneralCategory
    OtherSymbol             -> Bool
    True
        GeneralCategory
    DashPunctuation         -> Bool
    True
        GeneralCategory
    OtherPunctuation        -> Char
    c Char -> String -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` String
    "'\""
        GeneralCategory
    ConnectorPunctuation    -> Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '_'
        GeneralCategory
    _                       -> Bool
    False

    isPuncChar :: Char -> Bool
    isPuncChar :: Char -> Bool
    isPuncChar Char
    c = Char
    c Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` String
    ",;()[]{}`"

    -------------------------------------------------------------------------------
    -- TH-quoted names
    -------------------------------------------------------------------------------
    -- Note that this module only TemplateHaskellQuotes, not TemplateHaskell,
    -- which makes lens able to be used in stage1 cross-compilers.

    baseTypeName :: Name
    baseTypeName :: Name
    baseTypeName = ''Base

    recursiveTypeName :: Name
    recursiveTypeName :: Name
    recursiveTypeName = ''Recursive

    corecursiveTypeName :: Name
    corecursiveTypeName :: Name
    corecursiveTypeName = ''Corecursive

    projectValName :: Name
    projectValName :: Name
    projectValName = 'project

    embedValName :: Name
    embedValName :: Name
    embedValName = 'embed

    functorTypeName :: Name
    functorTypeName :: Name
    functorTypeName = ''Functor

    foldableTypeName :: Name
    foldableTypeName :: Name
    foldableTypeName = ''Foldable

    traversableTypeName :: Name
    traversableTypeName :: Name
    traversableTypeName = ''Traversable