{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans -Wno-noncanonical-monoid-instances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.DeriveLiftedInstances
-- Copyright   :  (c) Sjoerd Visscher 2020
--
-- Maintainer  :  sjoerd@w3future.com
-- Stability   :  experimental
-- Portability :  non-portable
-----------------------------------------------------------------------------
module Data.DeriveLiftedInstances (
  -- * Deriving instances
  deriveInstance,
  idDeriv, newtypeDeriv, isoDeriv,
  recordDeriv, apDeriv, biapDeriv, monoidDeriv, monoidDerivBy,
  showDeriv, ShowsPrec(..),
  -- * Creating derivators
  Derivator(..)
) where

import Language.Haskell.TH
import Data.DeriveLiftedInstances.Internal

import Data.Biapplicative
import Data.Bifoldable

import Control.Monad (zipWithM)
import Data.Reflection

-- | Given how to derive an instance for @a@, `apDeriv` creates a `Derivator` for @f a@,
-- when @f@ is an instance of `Applicative`. Example:
--
-- @
-- `deriveInstance` (`apDeriv` `idDeriv`) [t| forall a. `Num` a => `Num` [a] |]
--
-- > [2, 3] `*` [5, 10]
-- [10, 20, 15, 30]
-- @
apDeriv :: Derivator -> Derivator
apDeriv :: Derivator -> Derivator
apDeriv Derivator
deriv = Derivator {
  res :: Q Exp -> Q Exp
res = \Q Exp
e -> [| fmap (\w -> $(Derivator -> Q Exp -> Q Exp
res Derivator
deriv [| w |])) $Q Exp
e |],
  cst :: Q Exp -> Q Exp
cst = \Q Exp
e -> [| foldMap (\w -> $(Derivator -> Q Exp -> Q Exp
cst Derivator
deriv [| w |])) $Q Exp
e |],
  eff :: Q Exp -> Q Exp
eff = \Q Exp
e -> [| traverse (\w -> $(Derivator -> Q Exp -> Q Exp
eff Derivator
deriv [| w |])) $Q Exp
e |],
  op :: Name -> Q Exp -> Q Exp
op  = \Name
nm Q Exp
o -> [| pure $(Derivator -> Name -> Q Exp -> Q Exp
op Derivator
deriv Name
nm Q Exp
o) |],
  arg :: Type -> Q Exp -> Q Exp
arg = \Type
ty Q Exp
e -> [| pure $(Derivator -> Type -> Q Exp -> Q Exp
arg Derivator
deriv Type
ty Q Exp
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 -> $(Derivator -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var Derivator
deriv Q Exp -> Q Exp -> Q Exp
fold [| w |])) ($(Q Exp -> Q Exp -> Q Exp
fold [| traverse |] [| id |]) $Q Exp
v) |],
  inp :: Q Pat -> Q Pat
inp = Q Pat -> Q Pat
forall a. a -> a
id,
  ap :: Q Exp -> Q Exp -> Q Exp
ap  = \Q Exp
f Q Exp
a -> [| liftA2 (\g b -> $(Derivator -> Q Exp -> Q Exp -> Q Exp
ap Derivator
deriv [| g |] [| b |])) $Q Exp
f $Q Exp
a |]
}

-- | Given how to derive an instance for @a@ and @b@, `biapDeriv` creates a `Derivator` for @f a b@,
-- when @f@ is an instance of `Biapplicative`. Example:
--
-- @
-- `deriveInstance` (`biapDeriv` `idDeriv` `idDeriv`) [t| forall a b. (`Num` a, `Num` b) => `Num` (a, b) |]
--
-- > (2, 3) `*` (5, 10)
-- (10, 30)
-- @
biapDeriv :: Derivator -> Derivator -> Derivator
biapDeriv :: Derivator -> Derivator -> Derivator
biapDeriv Derivator
l Derivator
r = Derivator {
  res :: Q Exp -> Q Exp
res = \Q Exp
e -> [| bimap (\w -> $(Derivator -> Q Exp -> Q Exp
res Derivator
l [| w |])) (\w -> $(Derivator -> Q Exp -> Q Exp
res Derivator
r [| w |])) $Q Exp
e |],
  cst :: Q Exp -> Q Exp
cst = \Q Exp
e -> [| bifoldMap (\w -> $(Derivator -> Q Exp -> Q Exp
cst Derivator
l [| w |])) (\w -> $(Derivator -> Q Exp -> Q Exp
cst Derivator
r [| w |])) $Q Exp
e |],
  eff :: Q Exp -> Q Exp
eff = \Q Exp
e -> [| bitraverse (\w -> $(Derivator -> Q Exp -> Q Exp
eff Derivator
l [| w |])) (\w -> $(Derivator -> Q Exp -> Q Exp
eff Derivator
r [| w |])) $Q Exp
e |],
  op :: Name -> Q Exp -> Q Exp
op  = \Name
nm Q Exp
o -> [| bipure $(Derivator -> Name -> Q Exp -> Q Exp
op Derivator
l Name
nm Q Exp
o) $(Derivator -> Name -> Q Exp -> Q Exp
op Derivator
r Name
nm Q Exp
o) |],
  arg :: Type -> Q Exp -> Q Exp
arg = \Type
ty Q Exp
e -> [| bipure $(Derivator -> Type -> Q Exp -> Q Exp
arg Derivator
l Type
ty Q Exp
e) $(Derivator -> Type -> Q Exp -> Q Exp
arg Derivator
r Type
ty Q Exp
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 -> $(Derivator -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var Derivator
l Q Exp -> Q Exp -> Q Exp
fold [| w |])) (\w -> $(Derivator -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var Derivator
r Q Exp -> Q Exp -> Q Exp
fold [| w |]))
       ($(Q Exp -> Q Exp -> Q Exp
fold [| traverseBia |] [| id |]) $Q Exp
v) |],
  inp :: Q Pat -> Q Pat
inp = Q Pat -> Q Pat
forall a. a -> a
id,
  ap :: Q Exp -> Q Exp -> Q Exp
ap  = \Q Exp
f Q Exp
a -> [| biliftA2 (\g b -> $(Derivator -> Q Exp -> Q Exp -> Q Exp
ap Derivator
l [| g |] [| b |])) (\g b -> $(Derivator -> Q Exp -> Q Exp -> Q Exp
ap Derivator
r [| g |] [| b |])) $Q Exp
f $Q Exp
a |]
}

-- | Create a `Derivator` for any `Monoid` @m@. This is a degenerate instance that only collects
-- all values of type @m@, and ignores the rest.
monoidDeriv :: Derivator
monoidDeriv :: Derivator
monoidDeriv = Q Exp -> Q Exp -> Derivator
monoidDerivBy [| (<>) |] [| mempty |]

-- | Create a `Derivator` for a monoid, given TH expressions to replace `(<>)` and `mempty` respectively. Example:
--
-- @monoidDerivBy [| (+) |] [| 0 |]@
monoidDerivBy :: Q Exp -> Q Exp -> Derivator
monoidDerivBy :: Q Exp -> Q Exp -> Derivator
monoidDerivBy Q Exp
append Q Exp
empty = Derivator
idDeriv {
  cst = const [| mempty |],
  eff = \Q Exp
e -> [| pure $Q Exp
e |],
  op  = \Name
_ Q Exp
_ -> Q Exp
empty,
  arg = \Type
_ Q Exp
_ -> Q Exp
empty,
  var = \Q Exp -> Q Exp -> Q Exp
fold Q Exp
v -> [| ($(Q Exp -> Q Exp -> Q Exp
fold [| foldMapBy $Q Exp
append $Q Exp
empty |] [| id |]) $Q Exp
v) |],
  ap  = \Q Exp
f Q Exp
a -> [| $Q Exp
append $Q Exp
f $Q Exp
a |]
}

-- | Given how to derive an instance for @a@, and the names of a newtype wrapper around @a@,
-- `newtypeDeriv` creates a `Derivator` for that newtype. Example:
--
-- @
-- newtype Ap f a = Ap { getAp :: f a } deriving Show
-- `deriveInstance` (`newtypeDeriv` 'Ap 'getAp `idDeriv`) [t| forall f. `Functor` f => `Functor` (Ap f) |]
--
-- > `fmap` (+1) (Ap [1,2,3])
-- Ap {getAp = [2,3,4]}
-- @
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 a. a -> Q a
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 a. a -> Q a
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)

