pointless-lenses 0.0.6 → 0.0.7

raw patch · 7 files changed

+486/−9 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README +1/−1
• Test.hs +2/−0
• pointless-lenses.cabal +4/−1
• src/Generics/Pointless/Lenses/Examples/Examples.hs +47/−7
• src/Generics/Pointless/Lenses/Examples/Imdb.hs +129/−0
• src/Generics/Pointless/Lenses/Examples/MapExamples.hs +95/−0
• src/Generics/Pointless/Lenses/Examples/Recs.hs +208/−0

@@ -25,7 +25,7 @@  We can now test the well-behavedness of some lens, for example: -> quickCheck (wb filter_lns)+> quickCheck (wb filter_left_lns) +++ OK, passed 100 tests.  Or run some example and later check what it is actually doing:

@@ -1,3 +1,5 @@ module Test where  import Generics.Pointless.Lenses.Examples.Examples+import Generics.Pointless.Lenses.Examples.Imdb+import Generics.Pointless.Lenses.Examples.MapExamples

@@ -1,5 +1,5 @@ Name:            pointless-lenses-Version:         0.0.6+Version:         0.0.7 License:         BSD3 License-file:    LICENSE Author:          Alcino Cunha <alcino@di.uminho.pt>, Hugo Pacheco <hpacheco@di.uminho.pt>@@ -27,6 +27,9 @@         Generics.Pointless.Lenses.RecursionPatterns,         Generics.Pointless.Lenses.Reader.RecursionPatterns,         Generics.Pointless.Lenses.Examples.Examples,+        Generics.Pointless.Lenses.Examples.Imdb,+        Generics.Pointless.Lenses.Examples.Recs,+        Generics.Pointless.Lenses.Examples.MapExamples,         Generics.Pointless.Lenses    extensions: ScopedTypeVariables, FlexibleContexts, Rank2Types, TypeOperators, TypeFamilies, GADTs

