    {-# LANGUAGE CPP #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE KindSignatures #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE DefaultSignatures #-}

    -- | Lifted versions of the @'Functor'@, @'Pointed'@, @'Apply'@
    -- and @'Traversable'@ classes, plus template-haskell magic to automatically
    -- derive instances.
    -- \"Lifted\" because these classes are about datatypes parameterized over a
    -- constructor (i.e. of kind @(* -> *) -> *@). For example
    -- @fmap :: (a -> b) -> f a -> f b@ becomes
    -- @cMap :: (forall a . f a -> g a) -> c f -> c g@.
    --
    -- For the lifted version of @Applicative@, we focus on 'liftA2' instead of
    -- '\<*\>' as this is the only way to make the lifted version work. As a
    -- consequence, the class and method are named after 'zipWith' because of
    -- the similarity of the signatures and the semantics.
    --
    -- @
    -- liftA2   :: Applicative f =>         (g   -> h   -> i  ) -> f g -> f h -> f i
    -- zipWith  ::                          (g   -> h   -> i  ) -> [g] -> [h] -> [i]
    -- cZipWith :: CZipWith k => (forall a . g a -> h a -> i a) -> k g -> k h -> k i
    -- @
    --
    -- Types of the corresponding kind occur for example when handling program
    -- configuration: When we define our an example configuration type like
    --
    -- @
    -- data MyConfig f = MyConfig
    --   { flag_foo       :: f Bool
    --   , flag_bar       :: f Bool
    --   , flag_someLimit :: f Int
    --   }
    -- @
    --
    -- then
    --
    -- * @MyConfig Maybe@ can be used as the result-type of parsing the
    --   commandline or a configuration file; it includes the option that some
    --   field was not specified;
    -- * @MyConfig Identity@ can be used to represent both the default
    --   configuration and the actual configuration derived from
    --   defaults and the user input;
    -- * @MyConfig (Const Text)@ type to represent documentation for our config,
    --   to be displayed to the user.
    --
    -- This has the advantage that our configuration is defined in one place only,
    -- so that changes are easy to make and we do not ever run into any internal
    -- desynchonization of different datatypes. And once we obtained the final
    -- config @:: MyConfig Identity@, we don't have to think about @Nothing@ cases
    -- anymore.
    --
    -- @'cPointed'@ can initialize such polymorphic containers, and @'CZipWith'@
    -- further helps with this use-case, more specifically the merging of
    -- input and default config: we can express the merging of user/default config
    -- @:: MyConfig Maybe -> MyConfig Identity -> MyConfig Identity@ in terms of
    -- @'cZipWith'@. The instances are simple boilerplate and thus can be realized
    -- using the provided template-haskell.
    --
    -- As an example for such usage, the
    -- <https://github.com/lspitzner/brittany brittany> package uses this approach
    -- together with using automatically-derived Semigroup-instances that allow
    -- merging of config values (for example when commandline args do not override,
    -- but are added to those settings read from config file). See
    -- <https://github.com/lspitzner/brittany/blob/master/src/Language/Haskell/Brittany/Config/Types.hs the module containing the config type>.
    module Data.CZipWith
      ( CFunctor(..)
      , CPointed(..)
      , CZipWith(..)
      , CZipWithM(..)
      , cSequence
      , deriveCPointed
      , deriveCZipWith
      , deriveCZipWithM
      )
    where

    import           Data.Kind (Type)
    import           Data.Functor.Compose
    import           Language.Haskell.TH.Lib
    import           Language.Haskell.TH.Syntax hiding (Type)

    -- | The "lifted Apply" class
    class CPointed c where
      cPoint :: (forall a . f a) -> c f

    -- | The "lifted Functor" class
    class CFunctor c where
      cMap :: (forall a . f a -> g a) -> c f -> c g
      default cMap :: CZipWith c => (forall a . f a -> g a) -> c f -> c g
      cMap f :: forall a. f a -> g a
    f k :: c f
    k = (forall a. f a -> f a -> g a) -> c f -> c f -> c g
    forall (k :: (* -> *) -> *) (g :: * -> *) (h :: * -> *)
           (i :: * -> *).
    CZipWith k =>
    (forall a. g a -> h a -> i a) -> k g -> k h -> k i
    cZipWith (\x :: f a
    x _ -> f a -> g a
    forall a. f a -> g a
    f f a
    x) c f
    k c f
    k

    -- | laws:
    --
    -- * @'cZipWith' (\\x _ -> x) g _ = g@
    -- * @'cZipWith' (\\_ y -> y) _ h = h@
    --
    -- This class seems to be some kind of "lifted" version of 'Applicative'
    -- (or rather: of @'Apply'@),
    -- but it also seems to share an important property with the
    -- <https://hackage.haskell.org/package/distributive-0.5.2/docs/Data-Distributive.html#t:Distributive Distributive>
    -- class from the
    -- <https://hackage.haskell.org/package/distributive distributive> package,
    -- even when @'Distributive'@ and @'CZipWith'@ methods don't appear all that
    -- similar. From the corresponding docs:
    --
    -- > To be distributable a container will need to have a way to consistently
    -- > zip a potentially infinite number of copies of itself. This effectively
    -- > means that the holes in all values of that type, must have the same
    -- > cardinality, fixed sized vectors, infinite streams, functions, etc.
    -- > and no extra information to try to merge together.
    --
    -- Especially "all values of that type must have the same cardinality" is
    -- true for instances of CZipWith, the only difference being that the "holes"
    -- are instantiations of the @f :: * -> *@ to some type, where they are simply
    -- @a :: *@ for @'Distributive'@.
    --
    -- For many @'Distributive'@ instances there are corresponding datatypes that
    -- are instances of @'CZipWith'@ (although they do not seem particularly
    -- useful..), for example:
    --
    -- @
    -- newtype CUnit a f = CUnit (f a)      -- corresponding to 'Identity'
    -- data CPair a b f = CPair (f a) (f b) -- corresponding to 'data MonoPair a = MonoPair a a'
    --                                      -- (Pair being a trivial fixed-size vector example)
    -- data CStream a f = CStream (f a) (CStream a f) -- corresponding to an infinite stream
    -- @
    class CZipWith (k :: (Type -> Type) -> Type) where
      -- | zipWith on constructors instead of values.
      cZipWith :: (forall a . g a -> h a -> i a) -> k g -> k h -> k i

    -- | Where 'CZipWith' is a "lifted @Apply@", this is a "lifted 'Traversable'".
    --
    -- laws:
    --
    -- [/naturality/]
    --   @t . 'cTraverse' f = 'cTraverse' (t . f)@
    --   for every applicative transformation @t@
    --
    -- [/identity/]
    --   @'cTraverse' Identity = Identity@
    --
    -- [/composition/]
    --   @'cTraverse' (Compose . 'fmap' g . f) = Compose . 'fmap' ('cTraverse' g) . 'cTraverse' f@
    --
    -- and @cZipWithM f k l@ must behave like
    -- @cTraverse getCompose (cZipWith (\x y -> Compose (f x y)) k l)@
    --
    class CZipWith c => CZipWithM c where
      {-# MINIMAL cTraverse | cZipWithM #-}

      cTraverse :: Applicative m => (forall a . f a -> m (g a)) -> c f -> m (c g)
      cTraverse f :: forall a. f a -> m (g a)
    f k :: c f
    k = (forall a. f a -> f a -> m (g a)) -> c f -> c f -> m (c g)
    forall (c :: (* -> *) -> *) (m :: * -> *) (f :: * -> *)
           (g :: * -> *) (h :: * -> *).
    (CZipWithM c, Applicative m) =>
    (forall a. f a -> g a -> m (h a)) -> c f -> c g -> m (c h)
    cZipWithM (\x :: f a
    x _ -> f a -> m (g a)
    forall a. f a -> m (g a)
    f f a
    x) c f
    k c f
    k
      cZipWithM :: Applicative m => (forall a . f a -> g a -> m (h a)) -> c f -> c g -> m (c h)
      cZipWithM f :: forall a. f a -> g a -> m (h a)
    f k :: c f
    k l :: c g
    l =
        (forall a. Compose m h a -> m (h a)) -> c (Compose m h) -> m (c h)
    forall (c :: (* -> *) -> *) (m :: * -> *) (f :: * -> *)
           (g :: * -> *).
    (CZipWithM c, Applicative m) =>
    (forall a. f a -> m (g a)) -> c f -> m (c g)
    cTraverse forall a. Compose m h a -> m (h a)
    forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
    Compose f g a -> f (g a)
    getCompose (c (Compose m h) -> m (c h)) -> c (Compose m h) -> m (c h)
    forall a b. (a -> b) -> a -> b
    $ (forall a. f a -> g a -> Compose m h a)
    -> c f -> c g -> c (Compose m h)
    forall (k :: (* -> *) -> *) (g :: * -> *) (h :: * -> *)
           (i :: * -> *).
    CZipWith k =>
    (forall a. g a -> h a -> i a) -> k g -> k h -> k i
    cZipWith (\x :: f a
    x y :: g a
    y -> m (h a) -> Compose m h a
    forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
    f (g a) -> Compose f g a
    Compose (f a -> g a -> m (h a)
    forall a. f a -> g a -> m (h a)
    f f a
    x g a
    y)) c f
    k c g
    l

    -- | The equivalent of @'Traversable'@'s @'sequence'@/@'sequenceA'@
    cSequence :: Applicative m => CZipWithM c => (c (Compose m f)) -> m (c f)
    cSequence :: c (Compose m f) -> m (c f)
    cSequence = (forall a. Compose m f a -> m (f a)) -> c (Compose m f) -> m (c f)
    forall (c :: (* -> *) -> *) (m :: * -> *) (f :: * -> *)
           (g :: * -> *).
    (CZipWithM c, Applicative m) =>
    (forall a. f a -> m (g a)) -> c f -> m (c g)
    cTraverse forall a. Compose m f a -> m (f a)
    forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
    Compose f g a -> f (g a)
    getCompose

    -- | Derives a 'cPointed' instance for a datatype of kind @(* -> *) -> *@.
    --
    -- Requires that for this datatype (we shall call its argument @f :: * -> *@ here)
    --
    -- * there is exactly one constructor;
    -- * all fields in the one constructor are either of the form @f x@ for some
    --   @x@ or of the form @X f@ for some type @X@ where there is an
    --   @instance cPointed X@.
    --
    -- For example, the following would be valid usage:
    --
    -- @
    -- data A f = A
    --   { a_str  :: f String
    --   , a_bool :: f Bool
    --   }
    --
    -- data B f = B
    --   { b_int   :: f Int
    --   , b_float :: f Float
    --   , b_a     :: A f
    --   }
    --
    -- derivecPointed ''A
    -- derivecPointed ''B
    -- @
    --
    -- This produces the following instances:
    --
    -- @
    -- instance cPointed A where
    --   cPoint f = A f f
    --
    -- instance cPointed B where
    --   cPoint f = B f f (cPoint f f)
    -- @
    deriveCPointed :: Name -> DecsQ
    deriveCPointed :: Name -> DecsQ
    deriveCPointed name :: Name
    name = do
      Info
    info <- Name -> Q Info
    reify Name
    name
      case Info
    info of
    #if MIN_VERSION_template_haskell(2,11,0)
        TyConI (DataD _ _ [_tyvarbnd :: TyVarBndr
    _tyvarbnd] _ [con :: Con
    con] []) -> do
    #else
        TyConI (DataD _ _ [_tyvarbnd] [con] []) -> do
    #endif
          let (cons :: Name
    cons, elemTys :: [Type]
    elemTys) = case Con
    con of
                NormalC c :: Name
    c tys :: [BangType]
    tys -> (Name
    c, [BangType]
    tys [BangType] -> (BangType -> Type) -> [Type]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \(_, t :: Type
    t) -> Type
    t)
                RecC    c :: Name
    c tys :: [VarBangType]
    tys -> (Name
    c, [VarBangType]
    tys [VarBangType] -> (VarBangType -> Type) -> [Type]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \(_, _, t :: Type
    t) -> Type
    t)
                _ ->
                  [Char] -> (Name, [Type])
    forall a. HasCallStack => [Char] -> a
    error
                    ([Char] -> (Name, [Type])) -> [Char] -> (Name, [Type])
    forall a b. (a -> b) -> a -> b
    $  "Deriving requires non-GADT, non-infix data type/record!"
                    [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ " (Found: "
                    [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Con -> [Char]
    forall a. Show a => a -> [Char]
    show Con
    con
                    [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ")"
          let tyvar :: Name
    tyvar = case TyVarBndr
    _tyvarbnd of
                PlainTV n :: Name
    n    -> Name
    n
                KindedTV n :: Name
    n _ -> Name
    n
          let fQ :: Name
    fQ   = [Char] -> Name
    mkName "f"
          let pats :: [PatQ]
    pats = [Name -> PatQ
    varP Name
    fQ]
          let
            params :: [ExpQ]
    params = [Type]
    elemTys [Type] -> (Type -> ExpQ) -> [ExpQ]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \ty :: Type
    ty -> case Type
    ty of
              AppT (VarT a1 :: Name
    a1) _ | Name
    a1 Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    tyvar      -> Name -> ExpQ
    varE Name
    fQ
              AppT ConT{} (VarT a2 :: Name
    a2) | Name
    a2 Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    tyvar -> [|$(varE 'cPoint) $(varE fQ)|]
              _ ->
                [Char] -> ExpQ
    forall a. HasCallStack => [Char] -> a
    error
                  ([Char] -> ExpQ) -> [Char] -> ExpQ
    forall a b. (a -> b) -> a -> b
    $ "All constructor arguments must have either type k a for some a or C k for some C (with instance CZip C)!"
                  [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ " (Found: "
                  [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Type -> [Char]
    forall a. Show a => a -> [Char]
    show Type
    ty
                  [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ")"
          let body :: BodyQ
    body = ExpQ -> BodyQ
    normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
    forall a b. (a -> b) -> a -> b
    $ [ExpQ] -> ExpQ
    appsE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
    forall a b. (a -> b) -> a -> b
    $ Name -> ExpQ
    conE Name
    cons ExpQ -> [ExpQ] -> [ExpQ]
    forall a. a -> [a] -> [a]
    : [ExpQ]
    params
          let funQ :: DecQ
    funQ = Name -> [ClauseQ] -> DecQ
    funD 'cPoint [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
    clause [PatQ]
    pats BodyQ
    body []]
          [DecQ] -> DecsQ
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence [CxtQ -> TypeQ -> [DecQ] -> DecQ
    instanceD ([TypeQ] -> CxtQ
    cxt []) [t|CPointed $(conT name)|] [DecQ
    funQ]]
        TyConI (DataD{}) ->
          [Char] -> DecsQ
    forall a. HasCallStack => [Char] -> a
    error
            ([Char] -> DecsQ) -> [Char] -> DecsQ
    forall a b. (a -> b) -> a -> b
    $  "datatype must have kind (* -> *) -> *!"
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ " (Found: "
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Info -> [Char]
    forall a. Show a => a -> [Char]
    show Info
    info
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ")"
        _ ->
          [Char] -> DecsQ
    forall a. HasCallStack => [Char] -> a
    error
            ([Char] -> DecsQ) -> [Char] -> DecsQ
    forall a b. (a -> b) -> a -> b
    $  "name does not refer to a datatype!"
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ " (Found: "
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Info -> [Char]
    forall a. Show a => a -> [Char]
    show Info
    info
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ")"

    -- | Derives a 'CZipWith' instance for a datatype of kind @(* -> *) -> *@.
    --
    -- Requires that for this datatype (we shall call its argument @f :: * -> *@ here)
    --
    -- * there is exactly one constructor;
    -- * all fields in the one constructor are either of the form @f x@ for some
    --   @x@ or of the form @X f@ for some type @X@ where there is an
    --   @instance CZipWith X@.
    --
    -- For example, the following would be valid usage:
    --
    -- @
    -- data A f = A
    --   { a_str  :: f String
    --   , a_bool :: f Bool
    --   }
    --
    -- data B f = B
    --   { b_int   :: f Int
    --   , b_float :: f Float
    --   , b_a     :: A f
    --   }
    --
    -- deriveCZipWith ''A
    -- deriveCZipWith ''B
    -- @
    --
    -- This produces the following instances:
    --
    -- @
    -- instance CZipWith A where
    --   cZipWith f (A x1 x2) (A y1 y2) = A (f x1 y1) (f x2 y2)
    --
    -- instance CZipWith B where
    --   cZipWith f (B x1 x2 x3) (B y1 y2 y3) =
    --     B (f x1 y1) (f x2 y2) (cZipWith f x3 y3)
    -- @
    deriveCZipWith :: Name -> DecsQ
    deriveCZipWith :: Name -> DecsQ
    deriveCZipWith name :: Name
    name = do
      Info
    info <- Name -> Q Info
    reify Name
    name
      case Info
    info of
    #if MIN_VERSION_template_haskell(2,11,0)
        TyConI (DataD _ _ [tyvarbnd :: TyVarBndr
    tyvarbnd] _ [con :: Con
    con] []) -> do
    #else
        TyConI (DataD _ _ [tyvarbnd] [con] []) -> do
    #endif
          let (cons :: Name
    cons, elemTys :: [Type]
    elemTys) = case Con
    con of
                NormalC c :: Name
    c tys :: [BangType]
    tys -> (Name
    c, [BangType]
    tys [BangType] -> (BangType -> Type) -> [Type]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \(_, t :: Type
    t) -> Type
    t)
                RecC    c :: Name
    c tys :: [VarBangType]
    tys -> (Name
    c, [VarBangType]
    tys [VarBangType] -> (VarBangType -> Type) -> [Type]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \(_, _, t :: Type
    t) -> Type
    t)
                _ ->
                  [Char] -> (Name, [Type])
    forall a. HasCallStack => [Char] -> a
    error
                    ([Char] -> (Name, [Type])) -> [Char] -> (Name, [Type])
    forall a b. (a -> b) -> a -> b
    $  "Deriving requires non-GADT, non-infix data type/record!"
                    [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ " (Found: "
                    [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Con -> [Char]
    forall a. Show a => a -> [Char]
    show Con
    con
                    [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ")"
          let tyvar :: Name
    tyvar = case TyVarBndr
    tyvarbnd of
                PlainTV n :: Name
    n    -> Name
    n
                KindedTV n :: Name
    n _ -> Name
    n
          let fQ :: Name
    fQ       = [Char] -> Name
    mkName "f"
          let indexTys :: [(Int, Type)]
    indexTys = [Int] -> [Type] -> [(Int, Type)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [1 ..] [Type]
    elemTys
          let indexTysVars :: [(Type, Name, Name)]
    indexTysVars = [(Int, Type)]
    indexTys [(Int, Type)]
    -> ((Int, Type) -> (Type, Name, Name)) -> [(Type, Name, Name)]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \(i :: Int, ty :: Type
    ty) ->
                (Type
    ty, [Char] -> Name
    mkName ([Char] -> Name) -> [Char] -> Name
    forall a b. (a -> b) -> a -> b
    $ "x" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Int -> [Char]
    forall a. Show a => a -> [Char]
    show Int
    i, [Char] -> Name
    mkName ([Char] -> Name) -> [Char] -> Name
    forall a b. (a -> b) -> a -> b
    $ "y" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Int -> [Char]
    forall a. Show a => a -> [Char]
    show Int
    i)
          let dPat1 :: PatQ
    dPat1     = Name -> [PatQ] -> PatQ
    conP Name
    cons ([PatQ] -> PatQ) -> [PatQ] -> PatQ
    forall a b. (a -> b) -> a -> b
    $ [(Type, Name, Name)]
    indexTysVars [(Type, Name, Name)] -> ((Type, Name, Name) -> PatQ) -> [PatQ]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \(_, x :: Name
    x, _) -> Name -> PatQ
    varP Name
    x
          let dPat2 :: PatQ
    dPat2     = Name -> [PatQ] -> PatQ
    conP Name
    cons ([PatQ] -> PatQ) -> [PatQ] -> PatQ
    forall a b. (a -> b) -> a -> b
    $ [(Type, Name, Name)]
    indexTysVars [(Type, Name, Name)] -> ((Type, Name, Name) -> PatQ) -> [PatQ]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \(_, _, x :: Name
    x) -> Name -> PatQ
    varP Name
    x
          let pats :: [PatQ]
    pats      = [Name -> PatQ
    varP Name
    fQ, PatQ
    dPat1, PatQ
    dPat2]
          let
            params :: [ExpQ]
    params = [(Type, Name, Name)]
    indexTysVars [(Type, Name, Name)] -> ((Type, Name, Name) -> ExpQ) -> [ExpQ]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \(ty :: Type
    ty, x :: Name
    x, y :: Name
    y) -> case Type
    ty of
              AppT (VarT a1 :: Name
    a1) _ | Name
    a1 Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    tyvar -> [|$(varE fQ) $(varE x) $(varE y)|]
              AppT ConT{} (VarT a2 :: Name
    a2) | Name
    a2 Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    tyvar ->
                [|cZipWith $(varE fQ) $(varE x) $(varE y)|]
              _ ->
                [Char] -> ExpQ
    forall a. HasCallStack => [Char] -> a
    error
                  ([Char] -> ExpQ) -> [Char] -> ExpQ
    forall a b. (a -> b) -> a -> b
    $ "All constructor arguments must have either type k a for some a or C k for some C (with instance CZip C)!"
                  [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ " (Found: "
                  [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Type -> [Char]
    forall a. Show a => a -> [Char]
    show Type
    ty
                  [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ")"
          let body :: BodyQ
    body = ExpQ -> BodyQ
    normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
    forall a b. (a -> b) -> a -> b
    $ [ExpQ] -> ExpQ
    appsE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
    forall a b. (a -> b) -> a -> b
    $ Name -> ExpQ
    conE Name
    cons ExpQ -> [ExpQ] -> [ExpQ]
    forall a. a -> [a] -> [a]
    : [ExpQ]
    params
          let funQ :: DecQ
    funQ = Name -> [ClauseQ] -> DecQ
    funD 'cZipWith [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
    clause [PatQ]
    pats BodyQ
    body []]
          [DecQ] -> DecsQ
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence [CxtQ -> TypeQ -> [DecQ] -> DecQ
    instanceD ([TypeQ] -> CxtQ
    cxt []) [t|CZipWith $(conT name)|] [DecQ
    funQ]]
        TyConI (DataD{}) ->
          [Char] -> DecsQ
    forall a. HasCallStack => [Char] -> a
    error
            ([Char] -> DecsQ) -> [Char] -> DecsQ
    forall a b. (a -> b) -> a -> b
    $  "datatype must have kind (* -> *) -> *!"
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ " (Found: "
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Info -> [Char]
    forall a. Show a => a -> [Char]
    show Info
    info
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ")"
        _ ->
          [Char] -> DecsQ
    forall a. HasCallStack => [Char] -> a
    error
            ([Char] -> DecsQ) -> [Char] -> DecsQ
    forall a b. (a -> b) -> a -> b
    $  "name does not refer to a datatype!"
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ " (Found: "
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Info -> [Char]
    forall a. Show a => a -> [Char]
    show Info
    info
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ")"

    -- | Derives a 'CZipWithM' instance for a datatype of kind @(* -> *) -> *@.
    --
    -- Requires that for this datatype (we shall call its argument @f :: * -> *@ here)
    --
    -- * there is exactly one constructor;
    -- * all fields in the one constructor are either of the form @f x@ for some
    --   @x@ or of the form @X f@ for some type @X@ where there is an
    --   @instance CZipWithM X@.
    --
    -- For example, the following would be valid usage:
    --
    -- @
    -- data A f = A
    --   { a_str  :: f String
    --   , a_bool :: f Bool
    --   }
    --
    -- data B f = B
    --   { b_int   :: f Int
    --   , b_float :: f Float
    --   , b_a     :: A f
    --   }
    --
    -- deriveCZipWithM ''A
    -- deriveCZipWithM ''B
    -- @
    --
    -- This produces the following instances:
    --
    -- @
    -- instance CZipWithM A where
    --   cZipWithM f (A x1 x2) (A y1 y2) = A \<$\> f x1 y1 \<*\> f x2 y2
    --
    -- instance CZipWith B where
    --   cZipWithM f (B x1 x2 x3) (B y1 y2 y3) =
    --     B \<$\> f x1 y1 \<*\> f x2 y2 \<*\> cZipWithM f x3 y3
    -- @
    deriveCZipWithM :: Name -> DecsQ
    deriveCZipWithM :: Name -> DecsQ
    deriveCZipWithM name :: Name
    name = do
      Info
    info <- Name -> Q Info
    reify Name
    name
      case Info
    info of
    #if MIN_VERSION_template_haskell(2,11,0)
        TyConI (DataD _ _ [tyvarbnd :: TyVarBndr
    tyvarbnd] _ [con :: Con
    con] []) -> do
    #else
        TyConI (DataD _ _ [tyvarbnd] [con] []) -> do
    #endif
          let (cons :: Name
    cons, elemTys :: [Type]
    elemTys) = case Con
    con of
                NormalC c :: Name
    c tys :: [BangType]
    tys -> (Name
    c, [BangType]
    tys [BangType] -> (BangType -> Type) -> [Type]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \(_, t :: Type
    t) -> Type
    t)
                RecC    c :: Name
    c tys :: [VarBangType]
    tys -> (Name
    c, [VarBangType]
    tys [VarBangType] -> (VarBangType -> Type) -> [Type]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \(_, _, t :: Type
    t) -> Type
    t)
                _ ->
                  [Char] -> (Name, [Type])
    forall a. HasCallStack => [Char] -> a
    error
                    ([Char] -> (Name, [Type])) -> [Char] -> (Name, [Type])
    forall a b. (a -> b) -> a -> b
    $  "Deriving requires non-GADT, non-infix data type/record!"
                    [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ " (Found: "
                    [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Con -> [Char]
    forall a. Show a => a -> [Char]
    show Con
    con
                    [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ")"
          let tyvar :: Name
    tyvar = case TyVarBndr
    tyvarbnd of
                PlainTV n :: Name
    n    -> Name
    n
                KindedTV n :: Name
    n _ -> Name
    n
          let fQ :: Name
    fQ       = [Char] -> Name
    mkName "f"
          let indexTys :: [(Int, Type)]
    indexTys = [Int] -> [Type] -> [(Int, Type)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [1 ..] [Type]
    elemTys
          let indexTysVars :: [(Type, Name, Name)]
    indexTysVars = [(Int, Type)]
    indexTys [(Int, Type)]
    -> ((Int, Type) -> (Type, Name, Name)) -> [(Type, Name, Name)]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \(i :: Int, ty :: Type
    ty) ->
                (Type
    ty, [Char] -> Name
    mkName ([Char] -> Name) -> [Char] -> Name
    forall a b. (a -> b) -> a -> b
    $ "x" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Int -> [Char]
    forall a. Show a => a -> [Char]
    show Int
    i, [Char] -> Name
    mkName ([Char] -> Name) -> [Char] -> Name
    forall a b. (a -> b) -> a -> b
    $ "y" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Int -> [Char]
    forall a. Show a => a -> [Char]
    show Int
    i)
          let dPat1 :: PatQ
    dPat1     = Name -> [PatQ] -> PatQ
    conP Name
    cons ([PatQ] -> PatQ) -> [PatQ] -> PatQ
    forall a b. (a -> b) -> a -> b
    $ [(Type, Name, Name)]
    indexTysVars [(Type, Name, Name)] -> ((Type, Name, Name) -> PatQ) -> [PatQ]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \(_, x :: Name
    x, _) -> Name -> PatQ
    varP Name
    x
          let dPat2 :: PatQ
    dPat2     = Name -> [PatQ] -> PatQ
    conP Name
    cons ([PatQ] -> PatQ) -> [PatQ] -> PatQ
    forall a b. (a -> b) -> a -> b
    $ [(Type, Name, Name)]
    indexTysVars [(Type, Name, Name)] -> ((Type, Name, Name) -> PatQ) -> [PatQ]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \(_, _, x :: Name
    x) -> Name -> PatQ
    varP Name
    x
          let pats :: [PatQ]
    pats      = [Name -> PatQ
    varP Name
    fQ, PatQ
    dPat1, PatQ
    dPat2]
          let
            params :: [ExpQ]
    params = [(Type, Name, Name)]
    indexTysVars [(Type, Name, Name)] -> ((Type, Name, Name) -> ExpQ) -> [ExpQ]
    forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
    <&> \(ty :: Type
    ty, x :: Name
    x, y :: Name
    y) -> case Type
    ty of
              AppT (VarT a1 :: Name
    a1) _ | Name
    a1 Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    tyvar -> [|$(varE fQ) $(varE x) $(varE y)|]
              AppT ConT{} (VarT a2 :: Name
    a2) | Name
    a2 Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    tyvar ->
                [|cZipWithM $(varE fQ) $(varE x) $(varE y)|]
              _ ->
                [Char] -> ExpQ
    forall a. HasCallStack => [Char] -> a
    error
                  ([Char] -> ExpQ) -> [Char] -> ExpQ
    forall a b. (a -> b) -> a -> b
    $ "All constructor arguments must have either type k a for some a or C k for some C (with instance CZip C)!"
                  [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ " (Found: "
                  [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Type -> [Char]
    forall a. Show a => a -> [Char]
    show Type
    ty
                  [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ")"
          let body :: BodyQ
    body = ExpQ -> BodyQ
    normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
    forall a b. (a -> b) -> a -> b
    $ case [ExpQ]
    params of
                [] -> [|pure $(conE cons)|]
                (p1 :: ExpQ
    p1:pr :: [ExpQ]
    pr) -> (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl (\x :: ExpQ
    x p :: ExpQ
    p -> [|$x <*> $p|]) [|$(conE cons) <$> $p1|] [ExpQ]
    pr
          let funQ :: DecQ
    funQ = Name -> [ClauseQ] -> DecQ
    funD 'cZipWithM [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
    clause [PatQ]
    pats BodyQ
    body []]
          [DecQ] -> DecsQ
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence [CxtQ -> TypeQ -> [DecQ] -> DecQ
    instanceD ([TypeQ] -> CxtQ
    cxt []) [t|CZipWithM $(conT name)|] [DecQ
    funQ]]
        TyConI (DataD{}) ->
          [Char] -> DecsQ
    forall a. HasCallStack => [Char] -> a
    error
            ([Char] -> DecsQ) -> [Char] -> DecsQ
    forall a b. (a -> b) -> a -> b
    $  "datatype must have kind (* -> *) -> *!"
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ " (Found: "
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Info -> [Char]
    forall a. Show a => a -> [Char]
    show Info
    info
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ")"
        _ ->
          [Char] -> DecsQ
    forall a. HasCallStack => [Char] -> a
    error
            ([Char] -> DecsQ) -> [Char] -> DecsQ
    forall a b. (a -> b) -> a -> b
    $  "name does not refer to a datatype!"
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ " (Found: "
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Info -> [Char]
    forall a. Show a => a -> [Char]
    show Info
    info
            [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ")"

    -- local utility, not worth an extra dependency
    (<&>) :: Functor f => f a -> (a -> b) -> f b
    <&> :: f a -> (a -> b) -> f b
    (<&>) = ((a -> b) -> f a -> f b) -> f a -> (a -> b) -> f b
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (a -> b) -> f a -> f b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap