lens 3.8.3 → 3.8.4

raw patch · 28 files changed

+1176/−152 lines, 28 filesdep ~basedep ~generic-derivingPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, generic-deriving

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +7/−0
• benchmarks/alongside.hs +109/−0
• benchmarks/plated.hs +74/−0
• benchmarks/unsafe.hs +63/−0
• benchmarks/zipper.hs +45/−0
• lens.cabal +47/−43
• src/Control/Lens/Action.hs +2/−1
• src/Control/Lens/Combinators.hs +1/−0
• src/Control/Lens/Cons.hs +1/−0
• src/Control/Lens/Fold.hs +3/−2
• src/Control/Lens/Internal/Zipper.hs +1/−0
• src/Control/Lens/Lens.hs +1/−0
• src/Control/Lens/Level.hs +1/−0
• src/Control/Lens/Operators.hs +1/−1
• src/Control/Lens/Review.hs +4/−3
• src/Control/Lens/Setter.hs +1/−0
• src/Control/Lens/Traversal.hs +1/−0
• src/Control/Lens/Zipper.hs +2/−1
• src/Data/ByteString/Lazy/Lens.hs +6/−2
• src/Data/ByteString/Strict/Lens.hs +2/−1
• src/Data/Data/Lens.hs +1/−0
• src/Data/List/Lens.hs +36/−14
• src/GHC/Generics/Lens.hs +3/−84
• src/Generics/Deriving/Lens.hs +104/−0
• tests/doctests.hsc +71/−0
• tests/hunit.hs +279/−0
• tests/properties.hs +195/−0
• tests/templates.hs +115/−0

@@ -1,3 +1,10 @@+3.8.4+-----+* Renamed `strippingPrefix` to `prefixed`, `strippingSuffix` to `suffixed`. Left the old names as deprecated aliases.+* Fixed issues with the test suite caused by `doctests` carrying flags from the $setup block between modules.+* Benchmarks now use `generic-deriving` rather than `ghc-prim` directly, like the rest of the package.+* Added `Generics.Deriving.Lens`, which is now simply re-exported from `GHC.Generics.Lens`.+ 3.8.3 ----- * Added `strippingSuffix` and `stripSuffix` to `Data.Data.Lens`

