{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DefaultSignatures #-}
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)
class CPointed c where
cPoint :: (forall a . f a) -> c f
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
class CZipWith (k :: (Type -> Type) -> Type) where
cZipWith :: (forall a . g a -> h a -> i a) -> k g -> k h -> k i
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} {k2} (f :: k1 -> *) (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
cSequence :: Applicative m => CZipWithM c => (c (Compose m f)) -> m (c f)
cSequence :: forall (m :: * -> *) (c :: (* -> *) -> *) (f :: * -> *).
(Applicative m, CZipWithM c) =>
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} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose
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 Name
n ()
_ -> Name
n
KindedTV Name
n ()
_ Kind
_ -> Name
n
#else
PlainTV n -> n
KindedTV n _ -> n
#endif
let fQ :: Name
fQ = [Char] -> Name
mkName [Char]
"f"
let pats :: [Q Pat]
pats = [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
fQ]
let
params :: [Q Exp]
params = Cxt
elemTys Cxt -> (Kind -> Q Exp) -> [Q Exp]
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 -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
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] -> Q Exp
forall a. HasCallStack => [Char] -> a
error
([Char] -> Q Exp) -> [Char] -> Q Exp
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 :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cons Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [Q Exp]
params
let funQ :: Q Dec
funQ = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'cPoint [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
pats Q Body
body []]
[Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Cxt -> Q Kind -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Kind -> [m Dec] -> m Dec
instanceD ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt []) [t|CPointed $(conT name)|] [Q Dec
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]
")"
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 Name
n ()
_ -> Name
n
KindedTV Name
n ()
_ Kind
_ -> Name
n
#else
PlainTV n -> n
KindedTV n _ -> 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
<&> \(Int
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 :: Q Pat
dPat1 = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cons ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ [(Kind, Name, Name)]
indexTysVars [(Kind, Name, Name)] -> ((Kind, Name, Name) -> Q Pat) -> [Q Pat]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Kind
_, Name
x, Name
_) -> Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x
let dPat2 :: Q Pat
dPat2 = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cons ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ [(Kind, Name, Name)]
indexTysVars [(Kind, Name, Name)] -> ((Kind, Name, Name) -> Q Pat) -> [Q Pat]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Kind
_, Name
_, Name
x) -> Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x
let pats :: [Q Pat]
pats = [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
fQ, Q Pat
dPat1, Q Pat
dPat2]
let
params :: [Q Exp]
params = [(Kind, Name, Name)]
indexTysVars [(Kind, Name, Name)] -> ((Kind, Name, Name) -> Q Exp) -> [Q Exp]
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] -> Q Exp
forall a. HasCallStack => [Char] -> a
error
([Char] -> Q Exp) -> [Char] -> Q Exp
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 :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cons Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [Q Exp]
params
let funQ :: Q Dec
funQ = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'cZipWith [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
pats Q Body
body []]
[Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Cxt -> Q Kind -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Kind -> [m Dec] -> m Dec
instanceD ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt []) [t|CZipWith $(conT name)|] [Q Dec
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]
")"
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 Name
n ()
_ -> Name
n
KindedTV Name
n ()
_ Kind
_ -> Name
n
#else
PlainTV n -> n
KindedTV n _ -> 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
<&> \(Int
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 :: Q Pat
dPat1 = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cons ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ [(Kind, Name, Name)]
indexTysVars [(Kind, Name, Name)] -> ((Kind, Name, Name) -> Q Pat) -> [Q Pat]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Kind
_, Name
x, Name
_) -> Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x
let dPat2 :: Q Pat
dPat2 = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cons ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ [(Kind, Name, Name)]
indexTysVars [(Kind, Name, Name)] -> ((Kind, Name, Name) -> Q Pat) -> [Q Pat]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Kind
_, Name
_, Name
x) -> Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x
let pats :: [Q Pat]
pats = [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
fQ, Q Pat
dPat1, Q Pat
dPat2]
let
params :: [Q Exp]
params = [(Kind, Name, Name)]
indexTysVars [(Kind, Name, Name)] -> ((Kind, Name, Name) -> Q Exp) -> [Q Exp]
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] -> Q Exp
forall a. HasCallStack => [Char] -> a
error
([Char] -> Q Exp) -> [Char] -> Q Exp
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 :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ case [Q Exp]
params of
[] -> [|pure $(conE cons)|]
(Q Exp
p1:[Q Exp]
pr) -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
x Q Exp
p -> [|$x <*> $p|]) [|$(conE cons) <$> $p1|] [Q Exp]
pr
let funQ :: Q Dec
funQ = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'cZipWithM [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
pats Q Body
body []]
[Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Cxt -> Q Kind -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Kind -> [m Dec] -> m Dec
instanceD ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt []) [t|CZipWithM $(conT name)|] [Q Dec
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]
")"
(<&>) :: Functor f => f a -> (a -> b) -> f b
<&> :: forall (f :: * -> *) a b. Functor f => 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