@@ -19,16 +19,56 @@  import Generics.Pointless.Combinators import Generics.Pointless.Functors-import Generics.Pointless.Fctrable import Generics.Pointless.Bifunctors-import Generics.Pointless.Bifctrable import Generics.Pointless.Examples.Examples import Generics.Pointless.Lenses import Generics.Pointless.Lenses.Combinators import Generics.Pointless.Lenses.RecursionPatterns-import Generics.Pointless.Lenses.Reader.RecursionPatterns -import Data.Char+{-# RULES+  "mapId"+  map_lns id_lns = id_lns+  #-}+{-# RULES+  "mapFusion" forall l1 l2.+  map_lns l1 .< map_lns l2 = map_lns (l1 .< l2)+  #-}+{-# RULES+  "mapCat" forall l1.+  map_lns l1 .< cat_lns = cat_lns .< (map_lns l1 ><< map_lns l1)+  #-}+{-# RULES+  "mapConcat" forall l1.+  map_lns l1 .< concat_lns = concat_lns .< map_lns (map_lns l1)+  #-}+{-# RULES+  "filterLeftMap" forall l1 l2.+  filter_left_lns .< map_lns (l1 -|-< l2) = map_lns l1 .< filter_left_lns+  #-}+{-# RULES+  "filterLeftMap" forall l1 l2.+  filter_left_lns .< map_lns (l1 -|-< l2) = map_lns l1 .< filter_left_lns+  #-}+{-# RULES+  "lengthCat" forall c.+  length_lns c .< cat_lns = plus_lns .< (length_lns c ><< length_lns c)+  #-}+{-# RULES+  "lengthMap" forall c l1.+  length_lns c .< map_lns l1 = length_lns (create l1 c)+  #-}+{-# RULES+  "lengthConcat" forall c.+  length_lns c .< concat_lns = suml_lns .< map_lns (length_lns c)+  #-}+{-# RULES+  "filterMap"  forall l1 l2.+  filter_left_lns .< (map_lns (l1 -|-< l2)) = (map_lns l1) .< filter_left_lns+  #-}+{-# RULES+  "filterMap"  forall l1 l2.+  filter_left_lns .< (map_lns (l1 -|-< l2)) = (map_lns l1) .< filter_left_lns+  #-}  -- * Lenses over trees @@ -46,7 +86,7 @@  -- | List length lens. length_lns :: a -> Lens [a] Nat-length_lns a = nat_lns _L (\x -> id_lns -|-< snd_lns (a!))+length_lns a = nat_lns _L (\_ -> id_lns -|-< snd_lns (a!))  zipWith_lns :: Lens (a,b) c -> Lens ([a],[b]) [c] zipWith_lns f = ana_lns _L (((!<) c -|-< (f ><< id_lns) .< distp_lns) .< coassocl_lns .< dists_lns .< (out_lns ><< out_lns))@@ -127,7 +167,7 @@  -- | List mapping lens. map_lns :: Lens c a -> Lens [c] [a]-map_lns f = nat_lns _L (\x -> id_lns -|-< f ><< id_lns)+map_lns f = nat_lns _L (\_ -> id_lns -|-< f ><< id_lns)  head_lns :: [a] -> Lens [a] (Either One a) head_lns l = (id_lns -|-< fst_lns (l!)) .< out_lns@@ -178,7 +218,7 @@ add_lns :: Lens (Int,Int) Int add_lns = Lens get' put' create'     where get' (x,y) = x+y-          put' (x,(a,b)) = (a,x-a)+          put' (x,(a,_)) = (a,x-a)           -- needs to be strictly decreasing in the first argument, that will be the recursive argument of sumInt_lns           create' x | x > 0 = (div x 2 + mod x 2,div x 2)                     | otherwise = (div x 2,div x 2 + mod x 2)

@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.Pointless.Lenses.Examples.Imdb+-- Copyright   :  (c) 2010 University of Minho+-- License     :  BSD3+--+-- Maintainer  :  hpacheco@di.uminho.pt+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Pointless Lenses:+-- bidirectional lenses with point-free programming+-- +-- Internet Movie Database example+--+-----------------------------------------------------------------------------++module Generics.Pointless.Lenses.Examples.Imdb where+    +import Prelude hiding (Show(..),concat,length,shows)+import Generics.Pointless.Functors (Nat(..))+import Generics.Pointless.Combinators+import Generics.Pointless.Lenses.Combinators+import Generics.Pointless.Lenses+import Generics.Pointless.Lenses.Examples.Recs+    +type Imdb = ([Show],[Actor])+type Show = (((Year,Title),[Review]),Either Movie TV)+type Review = (User,[Comment])+type Movie = (Director,[BoxOffice])+type BoxOffice = (Country,Maybe Value)+type TV = [Season]+type Season = (Year,[Episode])+type Actor = (Name,[Played])+type Played = (((Year,Title),Role),[Award])+type Award = (Year,Category)++type Year = Int+type Title = String+type User = String+type Comment = String+type Director = String+type Country = String+type Value = Nat+type Episode = String+type Name = String+type Role = String+type Category = String++dyear = const 2010+dtitle = const "unknown"+dlist = const []+drole = const "unknown"+dcountry = const "unknown"+duser = const "anonymous"+dcomment = "empty"+dytrole :: x -> ((Year,Title),Role)+dytrole = (dyear /\ dtitle) /\ drole++-- ** Specification++imdb :: (Lens Imdb ([(((Year,Title),Nat),(Director,Value))],[(Name,[Category])]))+imdb = (shows ><< map_pf actor)++actor :: (Lens Actor (Name,[Category]))+actor = id_lns ><< awards++movie :: (Lens Movie (Director,Value))+movie = id_lns ><< boxoffices++awards :: Lens [Played] [Category]+awards = map_pf (snd_lns dyear) .< concat_pf .< map_pf (snd_lns dytrole)++shows :: (Lens [Show] [(((Year,Title),Nat),(Director,Value))])+shows = (map_pf f) .< filter_left_pf .< map_pf distr_lns .< map_pf g+    where f = (id_lns ><< reviews) ><< id_lns+          g = id_lns ><< (movie -|-< tv)+          +boxoffices :: (Lens [BoxOffice] Value)+boxoffices = suml_pf .< filter_right_pf .< map_pf (outMaybe_lns .< snd_lns dcountry)++reviews :: (Lens [Review] Nat)+reviews = length_pf dcomment .< concat_pf .< map_pf (snd_lns duser)++tv :: Lens TV [Episode]+tv = concat_pf .< map_pf (snd_lns dyear)++-- ** Optimization++imdb_opt :: (Lens Imdb ([(((Year,Title),Nat),(Director,Value))],[(Name,[Category])]))+imdb_opt = (shows_opt><< map_pf actor_opt)++actor_opt :: (Lens Actor (Name,[Category]))+actor_opt = id_lns ><< awards_opt++movie_opt :: (Lens Movie (Director,Value))+movie_opt = id_lns ><< boxoffices_opt++awards_opt :: Lens [Played] [Category]+awards_opt = cataList_lns $ innList_lns .< f .< coassocl_lns .< (id_lns -|-< outList_lns .< hyloNeList_lns g h .< ((snd_lns dytrole) ><< id_lns))+    where+    f = (!<) inl -|-< id_lns+    g = innList_lns .< (id_lns -|-< (((inr . bang) \/< id_lns) id_lns)) .< coassocr_lns+    h = ((outList_lns .< (snd_lns bang)) -|-< (assocr_lns .< (((snd_lns dyear) ><< id_lns) ><< id_lns)))+      .< distl_lns .< (outList_lns ><< id_lns)++shows_opt :: (Lens [Show] [(((Year,Title),Nat),(Director,Value))])    +shows_opt = cataList_lns aux+    where+    aux = ((\/<) (inl . bang) l r) .< f+    l = innList_lns .< (id_lns -|-< ((((id_lns ><< reviews) ><< movie) .< swap_lns) ><< id_lns))+    r = snd_lns _L+    f = coassocl_lns .< (id_lns -|-< (distl_lns .< ((distl_lns .< swap_lns) ><< id_lns)))++boxoffices_opt :: (Lens [BoxOffice] Value)+boxoffices_opt = cataList_lns aux+    where+    aux = ((\/<) (inl . bang) l r) .< coassocl_lns .< f+    l = innNat_lns .< (((!<) inl) -|-< id_lns) .< coassocl_lns .< (id_lns -|-< (outNat_lns .< plus_pf))+    r = snd_lns bang+    f = (id_lns -|-< (coswap_lns .< distl_lns .< ((outMaybe_lns .< (snd_lns dcountry)) ><< id_lns)))++reviews_opt :: (Lens [Review] Nat)+reviews_opt = cataList_lns aux+    where+    aux = innNat_lns .< (((!<) inl) -|-< id_lns) .< coassocl_lns .< (id_lns -|-< outNat_lns .< f)+    f = hyloNeNat_lns g h .< ((snd_lns duser) ><< id_lns)+    g = innNat_lns .< (id_lns -|-< (((inr . bang) \/< id_lns) id_lns)) .< coassocr_lns+    h = ((outNat_lns .< (snd_lns bang)) -|-< ((snd_lns (const dcomment)) ><< id_lns)) .< distl_lns .< (outList_lns ><< id_lns)

@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.Pointless.Lenses.Examples.MapExamples+-- Copyright   :  (c) 2010 University of Minho+-- License     :  BSD3+--+-- Maintainer  :  hpacheco@di.uminho.pt+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Pointless Lenses:+-- bidirectional lenses with point-free programming+-- +-- More example involving composed maps.+--+-----------------------------------------------------------------------------++module Generics.Pointless.Lenses.Examples.MapExamples where++import Generics.Pointless.Functors+import Generics.Pointless.Combinators+import Generics.Pointless.Lenses+import Generics.Pointless.Lenses.Combinators+import Generics.Pointless.Lenses.Examples.Recs++-- ** map ! . filter_left . map (map f -|- map g)++mapbang_hand :: Lens [Either [(Int,Char)] [(Bool,Char)]] [One]+mapbang_hand = Lens get' put' create'+    where+    get' [] = []+    get' (Left _ :xs) = _L : get' xs+    get' (Right _:xs) = get' xs+    create' [] = []+    create' (x:xs) = Left [] : create' xs+    put' ([],[]) = []+    put' (l,Right y:ys) = Right y : put' (l,ys)+    put' ([],_) = []+    put' (x:xs,Left y:ys) = Left y : put' (xs,ys)+    put' (x:xs,[]) = Left [] : put' (xs,[])++mapbang_pf :: Lens [Either [(Int,Char)] [(Bool,Char)]] [One]+mapbang_pf = map_pf ((!<) (innList . inl . bang)) .< filter_left_pf+     .< map_pf (map_pf (fst_lns (pnt 'c' . bang)) -|-< map_pf (snd_lns (pnt True . bang)))+ +mapbang_opt :: Lens [Either [(Int,Char)] [(Bool,Char)]] [One]   +mapbang_opt = cataList_lns (((\/<) (inl . bang) f g) .< coassocl_lns .< (id_lns -|-< distl_lns))+    where f = innList_lns .< (id_lns -|-< (((!<) (innList . inl)) ><< id_lns))+          g = snd_lns _L+          +-- ** Persons (count the number of women)++type Person = (Name,Gender)+type Name = String+data Gender = M | F deriving (Eq,Show,Read)++innGender :: Either One One -> Gender+innGender = const M \/ const F++outGender :: Gender -> Either One One+outGender M = Left _L+outGender F = Right _L++outGender_lns :: Lens Gender (Either One One)+outGender_lns = Lens outGender (innGender . fst) innGender++type instance PF Gender = Const One :+: Const One+instance Mu Gender where+    inn (Left _) = M+    inn (Right _) = F+    out M = Left _L+    out F = Right _L++women_hand :: Lens [Person] Nat+women_hand = Lens get' put' create'+    where+    get' [] = Zero+    get' ((nm,M):ps) = get' ps+    get' ((nm,F):ps) = Succ (get' ps)+    create' Zero = []+    create' (Succ n) = ("woman",F) : create' n+    put' (Zero,[]) = []+    put' (n,(nm,M):ps) = (nm,M) : put' (n,ps)+    put' (Zero,_) = []+    put' (Succ n,[]) = ("woman",F) : create' n+    put' (Succ n,(nm,F):ps) = (nm,F) : put' (n,ps)++women_pf :: Lens [Person] Nat+women_pf = length_pf _L .< filter_right_pf .< map_pf (outGender_lns .< snd_lns (pnt "woman" . bang))+    +women_opt :: Lens [Person] Nat+women_opt = cataList_lns ((innNat_lns .< (id_lns -|-< snd_lns bang) .\/< snd_lns bang) .< f)+    where f = coassocl_lns+           .< (id_lns -|-< (coswap_lns .< distl_lns .< (g ><< id_lns)))+          g = outGender_lns .< snd_lns (pnt "woman" . bang)

@@ -0,0 +1,208 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.Pointless.Lenses.Examples.Recs+-- Copyright   :  (c) 2010 University of Minho+-- License     :  BSD3+--+-- Maintainer  :  hpacheco@di.uminho.pt+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Pointless Lenses:+-- bidirectional lenses with point-free programming+-- +-- This module provides specialized versions of recursion patterns to avoid using the internal classes and type families.+-- These functions are more efficient and better for profiling and runtime tests.+--+-----------------------------------------------------------------------------++module Generics.Pointless.Lenses.Examples.Recs where++import Generics.Pointless.Combinators+import Generics.Pointless.Functors+import Generics.Pointless.Lenses+import Generics.Pointless.Lenses.Combinators++innNat :: Either One Nat -> Nat+innNat (Left _) = Zero+innNat (Right n) = Succ n++outNat :: Nat -> Either One Nat+outNat Zero = Left _L+outNat (Succ n) = Right n++innNat_lns :: Lens (Either One Nat) Nat+innNat_lns = Lens innNat (outNat . fst) outNat++outNat_lns :: Lens Nat (Either One Nat)+outNat_lns = Lens outNat (innNat . fst) innNat++innMaybe :: Either One a -> Maybe a+innMaybe (Left _) = Nothing+innMaybe (Right x) = Just x++outMaybe :: Maybe a -> Either One a+outMaybe (Nothing) = Left _L+outMaybe (Just x) = Right x++innMaybe_lns :: Lens (Either One a) (Maybe a)+innMaybe_lns = Lens innMaybe (outMaybe . fst) outMaybe++outMaybe_lns :: Lens (Maybe a) (Either One a)+outMaybe_lns = Lens outMaybe (innMaybe . fst) innMaybe++innList :: Either One (a,[a]) -> [a]+innList (Left _) = []+innList (Right (x,xs)) = x:xs++outList :: [a] -> Either One (a,[a])+outList [] = Left _L+outList (x:xs) = Right (x,xs)++innList_lns :: Lens (Either One (a,[a])) [a]+innList_lns = Lens innList (outList . fst) outList++outList_lns :: Lens [a] (Either One (a,[a]))+outList_lns = Lens outList (innList . fst) innList++outNeList :: (NeList a b) -> Either a (b,NeList a b)+outNeList (NeNil a) = Left a+outNeList (NeCons b n) = Right (b,n)++innNeList :: Either a (b,NeList a b) -> NeList a b+innNeList (Left a) = NeNil a+innNeList (Right (b,n)) = NeCons b n++cataList :: (Either One (a,b) -> b) -> [a] -> b+cataList g [] = g $ Left _L+cataList g (x:xs) = g $ Right (x,cataList g xs)++anaList :: (b -> Either One (a,b)) -> b -> [a]+anaList g b = aux (g b)+    where+    aux (Left _L) = []+    aux (Right (x,xs)) = x : anaList g xs      ++fmapList :: (x -> y) -> Either z (a,x) -> Either z (a,y)+fmapList f = id -|- id >< f++fmapNat :: (x -> y) -> Either a x -> Either a y+fmapNat f = id -|- f++fzipList :: (a -> c) -> (Either z (x,a),Either z (x,c)) -> Either z (x,(a,c))+fzipList f (Left z,_) = Left z+fzipList f (Right (x,a),Left _) = Right $ (x,(a,f a))+fzipList f (Right (x,a),Right (y,c)) = Right $ (x,(a,c))++fzipNat :: (a -> c) -> (Either z a,Either z c) -> Either z (a,c)+fzipNat f (Left z,_) = Left z+fzipNat f (Right a,Left _) = Right (a,f a)+fzipNat f (Right a,Right c) = Right (a,c)++cataList_lns :: (Lens (Either One (a,b)) b) -> Lens [a] b+cataList_lns g = Lens get' put' create'+    where get' = cataList (get g)+          create' = anaList (create g)+          put' = anaList $ fzipList create' . (put g . (id >< fmapList get') /\ snd) . (id >< outList)++hyloList :: (Either x (y,c) -> c) -> (a -> Either x (y,a)) -> (a -> c)+hyloList g h = g . (id -|- id >< hyloList g h) . h++outNeNat :: NeNat a -> Either a (NeNat a)+outNeNat (NNil x) = Left x+outNeNat (NCons n) = Right n++data NeNat a = NNil a | NCons (NeNat a)++cataNeNat :: (Either a c -> c) -> NeNat a -> c+cataNeNat f (NNil x) = f (Left x)+cataNeNat f (NCons n) = f (Right $ cataNeNat f n)++anaNeNat :: (c -> Either a c) -> c -> NeNat a+anaNeNat f c = aux (f c)+    where+    aux (Left x) = NNil x+    aux (Right n) = NCons (anaNeNat f n)++accumNeNat :: ((Either a y,x) -> y) -> ((Either a (NeNat a),x) -> Either a (NeNat a,x)) -> ((NeNat a,x) -> y)+accumNeNat g tau (NNil a,x) = g (Left a,x)+accumNeNat g tau (NCons ne,x) = g ((id -|- accumNeNat g tau) aux,x)+    where aux = tau (Right ne,x)++cataNeNat_lns :: (Lens (Either a c) c) -> Lens (NeNat a) c+cataNeNat_lns f = Lens get' put' create'+    where+    get' = cataNeNat (get f)+    create' = anaNeNat (create f)+    put' = anaNeNat $ fzipNat create' . (put f . (id >< fmapNat get') /\ snd) . (id >< outNeNat)++anaNeNat_lns :: (Lens c (Either a c)) -> Lens c (NeNat a)+anaNeNat_lns g = Lens get' put' create'+    where get' = anaNeNat (get g)+          create' = cataNeNat (create g)+          put' = accumNeNat (put g) (fzipNat create' . (id >< get g))++hyloNeNat_lns :: (Lens (Either x b) b) -> (Lens a (Either x a)) -> Lens a b+hyloNeNat_lns g h = cataNeNat_lns g .< anaNeNat_lns h++data NeList a b = NeNil a | NeCons b (NeList a b)++cataNeList :: (Either a (b,c) -> c) -> NeList a b -> c+cataNeList f (NeNil x) = f (Left x)+cataNeList f (NeCons x xs) = f (Right (x,cataNeList f xs))++anaNeList :: (c -> Either a (b,c)) -> c -> NeList a b+anaNeList f c = aux (f c)+    where+    aux (Left x) = NeNil x+    aux (Right (x,xs)) = NeCons x (anaNeList f xs)++accumNeList :: ((Either a (b,y),x) -> y) -> ((Either a (b,NeList a b),x) -> Either a (b,(NeList a b,x))) -> ((NeList a b,x) -> y)+accumNeList g tau (NeNil a,x) = g (Left a,x)+accumNeList g tau (NeCons b ne,x) = g ((id -|- id >< accumNeList g tau) aux,x)+    where aux = tau (Right (b,ne),x)++cataNeList_lns :: (Lens (Either a (b,c)) c) -> Lens (NeList a b) c+cataNeList_lns g = Lens get' put' create'+    where get' = cataNeList (get g)+          create' = anaNeList (create g )+          put' = anaNeList $ fzipList create' . (put g . (id >< fmapList get') /\ snd) . (id >< outNeList)++anaNeList_lns :: (Lens c (Either a (b,c))) -> Lens c (NeList a b)+anaNeList_lns g = Lens get' put' create'+    where get' = anaNeList (get g)+          create' = cataNeList (create g)+          put' = accumNeList (put g) (fzipList create' . (id >< get g))++hyloNeList_lns :: (Lens (Either x (y,b)) b) -> (Lens a (Either x (y,a))) -> Lens a b+hyloNeList_lns g h = cataNeList_lns g .< anaNeList_lns h++-- ** Examples++length_pf :: a -> Lens [a] Nat+length_pf v = cataList_lns (innNat_lns .< (id_lns -|-< snd_lns (v!)))++plus_pf :: Lens (Nat,Nat) Nat+plus_pf = hyloNeNat_lns f g+   where f = innNat_lns .< (outNat_lns \/$< id_lns)+         g = (snd_lns bang -|-< id_lns) .< distl_lns .< (outNat_lns ><< id_lns)++suml_pf :: Lens [Nat] Nat+suml_pf = cataList_lns (innNat_lns .< (id_lns #\/< (outNat_lns .< plus_pf)))++cat_pf :: Lens ([a],[a]) [a]+cat_pf = hyloNeList_lns g h+    where g = innList_lns .< (outList_lns \/$< id_lns)+          h = (snd_lns bang -|-< assocr_lns) .< distl_lns .< (outList_lns ><< id_lns)++concat_pf :: Lens [[a]] [a]+concat_pf = cataList_lns (innList_lns .< (id_lns #\/< (outList_lns .< cat_pf)))++map_pf :: Lens a b -> Lens [a] [b]+map_pf l = cataList_lns (innList_lns .< (id_lns -|-< l ><< id_lns))++filter_left_pf :: Lens [Either a b] [a]+filter_left_pf = cataList_lns ((innList_lns .\/< snd_lns _L) .< coassocl_lns .< (id_lns -|-< distl_lns))++filter_right_pf :: Lens [Either a b] [b]+filter_right_pf = cataList_lns ((innList_lns .\/< snd_lns _L) .< coassocl_lns .< (id_lns -|-< coswap_lns .< distl_lns))