@@ -0,0 +1,109 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+import Control.Applicative+import Control.Comonad+import Control.Comonad.Store.Class+import Control.Lens.Internal+import Control.Lens+import Criterion.Main+import Data.Functor.Compose+import Data.Functor.Identity++-- | A finally encoded Store+newtype Experiment a b s = Experiment { runExperiment :: forall f. Functor f => (a -> f b) -> f s }++instance Functor (Experiment a b) where+  fmap f (Experiment k) = Experiment (fmap f . k)+  {-# INLINE fmap #-}++instance (a ~ b) => Comonad (Experiment a b) where+  extract (Experiment m) = runIdentity (m Identity)+  {-# INLINE extract #-}+  duplicate = duplicateExperiment+  {-# INLINE duplicate #-}++-- | 'Experiment' is an indexed 'Comonad'.+duplicateExperiment :: Experiment a c s -> Experiment a b (Experiment b c s)+duplicateExperiment (Experiment m) = getCompose (m (Compose . fmap placebo . placebo))+{-# INLINE duplicateExperiment #-}++-- | A trivial 'Experiment'.+placebo :: a -> Experiment a b b+placebo i = Experiment (\k -> k i)+{-# INLINE placebo #-}++instance (a ~ b) => ComonadStore a (Experiment a b) where+  pos m = posExperiment m+  peek d m = peekExperiment d m+  peeks f m = runIdentity $ runExperiment m (\c -> Identity (f c))+  experiment f m = runExperiment m f++posExperiment :: Experiment a b s -> a+posExperiment m = getConst (runExperiment m Const)+{-# INLINE posExperiment #-}++peekExperiment :: b -> Experiment a b s -> s+peekExperiment b m = runIdentity $ runExperiment m (\_ -> Identity b)+{-# INLINE peekExperiment #-}++trial :: Lens s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b')+trial l r pfq (s,s') = fmap (\(b,t') -> (peekExperiment b x,t')) (getCompose (r (\a' -> Compose $ pfq (posExperiment x, a')) s'))+  where x = l placebo s+{-# INLINE trial #-}++posContext :: Context a b s -> a+posContext (Context _ a) = a+{-# INLINE posContext #-}++peekContext :: b -> Context a b s -> s+peekContext b (Context f _) = f b+{-# INLINE peekContext #-}++-- a version of alongside built with Context and product+half :: LensLike (Context a b) s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b')+half l r pfq (s,s') = fmap (\(b,t') -> (peekContext b x,t')) (getCompose (r (\a' -> Compose $ pfq (posContext x, a')) s'))+  where x = l (Context id) s+{-# INLINE half #-}++-- alongside' :: Lens s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b')+-- {-# INLINE alongside'#-}++compound :: Lens s t a b+         -> Lens s' t' a' b'+         -> Lens (s,s') (t,t') (a,a') (b,b')+compound l r = lens (\(s, s') -> (view l s, view r s'))+                    (\(s, s') (t, t') -> (set l t s, set r t' s'))+{-# INLINE compound #-}++compound5 :: Lens s t a b+          -> Lens s' t' a' b'+          -> Lens s'' t'' a'' b''+          -> Lens s''' t''' a''' b'''+          -> Lens s'''' t'''' a'''' b''''+          -> Lens (s, (s', (s'', (s''', s''''))))+                  (t, (t', (t'', (t''', t''''))))+                  (a, (a', (a'', (a''', a''''))))+                  (b, (b', (b'', (b''', b''''))))+compound5 l l' l'' l''' l''''+  = lens (\(s, (s', (s'', (s''', s''''))))+           -> (view l s, (view l' s', (view l'' s'', (view l''' s''', view l'''' s'''')))) )+         (\(s, (s', (s'', (s''', s'''')))) (t, (t', (t'', (t''', t''''))))+           -> (set l t s, (set l' t' s', (set l'' t'' s'', (set l''' t''' s''', set l'''' t'''' s'''')))) )++main = defaultMain+    [ bench "alongside1" $ nf (view $ alongside _1 _2) (("hi", 1), (2, "there!"))+    , bench "trial1" $ nf (view $ trial _1 _2) (("hi", 1), (2, "there!"))+    , bench "half1" $ nf (view $ half _1 _2) (("hi", 1), (2, "there!"))+    , bench "compound1"  $ nf (view $ compound _1 _2) (("hi", 1), (2, "there!"))+    , bench "alongside5"  $ nf (view $ (alongside _1 (alongside _1 (alongside _1 (alongside _1 _1)))))+      ((v,v),((v,v),((v,v),((v,v),(v,v)))))+    , bench "trial5"  $ nf (view $ (trial _1 (trial _1 (trial _1 (trial _1 _1)))))+      ((v,v),((v,v),((v,v),((v,v),(v,v)))))+    , bench "half5"  $ nf (view $ (half _1 (half _1 (half _1 (half _1 _1)))))+      ((v,v),((v,v),((v,v),((v,v),(v,v)))))+    , bench "compound5"  $ nf (view $ compound5 _1 _1 _1 _1 _1)+      ((v,v),((v,v),((v,v),((v,v),(v,v)))))+    ]+  where v = 1 :: Int

@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}+import           Control.Applicative+import           Control.Lens+import           Control.DeepSeq+import           Criterion.Main+import           Data.Data+import           Data.Data.Lens as Data+#ifdef BENCHMARK_UNIPLATE+import qualified Data.Generics.Uniplate.Direct as Uni+import           Data.Generics.Uniplate.Direct ((|*))+import qualified Data.Generics.Uniplate.DataOnly as UniDataOnly+#endif+import           Generics.Deriving hiding (universe)+import           GHC.Generics.Lens as Generic++data Expr  =  Val !Int+           |  Var String+           |  Neg !Expr+           |  Add !Expr !Expr+           |  Sub !Expr !Expr+           |  Mul !Expr !Expr+           |  Div !Expr !Expr+           deriving (Eq,Show,Data,Typeable,Generic)++instance NFData Expr where+  rnf (Neg a)   = rnf a+  rnf (Add a b) = rnf a `seq` rnf b+  rnf (Sub a b) = rnf a `seq` rnf b+  rnf (Mul a b) = rnf a `seq` rnf b+  rnf (Div a b) = rnf a `seq` rnf b+  rnf (Val i)   = rnf i+  rnf (Var s)   = rnf s++instance Plated Expr where+  plate f (Neg a)   = Neg <$> f a+  plate f (Add a b) = Add <$> f a <*> f b+  plate f (Sub a b) = Sub <$> f a <*> f b+  plate f (Mul a b) = Mul <$> f a <*> f b+  plate f (Div a b) = Div <$> f a <*> f b+  plate _ t = pure t+  {-# INLINE plate #-}++#ifdef BENCHMARK_UNIPLATE+instance Uni.Uniplate Expr where+  uniplate (Neg a)   = Uni.plate Neg |* a+  uniplate (Add a b) = Uni.plate Add |* a |* b+  uniplate (Sub a b) = Uni.plate Sub |* a |* b+  uniplate (Mul a b) = Uni.plate Mul |* a |* b+  uniplate (Div a b) = Uni.plate Div |* a |* b+  uniplate (Val i)   = Uni.plate (Val i)+  uniplate (Var s)   = Uni.plate (Var s)+  {-# INLINE uniplate #-}+#endif++main :: IO ()+main = defaultMain+  [ bench "universe"                           $ nf (map universe) testsExpr+  , bench "universeOf plate"                   $ nf (map (universeOf plate)) testsExpr+  , bench "universeOf Generic.tinplate"        $ nf (map (universeOf Generic.tinplate)) testsExpr+  , bench "universeOf Data.tinplate"           $ nf (map (universeOf Data.tinplate)) testsExpr+  , bench "universeOf Data.template"           $ nf (map (universeOf Data.template)) testsExpr+  , bench "universeOf Data.uniplate"           $ nf (map (universeOf Data.uniplate)) testsExpr+  , bench "universeOf (cloneTraversal plate)"  $ nf (map (universeOf (cloneTraversal plate))) testsExpr+#ifdef BENCHMARK_UNIPLATE+  , bench "Direct.universe"                    $ nf (map Uni.universe) testsExpr+  , bench "DataOnly.universe"                  $ nf (map UniDataOnly.universe) testsExpr+#endif+  ]++testsExpr :: [Expr]+testsExpr = [Val 3,Val 2,Val 6,Neg (Neg (Var "dus")),Mul (Div (Add (Val 4) (Var "kxm")) (Sub (Mul (Div (Var "") (Var "")) (Var "w")) (Var "ed"))) (Var "whpd"),Val 6,Val 4,Val 2,Var "a",Val 1,Div (Var "") (Val 0),Var "",Var "",Val (-3),Val 3,Sub (Var "") (Val 2),Neg (Var "dlp"),Div (Val 0) (Var "sd"),Val (-2),Val (-3),Var "g",Mul (Val 3) (Var "i"),Val 1,Var "ul",Div (Add (Var "") (Var "")) (Mul (Div (Val 0) (Neg (Val 0))) (Neg (Neg (Mul (Var "") (Val 0))))),Var "z",Sub (Neg (Add (Var "") (Val 0))) (Var ""),Neg (Sub (Mul (Val 0) (Val 2)) (Val 5)),Val 0,Val 0,Mul (Val (-4)) (Sub (Val 5) (Neg (Div (Div (Val 0) (Sub (Neg (Sub (Val (-3)) (Mul (Mul (Var "ap") (Val 3)) (Add (Add (Add (Var "owre") (Add (Add (Var "avj") (Val 3)) (Var "vhi"))) (Mul (Val 2) (Var "hak"))) (Val 2))))) (Var "nf"))) (Add (Sub (Val 5) (Sub (Var "pkjyh") (Val 2))) (Var "lsiu"))))),Var "u",Val 1,Neg (Add (Add (Var "") (Val 1)) (Sub (Add (Add (Val (-3)) (Mul (Val 1) (Var "pfe"))) (Var "yv")) (Mul (Var "") (Var "jfq")))),Val 2,Div (Div (Div (Div (Var "xrgykq") (Mul (Var "kyfu") (Val 2))) (Sub (Var "v") (Val 0))) (Sub (Val 6) (Val 2))) (Val 3),Var "",Var "",Add (Var "ob") (Sub (Mul (Neg (Val 2)) (Val 6)) (Add (Mul (Val 6) (Sub (Add (Var "wue") (Mul (Var "hgsuj") (Neg (Div (Var "hr") (Var "ozvsb"))))) (Sub (Var "j") (Div (Var "yeyhvq") (Val (-6)))))) (Var "b"))),Div (Add (Div (Div (Neg (Val 4)) (Var "")) (Var "yfx")) (Div (Sub (Var "") (Sub (Var "np") (Mul (Val 3) (Var "mxr")))) (Mul (Var "m") (Var "kkhbf")))) (Neg (Sub (Var "yie") (Val 1))),Neg (Var ""),Var "liuh",Var "pbqg",Var "",Neg (Div (Sub (Add (Val (-1)) (Var "onynvr")) (Neg (Var "tqjsay"))) (Add (Val 4) (Var "yorkb"))),Val 1,Add (Mul (Neg (Div (Val (-1)) (Var "u"))) (Sub (Var "") (Neg (Val 1)))) (Var "h"),Var "",Add (Mul (Sub (Var "em") (Val 0)) (Add (Val (-2)) (Val 1))) (Var ""),Add (Mul (Add (Div (Add (Val 0) (Mul (Mul (Var "e") (Add (Val 1) (Var ""))) (Neg (Neg (Div (Add (Div (Neg (Val 1)) (Div (Val (-1)) (Mul (Add (Div (Val (-1)) (Mul (Mul (Val 1) (Val 1)) (Mul (Var "t") (Val (-1))))) (Val 1)) (Val 1)))) (Add (Neg (Add (Val 0) (Var "k"))) (Mul (Neg (Div (Sub (Sub (Var "u") (Val 1)) (Val 1)) (Sub (Neg (Var "")) (Sub (Var "b") (Val (-1)))))) (Neg (Var ""))))) (Val 0)))))) (Val 0)) (Var "a")) (Var "")) (Val (-1)),Var "xijsnp",Div (Var "h") (Neg (Val 5)),Div (Var "dmzlh") (Add (Val 6) (Val (-2))),Neg (Add (Val 0) (Var "")),Add (Add (Add (Sub (Val 4) (Var "nfse")) (Var "o")) (Add (Val 2) (Div (Var "mtqdx") (Val (-3))))) (Val 3),Neg (Var "c"),Var "sr",Mul (Add (Sub (Neg (Val 1)) (Sub (Div (Add (Sub (Add (Sub (Sub (Var "gd") (Mul (Var "v") (Var "d"))) (Var "")) (Val 1)) (Add (Val 2) (Var ""))) (Var "kk")) (Div (Var "fw") (Add (Val 1) (Var "f")))) (Var ""))) (Val 2)) (Add (Neg (Div (Var "") (Val 0))) (Add (Var "") (Add (Var "s") (Add (Mul (Var "") (Val (-1))) (Val 1))))),Val 1,Var "",Sub (Var "vbnzahx") (Val (-5)),Var "nl",Val 0,Add (Mul (Neg (Mul (Var "") (Var "mvil"))) (Var "")) (Neg (Var "zxl")),Val (-3),Var "",Var "e",Add (Div (Sub (Val 0) (Add (Val 5) (Val 7))) (Mul (Var "") (Var "qz"))) (Val 4),Add (Val (-1)) (Neg (Var "lk")),Add (Add (Var "u") (Mul (Val 1) (Var "h"))) (Sub (Mul (Div (Val 1) (Div (Var "t") (Neg (Var "")))) (Var "")) (Mul (Val 1) (Neg (Div (Neg (Var "")) (Var ""))))),Val 0,Val 0,Val (-7),Mul (Var "") (Val 0),Mul (Add (Val (-6)) (Add (Val 2) (Sub (Div (Var "z") (Var "gbb")) (Var "vddnpsl")))) (Add (Add (Add (Var "") (Sub (Div (Val 3) (Neg (Div (Add (Var "cfvgz") (Add (Sub (Var "htd") (Sub (Var "mhbl") (Var "un"))) (Val 3))) (Val (-3))))) (Var ""))) (Val 5)) (Neg (Mul (Val 0) (Var "sufvvj")))),Sub (Div (Neg (Add (Add (Neg (Add (Var "") (Val 0))) (Var "")) (Sub (Val 0) (Val 0)))) (Val 0)) (Add (Neg (Div (Div (Add (Sub (Add (Add (Neg (Var "")) (Val 0)) (Val 0)) (Add (Neg (Add (Neg (Var "")) (Neg (Val 0)))) (Val 0))) (Div (Val 0) (Val 0))) (Val 0)) (Val 0))) (Var "")),Var "",Sub (Div (Val 0) (Div (Add (Val 1) (Neg (Div (Neg (Var "y")) (Val 0)))) (Var ""))) (Sub (Div (Var "t") (Var "")) (Neg (Var "s"))),Mul (Div (Sub (Var "") (Var "")) (Add (Val 0) (Sub (Div (Var "yr") (Neg (Var "o"))) (Val 1)))) (Var "u"),Var "odmn",Div (Var "uddqy") (Val 3),Var "",Sub (Val 2) (Neg (Val (-1))),Div (Mul (Var "sox") (Val (-3))) (Val (-3)),Var "qv",Var "xmbnts",Var "j",Mul (Val 6) (Mul (Var "fryndq") (Neg (Val 6))),Var "",Var "",Val (-1),Val 7,Add (Var "dg") (Val 1),Neg (Val 1),Val 0,Var "xnm",Sub (Div (Div (Var "miwi") (Var "mbh")) (Val 3)) (Val 3),Neg (Val (-4)),Var "ndubxoa",Var ""]

