{-# 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 forall a. f a -> g a
f 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 (\f a
x f a
_ -> 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 forall a. f a -> m (g a)
f 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 (\f a
x f a
_ -> 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 forall a. f a -> g a -> m (h a)
f c f
k 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 (\f a
x 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 = do
  Info
info <- Name -> Q Info
reify Name
name
  case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr
_tyvarbnd] Maybe Kind
_ [Con
con] []) -> do
#else
    TyConI (DataD _ _ [_tyvarbnd] [con] []) -> do
#endif
      let (Name
cons, Cxt
elemTys) = case Con
con of
            NormalC Name
c [BangType]
tys -> (Name
c, [BangType]
tys [BangType] -> (BangType -> Kind) -> Cxt
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Bang
_, Kind
t) -> Kind
t)
            RecC    Name
c [VarBangType]
tys -> (Name
c, [VarBangType]
tys [VarBangType] -> (VarBangType -> Kind) -> Cxt
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Name
_, Bang
_, Kind
t) -> Kind
t)
            Con
_ ->
              [Char] -> (Name, Cxt)
forall a. HasCallStack => [Char] -> a
error
                ([Char] -> (Name, Cxt)) -> [Char] -> (Name, Cxt)
forall a b. (a -> b) -> a -> b
$  [Char]
"Deriving requires non-GADT, non-infix data type/record!"
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (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]
++ [Char]
")"
      let tyvar :: Name
tyvar = case TyVarBndr
_tyvarbnd of
#if MIN_VERSION_template_haskell(2,17,0)
            PlainTV n _    -> n
            KindedTV n _ _ -> n
#else
            PlainTV Name
n    -> Name
n
            KindedTV Name
n Kind
_ -> Name
n
#endif
      let fQ :: Name
fQ   = [Char] -> Name
mkName [Char]
"f"
      let pats :: [PatQ]
pats = [Name -> PatQ
varP Name
fQ]
      let
        params :: [ExpQ]
params = Cxt
elemTys Cxt -> (Kind -> ExpQ) -> [ExpQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Kind
ty -> case Kind
ty of
          AppT (VarT Name
a1) Kind
_ | Name
a1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
tyvar      -> Name -> ExpQ
varE Name
fQ
          AppT ConT{} (VarT Name
a2) | Name
a2 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
tyvar -> [|$(varE 'cPoint) $(varE fQ)|]
          Kind
_ ->
            [Char] -> ExpQ
forall a. HasCallStack => [Char] -> a
error
              ([Char] -> ExpQ) -> [Char] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Char]
"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]
++ [Char]
" (Found: "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Kind -> [Char]
forall a. Show a => a -> [Char]
show Kind
ty
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
      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
$  [Char]
"datatype must have kind (* -> *) -> *!"
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (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]
")"
    Info
_ ->
      [Char] -> DecsQ
forall a. HasCallStack => [Char] -> a
error
        ([Char] -> DecsQ) -> [Char] -> DecsQ
forall a b. (a -> b) -> a -> b
$  [Char]
"name does not refer to a datatype!"
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (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]
")"


-- | 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 ''An
-- 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 wheren
--   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 = do
  Info
info <- Name -> Q Info
reify Name
name
  case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr
tyvarbnd] Maybe Kind
_ [Con
con] []) -> do
#else
    TyConI (DataD _ _ [tyvarbnd] [con] []) -> do
#endif
      let (Name
cons, Cxt
elemTys) = case Con
con of
            NormalC Name
c [BangType]
tys -> (Name
c, [BangType]
tys [BangType] -> (BangType -> Kind) -> Cxt
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Bang
_, Kind
t) -> Kind
t)
            RecC    Name
c [VarBangType]
tys -> (Name
c, [VarBangType]
tys [VarBangType] -> (VarBangType -> Kind) -> Cxt
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Name
_, Bang
_, Kind
t) -> Kind
t)
            Con
_ ->
              [Char] -> (Name, Cxt)
forall a. HasCallStack => [Char] -> a
error
                ([Char] -> (Name, Cxt)) -> [Char] -> (Name, Cxt)
forall a b. (a -> b) -> a -> b
$  [Char]
"Deriving requires non-GADT, non-infix data type/record!"
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (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]
++ [Char]
")"
      let tyvar :: Name
tyvar = case TyVarBndr
tyvarbnd of
#if MIN_VERSION_template_haskell(2,17,0)
            PlainTV n _    -> n
            KindedTV n _ _ -> n
#else
            PlainTV Name
n    -> Name
n
            KindedTV Name
n Kind
_ -> Name
n
#endif
      let fQ :: Name
fQ       = [Char] -> Name
mkName [Char]
"f"
      let indexTys :: [(Int, Kind)]
