{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- 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 Control.Applicative (liftA2)

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 :: (Q Exp -> Q Exp)
-> (Q Exp -> Q Exp)
-> (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 Pat -> Q Pat)
-> (Q Exp -> Q Exp -> Q Exp)
-> Derivator
Derivator {
  res :: Q Exp -> Q Exp
res = \Q Exp
e -> [| fmap (\w -> $(res deriv [| w |])) $e |],
  cst :: Q Exp -> Q Exp
cst = \Q Exp
e -> [| foldMap (\w -> $(cst deriv [| w |])) $e |],
  eff :: Q Exp -> Q Exp
eff = \Q Exp
e -> [| traverse (\w -> $(eff deriv [| w |])) $e |],
  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) |],
  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 -> $(ap deriv [| g |] [| b |])) $f $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 :: (Q Exp -> Q Exp)
-> (Q Exp -> Q Exp)
-> (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 Pat -> Q Pat)
-> (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 |],
  cst :: Q Exp -> Q Exp
cst = \Q Exp
e -> [| bifoldMap (\w -> $(cst l [| w |])) (\w -> $(cst r [| w |])) $e |],
  eff :: Q Exp -> Q Exp
eff = \Q Exp
e -> [| bitraverse (\w -> $(eff l [| w |])) (\w -> $(eff 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) |],
  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 -> $(ap l [| g |] [| b |])) (\g b -> $(ap r [| g |] [| b |])) $f $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 :: Q Exp -> Q Exp
cst = Q Exp -> Q Exp -> Q Exp
forall a b. a -> b -> a
const [| mempty |],
  eff :: Q Exp -> Q Exp
eff = \Q Exp
e -> [| pure $e |],
  op :: Name -> Q Exp -> Q Exp
op  = \Name
_ Q Exp
_ -> Q Exp
empty,
  arg :: Type -> Q Exp -> Q Exp
arg = \Type
_ Q Exp
_ -> Q Exp
empty,
  var :: (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var = \Q Exp -> Q Exp -> Q Exp
fold Q Exp
v -> [| ($(fold [| foldMapBy $append $empty |] [| id |]) $v) |],
  ap :: Q Exp -> Q Exp -> Q Exp
ap  = \Q Exp
f Q Exp
a -> [| $append $f $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 (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)

-- | 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 -> 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 |]
}

-- | 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 :: (Q Exp -> Q Exp)
-> (Q Exp -> Q Exp)
-> (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 Pat -> Q Pat)
-> (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) -> $(foldl (\f ((_, d), v) -> [| $f $(res d (ex v)) |]) mk (zip flds vnms)) |],
  cst :: Q Exp -> Q Exp
cst = \Q Exp
vs -> do [Name]
vnms <- Q [Name]
vars; [| case $vs of $(pat vnms) -> $(foldl (\f ((_, d), v) -> [| $f <> $(cst d (ex v)) |]) [| mempty |] (zip flds vnms)) |],
  eff :: Q Exp -> Q Exp
eff = \Q Exp
vs -> do [Name]
vnms <- Q [Name]
vars; [| case $vs of $(pat vnms) -> $(foldl (\f ((_, d), v) -> [| $f <*> $(eff d (ex v)) |]) [| pure $mk |] (zip flds 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)
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,
  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 ($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
#if __GLASGOW_HASKELL__ >= 810
    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)
#else
    tup = fmap TupE
#endif
    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
    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 |]