@@ -0,0 +1,63 @@+{-# LANGUAGE BangPatterns #-}+module Main where++import Control.Lens+import Control.Lens.Internal+import Control.Exception++import Criterion.Main+import Criterion.Config++import GHC.Exts++overS :: ASetter s t a b -> (a -> b) -> s -> t+overS l f = runMutator . l (Mutator . f)+{-# INLINE overS #-}++mappedS :: ASetter [a] [b] a b+mappedS f = Mutator . map (runMutator . f)+{-# INLINE mappedS #-}++overU :: ASetter s t a b -> (a -> b) -> s -> t+overU = over+{-# INLINE overU #-}++mappedU :: ASetter [a] [b] a b+mappedU = mapped+{-# INLINE mappedU #-}+++-- Need to eta-expand for full inlining in the NOINLINE cases?+-- Doesn't seem to make a difference, though.++mapSN :: (a -> b) -> [a] -> [b]+mapSN f l = overS mappedS f l+{-# NOINLINE mapSN #-}++mapSI :: (a -> b) -> [a] -> [b]+mapSI f = overS mappedS f+{-# INLINE mapSI #-}++mapUN :: (a -> b) -> [a] -> [b]+mapUN f l = overU mappedU f l+{-# NOINLINE mapUN #-}++mapUI :: (a -> b) -> [a] -> [b]+mapUI f = overU mappedU f+{-# INLINE mapUI #-}++main :: IO ()+main = do+    let n = 1000+        l = replicate n "hi"; f = length+        --l = replicate n ();   f = (\ _ -> ())+        --l = replicate n ();   f = (\ !_ -> ()) -- strange results+        --l = replicate n ();   f = lazy (\_ -> ())+    defaultMainWith config (return ())+        [ bench "map   safe noinline" $ nf (mapSN f) l+        , bench "map   safe   inline" $ nf (mapSI f) l+        , bench "map unsafe noinline" $ nf (mapUN f) l+        , bench "map unsafe   inline" $ nf (mapUI f) l+        ]+  where+    config = defaultConfig { cfgSamples = ljust 1000 }

@@ -0,0 +1,45 @@+module Main+       ( main -- :: IO ()+       ) where++import Control.Lens+import Criterion.Main++main :: IO ()+main = defaultMain+  [ bgroup "rezip"+      [ bench "rezip"             $ nf tugAndRezip1 ['a'..'z']+      , bench "farthest leftward" $ nf tugAndRezip2 ['a'..'z']+      , bench "leftmost"          $ nf tugAndRezip3 ['a'..'z']+      , bench "tugTo"             $ nf tugAndRezip4 ['a'..'z']+      ]+  , bgroup "zipper creation"+      [ bench "over traverse id"  $ nf (over traverse id) ['a'..'z']+      , bench "zipper"            $ nf zipTraverseRezip   ['a'..'z']+      ]+  , bgroup "downward"+      [ bench "downward _1"       $ nf downwardAndRezip1 (['a'..'z'],['z'..'a'])+      , bench "fromWithin"        $ nf downwardAndRezip2 (['a'..'z'],['z'..'a'])+      ]+  ]++-- What's the fastest rezip of all?+tugAndRezip1, tugAndRezip2, tugAndRezip3 :: String -> String+tugAndRezip1 xs = zipntugs 25 xs & focus .~ 'a' & rezip+tugAndRezip2 xs = zipntugs 25 xs & focus .~ 'b' & farthest leftward & rezip+tugAndRezip3 xs = zipntugs 25 xs & focus .~ 'c' & leftmost & rezip+tugAndRezip4 xs = zipntugs 25 xs & focus .~ 'd' & tugTo 0 & rezip++zipntugs i x = zipper x & fromWithin traverse & tugs rightward i++-- How fast is creating and destroying a zipper compared to+-- a regular traversal?+zipTraverseRezip x = zipper x & fromWithin traverse & rezip++-- is 'downward' any faster than the composition of traverse?+downwardAndRezip1 :: (String, String) -> (String, String)+downwardAndRezip1 xs =+  zipper xs & downward _1 & fromWithin traverse & focus .~ 'h' & rezip+downwardAndRezip2 :: (String, String) -> (String, String)+downwardAndRezip2 xs =+  zipper xs & fromWithin (_1.traverse) & focus .~ 'g' & rezip

@@ -1,6 +1,6 @@ name:          lens category:      Data, Lenses-version:       3.8.3+version:       3.8.4 license:       BSD3 cabal-version: >= 1.8 license-file:  LICENSE@@ -264,6 +264,7 @@     Data.Typeable.Lens     Data.Vector.Lens     Data.Vector.Generic.Lens+    Generics.Deriving.Lens     GHC.Generics.Lens     System.Exit.Lens     System.FilePath.Lens@@ -275,25 +276,24 @@     cpp-options: -DSAFE=1    if flag(trustworthy) && impl(ghc>=7.2)+    other-extensions: Trustworthy     cpp-options: -DTRUSTWORTHY=1 -  if impl(ghc<7.4)-    ghc-options: -fno-spec-constr-count--  if impl(ghc>=7.6.0.20120810)-    if flag(old-inline-pragmas)+  if flag(old-inline-pragmas) && impl(ghc>=7.6.0.20120810)       cpp-options: -DOLD_INLINE_PRAGMAS=1    if flag(inlining)     cpp-options: -DINLINING -  if impl(ghc>=7.2)-    other-extensions: Trustworthy-    cpp-options: -DDEFAULT_SIGNATURES=1-   if flag(lib-Werror)     ghc-options: -Werror +  if impl(ghc<7.4)+    ghc-options: -fno-spec-constr-count++  if impl(ghc>=7.2)+    cpp-options: -DDEFAULT_SIGNATURES=1+   ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields   hs-source-dirs: src @@ -301,22 +301,24 @@ test-suite templates   type: exitcode-stdio-1.0   main-is: templates.hs-  build-depends:-    base,-    lens+  build-depends: base, lens   ghc-options: -Wall -threaded+  hs-source-dirs: tests+   if flag(dump-splices)     ghc-options: -ddump-splices+   if impl(ghc<7.6.1)     ghc-options: -Werror-  hs-source-dirs: tests + -- Verify the properties of lenses with QuickCheck test-suite properties   type: exitcode-stdio-1.0   main-is: properties.hs   ghc-options: -w -threaded -rtsopts -with-rtsopts=-N   hs-source-dirs: tests+   if !flag(test-properties)     buildable: False   else@@ -334,6 +336,7 @@   main-is: hunit.hs   ghc-options: -w -threaded -rtsopts -with-rtsopts=-N   hs-source-dirs: tests+   if !flag(test-hunit)     buildable: False   else@@ -349,8 +352,11 @@  -- Verify the results of the examples test-suite doctests-  type:    exitcode-stdio-1.0-  main-is: doctests.hs+  type:           exitcode-stdio-1.0+  main-is:        doctests.hs+  ghc-options:    -Wall -threaded+  hs-source-dirs: tests+   if !flag(test-doctests)     buildable: False   else@@ -358,50 +364,49 @@       base,       bytestring,       containers,-      directory >= 1.0,+      directory      >= 1.0,       deepseq,-      doctest >= 0.9.1,+      doctest        >= 0.9.1,       filepath,       mtl,       nats,       parallel,-      semigroups >= 0.9,+      semigroups     >= 0.9,       simple-reflect >= 0.3.1,       split,       text,       unordered-containers,       vector -  ghc-options: -Wall -threaded   if impl(ghc<7.6.1)     ghc-options: -Werror-  hs-source-dirs: tests + -- Basic benchmarks for the uniplate-style combinators benchmark plated-  type: exitcode-stdio-1.0-  main-is: plated.hs+  type:           exitcode-stdio-1.0+  main-is:        plated.hs+  ghc-options:    -Wall -O2 -threaded -fdicts-cheap -funbox-strict-fields+  hs-source-dirs: benchmarks   build-depends:     base,     comonad,     criterion,     deepseq,+    generic-deriving,     lens,     transformers-  if impl(ghc>=7.2)-    build-depends: ghc-prim-  else-    build-depends: generic-deriving-  ghc-options: -Wall -O2 -threaded -fdicts-cheap -funbox-strict-fields-  hs-source-dirs: benchmarks+   if flag(benchmark-uniplate)     build-depends: uniplate >= 1.6.7 && < 1.7     cpp-options: -DBENCHMARK_UNIPLATE  -- Benchmarking alongside variants benchmark alongside-  type: exitcode-stdio-1.0-  main-is: alongside.hs+  type:           exitcode-stdio-1.0+  main-is:        alongside.hs+  ghc-options:    -w -O2 -threaded -fdicts-cheap -funbox-strict-fields+  hs-source-dirs: benchmarks   build-depends:     base,     comonad,@@ -410,37 +415,36 @@     deepseq,     lens,     transformers-  ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields-  hs-source-dirs: benchmarks  -- Benchmarking unsafe implementation strategies benchmark unsafe-  type: exitcode-stdio-1.0-  main-is: unsafe.hs+  type:           exitcode-stdio-1.0+  main-is:        unsafe.hs+  ghc-options:    -w -O2 -threaded -fdicts-cheap -funbox-strict-fields+  hs-source-dirs: benchmarks   build-depends:     base,     comonad,     comonads-fd,     criterion,     deepseq,-    ghc-prim,+    generic-deriving,     lens,     transformers-  ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields-  hs-source-dirs: benchmarks + -- Benchmarking zipper usage benchmark zipper-  type: exitcode-stdio-1.0-  main-is: zipper.hs+  type:           exitcode-stdio-1.0+  main-is:        zipper.hs+  ghc-options:    -w -O2 -threaded -fdicts-cheap -funbox-strict-fields+  hs-source-dirs: benchmarks   build-depends:     base,     comonad,     comonads-fd,     criterion,     deepseq,-    ghc-prim,+    generic-deriving,     lens,     transformers-  ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields-  hs-source-dirs: benchmarks

@@ -55,7 +55,8 @@ import Data.Profunctor.Unsafe  -- $setup--- >>> :m + Control.Lens+-- >>> :set -XNoOverloadedStrings+-- >>> import Control.Lens  infixr 8 ^!, ^!!, ^@!, ^@!!, ^!?, ^@!? 

@@ -22,6 +22,7 @@ -- >>> import Control.Monad.State -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f)+-- >>> :set -XNoOverloadedStrings -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f  infixl 1 &, <&>, ??

