{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.DeriveLiftedInstances (
deriveInstance,
idDeriv, newtypeDeriv, isoDeriv,
recordDeriv, apDeriv, biapDeriv, monoidDeriv,
showDeriv, ShowsPrec(..),
Derivator(..)
) where
import Language.Haskell.TH
import Data.DeriveLiftedInstances.Internal
import Control.Applicative (liftA2)
import Control.Monad (zipWithM)
import Data.Biapplicative
apDeriv :: Derivator -> Derivator
apDeriv :: Derivator -> Derivator
apDeriv Derivator
deriv = Derivator :: (Q Exp -> Q Exp)
-> (Name -> Q Exp -> Q Exp)
-> (Type -> Q Exp -> Q Exp)
-> ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp)
-> (Q Exp -> Q Exp -> Q Exp)
-> Derivator
Derivator {
res :: Q Exp -> Q Exp
res = \Q Exp
v -> [| fmap (\w -> $(res deriv [| w |])) $v |],
op :: Name -> Q Exp -> Q Exp
op = \Name
nm Q Exp
o -> [| pure $(op deriv nm o) |],
arg :: Type -> Q Exp -> Q Exp
arg = \Type
ty Q Exp
e -> [| pure $(arg deriv ty e) |],
var :: (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var = \Q Exp -> Q Exp -> Q Exp
fold Q Exp
v ->
[| fmap (\w -> $(var deriv fold [| w |])) ($(fold [| traverse |] [| id |]) $v) |],
ap :: Q Exp -> Q Exp -> Q Exp
ap = \Q Exp
f Q Exp
a -> [| liftA2 (\g b -> $(ap deriv [| g |] [| b |])) $f $a |]
}
biapDeriv :: Derivator -> Derivator -> Derivator
biapDeriv :: Derivator -> Derivator -> Derivator
biapDeriv Derivator
l Derivator
r = Derivator :: (Q Exp -> Q Exp)
-> (Name -> Q Exp -> Q Exp)
-> (Type -> Q Exp -> Q Exp)
-> ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp)
-> (Q Exp -> Q Exp -> Q Exp)
-> Derivator
Derivator {
res :: Q Exp -> Q Exp
res = \Q Exp
e -> [| bimap (\w -> $(res l [| w |])) (\w -> $(res r [| w |])) $e |],
op :: Name -> Q Exp -> Q Exp
op = \Name
nm Q Exp
o -> [| bipure $(op l nm o) $(op r nm o) |],
arg :: Type -> Q Exp -> Q Exp
arg = \Type
ty Q Exp
e -> [| bipure $(arg l ty e) $(arg r ty e) |],
var :: (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var = \Q Exp -> Q Exp -> Q Exp
fold Q Exp
v ->
[| bimap (\w -> $(var l fold [| w |])) (\w -> $(var r fold [| w |]))
($(fold [| traverseBia |] [| id |]) $v) |],
ap :: Q Exp -> Q Exp -> Q Exp
ap = \Q Exp
f Q Exp
a -> [| biliftA2 (\g b -> $(ap l [| g |] [| b |])) (\g b -> $(ap r [| g |] [| b |])) $f $a |]
}
monoidDeriv :: Derivator
monoidDeriv :: Derivator
monoidDeriv = Derivator
idDeriv {
op :: Name -> Q Exp -> Q Exp
op = \Name
_ Q Exp
_ -> [| mempty |],
arg :: Type -> Q Exp -> Q Exp
arg = \Type
_ Q Exp
_ -> [| mempty |],
var :: (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var = \Q Exp -> Q Exp -> Q Exp
fold Q Exp
v -> [| ($(fold [| foldMap |] [| id |]) $v) |],
ap :: Q Exp -> Q Exp -> Q Exp
ap = \Q Exp
f Q Exp
a -> [| $f <> $a |]
}
newtypeDeriv :: Name -> Name -> Derivator -> Derivator
newtypeDeriv :: Name -> Name -> Derivator -> Derivator
newtypeDeriv Name
mk Name
un = Q Exp -> Q Exp -> Derivator -> Derivator
isoDeriv (Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
mk) (Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
un)
isoDeriv :: Q Exp -> Q Exp -> Derivator -> Derivator
isoDeriv :: Q Exp -> Q Exp -> Derivator -> Derivator
isoDeriv Q Exp
mk Q Exp
un Derivator
deriv = Derivator
deriv {
res :: Q Exp -> Q Exp
res = \Q Exp
v -> [| $mk $(res deriv v) |],
var :: (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var = \Q Exp -> Q Exp -> Q Exp
fold Q Exp
v -> Derivator -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var Derivator
deriv Q Exp -> Q Exp -> Q Exp
fold [| $(fold [| fmap |] un) $v |]
}
recordDeriv :: Q Exp -> [(Q Exp, Derivator)] -> Derivator
recordDeriv :: Q Exp -> [(Q Exp, Derivator)] -> Derivator
recordDeriv Q Exp
mk [(Q Exp, Derivator)]
flds = Derivator :: (Q Exp -> Q Exp)
-> (Name -> Q Exp -> Q Exp)
-> (Type -> Q Exp -> Q Exp)
-> ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp)
-> (Q Exp -> Q Exp -> Q Exp)
-> Derivator
Derivator {
res :: Q Exp -> Q Exp
res = \Q Exp
vs -> do [Name]
vnms <- Q [Name]
vars; [| case $vs of $(pat vnms) -> $(exps vnms >>= foldl (\f v -> [| $f $(pure v) |]) mk) |],
op :: Name -> Q Exp -> Q Exp
op = \Name
nm Q Exp
o -> Q [Exp] -> Q Exp
tup (Q [Exp] -> Q Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ ((Q Exp, Derivator) -> Q Exp) -> [(Q Exp, Derivator)] -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Q Exp
_, Derivator
d) -> Derivator -> Name -> Q Exp -> Q Exp
op Derivator
d Name
nm Q Exp
o) [(Q Exp, Derivator)]
flds,
arg :: Type -> Q Exp -> Q Exp
arg = \Type
ty Q Exp
e -> Q [Exp] -> Q Exp
tup (Q [Exp] -> Q Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ ((Q Exp, Derivator) -> Q Exp) -> [(Q Exp, Derivator)] -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Q Exp
_, Derivator
d) -> Derivator -> Type -> Q Exp -> Q Exp
arg Derivator
d Type
ty Q Exp
e) [(Q Exp, Derivator)]
flds,
var :: (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var = \Q Exp -> Q Exp -> Q Exp
fold Q Exp
v -> Q [Exp] -> Q Exp
tup (Q [Exp] -> Q Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ ((Q Exp, Derivator) -> Q Exp) -> [(Q Exp, Derivator)] -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Q Exp
fld, Derivator
d) -> Derivator -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var Derivator
d Q Exp -> Q Exp -> Q Exp
fold [| $(fold [| fmap |] fld) $v |]) [(Q Exp, Derivator)]
flds,
ap :: Q Exp -> Q Exp -> Q Exp
ap = \Q Exp
fs Q Exp
as -> do
[Name]
fnms <- Q [Name]
funs
[Name]
vnms <- Q [Name]
vars
[| case ($fs, $as) of ($(pat fnms), $(pat vnms)) -> $(tup $ zipWithM (\(_, d) (f, v) -> ap d (ex f) (ex v)) flds (zip fnms vnms)) |]
}
where
tup :: Q [Exp] -> Q Exp
tup :: Q [Exp] -> Q Exp
tup = ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Maybe Exp] -> Exp
TupE ([Maybe Exp] -> Exp) -> ([Exp] -> [Maybe Exp]) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Maybe Exp
forall a. a -> Maybe a
Just)
pat :: [Name] -> Q Pat
pat :: [Name] -> Q Pat
pat = Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> ([Name] -> Pat) -> [Name] -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat] -> Pat
TupP ([Pat] -> Pat) -> ([Name] -> [Pat]) -> [Name] -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP
ex :: Name -> Q Exp
ex :: Name -> Q Exp
ex = Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> (Name -> Exp) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE
exps :: [Name] -> Q [Exp]
exps :: [Name] -> Q [Exp]
exps = (Name -> Q Exp) -> [Name] -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> Q Exp
ex
vars :: Q [Name]
vars :: Q [Name]
vars = String -> Q [Name]
names String
"a"
funs :: Q [Name]
funs :: Q [Name]
funs = String -> Q [Name]
names String
"f"
names :: String -> Q [Name]
names :: String -> Q [Name]
names String
s = ((Q Exp, Derivator) -> Q Name) -> [(Q Exp, Derivator)] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Q Name -> (Q Exp, Derivator) -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
newName String
s)) [(Q Exp, Derivator)]
flds
deriveInstance showDeriv [t| Bounded ShowsPrec |]
deriveInstance showDeriv [t| Num ShowsPrec |]
deriveInstance showDeriv [t| Fractional ShowsPrec |]
deriveInstance showDeriv [t| Floating ShowsPrec |]
deriveInstance showDeriv [t| Semigroup ShowsPrec |]
deriveInstance showDeriv [t| Monoid ShowsPrec |]