-- | Given how to derive an instance for @a@, and two functions of type @a `->` b@ and @b `->` a@,
-- `isoDeriv` creates a `Derivator` for @b@. (Note that the 2 functions don't have to form
-- an isomorphism, but if they don't, the new instance can break the class laws.) Example:
--
-- @
-- newtype X = X { unX :: `Int` } deriving `Show`
-- mkX :: `Int` -> X
-- mkX i = X (`mod` i 10)
-- `deriveInstance` (isoDeriv [| mkX |] [| unX |] `idDeriv`) [t| `Num` X |]
--
-- > mkX 4 `^` 2
-- X {unX = 6}
-- @
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
v -> [| $Q Exp
mk $(Derivator -> Q Exp -> Q Exp
res Derivator
deriv Q Exp
v) |],
  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 [| $(Q Exp -> Q Exp -> Q Exp
fold [| fmap |] Q Exp
un) $Q Exp
v |]
}

-- | Given an n-ary function to @a@, and a list of pairs, consisting of a function from @a@ and a
-- `Derivator` for the codomain of that function, create a `Derivator` for @a@. Examples:
--
-- @
-- data Rec f = Rec { getUnit :: f (), getInt :: f Int }
-- deriveInstance
--   (recordDeriv [| Rec |]
--     [ ([| getUnit |], apDeriv monoidDeriv)
--     , ([| getInt  |], apDeriv idDeriv)
--     ])
--   [t| forall f. Applicative f => Num (Rec f) |]
-- @
--
-- @
-- tripleDeriv deriv1 deriv2 deriv3 =
--   recordDeriv [| (,,) |]
--     [ ([| fst3 |], deriv1)
--     , ([| snd3 |], deriv2)
--     , ([| thd3 |], deriv3) ]
-- @
recordDeriv :: Q Exp -> [(Q Exp, Derivator)] -> Derivator
recordDeriv :: Q Exp -> [(Q Exp, Derivator)] -> Derivator
recordDeriv Q Exp
mk [(Q Exp, Derivator)]
flds = Derivator {
  res :: Q Exp -> Q Exp
res = \Q Exp
vs -> do [Name]
vnms <- Q [Name]
vars; [| case $Q Exp
vs of $([Name] -> Q Pat
pat [Name]
vnms) -> $((Q Exp -> ((Q Exp, Derivator), Name) -> Q Exp)
-> Q Exp -> [((Q Exp, Derivator), Name)] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
f ((Q Exp
_, Derivator
d), Name
v) -> [| $Q Exp
f $(Derivator -> Q Exp -> Q Exp
res Derivator
d (Name -> Q Exp
ex Name
v)) |]) Q Exp
mk ([(Q Exp, Derivator)] -> [Name] -> [((Q Exp, Derivator), Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Q Exp, Derivator)]
flds [Name]
vnms)) |],
  cst :: Q Exp -> Q Exp