@@ -61,6 +61,7 @@ import           Data.Word  -- $setup+-- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g)

@@ -147,17 +147,18 @@ import Data.Traversable  -- $setup+-- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Data.Function -- >>> import Data.List.Lens -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g)--- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f--- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g -- >>> import Control.DeepSeq (NFData (..), force) -- >>> import Control.Exception (evaluate) -- >>> import Data.Maybe (fromMaybe) -- >>> import System.Timeout (timeout)+-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f+-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g -- >>> let timingOut :: NFData a => a -> IO a; timingOut = fmap (fromMaybe (error "timeout")) . timeout (5*10^6) . evaluate . force  {-# ANN module "HLint: ignore Eta reduce" #-}

@@ -49,6 +49,7 @@ import Data.Profunctor.Unsafe  -- $setup+-- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Data.Char 

@@ -123,6 +123,7 @@ {-# ANN module "HLint: ignore Use ***" #-}  -- $setup+-- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g,h)

@@ -28,6 +28,7 @@ import Data.Profunctor.Unsafe  -- $setup+-- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Data.Char 

@@ -32,7 +32,7 @@   , (^?!), (^@?!)    -- * Reviewing-  , (#)+  , ( # )    -- * Common Operators   -- ** Setting

@@ -24,7 +24,7 @@   , re   , review, reviews   , reuse, reuses-  , (#)+  , ( # )   -- * Reviewable Profunctors   , Reviewable(..)   ) where@@ -158,8 +158,9 @@ -- ('#') :: 'Review''   s a -> a -> s -- ('#') :: 'Equality'' s a -> a -> s -- @-(#) :: AReview s t a b -> b -> t-(#) p = runIdentity #. runReviewed #. p .# Reviewed .# Identity+( # ) :: AReview s t a b -> b -> t+( # ) p = runIdentity #. runReviewed #. p .# Reviewed .# Identity+{-# INLINE ( # ) #-}  -- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'view' a value (or the current environment) through it the other way, -- applying a function.

@@ -101,6 +101,7 @@ -- >>> let h :: Expr -> Expr -> Expr; h = Vars.h -- >>> let getter :: Expr -> Expr; getter = fun "getter" -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter"+-- >>> :set -XNoOverloadedStrings  infixr 4 %@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, <.~, ?~, <?~ infix  4 %@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, <.=, ?=, <?=

@@ -132,6 +132,7 @@ import Prelude hiding ((.),id)  -- $setup+-- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens -- >>> import Control.DeepSeq (NFData (..), force) -- >>> import Control.Exception (evaluate)

@@ -91,4 +91,5 @@ import Control.Lens.Internal.Zipper  -- $setup--- >>> :m + Control.Lens+-- >>> :set -XNoOverloadedStrings+-- >>> import Control.Lens

@@ -22,6 +22,10 @@ import Data.Word (Word8) import Data.Int (Int64) +-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Numeric.Lens+ -- | 'Data.ByteString.Lazy.pack' (or 'Data.ByteString.Lazy.unpack') a list of bytes into a 'ByteString'. -- -- @@@ -31,7 +35,7 @@ -- @ -- -- >>> [104,101,108,108,111]^.packedBytes--- "hello"+-- Chunk "hello" Empty packedBytes :: Iso' [Word8] ByteString packedBytes = iso Words.pack unpackLazy {-# INLINE packedBytes #-}@@ -78,7 +82,7 @@ -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'from' 'packedChars' -- @ ----- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if length x == 1 then '0':x else x)+-- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if Prelude.length x == 1 then '0':x else x) -- "68656c6c6f" packedChars :: Iso' String ByteString packedChars = iso Char8.pack unpackLazy8

@@ -24,6 +24,7 @@  -- $setup -- >>> import Control.Lens+-- >>> import Numeric.Lens  -- | 'Data.ByteString.pack' (or 'Data.ByteString.unpack') a list of bytes into a 'ByteString' --@@ -81,7 +82,7 @@ -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'from' 'packedChars' -- @ ----- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if length x == 1 then '0':x else x)+-- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if Prelude.length x == 1 then '0':x else x) -- "68656c6c6f" packedChars :: Iso' String ByteString packedChars = iso Char8.pack unpackStrict8

@@ -70,6 +70,7 @@ {-# ANN module "HLint: ignore Reduce duplication" #-}  -- $setup+-- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens  -------------------------------------------------------------------------------

@@ -13,8 +13,12 @@ -- ---------------------------------------------------------------------------- module Data.List.Lens-  ( strippingPrefix-  , strippingSuffix, stripSuffix+  ( prefixed+  , suffixed+  , stripSuffix+  -- * Deprecated+  , strippingPrefix+  , strippingSuffix   ) where  import Control.Monad (guard)@@ -23,6 +27,7 @@ import Data.List  -- $setup+-- >>> :set -XNoOverloadedStrings -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f@@ -31,33 +36,37 @@ -- | A 'Prism' stripping a prefix from a list when used as a 'Traversal', or -- prepending that prefix when run backwards: ----- >>> "preview" ^? strippingPrefix "pre"+-- >>> "preview" ^? prefixed "pre" -- Just "view" ----- >>> "review" ^? strippingPrefix "pre"+-- >>> "review" ^? prefixed "pre" -- Nothing ----- >>> "amble"^.re (strippingPrefix "pre")+-- >>> prefixed "pre" # "amble" -- "preamble"-strippingPrefix :: Eq a => [a] -> Prism' [a] [a]-strippingPrefix ps = prism' (ps ++) (stripPrefix ps)-{-# INLINE strippingPrefix #-}+prefixed :: Eq a => [a] -> Prism' [a] [a]+prefixed ps = prism' (ps ++) (stripPrefix ps)+{-# INLINE prefixed #-}  -- | A 'Prism' stripping a suffix from a list when used as a 'Traversal', or -- prepending that prefix when run backwards: ----- >>> "review" ^? strippingSuffix "view"+-- >>> "review" ^? suffixed "view" -- Just "re" ----- >>> "review" ^? strippingSuffix "tire"+-- >>> "review" ^? suffixed "tire" -- Nothing ----- >>> "hello"^.re (strippingSuffix ".o")+-- >>> suffixed ".o" # "hello" -- "hello.o"-strippingSuffix :: Eq a => [a] -> Prism' [a] [a]-strippingSuffix qs = prism' (++ qs) (stripSuffix qs)-{-# INLINE strippingSuffix #-}+suffixed :: Eq a => [a] -> Prism' [a] [a]+suffixed qs = prism' (++ qs) (stripSuffix qs)+{-# INLINE suffixed #-} +------------------------------------------------------------------------------+-- Util+------------------------------------------------------------------------------+ stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] stripSuffix qs xs0 = go xs0 zs   where@@ -69,3 +78,16 @@     go xs [] = zipWith const xs0 zs <$ guard (xs == qs)     go [] _  = Nothing -- impossible {-# INLINE stripSuffix #-}++-- | This is a deprecated alias for 'prefixed'.+strippingPrefix :: Eq a => [a] -> Prism' [a] [a]+strippingPrefix = prefixed+{-# INLINE strippingPrefix #-}+{-# DEPRECATED strippingPrefix "Use 'prefixed'." #-}++-- | This is a deprecated alias for 'suffixed'.+strippingSuffix :: Eq a => [a] -> Prism' [a] [a]+strippingSuffix = suffixed+{-# INLINE strippingSuffix #-}+{-# DEPRECATED strippingSuffix "Use 'suffixed'." #-}+

@@ -23,93 +23,12 @@ -- and probably won't be explicitly referencing 'Control.Lens.Representable.Rep' from @Control.Lens@ -- in code that uses generics. ----- If you're using a version of GHC older than 7.2, this module is--- compatible with the+-- This module provides compatibility with older GHC versions by using the -- <http://hackage.haskell.org/package/generic-deriving generic-deriving> -- package. ---------------------------------------------------------------------------- module GHC.Generics.Lens-  (-  -- * Isomorphisms for @GHC.Generics@-    generic-  , generic1-  -- * Generic Traversal-  , tinplate-  , GTraversal+  ( module Generics.Deriving.Lens   ) where -import           Control.Applicative-import           Control.Lens-import           Data.Maybe (fromJust)-import           Data.Typeable-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-import qualified GHC.Generics as Generic-import           GHC.Generics hiding (from, to)-#else-import qualified Generics.Deriving as Generic-import           Generics.Deriving hiding (from, to)-#endif---- | Convert from the data type to its representation (or back)------ >>> "hello"^.generic.from generic :: String--- "hello"----generic :: Generic a => Iso' a (Rep a b)-generic = iso Generic.from Generic.to-{-# INLINE generic #-}---- | Convert from the data type to its representation (or back)-generic1 :: Generic1 f => Iso' (f a) (Rep1 f a)-generic1 = iso from1 to1-{-# INLINE generic1 #-}---- | A 'GHC.Generics.Generic' 'Traversal' that visits every occurrence--- of something 'Typeable' anywhere in a container.------ >>> allOf tinplate (=="Hello") (1::Int,2::Double,(),"Hello",["Hello"])--- True------ >>> mapMOf_ tinplate putStrLn ("hello",[(2 :: Int, "world!")])--- hello--- world!-tinplate :: (Generic a, GTraversal (Rep a), Typeable b) => Traversal' a b-tinplate = generic . tinplated True-{-# INLINE tinplate #-}--maybeArg1Of :: Maybe c -> (c -> d) -> Maybe c-maybeArg1Of = const-{-# INLINE maybeArg1Of #-}---- | Used to traverse 'Generic' data by 'uniplate'.-class GTraversal f where-  tinplated :: Typeable b => Bool -> Traversal' (f a) b--instance (Generic a, GTraversal (Rep a), Typeable a) => GTraversal (K1 i a) where-  tinplated rec f (K1 a) = case cast a `maybeArg1Of` f of-    Just b  -> K1 . fromJust . cast <$> f b-    Nothing | rec       -> K1 <$> fmap generic (tinplated False) f a-            | otherwise -> pure $ K1 a-  {-# INLINE tinplated #-}--instance GTraversal U1 where-  tinplated _ _ U1 = pure U1-  {-# INLINE tinplated #-}--instance (GTraversal f, GTraversal g) => GTraversal (f :*: g) where-  tinplated _ f (x :*: y) = (:*:) <$> tinplated True f x <*> tinplated True f y-  {-# INLINE tinplated #-}--instance (GTraversal f, GTraversal g) => GTraversal (f :+: g) where-  tinplated _ f (L1 x) = L1 <$> tinplated True f x-  tinplated _ f (R1 x) = R1 <$> tinplated True f x-  {-# INLINE tinplated #-}--instance GTraversal a => GTraversal (M1 i c a) where-  tinplated rec f (M1 x) = M1 <$> tinplated rec f x-  {-# INLINE tinplated #-}---- ?-instance (Traversable f, GTraversal g) => GTraversal (f :.: g) where-  tinplated _ f (Comp1 fgp) = Comp1 <$> traverse (tinplated True f) fgp-  {-# INLINE tinplated #-}+import Generics.Deriving.Lens

@@ -0,0 +1,104 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.Deriving.Lens+-- Copyright   :  (C) 2012-13 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  GHC+--+-- Note: @Generics.Deriving@ exports a number of names that collide with @Control.Lens@.+--+-- You can use hiding or imports to mitigate this to an extent, and the following imports,+-- represent a fair compromise for user code:+--+-- > import Control.Lens hiding (Rep)+-- > import Generics.Deriving hiding (from, to)+--+-- You can use 'generic' to replace 'Generics.Deriving.from' and 'Generics.Deriving.to' from @Generics.Deriving@,+-- and probably won't be explicitly referencing 'Control.Lens.Representable.Rep' from @Control.Lens@+-- in code that uses generics.+----------------------------------------------------------------------------+module Generics.Deriving.Lens+  (+  -- * Isomorphisms for @GHC.Generics@+    generic+  , generic1+  -- * Generic Traversal+  , tinplate+  , GTraversal+  ) where++import           Control.Applicative+import           Control.Lens+import           Data.Maybe (fromJust)+import           Data.Typeable+import qualified Generics.Deriving as Generic+import           Generics.Deriving hiding (from, to)++-- | Convert from the data type to its representation (or back)+--+-- >>> "hello"^.generic.from generic :: String+-- "hello"+generic :: Generic a => Iso' a (Generic.Rep a b)+generic = iso Generic.from Generic.to+{-# INLINE generic #-}++-- | Convert from the data type to its representation (or back)+generic1 :: Generic1 f => Iso' (f a) (Rep1 f a)+generic1 = iso from1 to1+{-# INLINE generic1 #-}++-- | A 'GHC.Generics.Generic' 'Traversal' that visits every occurrence+-- of something 'Typeable' anywhere in a container.+--+-- >>> allOf tinplate (=="Hello") (1::Int,2::Double,(),"Hello",["Hello"])+-- True+--+-- >>> mapMOf_ tinplate putStrLn ("hello",[(2 :: Int, "world!")])+-- hello+-- world!+tinplate :: (Generic a, GTraversal (Generic.Rep a), Typeable b) => Traversal' a b+tinplate = generic . tinplated True+{-# INLINE tinplate #-}++maybeArg1Of :: Maybe c -> (c -> d) -> Maybe c+maybeArg1Of = const+{-# INLINE maybeArg1Of #-}++-- | Used to traverse 'Generic' data by 'uniplate'.+class GTraversal f where+  tinplated :: Typeable b => Bool -> Traversal' (f a) b++instance (Generic a, GTraversal (Generic.Rep a), Typeable a) => GTraversal (K1 i a) where+  tinplated rec f (K1 a) = case cast a `maybeArg1Of` f of+    Just b  -> K1 . fromJust . cast <$> f b+    Nothing | rec       -> K1 <$> fmap generic (tinplated False) f a+            | otherwise -> pure $ K1 a+  {-# INLINE tinplated #-}++instance GTraversal U1 where+  tinplated _ _ U1 = pure U1+  {-# INLINE tinplated #-}++instance (GTraversal f, GTraversal g) => GTraversal (f :*: g) where+  tinplated _ f (x :*: y) = (:*:) <$> tinplated True f x <*> tinplated True f y+  {-# INLINE tinplated #-}++instance (GTraversal f, GTraversal g) => GTraversal (f :+: g) where+  tinplated _ f (L1 x) = L1 <$> tinplated True f x+  tinplated _ f (R1 x) = R1 <$> tinplated True f x+  {-# INLINE tinplated #-}++instance GTraversal a => GTraversal (M1 i c a) where+  tinplated rec f (M1 x) = M1 <$> tinplated rec f x+  {-# INLINE tinplated #-}++-- ?+instance (Traversable f, GTraversal g) => GTraversal (f :.: g) where+  tinplated _ f (Comp1 fgp) = Comp1 <$> traverse (tinplated True f) fgp+  {-# INLINE tinplated #-}

@@ -0,0 +1,71 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (doctests)+-- Copyright   :  (C) 2012-13 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- This module provides doctests for a project based on the actual versions+-- of the packages it was built with. It requires a corresponding Setup.lhs+-- to be added to the project+-----------------------------------------------------------------------------+module Main where++import Build_doctests (deps)+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++##if defined(i386_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##elif defined(x64_64_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##endif++-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+##ifdef USE_CP+withUnicode m = do+  cp <- c_GetConsoleCP+  (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp+##else+withUnicode m = m+##endif++main :: IO ()+main = withUnicode $ getSources >>= \sources -> doctest $+    "-isrc"+  : "-idist/build/autogen"+  : "-optP-include"+  : "-optPdist/build/autogen/cabal_macros.h"+  : "-hide-all-packages"+  : map ("-package="++) deps ++ sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+  where+    go dir = do+      (dirs, files) <- getFilesAndDirectories dir+      (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c

@@ -0,0 +1,279 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (hunit)+-- Copyright   :  (C) 2012-13 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- This module provides a simple hunit test suite for lens.+--+-- The code attempts to enumerate common use cases rather than give an example+-- of each available lens function. The tests here merely scratch the surface+-- of what is possible using the lens package; there are a great many use cases+-- (and lens functions) that aren't covered.+-----------------------------------------------------------------------------+module Main where++import Control.Lens+import Control.Monad.State+import Data.Char+import Data.List as List+import Data.Monoid+import Data.Map as Map+import Test.Framework.Providers.HUnit+import Test.Framework.TH+import Test.Framework+import Test.HUnit hiding (test)+++data Point =+  Point+  { _x :: Int -- ^ X coordinate+  , _y :: Int -- ^ Y coordinate+  } deriving (Show, Eq, Ord)++makeLenses ''Point++data Box =+  Box+  { _low :: Point  -- ^ The lowest used coordinates.+  , _high :: Point -- ^ The highest used coordinates.+  } deriving (Show, Eq)++makeLenses ''Box++data Polygon =+  Polygon+  { _points :: [ Point ]+  , _labels :: Map Point String+  , _box :: Box+  } deriving (Show, Eq)++makeLenses ''Polygon++data Shape = SBox Box | SPolygon Polygon | SCircle Point Int | SVoid+makePrisms ''Shape++origin =+  Point { _x = 0, _y = 0 }++vectorFrom fromPoint toPoint =+  Point+  { _x = toPoint^.x - fromPoint^.x+  , _y = toPoint^.y - fromPoint^.y+  }++trig =+  Polygon+  { _points = [ Point { _x = 0, _y = 0 }+              , Point { _x = 4, _y = 7 }+              , Point { _x = 8, _y = 0 } ]+  , _labels = fromList [ (Point { _x = 0, _y = 0 }, "Origin")+                       , (Point { _x = 4, _y = 7 }, "Peak") ]+  , _box = Box { _low = Point { _x = 0, _y = 0 }+               , _high = Point { _x = 8, _y = 7 } }+  }++case_read_record_field =+  (trig^.box.high.y)+    @?= 7++case_read_state_record_field =+  runState test trig @?= (7, trig)+  where+    test = use $ box.high.y++case_read_record_field_and_apply_function =+  (trig^.points.to last.to (vectorFrom origin).x)+    @?= 8++case_read_state_record_field_and_apply_function =+  runState test trig @?= (8, trig)+  where test = use $ points.to last.to (vectorFrom origin).x++case_write_record_field =+  (trig & box.high.y .~ 6)+    @?= trig { _box = (trig & _box)+               { _high = (trig & _box & _high)+                         { _y = 6 } } }++case_write_state_record_field = do+  let trig' = trig { _box = (trig & _box)+                            { _high = (trig & _box & _high)+                                      { _y = 6 } } }+  runState test trig @?= ((), trig')+  where+    test = box.high.y .= 6++case_write_record_field_and_access_new_value =+  (trig & box.high.y <.~ 6)+    @?= (6, trig { _box = (trig & _box)+                          { _high = (trig & _box & _high)+                                    { _y = 6 } } })++case_write_state_record_field_and_access_new_value = do+  let trig' = trig { _box = (trig & _box)+                            { _high = (trig & _box & _high)+                                      { _y = 6 } } }+  runState test trig @?= (6, trig')+  where+    test = box.high.y <.= 6++case_write_record_field_and_access_old_value =+  (trig & box.high.y <<.~ 6)+    @?= (7, trig { _box = (trig & _box)+                          { _high = (trig & _box & _high)+                                    { _y = 6 } } })++case_write_state_record_field_and_access_old_value = do+  let trig' = trig { _box = (trig & _box)+                            { _high = (trig & _box & _high)+                                      { _y = 6 } } }+  runState test trig @?= (7, trig')+  where+    test = box.high.y <<.= 6++case_modify_record_field =+  (trig & box.low.y %~ (+ 2))+    @?= trig { _box = (trig & _box)+                      { _low = (trig & _box & _low)+                               { _y = ((trig & _box & _low & _y) + 2) } } }++case_modify_state_record_field = do+  let trig' = trig { _box = (trig & _box)+                            { _low = (trig & _box & _low)+                                     { _y = ((trig & _box & _low & _y) + 2) } } }+  runState test trig @?= ((), trig')+  where+    test = box.low.y %= (+ 2)++case_modify_record_field_and_access_new_value =+  (trig & box.low.y <%~ (+ 2))+    @?= (2, trig { _box = (trig & _box)+                          { _low = (trig & _box & _low)+                                   { _y = ((trig & _box & _low & _y) + 2) } } })++case_modify_state_record_field_and_access_new_value = do+  let trig' = trig { _box = (trig & _box)+                            { _low = (trig & _box & _low)+                                     { _y = ((trig & _box & _low & _y) + 2) } } }+  runState test trig @?= (2, trig')+  where+    test = box.low.y <%= (+ 2)++case_modify_record_field_and_access_old_value =+  (trig & box.low.y <<%~ (+ 2))+    @?= (0, trig { _box = (trig & _box)+                          { _low = (trig & _box & _low)+                                   { _y = ((trig & _box & _low & _y) + 2) } } })++case_modify_state_record_field_and_access_old_value = do+  let trig' = trig { _box = (trig & _box)+                            { _low = (trig & _box & _low)+                                     { _y = ((trig & _box & _low & _y) + 2) } } }+  runState test trig @?= (0, trig')+  where+    test = box.low.y <<%= (+ 2)++case_modify_record_field_and_access_side_result = do+  runState test trig @?= (8, trig')+  where+    test = box.high %%= modifyAndCompute+    modifyAndCompute point =+      (point ^. x, point & y +~ 2)+    trig' = trig { _box = (trig & _box)+                            { _high = (trig & _box & _high)+                                      { _y = ((trig & _box & _high & _y) + 2) } } }++case_increment_record_field =+  (trig & box.low.y +~ 1) -- And similarly for -~ *~ //~ ^~ ^^~ **~ ||~ &&~+    @?= trig { _box = (trig & _box)+                      { _low = (trig & _box & _low)+                               { _y = ((trig & _box & _low & _y) + 1) } } }++case_increment_state_record_field =+  runState test trig @?= ((), trig')+  where+    test = box.low.y += 1+    trig' = trig { _box = (trig & _box)+                   { _low = (trig & _box & _low)+                     { _y = ((trig & _box & _low & _y) + 1) } } }++case_append_to_record_field =+  (trig & points <>~ [ origin ])+    @?= trig { _points = (trig & _points) <> [ origin ] }++case_append_to_state_record_field = do+  runState test trig @?= ((), trig')+  where+    test = points <>= [ origin ]+    trig' = trig { _points = (trig & _points) <> [ origin ] }++case_append_to_record_field_and_access_new_value =+  (trig & points <<>~ [ origin ])+    @?= (_points trig <> [ origin ], trig { _points = (trig & _points) <> [ origin ] })++case_append_to_state_record_field_and_access_new_value = do+  runState test trig @?= (_points trig <> [ origin ], trig')+  where+    test = points <<>= [ origin ]+    trig' = trig { _points = (trig & _points) <> [ origin ] }++case_append_to_record_field_and_access_old_value =+  (trig & points <<%~ (<>[origin]))+    @?= (_points trig, trig { _points = (trig & _points) <> [ origin ] })++case_append_to_state_record_field_and_access_old_value = do+  runState test trig @?= (_points trig, trig')+  where+    test = points <<%= (<>[origin])+    trig' = trig { _points = (trig & _points) <> [ origin ] }++case_read_maybe_map_entry = trig^.labels.at origin @?= Just "Origin"++case_read_maybe_state_map_entry =+  runState test trig @?= (Just "Origin", trig)+  where test = use $ labels.at origin++case_read_map_entry = trig^.labels.ix origin @?= "Origin"++case_read_state_map_entry = runState test trig @?= ("Origin", trig)+  where test = use $ labels.ix origin++case_modify_map_entry =+  (trig & labels.ix origin %~ List.map toUpper)+    @?= trig { _labels = fromList [ (Point { _x = 0, _y = 0 }, "ORIGIN")+                                  , (Point { _x = 4, _y = 7 }, "Peak") ] }++case_insert_maybe_map_entry =+  (trig & labels.at (Point { _x = 8, _y = 0 }) .~ Just "Right")+    @?= trig { _labels = fromList [ (Point { _x = 0, _y = 0 }, "Origin")+                                  , (Point { _x = 4, _y = 7 }, "Peak")+                                  , (Point { _x = 8, _y = 0 }, "Right") ] }++case_delete_maybe_map_entry =+  (trig & labels.at origin .~ Nothing)+    @?= trig { _labels = fromList [ (Point { _x = 4, _y = 7 }, "Peak") ] }++case_read_list_entry =+  (trig ^? points.element 0)+    @?= Just origin++case_write_list_entry =+  (trig & points.element 0 .~ Point { _x = 2, _y = 0 })+    @?= trig { _points = [ Point { _x = 2, _y = 0 }+                         , Point { _x = 4, _y = 7 }+                         , Point { _x = 8, _y = 0 } ] }++case_write_through_list_entry =+  (trig & points.element 0 . x .~ 2)+    @?= trig { _points = [ Point { _x = 2, _y = 0 }+                         , Point { _x = 4, _y = 7 }+                         , Point { _x = 8, _y = 0 } ] }++main :: IO ()+main = defaultMain [$testGroupGenerator]

@@ -0,0 +1,195 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE LiberalTypeSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (properties)+-- Copyright   :  (C) 2012-13 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- This module provides a set of QuickCheck properties that can be run through+-- test-framework to validate a number of expected behaviors of the library.+-----------------------------------------------------------------------------+module Main where+++import Control.Applicative+import Control.Lens+import Test.QuickCheck+import Test.QuickCheck.Function+import Test.Framework.TH+import Test.Framework.Providers.QuickCheck2+import Data.Char (isAlphaNum, isAscii, toUpper)+import Data.Text.Strict.Lens+import Data.Maybe+import Data.List.Lens+import Data.Functor.Compose+import Numeric (showHex, showOct, showSigned)+import Numeric.Lens+++-- The first setter law:+setter_id :: Eq s => Setter' s a -> s -> Bool+setter_id l s = over l id s == s++--  The second setter law:+setter_composition :: Eq s => Setter' s a -> s -> Fun a a -> Fun a a -> Bool+setter_composition l s (Fun _ f) (Fun _ g) = over l f (over l g s) == over l (f . g) s++lens_set_view :: Eq s => Lens' s a -> s -> Bool+lens_set_view l s = set l (view l s) s == s++lens_view_set :: Eq a => Lens' s a -> s -> a -> Bool+lens_view_set l s a = view l (set l a s) == a++setter_set_set :: Eq s => Setter' s a -> s -> a -> a -> Bool+setter_set_set l s a b = set l b (set l a s) == set l b s++iso_hither :: Eq s => Simple AnIso s a -> s -> Bool+iso_hither l s = s ^.cloneIso l.from l == s++iso_yon :: Eq a => Simple AnIso s a -> a -> Bool+iso_yon l a = a^.from l.cloneIso l == a++prism_yin :: Eq a => Prism' s a -> a -> Bool+prism_yin l a = preview l (review l a) == Just a++prism_yang :: Eq s => Prism' s a -> s -> Bool+prism_yang l s = maybe s (review l) (preview l s) == s++traverse_pure :: forall f s a. (Applicative f, Eq (f s)) => LensLike' f s a -> s -> Bool+traverse_pure l s = l pure s == (pure s :: f s)++traverse_pureMaybe :: Eq s => LensLike' Maybe s a -> s -> Bool+traverse_pureMaybe = traverse_pure++traverse_pureList :: Eq s => LensLike' [] s a -> s -> Bool+traverse_pureList = traverse_pure++traverse_compose :: (Applicative f, Applicative g, Eq (f (g s)))+                    => Traversal' s a -> (a -> g a) -> (a -> f a) -> s -> Bool+traverse_compose t f g s = (fmap (t f) . t g) s == (getCompose . t (Compose . fmap f . g)) s++isSetter :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Function a)+         => Setter' s a -> Property+isSetter l = setter_id l .&. setter_composition l .&. setter_set_set l++isTraversal :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Function a)+         => Traversal' s a -> Property+isTraversal l = isSetter l .&. traverse_pureMaybe l .&. traverse_pureList l+                  .&. do as <- arbitrary+                         bs <- arbitrary+                         t <- arbitrary+                         property $ traverse_compose l (\x -> as++[x]++bs)+                                                       (\x -> if t then Just x else Nothing)++isLens :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a)+       => Lens' s a -> Property+isLens l = lens_set_view l .&. lens_view_set l .&. isTraversal l++isIso :: (Arbitrary s, Arbitrary a, CoArbitrary s, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function s, Function a)+      => Iso' s a -> Property+isIso l = iso_hither l .&. iso_yon l .&. isLens l .&. isLens (from l)++isPrism :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a)+      => Prism' s a -> Property+isPrism l = isTraversal l .&. prism_yin l .&. prism_yang l++-- an illegal lens+bad :: Lens' (Int,Int) Int+bad f (a,b) = (,) b <$> f a++badIso :: Iso' Int Bool+badIso = iso even fromEnum++-- Control.Lens.Type+prop_1                               = isLens (_1 :: Lens' (Int,Double,()) Int)+prop_2                               = isLens (_2 :: Lens' (Int,Bool) Bool)+prop_3                               = isLens (_3 :: Lens' (Int,Bool,()) ())+prop_4                               = isLens (_4 :: Lens' (Int,Bool,(),Maybe Int) (Maybe Int))+prop_5                               = isLens (_5 :: Lens' ((),(),(),(),Int) Int)++prop_2_2                             = isLens (_2._2 :: Lens' (Int,(Int,Bool),Double) Bool)++-- prop_illegal_lens                    = expectFailure $ isLens bad+-- prop_illegal_traversal               = expectFailure $ isTraversal bad+-- prop_illegal_setter                  = expectFailure $ isSetter bad+-- prop_illegal_iso                     = expectFailure $ isIso badIso++-- Control.Lens.Setter+prop_mapped                          = isSetter (mapped :: Setter' [Int] Int)+prop_mapped_mapped                   = isSetter (mapped.mapped :: Setter' [Maybe Int] Int)++prop_both                            = isTraversal (both           :: Traversal' (Int,Int) Int)+prop_value (Fun _ k :: Fun Int Bool) = isTraversal (each.indices k :: Traversal' (Int, Int) Int)+prop_traverseLeft                    = isTraversal (_Left          :: Traversal' (Either Int Bool) Int)+prop_traverseRight                   = isTraversal (_Right         :: Traversal' (Either Int Bool) Bool)++prop_simple                          = isIso (simple :: Iso' Int Int)+--prop_enum                            = isIso (enum :: Iso' Int Char)++prop__Left                           = isPrism (_Left :: Prism' (Either Int Bool) Int)+prop__Right                          = isPrism (_Right :: Prism' (Either Int Bool) Bool)+prop__Just                           = isPrism (_Just :: Prism' (Maybe Int) Int)++-- Data.List.Lens+prop_strippingPrefix s               = isPrism (strippingPrefix s :: Prism' String String)++-- Data.Text.Lens+prop_text s                          = s^.packed.from packed == s+--prop_text                           = isIso packed++-- Numeric.Lens+prop_base_show (n :: Integer) =+  conjoin [ show n == n ^. re (base 10)+          , showSigned showOct 0 n "" == n ^. re (base 8)+          , showSigned showHex 0 n "" == n ^. re (base 16)+          ]+prop_base_read (n :: Integer) =+  conjoin [ show n ^? base 10 == Just n+          , showSigned showOct 0 n "" ^? base 8  == Just n+          , showSigned showHex 0 n "" ^? base 16 == Just n+          , map toUpper (showSigned showHex 0 n "") ^? base 16 == Just n+          ]+prop_base_readFail (s :: String) =+  forAll (choose (2,36)) $ \b ->+    not isValid ==> s ^? base b == Nothing+  where+    isValid = (not . null) sPos && all isValidChar sPos+    sPos = case s of { ('-':s') -> s'; _ -> s }+    isValidChar c = isAscii c && isAlphaNum c++-- Control.Lens.Zipper++prop_zipper_id (NonEmpty (s :: String)) =+  (zipper s & fromWithin traverse & rezip) == s &&+  over traverse id s == s++prop_zipper_Rightmost (NonEmpty (s :: String)) =+  (zipper s & fromWithin traverse & rightmost & view focus) ==+  (zipper s & fromWithin traverse & farthest rightward & view focus)++prop_zipper_Leftmost (NonEmpty (s :: String)) =+  (zipper s & fromWithin traverse & leftmost & view focus) ==+  (zipper s & fromWithin traverse & farthest leftward & view focus)++prop_zipper_Rightward_fails (NonEmpty (s :: String)) =+  isNothing (zipper s & rightmost & rightward) &&+  isNothing (zipper s & fromWithin traverse & rightmost & rightward)++prop_zipper_Leftward_fails (NonEmpty (s :: String)) =+  isNothing (zipper s & leftmost & leftward) &&+  isNothing (zipper s & fromWithin traverse & leftmost & leftward)++prop_zipper_tooth_id (NonEmpty (s :: String)) =+  let z = zipper s in isJust (jerkTo (tooth z) z)++main :: IO ()+main = $defaultMainGenerator

@@ -0,0 +1,115 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (templates)+-- Copyright   :  (C) 2012-13 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- This test suite validates that we are able to generate usable lenses with +-- template haskell.+--+-- The commented code summarizes what will be auto-generated below+-----------------------------------------------------------------------------+module Main where++import Control.Lens+-- import Test.QuickCheck (quickCheck)++data Bar a b c = Bar { _baz :: (a, b) }+makeLenses ''Bar+-- baz :: Lens (Bar a b c) (Bar a' b' c) (a,b) (a',b')++data Quux a b = Quux { _quaffle :: Int, _quartz :: Double }+makeLenses ''Quux+-- quaffle :: Lens (Quux a b) (Quux a' b') Int Int+-- quartz :: Lens (Quux a b) (Quux a' b') Double Double++data Quark a = Qualified   { _gaffer :: a }+             | Unqualified { _gaffer :: a, _tape :: a }+makeLenses ''Quark+-- gaffer :: Simple Lens (Quark a) a+-- tape :: Simple Traversal (Quark a) a++data Hadron a b = Science { _a1 :: a, _a2 :: a, _b :: b }+makeLenses ''Hadron+-- a1 :: Simple Lens (Hadron a b) a+-- a2 :: Simple Lens (Hadron a b) a+-- b :: Lens (Hadron a b) (Hadron a b') b b'++data Perambulation a b+  = Mountains { _terrain :: a, _altitude :: b }+  | Beaches   { _terrain :: a, _dunes :: a }+makeLenses ''Perambulation+-- terrain :: Simple Lens (Perambulation a b) a+-- altitude :: Traversal (Perambulation a b) (Parambulation a b') b b'+-- dunes :: Simple Traversal (Perambulation a b) a+makeLensesFor [("_terrain", "allTerrain"), ("_dunes", "allTerrain")] ''Perambulation+-- allTerrain :: Traversal (Perambulation a b) (Perambulation a' b) a a'++data LensCrafted a = Still { _still :: a }+                   | Works { _still :: a }+makeLenses ''LensCrafted+-- still :: Lens (LensCrafted a) (LensCrafted b) a b++data Danger a = Zone { _highway :: a }+              | Twilight+makeLensesWith (partialLenses .~ True $ buildTraversals .~ False $ lensRules) ''Danger+-- highway :: Lens (Danger a) (Danger a') a a'++data Task a = Task+  { taskOutput :: a -> IO ()+  , taskState :: a+  , taskStop :: IO ()+  }++makeLensesFor [("taskOutput", "outputLens"), ("taskState", "stateLens"), ("taskStop", "stopLens")] ''Task++data Mono a = Mono { _monoFoo :: a, _monoBar :: Int }+makeClassy ''Mono+-- class HasMono t where+--   mono :: Simple Lens t Mono+-- instance HasMono Mono where+--   mono = id+-- monoFoo :: HasMono t => Simple Lens t Int+-- monoBar :: HasMono t => Simple Lens t Int++data Nucleosis = Nucleosis { _nuclear :: Mono Int }+makeClassy ''Nucleosis+-- class HasNucleosis t where+--   nucleosis :: Simple Lens t Nucleosis+-- instance HasNucleosis Nucleosis+-- nuclear :: HasNucleosis t => Simple Lens t Mono++instance HasMono Nucleosis Int where+  mono = nuclear++-- Dodek's example+data Foo = Foo { _fooX, _fooY :: Int }+makeClassy ''Foo+++data Dude a = Dude+    { _dudeLevel        :: Int+    , _dudeAlias        :: String+    , _dudeLife         :: ()+    , _dudeThing        :: a+    }+data Lebowski a = Lebowski+    { _lebowskiAlias    :: String+    , _lebowskiLife     :: Int+    , _lebowskiMansion  :: String+    , _lebowskiThing    :: Maybe a+    }++makeFields ''Dude+makeFields ''Lebowski++main :: IO ()+main = putStrLn "test/templates.hs: ok"