derive-lifted-instances 0 → 0.1

raw patch · 4 files changed

+115/−27 lines, 4 filesdep +bifunctorsPVP ok

version bump matches the API change (PVP)

Dependencies added: bifunctors

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−2
• Data/DeriveLiftedInstances.hs +72/−19
• derive-lifted-instances.cabal +2/−1
• examples/Test.hs +32/−5

@@ -1,4 +1,11 @@-# Changelog+Changelog+========= -## v0 2020-06-20+v0.1 2020-06-22+---------------+  - Generalize `tupleDeriv` to `biapDeriv`+  - Generalize `unitDeriv` to `monoidDeriv`++v0 2020-06-20+-------------   - First release

@@ -17,7 +17,7 @@   idDeriv, newtypeDeriv, isoDeriv,   -- * Derivators for algebraic classes   -- $algebraic-classes-  apDeriv, tupleDeriv, unitDeriv,+  recordDeriv, apDeriv, biapDeriv, monoidDeriv,   showDeriv, ShowsPrec(..),   -- * Creating derivators   Derivator(..)@@ -25,8 +25,9 @@  import Language.Haskell.TH import Data.DeriveLiftedInstances.Internal-import Control.Arrow ((***)) import Control.Applicative (liftA2)+import Control.Monad (zipWithM)+import Data.Biapplicative  -- $algebraic-classes -- Algebraic classes are type classes where all the methods return a value of the same type, which is also the class parameter.@@ -42,7 +43,7 @@ -- [10, 20, 15, 30] -- @ apDeriv :: Derivator -> Derivator-apDeriv deriv = deriv {+apDeriv deriv = Derivator {   res = \v -> [| fmap (\w -> $(res deriv [| w |])) $v |],   op  = \nm o -> [| pure $(op deriv nm o) |],   arg = \ty e -> [| pure $(arg deriv ty e) |],@@ -51,31 +52,34 @@   ap  = \f a -> [| liftA2 (\g b -> $(ap deriv [| g |] [| b |])) $f $a |] } --- | Given how to derive an instance for @a@ and @b@, `tupleDeriv` creates a `Derivator` for @(a, b)@.+-- | 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` (`tupleDeriv` `idDeriv` `idDeriv`) [t| forall a b. (`Num` a, `Num` b) => `Num` (a, b) |]+-- `deriveInstance` (`biapDeriv` `idDeriv` `idDeriv`) [t| forall a b. (`Num` a, `Num` b) => `Num` (a, b) |] -- -- > (2, 3) `*` (5, 10) -- (10, 30) -- @-tupleDeriv :: Derivator -> Derivator -> Derivator-tupleDeriv l r = idDeriv {-  res = \e -> [| ((\w -> $(res l [| w |])) *** (\w -> $(res r [| w |]))) $e |],-  op  = \nm o -> [| ($(op l nm o), $(op r nm o)) |],-  arg = \ty e -> [| ($(arg l ty e), $(arg r ty e)) |],+biapDeriv :: Derivator -> Derivator -> Derivator+biapDeriv l r = Derivator {+  res = \e -> [| bimap (\w -> $(res l [| w |])) (\w -> $(res r [| w |])) $e |],+  op  = \nm o -> [| bipure $(op l nm o) $(op r nm o) |],+  arg = \ty e -> [| bipure $(arg l ty e) $(arg r ty e) |],   var = \fold v ->-    [| ( $(var l fold [| $(fold [| fmap |] [| fst |]) $v |])-       , $(var r fold [| $(fold [| fmap |] [| snd |]) $v |])-       ) |],-  ap  = \f a  -> [| case ($f, $a) of ((g, h), (b, c)) -> ($(ap l [| g |] [| b |]), $(ap r [| h |] [| c |])) |]+    [| bimap (\w -> $(var l fold [| w |])) (\w -> $(var r fold [| w |]))+       ($(fold [| traverseBia |] [| id |]) $v) |],+  ap  = \f a -> [| biliftA2 (\g b -> $(ap l [| g |] [| b |])) (\g b -> $(ap r [| g |] [| b |])) $f $a |] } --- | A `Derivator` for @()@.-unitDeriv :: Derivator-unitDeriv = idDeriv {-  op = \_ _ -> [| () |],-  ap = const+-- | 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 = idDeriv {+  op  = \_ _ -> [| mempty |],+  arg = \_ _ -> [| mempty |],+  var = \fold v -> [| ($(fold [| foldMap |] [| id |]) $v) |],+  ap  = \f a -> [| $f <> $a |] }  -- | Given how to derive an instance for @a@, and the names of a newtype wrapper around @a@,@@ -109,6 +113,55 @@   res = \v -> [| $mk $(res deriv v) |],   var = \fold v -> var deriv 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 => Test (Rec f) |]+-- @+--+-- @+-- tripleDeriv deriv1 deriv2 deriv3 =+--   recordDeriv [| (,,) |]+--     [ ([| fst3 |], deriv1)+--     , ([| snd3 |], deriv2)+--     , ([| thd3 |], deriv3) ]+-- @+recordDeriv :: Q Exp -> [(Q Exp, Derivator)] -> Derivator+recordDeriv mk flds = Derivator {+  res = \vs -> do vnms <- vars; [| case $vs of $(pat vnms) -> $(exps vnms >>= foldl (\f v -> [| $f $(pure v) |]) mk) |],+  op  = \nm o -> tup $ traverse (\(_, d) -> op d nm o) flds,+  arg = \ty e -> tup $ traverse (\(_, d) -> arg d ty e) flds,+  var = \fold v -> tup $ traverse (\(fld, d) -> var d fold [| $(fold [| fmap |] fld) $v |]) flds,+  ap  = \fs as -> do+    fnms <- funs+    vnms <- 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 = fmap (TupE . fmap Just)+    pat :: [Name] -> Q Pat+    pat = pure . TupP . fmap VarP+    ex :: Name -> Q Exp+    ex = pure . VarE+    exps :: [Name] -> Q [Exp]+    exps = traverse ex+    vars :: Q [Name]+    vars = names "a"+    funs :: Q [Name]+    funs = names "f"+    names :: String -> Q [Name]+    names s = traverse (const (newName s)) flds++  deriveInstance showDeriv [t| Bounded ShowsPrec |] deriveInstance showDeriv [t| Num ShowsPrec |]

@@ -1,5 +1,5 @@ name:                derive-lifted-instances-version:             0+version:             0.1 synopsis:            Derive class instances though various kinds of lifting description:         Helper functions to use Template Haskell for generating class instances. homepage:            https://github.com/sjoerdvisscher/derive-lifted-instances@@ -25,6 +25,7 @@   build-depends:       base >= 4.13 && < 4.15     , template-haskell >= 2.15 && < 2.17+    , bifunctors >= 5.5.7 && < 6    default-language:     Haskell2010

@@ -1,3 +1,5 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-}@@ -16,20 +18,28 @@   op1 i is = i + sum is   op2 = sum . fmap sum +data Rec f = Rec { getUnit :: f (), getInt :: f Int }+deriveInstance (recordDeriv [| Rec |]+    [ ([| getUnit |], apDeriv monoidDeriv)+    , ([| getInt |], apDeriv idDeriv)+    ]) [t| forall f. Applicative f => Test (Rec f) |]+ newtype X = X { unX :: Int } deriving Show mkX :: Int -> X mkX = X . (`mod` 10)+deriveInstance (isoDeriv [| mkX |] [| unX |] idDeriv) [t| Num X |] deriveInstance (isoDeriv [| mkX |] [| unX |] idDeriv) [t| Test X |] deriveInstance (isoDeriv [| mkX |] [| unX |] idDeriv) [t| Eq X |] deriveInstance (isoDeriv [| mkX |] [| unX |] idDeriv) [t| Ord X |]-deriveInstance (isoDeriv [| mkX |] [| unX |] idDeriv) [t| Num X |]  deriveInstance showDeriv [t| Test ShowsPrec |]-deriveInstance unitDeriv [t| Test () |]+deriveInstance monoidDeriv [t| Test () |] deriveInstance (apDeriv idDeriv) [t| forall a. Test a => Test [a] |]-deriveInstance (tupleDeriv idDeriv idDeriv) [t| forall a b. (Test a, Test b) => Test (a, b) |]+deriveInstance (biapDeriv idDeriv idDeriv) [t| forall a b. (Test a, Test b) => Test (a, b) |] -- deriveInstance (newtypeDeriv 'Identity 'runIdentity idDeriv) [t| forall a. Test a => Test (Identity a) |] +deriveInstance (apDeriv monoidDeriv) [t| forall a. Monoid a => Test (IO a) |]+ newtype Ap f a = Ap { getAp :: f a } deriving Show deriveInstance (newtypeDeriv 'Ap 'getAp (apDeriv idDeriv)) [t| forall f a. (Applicative f, Test a) => Test (Ap f a) |] @@ -37,8 +47,8 @@  newtype Id a = Id { runId :: a } deriveInstance (apDeriv (apDeriv (newtypeDeriv 'Id 'runId idDeriv))) [t| forall a. Test a => Test (() -> Identity (Id a)) |]-deriveInstance (apDeriv (tupleDeriv idDeriv idDeriv)) [t| forall a b. (Test a, Test b) => Test (() -> (a, b)) |]-deriveInstance (tupleDeriv (apDeriv idDeriv) (newtypeDeriv 'Id 'runId idDeriv)) [t| forall a b. (Test a, Test b) => Test (() -> a, Id b) |]+deriveInstance (apDeriv (biapDeriv idDeriv idDeriv)) [t| forall a b. (Test a, Test b) => Test (() -> (a, b)) |]+deriveInstance (biapDeriv (apDeriv idDeriv) (newtypeDeriv 'Id 'runId idDeriv)) [t| forall a b. (Test a, Test b) => Test (() -> a, Id b) |]  class Test1 f where   hop0 :: f a@@ -54,3 +64,20 @@ deriveInstance (newtypeDeriv 'Ap 'getAp idDeriv) [t| forall f. Functor f => Functor (Ap f) |] deriveInstance (newtypeDeriv 'Ap 'getAp idDeriv) [t| forall f. Applicative f => Applicative (Ap f) |] deriveInstance (newtypeDeriv 'Ap 'getAp idDeriv) [t| forall f. Monad f => Monad (Ap f) |]++class Cotest a where+  co0 :: a -> Int+  co1 :: Int -> a -> a+  co2 :: a -> [[a]]++instance (Cotest a, Cotest b) => Cotest (Either a b) where+  co0 a = either co0 co0 a+  co1 i a = either (Left . co1 i) (Right . co1 i) a+  co2 a = either (fmap (fmap Left) . co2) (fmap (fmap Right) . co2) a++data Cofree c b where+  Cofree :: c a => (a -> b) -> a -> Cofree c b+instance Cotest (Cofree Cotest a) where+  co0 (Cofree _ a) = co0 a+  co1 i (Cofree k a) = Cofree k (co1 i a)+  co2 (Cofree k a) = fmap (fmap (Cofree k)) (co2 a)