derive-lifted-instances 0.1.1 → 0.2

raw patch · 6 files changed

+95/−49 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• Data/DeriveLiftedInstances.hs +21/−12
• Data/DeriveLiftedInstances/Internal.hs +30/−29
• README.md +29/−0
• derive-lifted-instances.cabal +1/−1
• examples/Test.hs +9/−7

@@ -1,6 +1,11 @@ Changelog ========= +v0.2   2020-06-29+-----------------+  - Support deriving co- and dialgebraic classes with `cst` and `eff`+  - Support doing pattern matching for input variables with `inp`+ v0.1.1 2020-06-24 -----------------   - Add `monoidDerivBy`

@@ -14,10 +14,7 @@ module Data.DeriveLiftedInstances (   -- * Deriving instances   deriveInstance,-  -- * Derivators for any class   idDeriv, newtypeDeriv, isoDeriv,-  -- * Derivators for algebraic classes-  -- $algebraic-classes   recordDeriv, apDeriv, biapDeriv, monoidDeriv, monoidDerivBy,   showDeriv, ShowsPrec(..),   -- * Creating derivators@@ -26,14 +23,14 @@  import Language.Haskell.TH import Data.DeriveLiftedInstances.Internal+ import Control.Applicative (liftA2)-import Control.Monad (zipWithM)+ import Data.Biapplicative-import Data.Reflection+import Data.Bifoldable --- $algebraic-classes--- Algebraic classes are type classes where all the methods return a value of the same type, which is also the class parameter.--- Examples from base are `Num` and `Monoid`.+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:@@ -46,11 +43,14 @@ -- @ apDeriv :: Derivator -> Derivator apDeriv deriv = Derivator {-  res = \v -> [| fmap (\w -> $(res deriv [| w |])) $v |],+  res = \e -> [| fmap (\w -> $(res deriv [| w |])) $e |],+  cst = \e -> [| foldMap (\w -> $(cst deriv [| w |])) $e |],+  eff = \e -> [| traverse (\w -> $(eff deriv [| w |])) $e |],   op  = \nm o -> [| pure $(op deriv nm o) |],   arg = \ty e -> [| pure $(arg deriv ty e) |],   var = \fold v ->     [| fmap (\w -> $(var deriv fold [| w |])) ($(fold [| traverse |] [| id |]) $v) |],+  inp = id,   ap  = \f a -> [| liftA2 (\g b -> $(ap deriv [| g |] [| b |])) $f $a |] } @@ -66,11 +66,14 @@ biapDeriv :: Derivator -> Derivator -> Derivator biapDeriv l r = Derivator {   res = \e -> [| bimap (\w -> $(res l [| w |])) (\w -> $(res r [| w |])) $e |],+  cst = \e -> [| bifoldMap (\w -> $(cst l [| w |])) (\w -> $(cst r [| w |])) $e |],+  eff = \e -> [| bitraverse (\w -> $(eff l [| w |])) (\w -> $(eff 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 ->     [| bimap (\w -> $(var l fold [| w |])) (\w -> $(var r fold [| w |]))        ($(fold [| traverseBia |] [| id |]) $v) |],+  inp = id,   ap  = \f a -> [| biliftA2 (\g b -> $(ap l [| g |] [| b |])) (\g b -> $(ap r [| g |] [| b |])) $f $a |] } @@ -79,8 +82,13 @@ monoidDeriv :: Derivator monoidDeriv = 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 append empty = idDeriv {+  cst = const [| mempty |],+  eff = \e -> [| pure $e |],   op  = \_ _ -> empty,   arg = \_ _ -> empty,   var = \fold v -> [| ($(fold [| foldMapBy $append $empty |] [| id |]) $v) |],@@ -141,10 +149,13 @@ -- @ 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) |],+  res = \vs -> do vnms <- vars; [| case $vs of $(pat vnms) -> $(foldl (\f ((_, d), v) -> [| $f $(res d (ex v)) |]) mk (zip flds vnms)) |],+  cst = \vs -> do vnms <- vars; [| case $vs of $(pat vnms) -> $(foldl (\f ((_, d), v) -> [| $f <> $(cst d (ex v)) |]) [| mempty |] (zip flds vnms)) |],+  eff = \vs -> do vnms <- vars; [| case $vs of $(pat vnms) -> $(foldl (\f ((_, d), v) -> [| $f <*> $(eff d (ex v)) |]) [| pure $mk |] (zip flds vnms)) |],   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,+  inp = id,   ap  = \fs as -> do     fnms <- funs     vnms <- vars@@ -161,8 +172,6 @@     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]

@@ -30,8 +30,8 @@ -- @ -- meth0 :: a -- meth1 :: Int -> a--- meth2 :: a -> Either Bool a -> Int--- meth3 :: Maybe [a] -> a+-- meth2 :: a -> Either Bool a -> Sum Int+-- meth3 :: Maybe [a] -> IO a -- @ -- -- the resulting template haskell declarations are (pseudo code):@@ -39,36 +39,34 @@ -- @ -- meth0 = $res ($op "meth0" meth0) -- meth1 a = $res (($op "meth1" meth1) `$ap` ($arg Int a))--- meth2 v0 v1 = (($op "meth2" meth2) `$ap` ($var fold0 v0)) `$ap` ($var fold1 v1)---   where---     fold0 _ f = f---     fold1 map f = [| $map $f |]--- meth3 v2 = $res (($op "meth2" meth2) `$ap` ($var fold2 v2))---   where---     fold2 map f = [| $map ($map $f) |]+-- meth2 ($inp v0) ($inp v1) = $cst (($op "meth2" meth2) `$ap` ($var (`iterate` 0) v0)) `$ap` ($var (`iterate` 1) v1)+-- meth3 ($inp v2) = $eff (($op "meth2" meth2) `$ap` ($var (`iterate` 2) v2)) -- @ data Derivator = Derivator {   res :: Q Exp -> Q Exp, -- ^ Convert the result of the method+  cst :: Q Exp -> Q Exp, -- ^ Convert the result of the method if it is a constant+  eff :: Q Exp -> Q Exp, -- ^ Convert the result of the method if it has an effect   op  :: Name -> Q Exp -> Q Exp, -- ^ Convert the method (still unapplied to any arguments)   arg :: Type -> Q Exp -> Q Exp, -- ^ Convert an argument   var :: (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp, -- ^ Convert a variable+  inp :: Q Pat -> Q Pat, -- ^ Generate an input pattern for a variable   ap  :: Q Exp -> Q Exp -> Q Exp -- ^ Apply an argument or variable to the method }  varExp :: Name -> Q Exp varExp = pure . VarE -varPat :: Name -> Q Pat-varPat = pure . VarP- -- | The identity `Derivator`. Not useful on its own, but often used as input for other `Derivator`s. idDeriv :: Derivator idDeriv = Derivator {-  res  = id,-  op   = const id,-  arg  = const id,-  var  = const id,-  ap   = \f a -> [| $f $a |]+  res = id,+  cst = id,+  eff = id,+  op  = const id,+  arg = const id,+  var = const id,+  inp = id,+  ap  = \f a -> [| $f $a |] }  -- | Derive the instance with the given `Derivator` and the given instance head.@@ -85,26 +83,27 @@ deriveInstance deriv qtyp = do   typ <- qtyp   case typ of-    ForallT _ ctx (AppT (ConT className) typeName) ->-      deriveInstance' deriv ctx className typeName-    AppT (ConT className) typeName ->-      deriveInstance' deriv [] className typeName+    ForallT _ ctx (AppT ty typeName) ->+      deriveInstance' deriv ctx (className ty) (AppT ty typeName)+    AppT ty typeName ->+      deriveInstance' deriv [] (className ty) (AppT ty typeName)     _ -> fail $ "No support for type: " ++ show typ  deriveInstance' :: Derivator -> Cxt -> Name -> Type -> Q [Dec]-deriveInstance' deriv ctx className typeName = do-  ClassI (ClassD _ _ [KindedTV tvn _] _ decs) _ <- reify className+deriveInstance' deriv ctx clsName typ = do+  ClassI (ClassD _ _ tvs _ decs) _ <- reify clsName+  let KindedTV tvn _ = last tvs   impl <- for decs $ \case     SigD nm tp -> do       dec <- reify nm       case dec of         ClassOpI{} -> do           (argNames, body) <- buildOperation deriv tvn tp (op deriv nm (varExp nm))-          let args = map (\argName -> if contains argName body then VarP argName else WildP) argNames+          args <- traverse (\argName -> if contains argName body then (if nameBase argName == "var" then inp deriv else id) . pure . VarP $ argName else pure WildP) argNames           pure $ Just $ FunD nm [Clause args (NormalB body) []]         _ -> fail $ "No support for declaration: " ++ show dec     _ -> pure Nothing-  pure [InstanceD Nothing ctx (AppT (ConT className) typeName) $ catMaybes impl]+  pure [InstanceD Nothing ctx typ $ catMaybes impl]  buildOperation :: Derivator -> Name -> Type -> Q Exp -> Q ([Name], Exp) buildOperation d nm (AppT (AppT ArrowT h) t) e | hasVar nm h = do@@ -116,8 +115,9 @@   (args, rhs) <- buildOperation d nm t (ap d e (arg d h (varExp varNm)))   pure (varNm : args, rhs) buildOperation d nm (ForallT _ _ t) e = buildOperation d nm t e+buildOperation d nm (AppT _ t) e | isVar nm t = ([],) <$> eff d e buildOperation d nm t e | isVar nm t = ([],) <$> res d e-                        | otherwise = ([],) <$> e+                        | otherwise = ([],) <$> cst d e  buildArgument :: Name -> Type -> Q Exp -> Q Exp -> Q Exp buildArgument nm (AppT h _) _ var | isVar nm h = var@@ -134,9 +134,10 @@ hasVar nm (AppT f a) = isVar nm f || hasVar nm a hasVar _ _ = False -tvName :: TyVarBndr -> Name-tvName (PlainTV nm) = nm-tvName (KindedTV nm _) = nm+className :: Type -> Name+className (ConT nm) = nm+className (AppT h _) = className h+className t = error $ "No support for class: " ++ show t  contains :: Data d => Name -> d -> Bool contains nm = gmapQl (||) False (\d -> maybe (contains nm d) (== nm) $ cast d)

@@ -3,3 +3,32 @@  [![Hackage](https://img.shields.io/hackage/v/derive-lifted-instances.svg)](https://hackage.haskell.org/package/derive-lifted-instances) [![Build Status](https://travis-ci.org/sjoerdvisscher/derive-lifted-instances.svg?branch=master)](https://travis-ci.org/github/sjoerdvisscher/derive-lifted-instances)++`derive-lifted-instances` generates type class instances using Template Haskell.++Below is an overview of what this library can do. If you could rewrite a class as one of the cases, and the listed constraints are satisfiable, then an instance can be derived. Note that when another instance of the class is required, this could also be a derived instance+(i.e. deriving is composable), in case you don't want that instance to actually exist.++|              | `class C x where alg :: f x -> x`+|--------------|---+| `x` iso `y`  | `(Functor f, C y)`+| `x=m`        | `(Foldable f, Monoid m)`+| `x=t a`      | `(Traversable f, Applicative t, C a)`+| `x=t a b`    | `(Traversable f, Biapplicative t, C a, C b)`+| `x` a record | `(Traversable f, All C flds)`++|              | `class C x where coalg :: x -> f x`+|--------------|---+| `x` iso `y`  | `(Functor f, C y)`+| `x=m`        | `(Pointed f)`+| `x=t a`      | `(Applicative f, Traversable t, C a)`+| `x=t a b`    | `(Applicative f, Bitraversable t, C a, C b)`+| `x` a record | `(Applicative f, All C flds)`++|              | `class C x where dialg :: f x -> g x`+|--------------|---+| `x` iso `y`  | `(Functor f, Functor g, C y)`+| `x=m`        | `(Foldable f, Porinted g, Monoid m)`+| `x=t a`      | `(Traversable f, Applicative g, Applicative t, Traversable t, C a)`+| `x=t a b`    | `(Traversable f, Applicative g, Biapplicative t, Bitraversable t, C a, C b)`+| `x` a record | `(Traversable f, Applicative g, All C flds)`

@@ -1,5 +1,5 @@ name:                derive-lifted-instances-version:             0.1.1+version:             0.2 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

@@ -20,13 +20,6 @@   op1 i is = i + sum is   op2 = sum . fmap sum -data Rec f = Rec { getUnit :: f (), getInt :: f Int }-deriving instance (Show (f ()), Show (f Int)) => Show (Rec f)-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)@@ -34,6 +27,15 @@ deriveInstance (isoDeriv [| mkX |] [| unX |] idDeriv) [t| Test X |] deriveInstance (isoDeriv [| mkX |] [| unX |] idDeriv) [t| Eq X |] deriveInstance (isoDeriv [| mkX |] [| unX |] idDeriv) [t| Ord X |]++data Rec f = Rec { getUnit :: f (), getInt :: f Int, getX :: f X }+deriving instance (Show (f ()), Show (f Int), Show (f X)) => Show (Rec f)+deriving instance (Eq (f ()), Eq (f Int), Eq (f X)) => Eq (Rec f)+-- deriveInstance (recordDeriv [| Rec |]+--     [ ([| getUnit |], apDeriv monoidDeriv)+--     , ([| getInt |], apDeriv idDeriv)+--     , ([| getX |], apDeriv (isoDeriv [| mkX |] [| unX |] idDeriv))+--     ]) [t| forall f. (Applicative f, Foldable f, Ord (f ()), Ord (f Int), Ord (f X)) => Ord (Rec f) |]  deriveInstance showDeriv [t| Test ShowsPrec |] deriveInstance monoidDeriv [t| Test () |]