packages feed

lens 1.7 → 1.7.1

raw patch · 11 files changed

+466/−412 lines, 11 filesdep −glossdep −randomdep ~basedep ~lens

Dependencies removed: gloss, random

Dependency ranges changed: base, lens

Files

+ examples/LICENSE view
@@ -0,0 +1,30 @@+Copyright 2012 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
− examples/Pong.hs 
@@ -1,220 +0,0 @@-{-# LANGUAGE TemplateHaskell, Rank2Types, NoMonomorphismRestriction #-}--import Control.Applicative ((<$>), (<*>))-import Control.Lens-import Control.Lens.TH (makeLenses)-import Control.Monad.State--import Data.Set (Set, member, empty, insert, delete)-import Data.Set.Lens (contains)-import Data.Pair.Lens (both)--import Graphics.Gloss-import Graphics.Gloss.Interface.Pure.Game--import System.Random---- Some global constants--gameSize        = 300-windowWidth     = 800-windowHeight    = 600-ballRadius      = 0.02-speedIncrease   = 1.2-losingAccuracy  = 0.7-winningAccuracy = 0.3-initialSpeed    = 0.6-paddleWidth     = 0.02-paddleHeight    = 0.3-paddleSpeed     = 1-textSize        = 0.001---- Pure data type for representing the game state--data Pong = Pong-  { _ballPos   :: Point-  , _ballSpeed :: Vector-  , _paddle1   :: Float-  , _paddle2   :: Float-  , _score     :: (Int, Int)-  , _vectors   :: [Vector]--  -- Since gloss doesn't cover this, we store the set of pressed keys-  , _keys      :: Set Key-  }---- Some nice lenses to go with it-makeLenses ''Pong--ahead (i, j) = i <= j--accuracy p-  | ahead (p^.score) = winningAccuracy-  | otherwise = losingAccuracy---- Renamed tuple lenses for enhanced clarity with points/vectors-_x = _1-_y = _2--initial :: Pong-initial = Pong (0, 0) (0, 0) 0 0 (0, 0) [] empty---- Calculate the y position at which the ball will next hit (on player2's side)-hitPos :: Point -> Vector -> Float-hitPos (x,y) (u,v) = ypos-  where-    xdist = if u >= 0 then 1 - x else 3 + x-    time  = xdist / abs u-    ydist = v * time-    ypos  = bounce (y + ydist)-    o     = 1 - ballRadius--    -- Calculate bounces iteratively-    bounce n-      | n >  o    = bounce (  2 *o - n)-      | n < -o    = bounce ((-2)*o - n)-      | otherwise = n---- Game update logic--update :: Float -> Pong -> Pong-update time = execState $ do-  updatePaddles time-  updateBall time-  checkBounds---- Move the ball by adding its current speed-updateBall :: Float -> State Pong ()-updateBall time = do-  (u, v) <- use ballSpeed-  ballPos += (time * u, time * v)--  -- Make sure it doesn't leave the playing area-  ballPos.both %= clamp ballRadius---- Update the paddles-updatePaddles :: Float -> State Pong ()-updatePaddles time = do-  p <- get--  let paddleMovement = time * paddleSpeed-      keyPressed key = p^.keys.contains (SpecialKey key)--  -- Update the player's paddle based on keys-  when (keyPressed KeyUp)   $ paddle1 += paddleMovement-  when (keyPressed KeyDown) $ paddle1 -= paddleMovement--  -- Calculate the optimal position-  let optimal = hitPos (p^.ballPos) (p^.ballSpeed)-      acc     = accuracy p-      target  = optimal * acc + (p^.ballPos._y) * (1 - acc)-      dist    = target - p^.paddle2--  -- Move the CPU's paddle towards this optimal position as needed-  when (abs dist > paddleHeight/3) $-    case compare dist 0 of-      GT -> paddle2 += paddleMovement-      LT -> paddle2 -= paddleMovement-      _  -> return ()--  -- Make sure both paddles don't leave the playing area-  paddle1 %= clamp (paddleHeight/2)-  paddle2 %= clamp (paddleHeight/2)---- Clamp to the region (-1, 1) but with padding-clamp :: Float -> Float -> Float-clamp pad = max (pad - 1) . min (1 - pad)---- Check for collisions and/or scores-checkBounds :: State Pong ()-checkBounds = do-  p <- get-  let (x,y) = p^.ballPos--  -- Check for collisions with the top or bottom-  when (abs y >= edge) $-    ballSpeed._y %= negate--  -- Check for collisions with paddles-  let check paddle other-        | y >= p^.paddle - paddleHeight/2 && y <= p^.paddle + paddleHeight/2 = do-            ballSpeed._x   %= negate-            ballSpeed._y   += 3*(y - p^.paddle) -- add english-            ballSpeed.both *= speedIncrease-        | otherwise = do-          score.other += 1-          reset--  when (x >=  edge) $ check paddle2 _1-  when (x <= -edge) $ check paddle1 _2--  where-    edge = 1 - ballRadius---- Reset the game-reset :: State Pong ()-reset = do-  ballPos .= (0, 0)-  ballSpeed <~ nextSpeed---- Retrieve a speed from the list, dropping it in the process-nextSpeed :: State Pong Vector-nextSpeed = do-  v:vs <- use vectors-  vectors .= vs-  return v---- Drawing a pong state to the screen--draw :: Pong -> Picture-draw p = scale gameSize gameSize $ Pictures-  [ drawBall   `at` p^.ballPos-  , drawPaddle `at` (-paddleX, p^.paddle1)-  , drawPaddle `at` ( paddleX, p^.paddle2)--  -- Score and playing field-  , drawScore (p^.score) `at` (-0.1, 0.85)-  , rectangleWire 2 2-  ]-  where-    paddleX = 1 + paddleWidth/2-    p `at` (x,y) = translate x y p; infixr 1 `at`--drawPaddle :: Picture-drawPaddle = rectangleSolid paddleWidth paddleHeight--drawBall :: Picture-drawBall = circleSolid ballRadius--drawScore :: (Int, Int) -> Picture-drawScore (x, y) = scale textSize textSize . text $ show x ++ " " ++ show y---- Handle input by simply updating the keys set--handle :: Event -> Pong -> Pong-handle (EventKey k s _ _) = keys.contains k .~ (s == Down)-handle _ = id---- The main program action--main = do-  v:vs <- startingSpeeds-  let world = ballSpeed .~ v $ vectors .~ vs $ initial-  play display backColor fps world draw handle update--  where-    display   = InWindow "Pong!" (windowWidth, windowHeight) (200, 200)-    backColor = white-    fps       = 120---- Generate the random list of starting speeds--startingSpeeds :: IO [Vector]-startingSpeeds = do-  rs <- randomRs (-initialSpeed, initialSpeed) <$> getStdGen-  return . interleave $ filter ((> 0.2) . abs) rs--  where-    interleave :: [a] -> [(a,a)]-    interleave (x:y:xs) = (x,y) : interleave xs-    interleave _        = []
+ examples/lens-examples.cabal view
@@ -0,0 +1,31 @@+name:          lens-examples+category:      Data, Lenses+version:       0.1+license:       BSD3+cabal-version: >= 1.8+license-file:  LICENSE+author:        nand+maintainer:    Edward A. Kmett <ekmett@gmail.com>+stability:     provisional+homepage:      http://github.com/ekmett/lens/+bug-reports:   http://github.com/ekmett/lens/issues+copyright:     Copyright (C) 2012 Edward A. Kmett+synopsis:      Lenses, Folds and Traversals+description:   Pong Example++build-type:    Simple+tested-with:   GHC == 7.4.1++source-repository head+  type: git+  location: git://github.com/ekmett/lens.git++executable pong+  build-depends:+    base       == 4.*,+    containers >= 0.4.2 && < 0.6,+    gloss      == 1.7.*,+    lens       == 1.7.*,+    mtl        >= 2.0.1 && < 2.2,+    random     == 1.0.*+  main-is: pong.hs
+ examples/pong.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE TemplateHaskell, Rank2Types, NoMonomorphismRestriction #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Main+-- Copyright   :  (C) 2012 Edward Kmett, nand`+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  TH, Rank2, NoMonomorphismRestriction+--+-- A simple game of pong using gloss.+-----------------------------------------------------------------------------+module Main where++import Control.Applicative ((<$>), (<*>))+import Control.Lens+import Control.Lens.TH (makeLenses)+import Control.Monad.State++import Data.Set (Set, member, empty, insert, delete)+import Data.Set.Lens (contains)+import Data.Pair.Lens (both)++import Graphics.Gloss+import Graphics.Gloss.Interface.Pure.Game++import System.Random++-- Some global constants++gameSize        = 300+windowWidth     = 800+windowHeight    = 600+ballRadius      = 0.02+speedIncrease   = 1.2+losingAccuracy  = 0.7+winningAccuracy = 0.3+initialSpeed    = 0.6+paddleWidth     = 0.02+paddleHeight    = 0.3+paddleSpeed     = 1+textSize        = 0.001++-- Pure data type for representing the game state++data Pong = Pong+  { _ballPos   :: Point+  , _ballSpeed :: Vector+  , _paddle1   :: Float+  , _paddle2   :: Float+  , _score     :: (Int, Int)+  , _vectors   :: [Vector]++  -- Since gloss doesn't cover this, we store the set of pressed keys+  , _keys      :: Set Key+  }++-- Some nice lenses to go with it+makeLenses ''Pong++ahead (i, j) = i <= j++accuracy p+  | ahead (p^.score) = winningAccuracy+  | otherwise = losingAccuracy++-- Renamed tuple lenses for enhanced clarity with points/vectors+_x = _1+_y = _2++initial :: Pong+initial = Pong (0, 0) (0, 0) 0 0 (0, 0) [] empty++-- Calculate the y position at which the ball will next hit (on player2's side)+hitPos :: Point -> Vector -> Float+hitPos (x,y) (u,v) = ypos+  where+    xdist = if u >= 0 then 1 - x else 3 + x+    time  = xdist / abs u+    ydist = v * time+    ypos  = bounce (y + ydist)+    o     = 1 - ballRadius++    -- Calculate bounces iteratively+    bounce n+      | n >  o    = bounce (  2 *o - n)+      | n < -o    = bounce ((-2)*o - n)+      | otherwise = n++-- Game update logic++update :: Float -> Pong -> Pong+update time = execState $ do+  updatePaddles time+  updateBall time+  checkBounds++-- Move the ball by adding its current speed+updateBall :: Float -> State Pong ()+updateBall time = do+  (u, v) <- use ballSpeed+  ballPos += (time * u, time * v)++  -- Make sure it doesn't leave the playing area+  ballPos.both %= clamp ballRadius++-- Update the paddles+updatePaddles :: Float -> State Pong ()+updatePaddles time = do+  p <- get++  let paddleMovement = time * paddleSpeed+      keyPressed key = p^.keys.contains (SpecialKey key)++  -- Update the player's paddle based on keys+  when (keyPressed KeyUp)   $ paddle1 += paddleMovement+  when (keyPressed KeyDown) $ paddle1 -= paddleMovement++  -- Calculate the optimal position+  let optimal = hitPos (p^.ballPos) (p^.ballSpeed)+      acc     = accuracy p+      target  = optimal * acc + (p^.ballPos._y) * (1 - acc)+      dist    = target - p^.paddle2++  -- Move the CPU's paddle towards this optimal position as needed+  when (abs dist > paddleHeight/3) $+    case compare dist 0 of+      GT -> paddle2 += paddleMovement+      LT -> paddle2 -= paddleMovement+      _  -> return ()++  -- Make sure both paddles don't leave the playing area+  paddle1 %= clamp (paddleHeight/2)+  paddle2 %= clamp (paddleHeight/2)++-- Clamp to the region (-1, 1) but with padding+clamp :: Float -> Float -> Float+clamp pad = max (pad - 1) . min (1 - pad)++-- Check for collisions and/or scores+checkBounds :: State Pong ()+checkBounds = do+  p <- get+  let (x,y) = p^.ballPos++  -- Check for collisions with the top or bottom+  when (abs y >= edge) $+    ballSpeed._y %= negate++  -- Check for collisions with paddles+  let check paddle other+        | y >= p^.paddle - paddleHeight/2 && y <= p^.paddle + paddleHeight/2 = do+            ballSpeed._x   %= negate+            ballSpeed._y   += 3*(y - p^.paddle) -- add english+            ballSpeed.both *= speedIncrease+        | otherwise = do+          score.other += 1+          reset++  when (x >=  edge) $ check paddle2 _1+  when (x <= -edge) $ check paddle1 _2++  where+    edge = 1 - ballRadius++-- Reset the game+reset :: State Pong ()+reset = do+  ballPos .= (0, 0)+  ballSpeed <~ nextSpeed++-- Retrieve a speed from the list, dropping it in the process+nextSpeed :: State Pong Vector+nextSpeed = do+  v:vs <- use vectors+  vectors .= vs+  return v++-- Drawing a pong state to the screen++draw :: Pong -> Picture+draw p = scale gameSize gameSize $ Pictures+  [ drawBall   `at` p^.ballPos+  , drawPaddle `at` (-paddleX, p^.paddle1)+  , drawPaddle `at` ( paddleX, p^.paddle2)++  -- Score and playing field+  , drawScore (p^.score) `at` (-0.1, 0.85)+  , rectangleWire 2 2+  ]+  where+    paddleX = 1 + paddleWidth/2+    p `at` (x,y) = translate x y p; infixr 1 `at`++drawPaddle :: Picture+drawPaddle = rectangleSolid paddleWidth paddleHeight++drawBall :: Picture+drawBall = circleSolid ballRadius++drawScore :: (Int, Int) -> Picture+drawScore (x, y) = scale textSize textSize . text $ show x ++ " " ++ show y++-- Handle input by simply updating the keys set++handle :: Event -> Pong -> Pong+handle (EventKey k s _ _) = keys.contains k .~ (s == Down)+handle _ = id++-- The main program action++main = do+  v:vs <- startingSpeeds+  let world = ballSpeed .~ v $ vectors .~ vs $ initial+  play display backColor fps world draw handle update++  where+    display   = InWindow "Pong!" (windowWidth, windowHeight) (200, 200)+    backColor = white+    fps       = 120++-- Generate the random list of starting speeds++startingSpeeds :: IO [Vector]+startingSpeeds = do+  rs <- randomRs (-initialSpeed, initialSpeed) <$> getStdGen+  return . interleave $ filter ((> 0.2) . abs) rs++  where+    interleave :: [a] -> [(a,a)]+    interleave (x:y:xs) = (x,y) : interleave xs+    interleave _        = []
lens.cabal view
@@ -1,6 +1,6 @@ name:          lens category:      Data, Lenses-version:       1.7+version:       1.7.1 license:       BSD3 cabal-version: >= 1.8 license-file:  LICENSE@@ -46,16 +46,11 @@ tested-with:   GHC == 7.4.1 extra-source-files:   .travis.yml-  examples/*.hs-  test/*.hs+  examples/LICENSE+  examples/lens-examples.cabal+  examples/pong.hs   README.markdown --- Build examples-flag examples-  default: False-  manual: True-  - source-repository head   type: git   location: git://github.com/ekmett/lens.git@@ -145,7 +140,7 @@     base == 4.*,     doctest >= 0.8 && <= 0.9   ghc-options: -Wall -Werror -threaded-  hs-source-dirs: test+  hs-source-dirs: tests  -- Verify that Template Haskell expansion works test-suite templates@@ -153,9 +148,9 @@   main-is: templates.hs   build-depends:     base == 4.*,-    lens == 1.7+    lens   ghc-options: -Wall -Werror -threaded-  hs-source-dirs: test+  hs-source-dirs: tests  -- Verify the properties of lenses with QuickCheck test-suite properties@@ -163,22 +158,8 @@   main-is: properties.hs   build-depends:     base         == 4.*,-    lens         == 1.7,+    lens,     QuickCheck   >= 2.4 && < 2.6,     transformers >= 0.3 && < 0.5   ghc-options: -w -threaded-  hs-source-dirs: test--executable pong-  if !flag(examples)-    buildable: False--  build-depends:-    base       == 4.*,-    containers >= 0.4.2 && < 0.6,-    gloss      == 1.7.*,-    lens       == 1.7,-    mtl        >= 2.0.1 && < 2.2,-    random     == 1.0.*-  main-is: Pong.hs-  hs-source-dirs: examples+  hs-source-dirs: tests
− test/doctests.hs 
@@ -1,22 +0,0 @@-module Main where--import Test.DocTest--main :: IO ()-main = doctest [-    "-isrc"-  , "-idist/build/autogen"-  , "-optP-include", "-optPdist/build/autogen/cabal_macros.h"-  , "src/Control/Lens/Action.hs"-  , "src/Control/Lens/Fold.hs"-  , "src/Control/Lens/Getter.hs"-  , "src/Control/Lens/Setter.hs"-  , "src/Data/Array/Lens.hs"-  , "src/Data/Bits/Lens.hs"-  , "src/Data/IntMap/Lens.hs"-  , "src/Data/IntSet/Lens.hs"-  , "src/Data/List/Lens.hs"-  , "src/Data/Map/Lens.hs"-  , "src/Data/Set/Lens.hs"-  , "src/GHC/Generics/Lens.hs"-  ]
− test/properties.hs 
@@ -1,90 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ExtendedDefaultRules #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Main where--import Control.Applicative-import Control.Monad-import Control.Lens-import Data.Functor.Identity-import System.Exit-import Test.QuickCheck-import Test.QuickCheck.All-import Test.QuickCheck.Function-import Data.Pair.Lens-import Data.Either.Lens-import Data.Text.Lens--setter_id :: Eq a => Simple Setter a b -> a -> Bool-setter_id l a = runIdentity (l Identity a) == a--setter_composition :: Eq a => Simple Setter a b -> a -> Fun b b -> Fun b b -> Bool-setter_composition l a (Fun _ f) (Fun _ g) = mapOf l f (mapOf l g a) == mapOf l (f . g) a--lens_set_view :: Eq a => Simple Lens a b -> a -> Bool-lens_set_view l a = set l (a^.l) a == a--lens_view_set :: Eq b => Simple Lens a b -> a -> b -> Bool-lens_view_set l a b = set l b a^.l == b--traversal_set_set :: Eq a => Simple Traversal a b -> a -> b -> b -> Bool-traversal_set_set l a b c = set l c (set l b a) == set l c a--iso_hither :: Eq a => Simple Iso a b -> a -> Bool-iso_hither l a = a ^.l.from l == a--iso_yon :: Eq b => Simple Iso a b -> b -> Bool-iso_yon l b = b^.from l.l == b--isSetter :: (Arbitrary a, Arbitrary b, CoArbitrary b, Show a, Show b, Eq a, Function b)-         => Simple Setter a b -> Property-isSetter l = setter_id l .&. setter_composition l--isTraversal :: (Arbitrary a, Arbitrary b, CoArbitrary b, Show a, Show b, Eq a, Function b)-         => Simple Traversal a b -> Property-isTraversal l = isSetter l .&. traversal_set_set l--isLens :: (Arbitrary a, Arbitrary b, CoArbitrary b, Show a, Show b, Eq a, Eq b, Function b)-       => Simple Lens a b -> Property-isLens l = lens_set_view l .&. lens_view_set l .&. isTraversal l--isIso :: (Arbitrary a, Arbitrary b, CoArbitrary a, CoArbitrary b, Show a, Show b, Eq a, Eq b, Function a, Function b)-      => Simple Iso a b -> Property-isIso l = iso_hither l .&. iso_yon l .&. isLens l .&. isLens (from l)---- an illegal lens-bad :: Simple Lens (Int,Int) Int-bad f (a,b) = (,) b <$> f a--badIso :: Simple Iso Int Bool-badIso = iso even fromEnum---- Control.Lens.Type-prop_1                               = isLens (_1 :: Simple Lens (Int,Double) Int)-prop_2                               = isLens (_2 :: Simple Lens (Int,Bool) Bool)-prop_2_2                             = isLens (_2._2 :: Simple Lens (Int,(Int,Bool)) 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 :: Simple Setter [Int] Int)-prop_mapped_mapped                   = isSetter (mapped.mapped :: Simple Setter [Maybe Int] Int)----prop_both                            = isTraversal (both :: Simple Traversal (Int,Int) Int)-prop_value (Fun _ k :: Fun Int Bool) = isTraversal (value k :: Simple Traversal (Int,Int) Int)-prop_traverseLeft                    = isTraversal (traverseLeft :: Simple Traversal (Either Int Bool) Int)-prop_traverseRight                   = isTraversal (traverseRight:: Simple Traversal (Either Int Bool) Bool)---- Data.Text.Lens-prop_text s                          = s^.packed.from packed == s--main :: IO ()-main = do-  b <- $quickCheckAll-  unless b $ exitWith (ExitFailure 1)
− test/templates.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-}--- | The commented code summarizes what will be auto-generated below-module Main where--import Control.Lens--- import Test.QuickCheck (quickCheck)---- newtype Foo a = Foo a--- makeIso ''Foo--- foo :: Iso a b (Foo a) (Foo b)--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--data LensCrafted a = Still { _still :: a }-                   | Works { _still :: a }-makeLenses ''LensCrafted--- still :: Lens (LensCrafted a) (LensCrafted b) a b--data Mono = Mono { _monoFoo :: Int, _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 }-makeClassy ''Nucleosis--- class HasNucleosis t where---   nucleosis :: Simple Lens t Nucleosis--- instance HasNucleosis Nucleosis--- nuclear :: HasNucleosis t => Simple Lens t Mono--instance HasMono Nucleosis where-  mono = nuclear--main :: IO ()-main = putStrLn "test/templates.hs: ok"
+ tests/doctests.hs view
@@ -0,0 +1,22 @@+module Main where++import Test.DocTest++main :: IO ()+main = doctest [+    "-isrc"+  , "-idist/build/autogen"+  , "-optP-include", "-optPdist/build/autogen/cabal_macros.h"+  , "src/Control/Lens/Action.hs"+  , "src/Control/Lens/Fold.hs"+  , "src/Control/Lens/Getter.hs"+  , "src/Control/Lens/Setter.hs"+  , "src/Data/Array/Lens.hs"+  , "src/Data/Bits/Lens.hs"+  , "src/Data/IntMap/Lens.hs"+  , "src/Data/IntSet/Lens.hs"+  , "src/Data/List/Lens.hs"+  , "src/Data/Map/Lens.hs"+  , "src/Data/Set/Lens.hs"+  , "src/GHC/Generics/Lens.hs"+  ]
+ tests/properties.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Control.Applicative+import Control.Monad+import Control.Lens+import Data.Functor.Identity+import System.Exit+import Test.QuickCheck+import Test.QuickCheck.All+import Test.QuickCheck.Function+import Data.Pair.Lens+import Data.Either.Lens+import Data.Text.Lens++setter_id :: Eq a => Simple Setter a b -> a -> Bool+setter_id l a = runIdentity (l Identity a) == a++setter_composition :: Eq a => Simple Setter a b -> a -> Fun b b -> Fun b b -> Bool+setter_composition l a (Fun _ f) (Fun _ g) = mapOf l f (mapOf l g a) == mapOf l (f . g) a++lens_set_view :: Eq a => Simple Lens a b -> a -> Bool+lens_set_view l a = set l (a^.l) a == a++lens_view_set :: Eq b => Simple Lens a b -> a -> b -> Bool+lens_view_set l a b = set l b a^.l == b++traversal_set_set :: Eq a => Simple Traversal a b -> a -> b -> b -> Bool+traversal_set_set l a b c = set l c (set l b a) == set l c a++iso_hither :: Eq a => Simple Iso a b -> a -> Bool+iso_hither l a = a ^.l.from l == a++iso_yon :: Eq b => Simple Iso a b -> b -> Bool+iso_yon l b = b^.from l.l == b++isSetter :: (Arbitrary a, Arbitrary b, CoArbitrary b, Show a, Show b, Eq a, Function b)+         => Simple Setter a b -> Property+isSetter l = setter_id l .&. setter_composition l++isTraversal :: (Arbitrary a, Arbitrary b, CoArbitrary b, Show a, Show b, Eq a, Function b)+         => Simple Traversal a b -> Property+isTraversal l = isSetter l .&. traversal_set_set l++isLens :: (Arbitrary a, Arbitrary b, CoArbitrary b, Show a, Show b, Eq a, Eq b, Function b)+       => Simple Lens a b -> Property+isLens l = lens_set_view l .&. lens_view_set l .&. isTraversal l++isIso :: (Arbitrary a, Arbitrary b, CoArbitrary a, CoArbitrary b, Show a, Show b, Eq a, Eq b, Function a, Function b)+      => Simple Iso a b -> Property+isIso l = iso_hither l .&. iso_yon l .&. isLens l .&. isLens (from l)++-- an illegal lens+bad :: Simple Lens (Int,Int) Int+bad f (a,b) = (,) b <$> f a++badIso :: Simple Iso Int Bool+badIso = iso even fromEnum++-- Control.Lens.Type+prop_1                               = isLens (_1 :: Simple Lens (Int,Double) Int)+prop_2                               = isLens (_2 :: Simple Lens (Int,Bool) Bool)+prop_2_2                             = isLens (_2._2 :: Simple Lens (Int,(Int,Bool)) 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 :: Simple Setter [Int] Int)+prop_mapped_mapped                   = isSetter (mapped.mapped :: Simple Setter [Maybe Int] Int)++++prop_both                            = isTraversal (both :: Simple Traversal (Int,Int) Int)+prop_value (Fun _ k :: Fun Int Bool) = isTraversal (value k :: Simple Traversal (Int,Int) Int)+prop_traverseLeft                    = isTraversal (traverseLeft :: Simple Traversal (Either Int Bool) Int)+prop_traverseRight                   = isTraversal (traverseRight:: Simple Traversal (Either Int Bool) Bool)++-- Data.Text.Lens+prop_text s                          = s^.packed.from packed == s++main :: IO ()+main = do+  b <- $quickCheckAll+  unless b $ exitWith (ExitFailure 1)
+ tests/templates.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-}+-- | The commented code summarizes what will be auto-generated below+module Main where++import Control.Lens+-- import Test.QuickCheck (quickCheck)++-- newtype Foo a = Foo a+-- makeIso ''Foo+-- foo :: Iso a b (Foo a) (Foo b)++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++data LensCrafted a = Still { _still :: a }+                   | Works { _still :: a }+makeLenses ''LensCrafted+-- still :: Lens (LensCrafted a) (LensCrafted b) a b++data Mono = Mono { _monoFoo :: Int, _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 }+makeClassy ''Nucleosis+-- class HasNucleosis t where+--   nucleosis :: Simple Lens t Nucleosis+-- instance HasNucleosis Nucleosis+-- nuclear :: HasNucleosis t => Simple Lens t Mono++instance HasMono Nucleosis where+  mono = nuclear++main :: IO ()+main = putStrLn "test/templates.hs: ok"