{-# 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 (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
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
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]
")"
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]
")"
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]
")"
(<&>) :: 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