diff --git a/examples/LICENSE b/examples/LICENSE new file mode 100644 --- /dev/null +++ b/examples/LICENSE @@ -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. diff --git a/examples/Pong.hs b/examples/Pong.hs deleted file mode 100644 --- a/examples/Pong.hs +++ /dev/null @@ -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 _ = [] diff --git a/examples/lens-examples.cabal b/examples/lens-examples.cabal new file mode 100644 --- /dev/null +++ b/examples/lens-examples.cabal @@ -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 +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 diff --git a/examples/pong.hs b/examples/pong.hs new file mode 100644 --- /dev/null +++ b/examples/pong.hs @@ -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 +-- 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 _ = [] diff --git a/lens.cabal b/lens.cabal --- a/lens.cabal +++ b/lens.cabal @@ -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 diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -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" - ] diff --git a/test/properties.hs b/test/properties.hs deleted file mode 100644 --- a/test/properties.hs +++ /dev/null @@ -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) diff --git a/test/templates.hs b/test/templates.hs deleted file mode 100644 --- a/test/templates.hs +++ /dev/null @@ -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" diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -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" + ] diff --git a/tests/properties.hs b/tests/properties.hs new file mode 100644 --- /dev/null +++ b/tests/properties.hs @@ -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) diff --git a/tests/templates.hs b/tests/templates.hs new file mode 100644 --- /dev/null +++ b/tests/templates.hs @@ -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"