    {-# LANGUAGE ScopedTypeVariables #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Data.Singletons.Deriving.Util
    -- Copyright   :  (C) 2018 Ryan Scott
    -- License     :  BSD-style (see LICENSE)
    -- Maintainer  :  Ryan Scott
    -- Stability   :  experimental
    -- Portability :  non-portable
    --
    -- Utilities used by the `deriving` machinery in singletons.
    --
    ----------------------------------------------------------------------------
    module Data.Singletons.Deriving.Util where

    import Control.Monad
    import Data.List
    import Data.Singletons.Names
    import Data.Singletons.Syntax
    import Data.Singletons.Util
    import Language.Haskell.TH.Desugar
    import qualified Language.Haskell.TH.Desugar.OSet as OSet
    import Language.Haskell.TH.Syntax

    -- A generic type signature for describing how to produce a derived instance.
    type DerivDesc q
       = Maybe DCxt  -- (Just ctx) if ctx was provided via StandaloneDeriving.
                     -- Nothing if using a deriving clause.
      -> DType       -- The data type argument to the class.
      -> DataDecl    -- The original data type information.
      -> q UInstDecl -- The derived instance.

    -- | Is this data type a non-vanilla data type? Here, \"non-vanilla\" refers to
    -- any data type that cannot be expressed using Haskell98 syntax. For instance,
    -- this GADT:
    --
    -- @
    -- data Foo :: Type -> Type where
    --   MkFoo :: forall a. a -> Foo a
    -- @
    --
    -- Is equivalent to this Haskell98 data type:
    --
    -- @
    -- data Foo a = MkFoo a
    -- @
    --
    -- However, the following GADT is non-vanilla:
    --
    -- @
    -- data Bar :: Type -> Type where
    --   MkBar :: Int -> Bar Int
    -- @
    --
    -- Since there is no equivalent Haskell98 data type. The closest you could get
    -- is this:
    --
    -- @
    -- data Bar a = (a ~ Int) => MkBar Int
    -- @
    --
    -- Which requires language extensions to write.
    --
    -- A data type is a non-vanilla if one of the following conditions are met:
    --
    -- 1. A constructor has any existentially quantified type variables.
    --
    -- 2. A constructor has a context.
    --
    -- We care about this because some derivable stock classes, such as 'Enum',
    -- forbid derived instances for non-vanilla data types.
    isNonVanillaDataType :: forall q. DsMonad q => DType -> [DCon] -> q Bool
    isNonVanillaDataType :: DType -> [DCon] -> q Bool
    isNonVanillaDataType data_ty :: DType
    data_ty = (DCon -> q Bool) -> [DCon] -> q Bool
    forall a. (a -> q Bool) -> [a] -> q Bool
    anyM ((DCon -> q Bool) -> [DCon] -> q Bool)
    -> (DCon -> q Bool) -> [DCon] -> q Bool
    forall a b. (a -> b) -> a -> b
    $ \con :: DCon
    con@(DCon _ ctxt :: DCxt
    ctxt _ _ _) -> do
        [DTyVarBndr]
    ex_tvbs <- DType -> DCon -> q [DTyVarBndr]
    forall (q :: * -> *). DsMonad q => DType -> DCon -> q [DTyVarBndr]
    conExistentialTvbs DType
    data_ty DCon
    con
        Bool -> q Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> q Bool) -> Bool -> q Bool
    forall a b. (a -> b) -> a -> b
    $ Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ [DTyVarBndr] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [DTyVarBndr]
    ex_tvbs Bool -> Bool -> Bool
    && DCxt -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null DCxt
    ctxt
      where
        anyM :: (a -> q Bool) -> [a] -> q Bool
        anyM :: (a -> q Bool) -> [a] -> q Bool
    anyM _ [] = Bool -> q Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
        anyM p :: a -> q Bool
    p (x :: a
    x:xs :: [a]
    xs) = do
          Bool
    b <- a -> q Bool
    p a
    x
          if Bool
    b then Bool -> q Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True else (a -> q Bool) -> [a] -> q Bool
    forall a. (a -> q Bool) -> [a] -> q Bool
    anyM a -> q Bool
    p [a]
    xs

    -----
    -- Utilities for deriving Functor-like classes.
    -- Much of this was cargo-culted from the GHC source code.
    -----

    data FFoldType a      -- Describes how to fold over a DType in a functor like way
       = FT { FFoldType a -> a
    ft_triv    :: a
              -- ^ Does not contain variable
            , FFoldType a -> a
    ft_var     :: a
              -- ^ The variable itself
            , FFoldType a -> DType -> a -> a
    ft_ty_app  :: DType -> a -> a
              -- ^ Type app, variable only in last argument
            , FFoldType a -> a
    ft_bad_app :: a
              -- ^ Type app, variable other than in last argument
            , FFoldType a -> [DTyVarBndr] -> a -> a
    ft_forall  :: [DTyVarBndr] -> a -> a
              -- ^ Forall type
            }

    -- Note that in GHC, this function is pure. It must be monadic here since we:
    --
    -- (1) Expand type synonyms
    -- (2) Detect type family applications
    --
    -- Which require reification in Template Haskell, but are pure in Core.
    functorLikeTraverse :: forall q a.
                           DsMonad q
                        => Name        -- ^ Variable to look for
                        -> FFoldType a -- ^ How to fold
                        -> DType       -- ^ Type to process
                        -> q a
    functorLikeTraverse :: Name -> FFoldType a -> DType -> q a
    functorLikeTraverse var :: Name
    var (FT { ft_triv :: forall a. FFoldType a -> a
    ft_triv = a
    caseTrivial, ft_var :: forall a. FFoldType a -> a
    ft_var = a
    caseVar
                                , ft_ty_app :: forall a. FFoldType a -> DType -> a -> a
    ft_ty_app = DType -> a -> a
    caseTyApp, ft_bad_app :: forall a. FFoldType a -> a
    ft_bad_app = a
    caseWrongArg
                                , ft_forall :: forall a. FFoldType a -> [DTyVarBndr] -> a -> a
    ft_forall = [DTyVarBndr] -> a -> a
    caseForAll })
                        ty :: DType
    ty
      = do DType
    ty' <- DType -> q DType
    forall (q :: * -> *). DsMonad q => DType -> q DType
    expandType DType
    ty
           (res :: a
    res, _) <- DType -> q (a, Bool)
    go DType
    ty'
           a -> q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure a
    res
      where
        go :: DType
           -> q (a, Bool) -- (result of type a, does type contain var)
        go :: DType -> q (a, Bool)
    go (DAppT f :: DType
    f x :: DType
    x) = do
          (_, fc :: Bool
    fc) <- DType -> q (a, Bool)
    go DType
    f
          if Bool
    fc
             then (a, Bool) -> q (a, Bool)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (a
    caseWrongArg, Bool
    True)
             else do (xr :: a
    xr, xc :: Bool
    xc) <- DType -> q (a, Bool)
    go DType
    x
                     if Bool
    xc
                        then let tyApp :: q (a, Bool)
                                 tyApp :: q (a, Bool)
    tyApp = (a, Bool) -> q (a, Bool)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (DType -> a -> a
    caseTyApp DType
    f a
    xr, Bool
    True)

                                 inspect :: DType -> q (a, Bool)
                                 inspect :: DType -> q (a, Bool)
    inspect (DConT n :: Name
    n) = do
                                   Bool
    itf <- Name -> q Bool
    forall (q :: * -> *). DsMonad q => Name -> q Bool
    isTyFamilyName Name
    n
                                   if Bool
    itf -- We can't decompose type families, so
                                          -- error if we encounter one here.
                                      then (a, Bool) -> q (a, Bool)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (a
    caseWrongArg, Bool
    True)
                                      else q (a, Bool)
    tyApp
                                 inspect (DForallT _ _ t :: DType
    t) = DType -> q (a, Bool)
    inspect DType
    t
                                 inspect (DSigT t :: DType
    t _)      = DType -> q (a, Bool)
    inspect DType
    t
                                 inspect (DAppT t :: DType
    t _)      = DType -> q (a, Bool)
    inspect DType
    t
                                 inspect (DAppKindT t :: DType
    t _)  = DType -> q (a, Bool)
    inspect DType
    t
                                 inspect (DVarT {})       = q (a, Bool)
    tyApp
                                 inspect DArrowT          = q (a, Bool)
    tyApp
                                 inspect (DLitT {})       = q (a, Bool)
    tyApp
                                 inspect DWildCardT       = q (a, Bool)
    tyApp

                             in case DType -> (DType, [DTypeArg])
    unfoldDType DType
    f of
                                  (f_head :: DType
    f_head, _) -> DType -> q (a, Bool)
    inspect DType
    f_head
                        else q (a, Bool)
    trivial
        go (DAppKindT t :: DType
    t k :: DType
    k) = do
          (_, kc :: Bool
    kc) <- DType -> q (a, Bool)
    go DType
    k
          if Bool
    kc
             then (a, Bool) -> q (a, Bool)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (a
    caseWrongArg, Bool
    True)
             else DType -> q (a, Bool)
    go DType
    t
        go (DSigT t :: DType
    t k :: DType
    k) = do
          (_, kc :: Bool
    kc) <- DType -> q (a, Bool)
    go DType
    k
          if Bool
    kc
             then (a, Bool) -> q (a, Bool)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (a
    caseWrongArg, Bool
    True)
             else DType -> q (a, Bool)
    go DType
    t
        go (DVarT v :: Name
    v)
          | Name
    v Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    var = (a, Bool) -> q (a, Bool)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (a
    caseVar, Bool
    True)
          | Bool
    otherwise = q (a, Bool)
    trivial
        go (DForallT tvbs :: [DTyVarBndr]
    tvbs _ t :: DType
    t) = do
          (tr :: a
    tr, tc :: Bool
    tc) <- DType -> q (a, Bool)
    go DType
    t
          if Name
    var Name -> [Name] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` (DTyVarBndr -> Name) -> [DTyVarBndr] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map DTyVarBndr -> Name
    extractTvbName [DTyVarBndr]
    tvbs Bool -> Bool -> Bool
    && Bool
    tc
             then (a, Bool) -> q (a, Bool)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ([DTyVarBndr] -> a -> a
    caseForAll [DTyVarBndr]
    tvbs a
    tr, Bool
    True)
             else q (a, Bool)
    trivial
        go (DConT {}) = q (a, Bool)
    trivial
        go DArrowT    = q (a, Bool)
    trivial
        go (DLitT {}) = q (a, Bool)
    trivial
        go DWildCardT = q (a, Bool)
    trivial

        trivial :: q (a, Bool)
        trivial :: q (a, Bool)
    trivial = (a, Bool) -> q (a, Bool)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (a
    caseTrivial, Bool
    False)

    isTyFamilyName :: DsMonad q => Name -> q Bool
    isTyFamilyName :: Name -> q Bool
    isTyFamilyName n :: Name
    n = do
      Maybe DInfo
    info <- Name -> q (Maybe DInfo)
    forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
    dsReify Name
    n
      Bool -> q Bool
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Bool -> q Bool) -> Bool -> q Bool
    forall a b. (a -> b) -> a -> b
    $ case Maybe DInfo
    info of
               Just (DTyConI dec :: DDec
    dec _)
                 | DOpenTypeFamilyD{}   <- DDec
    dec -> Bool
    True
                 | DClosedTypeFamilyD{} <- DDec
    dec -> Bool
    True
               _ -> Bool
    False

    -- A crude approximation of cond_functorOK from GHC. This checks that:
    --
    -- (1) There's at least one type variable in the data type.
    -- (2) It doesn't use the last type variable in the wrong place, e.g. data T a = MkT (X a a)
    -- (3) It doesn't constrain the last type variable, e.g., data T a = Eq a => MkT a
    functorLikeValidityChecks :: forall q. DsMonad q => Bool -> DataDecl -> q ()
    functorLikeValidityChecks :: Bool -> DataDecl -> q ()
    functorLikeValidityChecks allowConstrainedLastTyVar :: Bool
    allowConstrainedLastTyVar (DataDecl n :: Name
    n data_tvbs :: [DTyVarBndr]
    data_tvbs cons :: [DCon]
    cons)
      | [DTyVarBndr] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [DTyVarBndr]
    data_tvbs -- (1)
      = String -> q ()
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> q ()) -> String -> q ()
    forall a b. (a -> b) -> a -> b
    $ "Data type " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    nameBase Name
    n String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " must have some type parameters"
      | Bool
    otherwise
      = (DCon -> q ()) -> [DCon] -> q ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ DCon -> q ()
    check_con [DCon]
    cons
      where
        check_con :: DCon -> q ()
        check_con :: DCon -> q ()
    check_con con :: DCon
    con = do
          DCon -> q ()
    check_universal DCon
    con
          [q ()]
    checks <- FFoldType (q ()) -> DCon -> q [q ()]
    forall (q :: * -> *) a. DsMonad q => FFoldType a -> DCon -> q [a]
    foldDataConArgs (Name -> FFoldType (q ())
    ft_check (DCon -> Name
    extractName DCon
    con)) DCon
    con
          [q ()] -> q ()
    forall (t :: * -> *) (m :: * -> *) a.
    (Foldable t, Monad m) =>
    t (m a) -> m ()
    sequence_ [q ()]
    checks

        -- (2)
        check_universal :: DCon -> q ()
        check_universal :: DCon -> q ()
    check_universal con :: DCon
    con@(DCon con_tvbs :: [DTyVarBndr]
    con_tvbs con_theta :: DCxt
    con_theta con_name :: Name
    con_name _ res_ty :: DType
    res_ty)
          | Bool
    allowConstrainedLastTyVar
          = () -> q ()
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
          | (_, res_ty_args :: [DTypeArg]
    res_ty_args) <- DType -> (DType, [DTypeArg])
    unfoldDType DType
    res_ty
          , (_, last_res_ty_arg :: DType
    last_res_ty_arg) <- DCxt -> (DCxt, DType)
    forall a. [a] -> ([a], a)
    snocView (DCxt -> (DCxt, DType)) -> DCxt -> (DCxt, DType)
    forall a b. (a -> b) -> a -> b
    $ [DTypeArg] -> DCxt
    filterDTANormals [DTypeArg]
    res_ty_args
          , Just last_tv :: Name
    last_tv <- DType -> Maybe Name
    getDVarTName_maybe DType
    last_res_ty_arg
          = do [DTyVarBndr]
    ex_tvbs <- DType -> DCon -> q [DTyVarBndr]
    forall (q :: * -> *). DsMonad q => DType -> DCon -> q [DTyVarBndr]
    conExistentialTvbs (DType -> [DTyVarBndr] -> DType
    foldTypeTvbs (Name -> DType
    DConT Name
    n) [DTyVarBndr]
    data_tvbs) DCon
    con
               let univ_tvb_names :: [Name]
    univ_tvb_names = (DTyVarBndr -> Name) -> [DTyVarBndr] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map DTyVarBndr -> Name
    extractTvbName [DTyVarBndr]
    con_tvbs [Name] -> [Name] -> [Name]
    forall a. Eq a => [a] -> [a] -> [a]
    \\ (DTyVarBndr -> Name) -> [DTyVarBndr] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map DTyVarBndr -> Name
    extractTvbName [DTyVarBndr]
    ex_tvbs
               if Name
    last_tv Name -> [Name] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Name]
    univ_tvb_names
                    Bool -> Bool -> Bool
    && Name
    last_tv Name -> OSet Name -> Bool
    forall a. Ord a => a -> OSet a -> Bool
    `OSet.notMember` (DType -> OSet Name) -> DCxt -> OSet Name
    forall (t :: * -> *) m a.
    (Foldable t, Monoid m) =>
    (a -> m) -> t a -> m
    foldMap DType -> OSet Name
    fvDType DCxt
    con_theta
                  then () -> q ()
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
                  else String -> q ()
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> q ()) -> String -> q ()
    forall a b. (a -> b) -> a -> b
    $ Name -> String -> String
    badCon Name
    con_name String
    existential
          | Bool
    otherwise
          = String -> q ()
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> q ()) -> String -> q ()
    forall a b. (a -> b) -> a -> b
    $ Name -> String -> String
    badCon Name
    con_name String
    existential

        -- (3)
        ft_check :: Name -> FFoldType (q ())
        ft_check :: Name -> FFoldType (q ())
    ft_check con_name :: Name
    con_name =
          FT :: forall a.
    a
    -> a
    -> (DType -> a -> a)
    -> a
    -> ([DTyVarBndr] -> a -> a)
    -> FFoldType a
    FT { ft_triv :: q ()
    ft_triv    = () -> q ()
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
             , ft_var :: q ()
    ft_var     = () -> q ()
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
             , ft_ty_app :: DType -> q () -> q ()
    ft_ty_app  = \_ x :: q ()
    x -> q ()
    x
             , ft_bad_app :: q ()
    ft_bad_app = String -> q ()
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> q ()) -> String -> q ()
    forall a b. (a -> b) -> a -> b
    $ Name -> String -> String
    badCon Name
    con_name String
    wrong_arg
             , ft_forall :: [DTyVarBndr] -> q () -> q ()
    ft_forall  = \_ x :: q ()
    x -> q ()
    x
             }

        badCon :: Name -> String -> String
        badCon :: Name -> String -> String
    badCon con_name :: Name
    con_name msg :: String
    msg = "Constructor " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    nameBase Name
    con_name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    msg

        existential, wrong_arg :: String
        existential :: String
    existential = "must be truly polymorphic in the last argument of the data type"
        wrong_arg :: String
    wrong_arg   = "must use the type variable only as the last argument of a data type"

    -- Return all syntactic subterms of a type that contain the given variable somewhere.
    -- These are the things that should appear in Functor-like instance constraints.
    deepSubtypesContaining :: DsMonad q => Name -> DType -> q [DType]
    deepSubtypesContaining :: Name -> DType -> q DCxt
    deepSubtypesContaining tv :: Name
    tv
      = Name -> FFoldType DCxt -> DType -> q DCxt
    forall (q :: * -> *) a.
    DsMonad q =>
    Name -> FFoldType a -> DType -> q a
    functorLikeTraverse Name
    tv
            (FT :: forall a.
    a
    -> a
    -> (DType -> a -> a)
    -> a
    -> ([DTyVarBndr] -> a -> a)
    -> FFoldType a
    FT { ft_triv :: DCxt
    ft_triv    = []
                , ft_var :: DCxt
    ft_var     = []
                , ft_ty_app :: DType -> DCxt -> DCxt
    ft_ty_app  = (:)
                , ft_bad_app :: DCxt
    ft_bad_app = String -> DCxt
    forall a. HasCallStack => String -> a
    error "in other argument in deepSubtypesContaining"
                , ft_forall :: [DTyVarBndr] -> DCxt -> DCxt
    ft_forall  = \tvbs :: [DTyVarBndr]
    tvbs xs :: DCxt
    xs -> (DType -> Bool) -> DCxt -> DCxt
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\x :: DType
    x -> (DTyVarBndr -> Bool) -> [DTyVarBndr] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (DType -> DTyVarBndr -> Bool
    not_in_ty DType
    x) [DTyVarBndr]
    tvbs) DCxt
    xs })
      where
        not_in_ty :: DType -> DTyVarBndr -> Bool
        not_in_ty :: DType -> DTyVarBndr -> Bool
    not_in_ty ty :: DType
    ty tvb :: DTyVarBndr
    tvb = DTyVarBndr -> Name
    extractTvbName DTyVarBndr
    tvb Name -> OSet Name -> Bool
    forall a. Ord a => a -> OSet a -> Bool
    `OSet.notMember` DType -> OSet Name
    fvDType DType
    ty

    -- Fold over the arguments of a data constructor in a Functor-like way.
    foldDataConArgs :: forall q a. DsMonad q => FFoldType a -> DCon -> q [a]
    foldDataConArgs :: FFoldType a -> DCon -> q [a]
    foldDataConArgs ft :: FFoldType a
    ft (DCon _ _ _ fields :: DConFields
    fields res_ty :: DType
    res_ty) = do
      DCxt
    field_tys <- (DType -> q DType) -> DCxt -> q DCxt
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse DType -> q DType
    forall (q :: * -> *). DsMonad q => DType -> q DType
    expandType (DCxt -> q DCxt) -> DCxt -> q DCxt
    forall a b. (a -> b) -> a -> b
    $ DConFields -> DCxt
    tysOfConFields DConFields
    fields
      (DType -> q a) -> DCxt -> q [a]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse DType -> q a
    foldArg DCxt
    field_tys
      where
        foldArg :: DType -> q a
        foldArg :: DType -> q a
    foldArg
          | (_, res_ty_args :: [DTypeArg]
    res_ty_args) <- DType -> (DType, [DTypeArg])
    unfoldDType DType
    res_ty
          , (_, last_res_ty_arg :: DType
    last_res_ty_arg) <- DCxt -> (DCxt, DType)
    forall a. [a] -> ([a], a)
    snocView (DCxt -> (DCxt, DType)) -> DCxt -> (DCxt, DType)
    forall a b. (a -> b) -> a -> b
    $ [DTypeArg] -> DCxt
    filterDTANormals [DTypeArg]
    res_ty_args
          , Just last_tv :: Name
    last_tv <- DType -> Maybe Name
    getDVarTName_maybe DType
    last_res_ty_arg
          = Name -> FFoldType a -> DType -> q a
    forall (q :: * -> *) a.
    DsMonad q =>
    Name -> FFoldType a -> DType -> q a
    functorLikeTraverse Name
    last_tv FFoldType a
    ft
          | Bool
    otherwise
          = q a -> DType -> q a
    forall a b. a -> b -> a
    const (a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (FFoldType a -> a
    forall a. FFoldType a -> a
    ft_triv FFoldType a
    ft))

    -- If a type is a type variable (or a variable with a kind signature), return
    -- 'Just' that. Otherwise, return 'Nothing'.
    getDVarTName_maybe :: DType -> Maybe Name
    getDVarTName_maybe :: DType -> Maybe Name
    getDVarTName_maybe (DSigT t :: DType
    t _) = DType -> Maybe Name
    getDVarTName_maybe DType
    t
    getDVarTName_maybe (DVarT n :: Name
    n)   = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    n
    getDVarTName_maybe _           = Maybe Name
    forall a. Maybe a
    Nothing

    -- Make a 'DLamE' using a fresh variable.
    mkSimpleLam :: Quasi q => (DExp -> q DExp) -> q DExp
    mkSimpleLam :: (DExp -> q DExp) -> q DExp
    mkSimpleLam lam :: DExp -> q DExp
    lam = do
      Name
    n <- String -> q Name
    forall (q :: * -> *). Quasi q => String -> q Name
    newUniqueName "n"
      DExp
    body <- DExp -> q DExp
    lam (Name -> DExp
    DVarE Name
    n)
      DExp -> q DExp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DExp -> q DExp) -> DExp -> q DExp
    forall a b. (a -> b) -> a -> b
    $ [Name] -> DExp -> DExp
    DLamE [Name
    n] DExp
    body

    -- Make a 'DLamE' using two fresh variables.
    mkSimpleLam2 :: Quasi q => (DExp -> DExp -> q DExp) -> q DExp
    mkSimpleLam2 :: (DExp -> DExp -> q DExp) -> q DExp
    mkSimpleLam2 lam :: DExp -> DExp -> q DExp
    lam = do
      Name
    n1 <- String -> q Name
    forall (q :: * -> *). Quasi q => String -> q Name
    newUniqueName "n1"
      Name
    n2 <- String -> q Name
    forall (q :: * -> *). Quasi q => String -> q Name
    newUniqueName "n2"
      DExp
    body <- DExp -> DExp -> q DExp
    lam (Name -> DExp
    DVarE Name
    n1) (Name -> DExp
    DVarE Name
    n2)
      DExp -> q DExp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DExp -> q DExp) -> DExp -> q DExp
    forall a b. (a -> b) -> a -> b
    $ [Name] -> DExp -> DExp
    DLamE [Name
    n1, Name
    n2] DExp
    body

    -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
    --
    -- @mkSimpleConClause fold extra_pats con insides@ produces a match clause in
    -- which the LHS pattern-matches on @extra_pats@, followed by a match on the
    -- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
    -- and its arguments, applying an expression (from @insides@) to each of the
    -- respective arguments of @con@.
    mkSimpleConClause :: Quasi q
                      => (Name -> [DExp] -> DExp)
                      -> [DPat]
                      -> DCon
                      -> [DExp]
                      -> q DClause
    mkSimpleConClause :: (Name -> [DExp] -> DExp) -> [DPat] -> DCon -> [DExp] -> q DClause
    mkSimpleConClause fold :: Name -> [DExp] -> DExp
    fold extra_pats :: [DPat]
    extra_pats (DCon _ _ con_name :: Name
    con_name _ _) insides :: [DExp]
    insides = do
      [Name]
    vars_needed <- Int -> q Name -> q [Name]
    forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
    replicateM ([DExp] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [DExp]
    insides) (q Name -> q [Name]) -> q Name -> q [Name]
    forall a b. (a -> b) -> a -> b
    $ String -> q Name
    forall (q :: * -> *). Quasi q => String -> q Name
    newUniqueName "a"
      let pat :: DPat
    pat = Name -> [DPat] -> DPat
    DConP Name
    con_name ((Name -> DPat) -> [Name] -> [DPat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> DPat
    DVarP [Name]
    vars_needed)
          rhs :: DExp
    rhs = Name -> [DExp] -> DExp
    fold Name
    con_name ((DExp -> Name -> DExp) -> [DExp] -> [Name] -> [DExp]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\i :: DExp
    i v :: Name
    v -> DExp
    i DExp -> DExp -> DExp
    `DAppE` Name -> DExp
    DVarE Name
    v) [DExp]
    insides [Name]
    vars_needed)
      DClause -> q DClause
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (DClause -> q DClause) -> DClause -> q DClause
    forall a b. (a -> b) -> a -> b
    $ [DPat] -> DExp -> DClause
    DClause ([DPat]
    extra_pats [DPat] -> [DPat] -> [DPat]
    forall a. [a] -> [a] -> [a]
    ++ [DPat
    pat]) DExp
    rhs

    -- 'True' if the derived class's last argument is of kind (Type -> Type),
    -- and thus needs a different constraint inference approach.
    --
    -- Really, we should be determining this information by inspecting the kind
    -- of the class being used. But that comes dangerously close to kind
    -- inference territory, so for now we simply hardcode which stock derivable
    -- classes are Functor-like.
    isFunctorLikeClassName :: Name -> Bool
    isFunctorLikeClassName :: Name -> Bool
    isFunctorLikeClassName class_name :: Name
    class_name
      = Name
    class_name Name -> [Name] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Name
    functorName, Name
    foldableName, Name
    traversableName]