indexTys = [Int] -> Cxt -> [(Int, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] Cxt
elemTys
      let indexTysVars :: [(Kind, Name, Name)]
indexTysVars = [(Int, Kind)]
indexTys [(Int, Kind)]
-> ((Int, Kind) -> (Kind, Name, Name)) -> [(Kind, Name, Name)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(i :: Int, Kind
ty) ->
            (Kind
ty, [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"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
$ [Char]
"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
$ [(Kind, Name, Name)]
indexTysVars [(Kind, Name, Name)] -> ((Kind, Name, Name) -> PatQ) -> [PatQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Kind
_, Name
x, Name
_) -> 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
$ [(Kind, Name, Name)]
indexTysVars [(Kind, Name, Name)] -> ((Kind, Name, Name) -> PatQ) -> [PatQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Kind
_, Name
_, Name
x) -> Name -> PatQ
varP Name
x
      let pats :: [PatQ]
pats      = [Name -> PatQ
varP Name
fQ, PatQ
dPat1, PatQ
dPat2]
      let
        params :: [ExpQ]
params = [(Kind, Name, Name)]
indexTysVars [(Kind, Name, Name)] -> ((Kind, Name, Name) -> ExpQ) -> [ExpQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Kind
ty, Name
x, Name
y) -> case Kind
ty of
          AppT (VarT Name
a1) Kind
_ | Name
a1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
tyvar -> [|$(varE fQ) $(varE x) $(varE y)|]
          AppT ConT{} (VarT Name
a2) | Name
a2 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
tyvar ->
            [|cZipWith $(varE fQ) $(varE x) $(varE y)|]
          Kind
_ ->
            [Char] -> ExpQ
forall a. HasCallStack => [Char] -> a
error
              ([Char] -> ExpQ) -> [Char] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Char]
"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]
++ [Char]
" (Found: "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Kind -> [Char]
forall a. Show a => a -> [Char]
show Kind
ty
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
      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
$  [Char]
"datatype must have kind (* -> *) -> *!"
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (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]
")"
    Info
_ ->
      [Char] -> DecsQ
forall a. HasCallStack => [Char] -> a
error
        ([Char] -> DecsQ) -> [Char] -> DecsQ
forall a b. (a -> b) -> a -> b
$  [Char]
"name does not refer to a datatype!"
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (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]
")"


-- | 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 = do
  Info
info <- Name -> Q Info
reify Name
name
  case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr
tyvarbnd] Maybe Kind
_ [Con
con] []) -> do
#else
    TyConI (DataD _ _ [tyvarbnd] [con] []) -> do
#endif
      let (Name
cons, Cxt
elemTys) = case Con
con of
            NormalC Name
c [BangType]
tys -> (Name
c, [BangType]
tys [BangType] -> (BangType -> Kind) -> Cxt
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Bang
_, Kind
t) -> Kind
t)
            RecC    Name
c [VarBangType]
tys -> (Name
c, [VarBangType]
tys [VarBangType] -> (VarBangType -> Kind) -> Cxt
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Name
_, Bang
_, Kind
t) -> Kind
t)
            Con
_ ->
              [Char] -> (Name, Cxt)
forall a. HasCallStack => [Char] -> a
error
                ([Char] -> (Name, Cxt)) -> [Char] -> (Name, Cxt)
forall a b. (a -> b) -> a -> b
$  [Char]
"Deriving requires non-GADT, non-infix data type/record!"
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (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]
++ [Char]
")"
      let tyvar :: Name
tyvar = case TyVarBndr
tyvarbnd of
#if MIN_VERSION_template_haskell(2,17,0)
            PlainTV n _    -> n
            KindedTV n _ _ -> n
#else
            PlainTV Name
n    -> Name
n
            KindedTV Name
n Kind
_ -> Name
n
#endif
      let fQ :: Name
fQ       = [Char] -> Name
mkName [Char]
"f"
      let indexTys :: [(Int, Kind)]
indexTys = [Int] -> Cxt -> [(Int, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] Cxt
elemTys
      let indexTysVars :: [(Kind, Name, Name)]
indexTysVars = [(Int, Kind)]
indexTys [(Int, Kind)]
-> ((Int, Kind) -> (Kind, Name, Name)) -> [(Kind, Name, Name)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(i :: Int, Kind
ty) ->
            (Kind
ty, [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"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
$ [Char]
"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
$ [(Kind, Name, Name)]
indexTysVars [(Kind, Name, Name)] -> ((Kind, Name, Name) -> PatQ) -> [PatQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Kind
_, Name
x, Name
_) -> 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
$ [(Kind, Name, Name)]
indexTysVars [(Kind, Name, Name)] -> ((Kind, Name, Name) -> PatQ) -> [PatQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Kind
_, Name
_, Name
x) -> Name -> PatQ
varP Name
x
      let pats :: [PatQ]
pats      = [Name -> PatQ
varP Name
fQ, PatQ
dPat1, PatQ
dPat2]
      let
        params :: [ExpQ]
params = [(Kind, Name, Name)]
indexTysVars [(Kind, Name, Name)] -> ((Kind, Name, Name) -> ExpQ) -> [ExpQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Kind
ty, Name
x, Name
y) -> case Kind
ty of
          AppT (VarT Name
a1) Kind
_ | Name
a1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
tyvar -> [|$(varE fQ) $(varE x) $(varE y)|]
          AppT ConT{} (VarT Name
a2) | Name
a2 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
tyvar ->
            [|cZipWithM $(varE fQ) $(varE x) $(varE y)|]
          Kind
_ ->
            [Char] -> ExpQ
forall a. HasCallStack => [Char] -> a
error
              ([Char] -> ExpQ) -> [Char] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Char]
"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]
++ [Char]
" (Found: "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Kind -> [Char]
forall a. Show a => a -> [Char]
show Kind
ty
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
      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)|]
            (ExpQ
p1:[ExpQ]
pr) -> (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
x 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
$  [Char]
"datatype must have kind (* -> *) -> *!"
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (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]
")"
    Info
_ ->
      [Char] -> DecsQ
forall a. HasCallStack => [Char] -> a
error
        ([Char] -> DecsQ) -> [Char] -> DecsQ
forall a b. (a -> b) -> a -> b
$  [Char]
"name does not refer to a datatype!"
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (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]
")"


-- 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