one-liner 0.8 → 0.8.1

raw patch · 4 files changed

+85/−8 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• examples/freevars1.hs +1/−1
• one-liner.cabal +1/−1
• src/Generics/OneLiner.hs +40/−3
• src/Generics/OneLiner/Internal.hs +43/−3

@@ -1,6 +1,6 @@ -- Another go at this problem: -- https://github.com/sjoerdvisscher/blog/blob/master/2012/2012-03-03%20how%20to%20work%20generically%20with%20mutually%20recursive%20datatypes.md-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts, DeriveGeneric, ScopedTypeVariables, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts, DeriveGeneric, ScopedTypeVariables, MultiParamTypeClasses #-}  import GHC.Generics import Generics.OneLiner

@@ -1,5 +1,5 @@ Name:                 one-liner-Version:              0.8+Version:              0.8.1 Synopsis:             Constraint-based generics Description:          Write short and concise generic instances of type classes.                       one-liner is particularly useful for writing default

@@ -10,6 +10,8 @@ -- All functions without postfix are for instances of `Generic`, and functions -- with postfix `1` are for instances of `Generic1` (with kind @* -> *@) which -- get an extra argument to specify how to deal with the parameter.+-- The function `create_` does not require any such instance, but must be given+-- a constructor explicitly. ----------------------------------------------------------------------------- {-# LANGUAGE     RankNTypes@@ -22,6 +24,7 @@   -- * Producing values   create, createA, ctorIndex,   create1, createA1, ctorIndex1,+  createA_,   -- * Traversing values   gmap, gfoldMap, gtraverse,   gmap1, gfoldMap1, gtraverse1,@@ -32,7 +35,8 @@   consume, consume1,   -- * Functions for records   -- | These functions only work for single constructor data types.-  nullaryOp, unaryOp, binaryOp, algebra, dialgebra, gcotraverse1,+  nullaryOp, unaryOp, binaryOp, createA', algebra, dialgebra,+  createA1', gcotraverse1,   -- * Generic programming with profunctors   -- | All the above functions have been implemented using these functions,   -- using different `profunctor`s.@@ -71,10 +75,11 @@  -- | Create a value (one for each constructor), given how to construct the components, under an applicative effect. ----- Here's how to implement `get` from the `binary` package:+-- Here's how to implement `get` from the `binary` package, first encoding the+-- constructor in a byte: -- -- @--- get = getWord8 `>>=` \\ix -> `createA` (`For` :: `For` Binary) [get] `!!` `fromEnum` ix+-- get = getWord8 `>>=` \\ix -> `getCompose` (`createA` (`For` :: `For` Binary) (`Compose` [get])) `!!` `fromEnum` ix -- @ -- -- `createA` is `generic` specialized to `Joker`.@@ -99,6 +104,19 @@          => for c -> (forall b s. c s => f b -> f (s b)) -> f a -> f (t a) createA1 for f = dimap Joker runJoker $ generic1 for $ dimap runJoker Joker f +-- | Create a value, given a constructor (or a function) and+-- how to construct its components, under an applicative effect.+--+-- For example, this is the implementation of `Test.QuickCheck.arbitrary` for a+-- type with a single constructor (e.g., quadruples @(,,,)@).+--+-- @+-- arbitrary = `createA_` (`For` :: `For` Arbitrary) arbitrary (,,,)+-- @+createA_ :: (FunConstraints t c, Applicative f)+         => for c -> (forall s. c s => f s) -> t -> f (Result t)+createA_ for run = autoApply for run . pure+ -- | `consume1` is `generic1` specialized to `Clown`. consume1 :: (ADT1 t, Constraints1 t c, Decidable f)          => for c -> (forall b s. c s => f b -> f (s b)) -> f a -> f (t a)@@ -251,6 +269,20 @@          => for c -> (forall s. c s => s -> s -> s) -> t -> t -> t binaryOp for f = algebra for (\(Pair a b) -> f a b) .: Pair +-- | Create a value of a record type (with exactly one constructor), given+-- how to construct the components, under an applicative effect.+--+-- Here's how to implement `get` from the `binary` package:+--+-- @+-- get = `createA'` (`For` :: `For` Binary) get+-- @+--+-- `createA'` is `record` specialized to `Joker`.+createA' :: (ADTRecord t, Constraints t c, Applicative f)+         => for c -> (forall s. c s => f s) -> f t+createA' for f = runJoker $ record for $ Joker f+ data Pair a = Pair a a instance Functor Pair where   fmap f (Pair a b) = Pair (f a) (f b)@@ -270,6 +302,11 @@ dialgebra :: (ADTRecord t, Constraints t c, Functor f, Applicative g)         => for c -> (forall s. c s => f s -> g s) -> f t -> g t dialgebra for f = runBiff $ record for $ Biff f++-- | `createA1'` is `record1` specialized to `Joker`.+createA1' :: (ADTRecord1 t, Constraints1 t c, Applicative f)+         => for c -> (forall b s. c s => f b -> f (s b)) -> f a -> f (t a)+createA1' for f = dimap Joker runJoker $ record1 for $ dimap runJoker Joker f  -- | --

@@ -22,6 +22,7 @@   , FlexibleInstances   , ScopedTypeVariables   , UndecidableInstances+  , MultiParamTypeClasses   #-} module Generics.OneLiner.Internal where @@ -34,6 +35,7 @@ import Data.Bifunctor.Product import Data.Bifunctor.Tannen import Data.Functor.Contravariant.Divisible+import Data.Functor.Compose import Data.Profunctor import Data.Tagged @@ -186,9 +188,12 @@   unit = Costar $ const U1   mult (Costar f) (Costar g) = Costar $ \lr -> f (fst1 <$> lr) :*: g (snd1 <$> lr) -instance (Functor f, Applicative g) => GenericRecordProfunctor (Biff (->) f g) where-  unit = Biff $ const $ pure U1-  mult (Biff f) (Biff g) = Biff $ \lr -> (:*:) <$> f (fst1 <$> lr) <*> g (snd1 <$> lr)+instance (Functor f, Applicative g, GenericRecordProfunctor p) => GenericRecordProfunctor (Biff p f g) where+  unit = Biff $ dimap (const U1) pure unit+  mult (Biff f) (Biff g) = Biff $ dimap+    (liftA2 (:*:) (Compose . fmap fst1) (Compose . fmap snd1))+    (\(Compose l :*: Compose r) -> liftA2 (:*:) l r)+    (mult (dimap getCompose Compose f) (dimap getCompose Compose g))  instance Applicative f => GenericRecordProfunctor (Joker f) where   unit = Joker $ pure U1@@ -310,3 +315,38 @@ -- if you don't actually need a class constraint. class AnyType a instance AnyType a++-- | The result type of a curried function.+--+-- If @r@ is not a function type (i.e., does not unify with `_ -> _`):+--+-- @+-- `Result` (a -> r) ~ r+-- `Result` (a -> b -> r) ~ r+-- `Result` (a -> b -> c -> r) ~ r+-- @+type family Result t where+  Result (a -> b) = Result b+  Result r = r++-- | Automatically apply a lifted function to a polymorphic argument as+-- many times as possible.+--+-- A constraint `FunConstraint t c` is equivalent to the conjunction of+-- constraints `c s` for every argument type of `t`.+--+-- If @r@ is not a function type:+--+-- @+-- c a :- FunConstraints (a -> r) c+-- (c a, c b) :- FunConstraints (a -> b -> r) c+-- (c a, c b, c d) :- FunConstraints (a -> b -> d -> r) c+-- @+class FunConstraints t c where+  autoApply :: Applicative f => for c -> (forall s. c s => f s) -> f t -> f (Result t)++instance {-# OVERLAPPING #-} (c a, FunConstraints b c) => FunConstraints (a -> b) c where+  autoApply for run f = autoApply for run (f <*> run)++instance Result r ~ r => FunConstraints r c where+  autoApply _for _run r = r