{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.DeriveLiftedInstances (
deriveInstance,
idDeriv, newtypeDeriv, isoDeriv,
apDeriv, tupleDeriv, unitDeriv,
showDeriv, ShowsPrec(..),
Derivator(..)
) where
import Language.Haskell.TH
import Data.DeriveLiftedInstances.Internal
import Control.Arrow ((***))
import Control.Applicative (liftA2)
apDeriv :: Derivator -> Derivator
apDeriv :: Derivator -> Derivator
apDeriv Derivator
deriv = Derivator
deriv {
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 |]
}
tupleDeriv :: Derivator -> Derivator -> Derivator
tupleDeriv :: Derivator -> Derivator -> Derivator
tupleDeriv Derivator
l Derivator
r = Derivator
idDeriv {
res :: Q Exp -> Q Exp
res = \Q Exp
e -> [| ((\w -> $(res l [| w |])) *** (\w -> $(res r [| w |]))) $e |],
op :: Name -> Q Exp -> Q Exp
op = \Name
nm Q Exp
o -> [| ($(op l nm o), $(op r nm o)) |],
arg :: Type -> Q Exp -> Q Exp
arg = \Type
ty Q Exp
e -> [| ($(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 ->
[| ( $(var l fold [| $(fold [| fmap |] [| fst |]) $v |])
, $(var r fold [| $(fold [| fmap |] [| snd |]) $v |])
) |],
ap :: Q Exp -> Q Exp -> Q Exp
ap = \Q Exp
f Q Exp
a -> [| case ($f, $a) of ((g, h), (b, c)) -> ($(ap l [| g |] [| b |]), $(ap r [| h |] [| c |])) |]
}
unitDeriv :: Derivator
unitDeriv :: Derivator
unitDeriv = Derivator
idDeriv {
op :: Name -> Q Exp -> Q Exp
op = \Name
_ Q Exp
_ -> [| () |],
ap :: Q Exp -> Q Exp -> Q Exp
ap = Q Exp -> Q Exp -> Q Exp
forall a b. a -> b -> a
const
}
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 |]
}
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 |]