cst = \Q Exp
vs -> do [Name]
vnms <- Q [Name]
vars; [| case $Q Exp
vs of $([Name] -> Q Pat
pat [Name]
vnms) -> $((Q Exp -> ((Q Exp, Derivator), Name) -> Q Exp)
-> Q Exp -> [((Q Exp, Derivator), Name)] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
f ((Q Exp
_, Derivator
d), Name
v) -> [| $Q Exp
f <> $(Derivator -> Q Exp -> Q Exp
cst Derivator
d (Name -> Q Exp
ex Name
v)) |]) [| mempty |] ([(Q Exp, Derivator)] -> [Name] -> [((Q Exp, Derivator), Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Q Exp, Derivator)]
flds [Name]
vnms)) |],
  eff :: Q Exp -> Q Exp
eff = \Q Exp
vs -> do [Name]
vnms <- Q [Name]
vars; [| case $Q Exp
vs of $([Name] -> Q Pat
pat [Name]
vnms) -> $((Q Exp -> ((Q Exp, Derivator), Name) -> Q Exp)
-> Q Exp -> [((Q Exp, Derivator), Name)] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
f ((Q Exp
_, Derivator
d), Name
v) -> [| $Q Exp
f <*> $(Derivator -> Q Exp -> Q Exp
eff Derivator
d (Name -> Q Exp
ex Name
v)) |]) [| pure $Q Exp
mk |] ([(Q Exp, Derivator)] -> [Name] -> [((Q Exp, Derivator), Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Q Exp, Derivator)]
flds [Name]
vnms)) |],
  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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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 [| $(Q Exp -> Q Exp -> Q Exp
fold [| fmap |] Q Exp
fld) $Q Exp
v |]) [(Q Exp, Derivator)]
flds,
  inp :: Q Pat -> Q Pat
inp = Q Pat -> Q Pat
forall a. a -> a
id,
  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 ($Q Exp
fs, $Q Exp
as) of ($([Name] -> Q Pat
pat [Name]
fnms), $([Name] -> Q Pat
pat [Name]
vnms)) -> $(Q [Exp] -> Q Exp
tup (Q [Exp] -> Q Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ ((Q Exp, Derivator) -> (Name, Name) -> Q Exp)
-> [(Q Exp, Derivator)] -> [(Name, Name)] -> Q [Exp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\(Q Exp
_, Derivator
d) (Name
f, Name
v) -> Derivator -> Q Exp -> Q Exp -> Q Exp
ap Derivator
d (Name -> Q Exp
ex Name
f) (Name -> Q Exp
ex Name
v)) [(Q Exp, Derivator)]
flds ([Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fnms [Name]
vnms)) |]
}
  where
    tup :: Q [Exp] -> Q Exp
#if __GLASGOW_HASKELL__ >= 810
    tup :: Q [Exp] -> Q Exp
tup = ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> Q a -> Q b
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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Maybe Exp
forall a. a -> Maybe a
Just)
#else
    tup = fmap TupE
#endif
    pat :: [Name] -> Q Pat
    pat :: [Name] -> Q Pat
pat = Pat -> Q Pat
forall a. a -> Q a
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 a b. (a -> b) -> [a] -> [b]
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 a. a -> Q a
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
    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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Q Name -> (Q Exp, Derivator) -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
forall (m :: * -> *). Quote m => String -> m 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 |]