packages feed

one-liner 0.7 → 0.8

raw patch · 8 files changed

+241/−22 lines, 8 files

Files

+ examples/freevars.hs view
@@ -0,0 +1,47 @@+-- 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 #-}++import GHC.Generics+import Generics.OneLiner++data Decl = Var := Expr+          | Seq Decl Decl+          deriving (Eq, Show, Generic)++data Expr = Con Int+          | Add Expr Expr+          | Mul Expr Expr+          | EVar Var+          | Let Decl Expr+          deriving (Eq, Show, Generic)++type Var = String++class Vars t where+  vars :: t -> [Var] -> ([Var], [Var])++varsDefault :: (ADT t, Constraints t Vars) => t -> [Var] -> ([Var], [Var])+varsDefault = gfoldMap (For :: For Vars) vars++instance Vars Var where+  vars v = const ([], [v])+instance Vars Decl where+  vars = varsDefault+instance Vars Int where+  vars = mempty+instance Vars Expr where+  vars (EVar v) = \bound -> (if (v `elem` bound) then [] else [v], [])+  vars (Let d e) = \bound ->+    let+      (freeD, declD) = vars d bound+      (freeE, _)     = vars e (declD ++ bound)+    in+      (freeD ++ freeE, [])+  vars x = varsDefault x++freeVars :: Vars t => t -> [Var]+freeVars = fst . ($ []) . vars++test :: [Var]+test = freeVars $ Let ("x" := Con 42) (Add (EVar "x") (EVar "y"))
+ examples/freevars1.hs view
@@ -0,0 +1,41 @@+-- 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 #-}++import GHC.Generics+import Generics.OneLiner++data Decl a b = a := Expr a b+              | Seq (Decl a b) (Decl a b)+              deriving (Eq, Show, Generic1)++data Expr a b = Con Int+              | Add (Expr a b) (Expr a b)+              | Mul (Expr a b) (Expr a b)+              | EVar b+              | Let (Decl a b) (Expr a b)+              deriving (Eq, Show, Generic1)++class Vars a t where+  vars1 :: (b -> [a] -> ([a], [a])) -> t b -> [a] -> ([a], [a])++vars1Default :: forall a b t. (ADT1 t, Constraints1 t (Vars a)) => (b -> [a] -> ([a], [a])) -> t b -> [a] -> ([a], [a])+vars1Default = gfoldMap1 (For :: For (Vars a)) vars1++instance Vars a (Decl a) where+  vars1 f (v := e) = const ([], [v]) `mappend` vars1 f e+  vars1 f x = vars1Default f x+instance Vars a (Expr a) where+  vars1 f (Let d e) = \bound ->+    let+      (freeD, declD) = vars1 f d bound+      (freeE, _)     = vars1 f e (declD ++ bound)+    in+      (freeD ++ freeE, [])+  vars1 f x = vars1Default f x++freeVars :: (Eq a, Vars a t) => t a -> [a]+freeVars = fst . ($ []) . vars1 (\v bound -> (if (v `elem` bound) then [] else [v], []))++test :: [String]+test = freeVars $ Let (Seq ("x" := Con 42) ("q" := EVar "z")) (Add (EVar "x") (EVar "y"))
+ examples/lenses.hs view
@@ -0,0 +1,59 @@+-- This is a go at creating lenses with one-liner.+-- It is not a perfect match, but with some unsafeCoerce here and there it works.+{-# LANGUAGE RankNTypes, TypeOperators, DefaultSignatures, FlexibleContexts, DeriveGeneric, DeriveAnyClass #-}+import Generics.OneLiner+import Data.Profunctor+import GHC.Generics+import Control.Applicative+import Unsafe.Coerce (unsafeCoerce)++type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t+type Key t = forall x. Lens (t x) (t x) x x++constLens :: x -> Lens s t a b -> x+constLens x _ = x++index :: f a -> Key f -> a+index f l = getConst $ l Const f+++newtype Lensed s t a b = Lensed { getLensed :: Lens s t a b -> b }+instance Profunctor (Lensed s t) where+  dimap f g (Lensed ix) = Lensed $ \l -> g (ix (l . (fmap g .) . (. f)))+instance GenericRecordProfunctor (Lensed s t) where+  unit = Lensed (constLens U1)+  mult (Lensed a) (Lensed b) = Lensed (\l -> a (l . fstl) :*: b (l . sndl))++-- GenericRecordProfunctor is a bit too polymorphic,+-- but we can use unsafeCoerce because the types will end up being the same anyway.+fstl :: Lens ((a :*: b) x) ((c :*: b') x') (a x) (c x')+fstl f (a :*: b) = (\c -> c :*: unsafeCoerce b) <$> f a+sndl :: Lens ((a :*: b) x) ((a' :*: c) x') (b x) (c x')+sndl f (a :*: b) = (\c -> unsafeCoerce a :*: c) <$> f b+++class Repr f where++  lensed :: (Lens s t a b -> b) -> Lens s t (f a) (f b) -> f b+  default lensed :: (ADTRecord1 f, Constraints1 f Repr) => (Lens s t a b -> b) -> Lens s t (f a) (f b) -> f b+  lensed f = getLensed $ record1 (For :: For Repr) (\(Lensed g) -> Lensed $ lensed g) (Lensed f)++  tabulate :: (Key f -> a) -> f a+  tabulate f = lensed (\l -> f (runKey (unsafeCoerce (Lens l)))) id++-- Two wrappers needed to make unsafeCoerce happy+newtype WrappedLens s t a b = Lens { runLens :: Lens s t a b }+newtype WrappedKey t = Key { runKey :: Key t }+++data V3 a = V3 a a a deriving (Show, Generic1, Repr)+data V10 a = V10 a (V3 (V3 a)) deriving (Show, Generic1, Repr)++instance Functor V3 where+  fmap f v = tabulate (\k -> f (index v k))+instance Applicative V3 where+  pure a = tabulate (constLens a)+  fs <*> as = tabulate (\k -> index fs k (index as k))+instance Monad V3 where+  return = pure+  as >>= f = tabulate (\k -> f (as `index` k) `index` k)
examples/realworld.hs view
@@ -11,6 +11,7 @@ import Control.Monad.Logic.Class import Control.Monad import Data.Hashable+import Data.Functor.Classes import Data.Functor.Compose import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible@@ -83,11 +84,12 @@ gcoarbitrary = unCoArb $ consume (For :: For CoArbitrary) (CoArb coarbitrary)  --- -- http://hackage.haskell.org/package/lens-4.3.3/docs/Generics-Deriving-Lens.html--- whenCastableOrElse :: forall a b f. (Typeable a, Typeable b) => (b -> f b) -> (a -> f a) -> a -> f a--- whenCastableOrElse f g = maybe g (\Refl -> f) (eqT :: Maybe (a :~: b))------ tinplate :: forall t b. (Typeable b, Deep Typeable t) => Traversal' t b--- tinplate f---   | isAtom (Proxy :: Proxy t) = f `whenCastableOrElse` pure---   | otherwise = gtraverse (For :: For (Deep Typeable)) $ f `whenCastableOrElse` tinplate f+liftCompareDefault :: (ADT1 f, Constraints1 f Ord1) => (a -> a -> Ordering) -> f a -> f a -> Ordering+liftCompareDefault = mzipWith1 (For :: For Ord1) liftCompare++infixr 9 .:+(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)+(.:) = (.) . (.)++liftEqDefault :: (ADT1 f, Constraints1 f Eq1) => (a -> a -> Bool) -> f a -> f a -> Bool+liftEqDefault = (getAll .:) . mzipWith1 (For :: For Eq1) ((All .:) . liftEq . (getAll .:)) . (All .:)
+ examples/tinplate.hs view
@@ -0,0 +1,54 @@+-- http://hackage.haskell.org/package/lens-4.15.1/docs/Data-Data-Lens.html#v:tinplate+{-# LANGUAGE+  DataKinds,+  TypeFamilies,+  TypeOperators,+  FlexibleContexts,+  FlexibleInstances,+  ScopedTypeVariables,+  UndecidableInstances,+  MultiParamTypeClasses+  #-}++import Generics.OneLiner+import Data.Proxy+import Data.Type.Equality++import Data.Functor.Identity+++class TinplateHelper (p :: Bool) a b where+  trav' :: Applicative f => proxy p -> (a -> f a) -> b -> f b++instance TinplateHelper 'True a a where trav' _ f = f++instance {-# OVERLAPPABLE #-} (ADT b, Constraints b (TinplateAlias a)) => TinplateHelper 'False a b where+  trav' _ = tinplate++instance TinplateHelper 'False a Char where trav' _ _ = pure+instance TinplateHelper 'False a Double where trav' _ _ = pure+instance TinplateHelper 'False a Float where trav' _ _ = pure+instance TinplateHelper 'False a Int where trav' _ _ = pure+instance TinplateHelper 'False a Word where trav' _ _ = pure++class TinplateAlias a b where+  trav :: Applicative f => (a -> f a) -> b -> f b+instance TinplateHelper (a == b) a b => TinplateAlias a b where+  trav = trav' (Proxy :: Proxy (a == b))+++tinplate :: forall a b f. (ADT b, Constraints b (TinplateAlias a), Applicative f) => (a -> f a) -> b -> f b+tinplate f = gtraverse (For :: For (TinplateAlias a)) (trav f)++++test1, test2 :: [[(Char, Int)]] -> [[(Char, Int)]]+test1 = runIdentity . tinplate (Identity . f) where+  f :: Char -> Char+  f = succ+test2 = runIdentity . tinplate (Identity . f) where+  f :: Int -> Int+  f = succ++test12 :: [[(Char, Int)]]+test12 = test1 as ++ test2 as where as = [[('x', 1)], [('y', 2)]]
one-liner.cabal view
@@ -1,5 +1,5 @@ Name:                 one-liner-Version:              0.7+Version:              0.8 Synopsis:             Constraint-based generics Description:          Write short and concise generic instances of type classes.                       one-liner is particularly useful for writing default
src/Generics/OneLiner.hs view
@@ -97,12 +97,12 @@ -- | `createA1` is `generic1` specialized to `Joker`. createA1 :: (ADT1 t, Constraints1 t c, Alternative f)          => for c -> (forall b s. c s => f b -> f (s b)) -> f a -> f (t a)-createA1 for f p = runJoker $ generic1 for (Joker . f . runJoker) (Joker p)+createA1 for f = dimap Joker runJoker $ generic1 for $ dimap runJoker Joker f  -- | `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)-consume1 for f p = runClown $ generic1 for (Clown . f . runClown) (Clown p)+consume1 for f = dimap Clown runClown $ generic1 for $ dimap runClown Clown f   -- | Map over a structure, updating each component.@@ -150,7 +150,7 @@ -- `gfoldMap1` is `gtraverse1` specialized to `Const`. gfoldMap1 :: (ADT1 t, Constraints1 t c, Monoid m)           => for c -> (forall s b. c s => (b -> m) -> s b -> m) -> (a -> m) -> t a -> m-gfoldMap1 for f g = getConst . gtraverse1 for ((Const .) . f . (getConst .)) (Const . g)+gfoldMap1 for f = dimap (Const .) (getConst .) $ gtraverse1 for $ dimap (getConst .) (Const .) f  -- | -- @@@ -160,7 +160,7 @@ -- `gtraverse1` is `generic1` specialized to `Star`. gtraverse1 :: (ADT1 t, Constraints1 t c, Applicative f)            => for c -> (forall d e s. c s => (d -> f e) -> s d -> f (s e)) -> (a -> f b) -> t a -> f (t b)-gtraverse1 for f g = runStar $ generic1 for (Star . f . runStar) (Star g)+gtraverse1 for f = dimap Star runStar $ generic1 for $ dimap runStar Star f  -- | Combine two values by combining each component of the structures to a monoid, and combine the results. -- Returns `mempty` if the constructors don't match.@@ -172,7 +172,7 @@ -- `mzipWith` is `zipWithA` specialized to @`Compose` `Maybe` (`Const` m)@ mzipWith :: (ADT t, Constraints t c, Monoid m)          => for c -> (forall s. c s => s -> s -> m) -> t -> t -> m-mzipWith for f = outm2 $ zipWithA for (inm2 f)+mzipWith for f = outm2 $ zipWithA for $ inm2 f  -- | Combine two values by combining each component of the structures with the given function, under an applicative effect. -- Returns `empty` if the constructors don't match.@@ -182,19 +182,19 @@  -- | -- @--- liftCompare = mzipWith (For :: For Ord1) liftCompare+-- liftCompare = mzipWith1 (For :: For Ord1) liftCompare -- @ -- -- `mzipWith1` is `zipWithA1` specialized to @`Compose` `Maybe` (`Const` m)@ mzipWith1 :: (ADT1 t, Constraints1 t c, Monoid m)           => for c -> (forall s b. c s => (b -> b -> m) -> s b -> s b -> m)           -> (a -> a -> m) -> t a -> t a -> m-mzipWith1 for f p = outm2 $ zipWithA1 for (inm2 . f . outm2) (inm2 p)+mzipWith1 for f = dimap inm2 outm2 $ zipWithA1 for $ dimap outm2 inm2 f  zipWithA1 :: (ADT1 t, Constraints1 t c, Alternative f)           => for c -> (forall d e s. c s => (d -> d -> f e) -> s d -> s d -> f (s e))           -> (a -> a -> f b) -> t a -> t a -> f (t b)-zipWithA1 for f p = runZip $ generic1 for (Zip . f . runZip) (Zip p)+zipWithA1 for f = dimap Zip runZip $ generic1 for $ dimap runZip Zip f   newtype Zip f a b = Zip { runZip :: a -> a -> f b }@@ -210,11 +210,12 @@     h _ _ = empty instance Alternative f => GenericProfunctor (Zip f) where   zero = Zip absurd+  identity = Zip $ \_ _ -> empty  inm2 :: (t -> t -> m) -> t -> t -> Compose Maybe (Const m) a-inm2 f x y = Compose $ Just $ Const $ f x y+inm2 f = Compose .: Just .: Const .: f outm2 :: Monoid m => (t -> t -> Compose Maybe (Const m) a) -> t -> t -> m-outm2 f x y = maybe mempty getConst $ getCompose (f x y)+outm2 f = maybe mempty getConst .: getCompose .: f  -- | Implement a nullary operator by calling the operator for each component. --@@ -248,7 +249,7 @@ -- `binaryOp` is `algebra` specialized to pairs. binaryOp :: (ADTRecord t, Constraints t c)          => for c -> (forall s. c s => s -> s -> s) -> t -> t -> t-binaryOp for f l r = algebra for (\(Pair a b) -> f a b) (Pair l r)+binaryOp for f = algebra for (\(Pair a b) -> f a b) .: Pair  data Pair a = Pair a a instance Functor Pair where@@ -280,3 +281,7 @@ gcotraverse1 :: (ADTRecord1 t, Constraints1 t c, Functor f)              => for c -> (forall d e s. c s => (f d -> e) -> f (s d) -> s e) -> (f a -> b) -> f (t a) -> t b gcotraverse1 for f p = runCostar $ record1 for (Costar . f . runCostar) (Costar p)++infixr 9 .:+(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)+(.:) = (.) . (.)
src/Generics/OneLiner/Internal.hs view
@@ -85,6 +85,7 @@ type instance Constraints1' (f :.: g) c = (c f, Constraints1' g c) type instance Constraints1' Par1 c = () type instance Constraints1' (Rec1 f) c = c f+type instance Constraints1' (K1 i v) c = () type instance Constraints1' (M1 i t f) c = Constraints1' f c  class ADT1' (t :: * -> *) where@@ -106,6 +107,7 @@ instance ADT1' g => ADT1' (f :.: g) where generic1' for f p = dimap unComp1 Comp1 $ f (generic1' for f p) instance ADT1' Par1 where generic1' _ _ = dimap unPar1 Par1 instance ADT1' (Rec1 f) where generic1' _ f p = dimap unRec1 Rec1 (f p)+instance ADT1' (K1 i v) where generic1' _ _ _ = dimap unK1 K1 identity instance ADT1' f => ADT1' (M1 i t f) where generic1' for f p = dimap unM1 M1 (generic1' for f p)  instance ADTNonEmpty1' U1 where nonEmpty1' _ _ _ = unit@@ -152,9 +154,11 @@   plus :: p (f a) (f' a') -> p (g a) (g' a') -> p ((f :+: g) a) ((f' :+: g') a')  -- | A generic function using a `GenericProfunctor` works on any--- algebraic data type, including those with no constructors.+-- algebraic data type, including those with no constructors and constants. class GenericNonEmptyProfunctor p => GenericProfunctor p where+  identity :: p a a   zero :: p (V1 a) (V1 a')+  zero = lmap absurd identity  instance GenericRecordProfunctor (->) where   unit _ = U1@@ -163,6 +167,7 @@   plus f g = e1 (L1 . f) (R1 . g) instance GenericProfunctor (->) where   zero = absurd+  identity = id  instance GenericRecordProfunctor Tagged where   unit = Tagged U1@@ -175,6 +180,7 @@   plus (Star f) (Star g) = Star $ e1 (fmap L1 . f) (fmap R1 . g) instance Applicative f => GenericProfunctor (Star f) where   zero = Star absurd+  identity = Star pure  instance Functor f => GenericRecordProfunctor (Costar f) where   unit = Costar $ const U1@@ -191,6 +197,7 @@   plus (Joker l) (Joker r) = Joker $ L1 <$> l <|> R1 <$> r instance Alternative f => GenericProfunctor (Joker f) where   zero = Joker empty+  identity = Joker empty  instance Divisible f => GenericRecordProfunctor (Clown f) where   unit = Clown conquer@@ -198,7 +205,8 @@ instance Decidable f => GenericNonEmptyProfunctor (Clown f) where   plus (Clown f) (Clown g) = Clown $ choose (e1 Left Right) f g where instance Decidable f => GenericProfunctor (Clown f) where-  zero = Clown $ lose (\v -> v `seq` undefined)+  zero = Clown $ lose absurd+  identity = Clown conquer  instance (GenericRecordProfunctor p, GenericRecordProfunctor q) => GenericRecordProfunctor (Product p q) where   unit = Pair unit unit@@ -207,6 +215,7 @@   plus (Pair l1 r1) (Pair l2 r2) = Pair (plus l1 l2) (plus r1 r2) instance (GenericProfunctor p, GenericProfunctor q) => GenericProfunctor (Product p q) where   zero = Pair zero zero+  identity = Pair identity identity  instance (Applicative f, GenericRecordProfunctor p) => GenericRecordProfunctor (Tannen f p) where   unit = Tannen (pure unit)@@ -215,6 +224,7 @@   plus (Tannen l) (Tannen r) = Tannen $ liftA2 plus l r instance (Applicative f, GenericProfunctor p) => GenericProfunctor (Tannen f p) where   zero = Tannen (pure zero)+  identity = Tannen (pure identity)  data Ctor a b = Ctor { index :: a -> Int, count :: Int } instance Profunctor Ctor where@@ -226,6 +236,7 @@   plus l r = Ctor (e1 (index l) ((count l + ) . index r)) (count l + count r) instance GenericProfunctor Ctor where   zero = Ctor (const 0) 0+  identity = Ctor (const 0) 1  record :: (ADTRecord t, Constraints t c, GenericRecordProfunctor p)        => for c -> (forall s. c s => p s s) -> p t t