├── .gitignore ├── LICENSE ├── README.md ├── boris-git.toml ├── boris.toml ├── disorder-aeson ├── .ghci ├── ambiata-disorder-aeson.cabal ├── ambiata-disorder-aeson.submodules ├── mafia ├── master.toml ├── src │ └── Disorder │ │ ├── Aeson.hs │ │ └── Aeson │ │ └── Time.hs └── test │ ├── Test │ └── Disorder │ │ ├── Aeson.hs │ │ └── Aeson │ │ └── Time.hs │ └── test.hs ├── disorder-cli ├── ambiata-disorder-cli.cabal ├── mafia ├── master.toml ├── src │ └── Disorder │ │ └── Cli │ │ └── Shell.hs └── test │ ├── Test │ └── IO │ │ └── Disorder │ │ └── Cli │ │ └── Shell.hs │ └── test-io.hs ├── disorder-core ├── .ghci ├── ambiata-disorder-core.cabal ├── ambiata-disorder-core.lock-7.10.2 ├── mafia ├── master.toml ├── src │ └── Disorder │ │ ├── Core.hs │ │ └── Core │ │ ├── Combinators.hs │ │ ├── Gen.hs │ │ ├── IO.hs │ │ ├── Main.hs │ │ ├── OrdPair.hs │ │ ├── Property.hs │ │ ├── QuickCheck.hs │ │ ├── Run.hs │ │ ├── Tripping.hs │ │ └── UniquePair.hs └── test │ ├── Test │ └── Disorder │ │ └── Core │ │ ├── Combinators.hs │ │ ├── Gen.hs │ │ ├── IO.hs │ │ ├── OrdPair.hs │ │ ├── Property.hs │ │ ├── Tripping.hs │ │ └── UniquePair.hs │ ├── cli │ ├── arguments │ │ └── run │ └── core │ │ └── run │ ├── test-cli.hs │ └── test.hs ├── disorder-corpus ├── .ghci ├── ambiata-disorder-corpus.cabal ├── mafia ├── master.toml ├── src │ └── Disorder │ │ └── Corpus.hs └── test │ ├── Test │ └── Disorder │ │ └── Corpus.hs │ └── test.hs ├── disorder-eithert ├── .ghci ├── ambiata-disorder-eithert.cabal ├── mafia ├── master.toml └── src │ └── Disorder │ └── Either.hs ├── disorder-fsm ├── .ghci ├── ambiata-disorder-fsm.cabal ├── mafia ├── master.toml ├── src │ └── Disorder │ │ ├── FSM.hs │ │ └── FSM │ │ ├── Catch.hs │ │ ├── Core.hs │ │ ├── Property.hs │ │ └── Runner.hs └── test │ ├── Test │ └── Disorder │ │ ├── FSM.hs │ │ └── FSM │ │ ├── Cont.hs │ │ ├── IO.hs │ │ └── Property.hs │ └── test.hs ├── disorder-jack ├── .ghci ├── README.md ├── ambiata-disorder-jack.cabal ├── img │ └── dice.jpg ├── mafia ├── master.toml ├── src │ ├── Disorder │ │ ├── Jack.hs │ │ └── Jack │ │ │ ├── Combinators.hs │ │ │ ├── Core.hs │ │ │ ├── Property.hs │ │ │ ├── Property │ │ │ └── Diff.hs │ │ │ ├── Shrink.hs │ │ │ ├── Tree.hs │ │ │ └── Tripping.hs │ └── Test │ │ └── QuickCheck │ │ └── Jack.hs └── test │ ├── Test │ └── Disorder │ │ └── Jack │ │ ├── Combinators.hs │ │ ├── Core.hs │ │ ├── Minimal.hs │ │ ├── Property │ │ └── Diff.hs │ │ ├── Shrink.hs │ │ ├── Tree.hs │ │ └── Tripping.hs │ └── test.hs ├── disorder-lens ├── ambiata-disorder-lens.cabal ├── mafia ├── master.toml ├── src │ └── Disorder │ │ └── Lens.hs └── test │ ├── Test │ └── Disorder │ │ └── Lens.hs │ └── test.hs └── framework ├── mafia └── master.toml /.gitignore: -------------------------------------------------------------------------------- 1 | TAGS 2 | dist 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | .virthualenv 9 | .cabal-sandbox 10 | cabal.sandbox.config 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017, Ambiata, All Rights Reserved. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are 5 | met: 6 | 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of 15 | its contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | disorder 2 | ======== 3 | 4 | ``` 5 | "Lights are flashing, cars are crashing, getting frequent now" 6 | ``` 7 | 8 | A small library of useful quickcheck generators, laws and other bits and pieces. 9 | -------------------------------------------------------------------------------- /boris-git.toml: -------------------------------------------------------------------------------- 1 | [boris] 2 | version = 1 3 | 4 | [build.dist-*] 5 | git = "refs/heads/master" 6 | 7 | [build.branches-*] 8 | git = "refs/heads/topic/*" 9 | 10 | [build.all-*] 11 | git = "refs/heads/**" 12 | -------------------------------------------------------------------------------- /boris.toml: -------------------------------------------------------------------------------- 1 | [boris] 2 | version = 1 3 | 4 | [build.dist-8-0-core] 5 | command = [["master", "build", "dist-8-0", "-C", "disorder-core"]] 6 | 7 | [build.dist-8-0-corpus] 8 | command = [["master", "build", "dist-8-0", "-C", "disorder-corpus"]] 9 | 10 | [build.dist-8-0-jack] 11 | command = [["master", "build", "dist-8-0", "-C", "disorder-jack"]] 12 | 13 | [build.dist-8-0-cli] 14 | command = [["master", "build", "dist-8-0", "-C", "disorder-cli"]] 15 | 16 | [build.dist-8-0-aeson] 17 | command = [["master", "build", "dist-8-0", "-C", "disorder-aeson"]] 18 | 19 | [build.dist-8-0-eithert] 20 | command = [["master", "build", "dist-8-0", "-C", "disorder-eithert"]] 21 | 22 | [build.dist-8-0-fsm] 23 | command = [["master", "build", "dist-8-0", "-C", "disorder-fsm"]] 24 | 25 | [build.dist-8-0-lens] 26 | command = [["master", "build", "dist-8-0", "-C", "disorder-lens"]] 27 | 28 | [build.branches-7-10-core] 29 | command = [["master", "build", "branches-7-10", "-C", "disorder-core"]] 30 | 31 | [build.branches-7-10-corpus] 32 | command = [["master", "build", "branches-7-10", "-C", "disorder-corpus"]] 33 | 34 | [build.branches-7-10-jack] 35 | command = [["master", "build", "branches-7-10", "-C", "disorder-jack"]] 36 | 37 | [build.branches-7-10-cli] 38 | command = [["master", "build", "branches-7-10", "-C", "disorder-cli"]] 39 | 40 | [build.branches-7-10-aeson] 41 | command = [["master", "build", "branches-7-10", "-C", "disorder-aeson"]] 42 | 43 | [build.branches-7-10-eithert] 44 | command = [["master", "build", "branches-7-10", "-C", "disorder-eithert"]] 45 | 46 | [build.branches-7-10-fsm] 47 | command = [["master", "build", "branches-7-10", "-C", "disorder-fsm"]] 48 | 49 | [build.branches-7-10-lens] 50 | command = [["master", "build", "branches-7-10", "-C", "disorder-lens"]] 51 | 52 | [build.branches-8-0-core] 53 | command = [["master", "build", "branches-8-0", "-C", "disorder-core"]] 54 | 55 | [build.branches-8-0-corpus] 56 | command = [["master", "build", "branches-8-0", "-C", "disorder-corpus"]] 57 | 58 | [build.branches-8-0-jack] 59 | command = [["master", "build", "branches-8-0", "-C", "disorder-jack"]] 60 | 61 | [build.branches-8-0-cli] 62 | command = [["master", "build", "branches-8-0", "-C", "disorder-cli"]] 63 | 64 | [build.branches-8-0-aeson] 65 | command = [["master", "build", "branches-8-0", "-C", "disorder-aeson"]] 66 | 67 | [build.branches-8-0-eithert] 68 | command = [["master", "build", "branches-8-0", "-C", "disorder-eithert"]] 69 | 70 | [build.branches-8-0-fsm] 71 | command = [["master", "build", "branches-8-0", "-C", "disorder-fsm"]] 72 | 73 | [build.branches-8-0-lens] 74 | command = [["master", "build", "branches-8-0", "-C", "disorder-lens"]] 75 | 76 | [build.dist-validate] 77 | command = [["validate-respect"]] 78 | 79 | [build.all-submodules] 80 | command = [["dangling-refs"]] 81 | 82 | [build.all-rebased] 83 | command = [["rebased"]] 84 | -------------------------------------------------------------------------------- /disorder-aeson/.ghci: -------------------------------------------------------------------------------- 1 | :set -XQuasiQuotes 2 | :set prompt ">> " 3 | :set -Wall 4 | -------------------------------------------------------------------------------- /disorder-aeson/ambiata-disorder-aeson.cabal: -------------------------------------------------------------------------------- 1 | name: ambiata-disorder-aeson 2 | version: 0.0.3 3 | license: AllRightsReserved 4 | author: Ambiata 5 | maintainer: Ambiata 6 | copyright: (c) 2015 Ambiata 7 | synopsis: disorder-aeson 8 | category: System 9 | cabal-version: >= 1.22 10 | build-type: Simple 11 | description: disorder-aeson. 12 | 13 | library 14 | build-depends: 15 | base >= 3 && < 6 16 | , aeson >= 0.8 && < 1.2 17 | , ambiata-disorder-core 18 | , QuickCheck 19 | , time 20 | 21 | default-language: 22 | Haskell2010 23 | 24 | ghc-options: 25 | -Wall 26 | 27 | hs-source-dirs: 28 | src 29 | 30 | 31 | exposed-modules: 32 | Disorder.Aeson 33 | Disorder.Aeson.Time 34 | 35 | test-suite test 36 | type: exitcode-stdio-1.0 37 | 38 | main-is: test.hs 39 | 40 | ghc-options: -Wall -threaded -O2 41 | 42 | hs-source-dirs: 43 | test 44 | 45 | build-depends: 46 | base 47 | , ambiata-disorder-aeson 48 | , aeson 49 | , QuickCheck 50 | , time 51 | 52 | default-language: 53 | Haskell2010 54 | -------------------------------------------------------------------------------- /disorder-aeson/ambiata-disorder-aeson.submodules: -------------------------------------------------------------------------------- 1 | disorder-core 2 | -------------------------------------------------------------------------------- /disorder-aeson/mafia: -------------------------------------------------------------------------------- 1 | ../framework/mafia -------------------------------------------------------------------------------- /disorder-aeson/master.toml: -------------------------------------------------------------------------------- 1 | ../framework/master.toml -------------------------------------------------------------------------------- /disorder-aeson/src/Disorder/Aeson.hs: -------------------------------------------------------------------------------- 1 | module Disorder.Aeson where 2 | 3 | import Disorder.Core 4 | 5 | import Data.Aeson 6 | import Data.Aeson.Types 7 | 8 | import Test.QuickCheck 9 | 10 | jsonProp :: (ToJSON a, FromJSON a, Eq a, Show a) => a -> Property 11 | jsonProp = 12 | tripping toJSON (parseEither parseJSON) 13 | -------------------------------------------------------------------------------- /disorder-aeson/src/Disorder/Aeson/Time.hs: -------------------------------------------------------------------------------- 1 | module Disorder.Aeson.Time ( 2 | genTime 3 | ) where 4 | 5 | import Control.Applicative 6 | 7 | import Data.Time 8 | 9 | import Test.QuickCheck 10 | 11 | import Prelude 12 | 13 | genTime :: Gen UTCTime 14 | genTime = 15 | let 16 | -- Add one for leap seconds. 17 | maxDayMilliseconds = 60 * 60 * 24 * 1000 + 1000 18 | in 19 | UTCTime 20 | <$> fmap ModifiedJulianDay arbitrary 21 | <*> fmap (picosecondsToDiffTime . (*) 1000000000) (choose (0, maxDayMilliseconds)) 22 | -------------------------------------------------------------------------------- /disorder-aeson/test/Test/Disorder/Aeson.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Test.Disorder.Aeson where 4 | 5 | import Disorder.Aeson 6 | 7 | import Test.QuickCheck 8 | 9 | prop_jsonProp :: Int -> Property 10 | prop_jsonProp = 11 | jsonProp 12 | 13 | return [] 14 | tests :: IO Bool 15 | tests = $quickCheckAll 16 | -------------------------------------------------------------------------------- /disorder-aeson/test/Test/Disorder/Aeson/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Test.Disorder.Aeson.Time where 3 | 4 | import Disorder.Aeson 5 | import Disorder.Aeson.Time 6 | 7 | import Test.QuickCheck 8 | 9 | 10 | prop_genTime :: Property 11 | prop_genTime = forAll genTime jsonProp 12 | 13 | 14 | return [] 15 | tests :: IO Bool 16 | tests = $quickCheckAll 17 | -------------------------------------------------------------------------------- /disorder-aeson/test/test.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | import qualified Test.Disorder.Aeson 4 | import qualified Test.Disorder.Aeson.Time 5 | 6 | import System.Exit 7 | import System.IO 8 | 9 | 10 | main :: IO () 11 | main = 12 | hSetBuffering stdout LineBuffering >> mapM id [ 13 | Test.Disorder.Aeson.tests 14 | , Test.Disorder.Aeson.Time.tests 15 | ] >>= \rs -> when (not . all id $ rs) exitFailure 16 | -------------------------------------------------------------------------------- /disorder-cli/ambiata-disorder-cli.cabal: -------------------------------------------------------------------------------- 1 | name: ambiata-disorder-cli 2 | version: 0.0.3 3 | license: AllRightsReserved 4 | author: Ambiata 5 | maintainer: Ambiata 6 | copyright: (c) 2015 Ambiata 7 | synopsis: disorder-cli 8 | category: System 9 | cabal-version: >= 1.24 10 | build-type: Simple 11 | description: disorder-cli. 12 | 13 | library 14 | build-depends: 15 | base >= 3 && < 6 16 | , clock == 0.5.* 17 | , directory >= 1.2 && < 1.6 18 | , ieee754 == 0.7.* 19 | , process >= 1.2 && < 1.7 20 | , text >= 1.1 && < 1.3 21 | -- Minimum requirement for managed 1.0.3 due to 'Control.Monad.Trans.Except' 22 | -- https://github.com/Gabriel439/Haskell-Managed-Library/issues/6 23 | , transformers >= 0.4 && < 0.6 24 | , turtle >= 1.2 && < 1.6 25 | 26 | default-language: 27 | Haskell2010 28 | 29 | ghc-options: 30 | -Wall 31 | 32 | hs-source-dirs: 33 | src 34 | 35 | 36 | exposed-modules: 37 | Disorder.Cli.Shell 38 | 39 | test-suite test-io 40 | type: exitcode-stdio-1.0 41 | main-is: test-io.hs 42 | ghc-options: -Wall -threaded -O2 43 | hs-source-dirs: test 44 | build-depends: base >= 3 && < 6 45 | , QuickCheck 46 | , ambiata-disorder-core 47 | , ambiata-disorder-cli 48 | , directory 49 | , ieee754 50 | , process 51 | , text 52 | , turtle 53 | default-language: 54 | Haskell2010 -------------------------------------------------------------------------------- /disorder-cli/mafia: -------------------------------------------------------------------------------- 1 | ../framework/mafia -------------------------------------------------------------------------------- /disorder-cli/master.toml: -------------------------------------------------------------------------------- 1 | ../framework/master.toml -------------------------------------------------------------------------------- /disorder-cli/src/Disorder/Cli/Shell.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE CPP #-} 3 | module Disorder.Cli.Shell ( 4 | testShell 5 | , testShell' 6 | , cliOutput 7 | , toLine 8 | ) where 9 | 10 | import qualified Data.Text as T 11 | 12 | import Turtle 13 | 14 | #if ! MIN_VERSION_turtle(1, 3, 0) 15 | type Line = Text 16 | toLine :: Functor f => f Text -> f Line 17 | toLine = id 18 | #else 19 | toLine :: Functor f => f Text -> f Line 20 | toLine = fmap unsafeTextToLine 21 | #endif 22 | 23 | -- | We could just use execve rather than building a string to pass to a 24 | -- shell, but we want to simulate an interactive shell/shell script as 25 | -- as closely as possible. 26 | -- 27 | -- Of course, as this function directly passes its input to a shell, it should 28 | -- never be used for anything except a test with no uncontrolled input. 29 | testShell :: [Text] -> Shell Line -> IO (ExitCode, Text) 30 | testShell args = shellStrict args' 31 | where 32 | args' = T.intercalate " " args 33 | 34 | testShell' :: [Text] -> IO (ExitCode, Text) 35 | testShell' = flip testShell empty 36 | 37 | -- | Render the 'Text' value expected from a line of output. 38 | cliOutput :: (Show a) => a -> Text 39 | cliOutput = flip T.snoc '\n' . T.pack . show 40 | -------------------------------------------------------------------------------- /disorder-cli/test/Test/IO/Disorder/Cli/Shell.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Test.IO.Disorder.Cli.Shell where 5 | 6 | import Control.Applicative 7 | 8 | import Data.Monoid 9 | import qualified Data.Text as T 10 | 11 | import Disorder.Cli.Shell 12 | import Disorder.Core.IO 13 | 14 | import System.Exit 15 | 16 | import Test.QuickCheck 17 | import Test.QuickCheck.Monadic 18 | 19 | import Turtle 20 | 21 | import Prelude 22 | 23 | boring :: Gen Text 24 | boring = fmap T.pack . listOf1 $ elements (['a'..'z'] <> ['A'..'Z'] <> ['0'..'9']) 25 | 26 | prop_testShell :: Property 27 | prop_testShell = forAll (listOf1 boring) $ \ms -> (monadicIO . (=<<) stopIO . run) $ do 28 | (st, out) <- testShell ["tac"] $ select (toLine ms) 29 | pure $ (st, out) === (ExitSuccess, flip T.snoc '\n' $ T.intercalate "\n" (reverse ms)) 30 | 31 | prop_testShell_succ :: Property 32 | prop_testShell_succ = forAll boring $ \m -> (monadicIO . (=<<) stopIO . run) $ do 33 | (st, out) <- testShell' ["echo", "-n", m] 34 | pure $ (st, out) === (ExitSuccess, m) 35 | 36 | prop_testShell_fail :: Property 37 | prop_testShell_fail = forAll boring $ \m -> (monadicIO . (=<<) stopIO . run) $ do 38 | (st, out) <- testShell' ["echo", "-n", m, "&&", "false"] 39 | pure $ (st == ExitSuccess, out) === (False, m) 40 | 41 | return [] 42 | tests :: IO Bool 43 | tests = $quickCheckAll 44 | -------------------------------------------------------------------------------- /disorder-cli/test/test-io.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | import qualified Test.IO.Disorder.Cli.Shell 4 | 5 | import System.Exit 6 | import System.IO 7 | 8 | main :: IO () 9 | main = hSetBuffering stdout LineBuffering >> 10 | sequence [ 11 | Test.IO.Disorder.Cli.Shell.tests 12 | ] >>= \rs -> unless (and rs) exitFailure 13 | 14 | -------------------------------------------------------------------------------- /disorder-core/.ghci: -------------------------------------------------------------------------------- 1 | :set prompt "λ> " 2 | :set -Wall 3 | :set -XOverloadedStrings 4 | :set -XScopedTypeVariables 5 | -------------------------------------------------------------------------------- /disorder-core/ambiata-disorder-core.cabal: -------------------------------------------------------------------------------- 1 | name: ambiata-disorder-core 2 | version: 0.0.3 3 | license: AllRightsReserved 4 | author: Ambiata 5 | maintainer: Ambiata 6 | copyright: (c) 2015 Ambiata 7 | synopsis: disorder-core 8 | category: System 9 | cabal-version: >= 1.22 10 | build-type: Simple 11 | description: disorder-core. 12 | tested-with: GHC==8.0.2, GHC==7.10.2 13 | 14 | library 15 | build-depends: 16 | base >= 3 && < 5 17 | , QuickCheck >= 2.8 && < 2.14 18 | , directory >= 1.2 && < 1.6 19 | , ieee754 >= 0.7 && < 0.9 20 | , quickcheck-text >= 0.1 && < 0.2 21 | , process >= 1.2 && < 1.7 22 | , semigroups >= 0.16 && < 0.19 23 | , text >= 1.1 && < 1.3 24 | , transformers >= 0.3 && < 1 25 | , template-haskell 26 | 27 | default-language: 28 | Haskell2010 29 | 30 | ghc-options: -Wall 31 | if impl(ghc >= 8.0) 32 | ghc-options: -fno-warn-redundant-constraints 33 | 34 | 35 | hs-source-dirs: 36 | src 37 | 38 | 39 | exposed-modules: 40 | Disorder.Core 41 | Disorder.Core.Gen 42 | Disorder.Core.IO 43 | Disorder.Core.Main 44 | Disorder.Core.OrdPair 45 | Disorder.Core.Property 46 | Disorder.Core.Run 47 | Disorder.Core.Tripping 48 | Disorder.Core.UniquePair 49 | Disorder.Core.QuickCheck 50 | Disorder.Core.Combinators 51 | 52 | test-suite test 53 | type: exitcode-stdio-1.0 54 | 55 | main-is: test.hs 56 | 57 | ghc-options: -Wall -threaded -O2 58 | if impl(ghc >= 8.0) 59 | ghc-options: -fno-warn-redundant-constraints 60 | 61 | hs-source-dirs: 62 | test 63 | 64 | build-depends: 65 | base 66 | , ambiata-disorder-core 67 | , QuickCheck 68 | , text 69 | , quickcheck-instances 70 | , ieee754 71 | , transformers 72 | 73 | default-language: 74 | Haskell2010 75 | 76 | test-suite test-cli 77 | type: exitcode-stdio-1.0 78 | 79 | main-is: test-cli.hs 80 | 81 | ghc-options: -Wall -threaded -O2 82 | if impl(ghc >= 8.0) 83 | ghc-options: -fno-warn-redundant-constraints 84 | 85 | hs-source-dirs: 86 | test 87 | 88 | build-depends: 89 | base 90 | , ambiata-disorder-core 91 | 92 | default-language: 93 | Haskell2010 94 | -------------------------------------------------------------------------------- /disorder-core/ambiata-disorder-core.lock-7.10.2: -------------------------------------------------------------------------------- 1 | # mafia-lock-file-version: 0 2 | hashable == 1.2.4.0 3 | ieee754 == 0.7.8 4 | old-locale == 1.0.0.7 5 | old-time == 1.1.0.3 6 | primitive == 0.6.1.0 7 | QuickCheck == 2.8.2 8 | quickcheck-instances == 0.3.12 9 | quickcheck-text == 0.1.2.1 10 | random == 1.1 11 | scientific == 0.3.4.9 12 | semigroups == 0.18.2 13 | semigroups -bytestring-builder 14 | tagged == 0.8.5 15 | text == 1.2.2.1 16 | tf-random == 0.5 17 | transformers-compat == 0.5.1.4 18 | unordered-containers == 0.2.7.1 19 | vector == 0.11.0.0 20 | -------------------------------------------------------------------------------- /disorder-core/mafia: -------------------------------------------------------------------------------- 1 | ../framework/mafia -------------------------------------------------------------------------------- /disorder-core/master.toml: -------------------------------------------------------------------------------- 1 | ../framework/master.toml -------------------------------------------------------------------------------- /disorder-core/src/Disorder/Core.hs: -------------------------------------------------------------------------------- 1 | module Disorder.Core ( 2 | module X 3 | ) where 4 | 5 | import Disorder.Core.Gen as X 6 | import Disorder.Core.OrdPair as X 7 | import Disorder.Core.Property as X 8 | import Disorder.Core.Run as X 9 | import Disorder.Core.Tripping as X 10 | import Disorder.Core.UniquePair as X 11 | import Disorder.Core.Combinators as X 12 | -------------------------------------------------------------------------------- /disorder-core/src/Disorder/Core/Combinators.hs: -------------------------------------------------------------------------------- 1 | module Disorder.Core.Combinators 2 | ( testJust 3 | , testRight 4 | ) where 5 | 6 | 7 | import Test.QuickCheck (Property, counterexample) 8 | 9 | 10 | -- | testRight label eitherValue nextProp : 11 | -- On a `Right`, pass the value to the next property. 12 | -- On a `Left` fail with a label and the left value. 13 | -- The label is useful for the case of nested `testRight`. 14 | testRight :: Show a => String -> Either a b -> (b -> Property) -> Property 15 | testRight _ (Right b) nextProp = nextProp b 16 | testRight label (Left a) _ = counterexample (label ++ ": " ++ show a) False 17 | 18 | 19 | -- | testJust label maybeValue nextProp 20 | -- On a `Just`, pass the value to the next property. 21 | -- On a `Nothing`, fail and print the label. 22 | -- The label is useful for the case of nested `testJust`/`testRight``. 23 | testJust :: String -> Maybe b -> (b -> Property) -> Property 24 | testJust _ (Just b) nextProp = nextProp b 25 | testJust label _ _ = counterexample (label ++ ": Nothing ") False 26 | -------------------------------------------------------------------------------- /disorder-core/src/Disorder/Core/Gen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Disorder.Core.Gen ( 3 | GenSeed(..) 4 | , chooseSize 5 | , genDeterministic 6 | , genDeterministic' 7 | , genEnum 8 | , genFromMaybe 9 | , listOfSized 10 | , listOfSizedWithIndex 11 | , listWithIndex 12 | , maybeGen 13 | , oneofSized 14 | , smaller 15 | , vectorOfSize 16 | , vectorOfUnique 17 | , vectorOfUnique' 18 | , vectorOfUniqueBy 19 | , vectorOfUniqueBy' 20 | , listOf1Unique 21 | , listOf1UniquePair 22 | , genNonEmpty 23 | , genNonEmptyUnique 24 | 25 | -- * re-exports from quickcheck-text 26 | , genValidUtf8 27 | , genValidUtf81 28 | #if MIN_VERSION_quickcheck_text(0, 1, 1) 29 | , shrinkValidUtf8 30 | , shrinkValidUtf81 31 | , shrinkUtf8BS 32 | , shrinkUtf8BS1 33 | , utf8BS 34 | , utf8BS1 35 | #endif 36 | ) where 37 | 38 | import Control.Applicative 39 | 40 | import Data.List.NonEmpty (NonEmpty (..)) 41 | import qualified Data.List.NonEmpty as N 42 | import Data.Maybe (isJust) 43 | import Data.Monoid ((<>)) 44 | 45 | import Test.QuickCheck.Gen 46 | import Test.QuickCheck.Random 47 | import Test.QuickCheck.Utf8 48 | 49 | import Prelude 50 | 51 | -- | Return a vector whose size is within the provided bounds 52 | vectorOfSize :: Int -> Int -> Gen a -> Gen [a] 53 | vectorOfSize min' max' gen = 54 | chooseSize min' max' >>= flip vectorOf gen 55 | 56 | -- | Return an 'Int' which is between the provided range, and influenced by the current "size" 57 | chooseSize :: Int -> Int -> Gen Int 58 | chooseSize x0 y0 = 59 | sized $ \sz0 -> 60 | let 61 | x = 62 | toInteger x0 63 | 64 | y = 65 | toInteger y0 66 | 67 | sz = 68 | toInteger sz0 69 | 70 | diff = 71 | ((y - x) * sz) `quot` 99 72 | 73 | xdiff = 74 | fromIntegral $ 75 | min (fromIntegral y0) (x + diff) 76 | in 77 | choose (x0, xdiff) 78 | 79 | -- | from a generator return a generator that will generate Nothing sometimes 80 | maybeGen :: Gen a -> Gen (Maybe a) 81 | maybeGen g = sized $ \s -> 82 | frequency [ 83 | (1, return Nothing), 84 | (s, Just <$> resize (s `div` 2) g)] 85 | 86 | -- | Wait for a generated `Just` value 87 | -- 88 | -- Use _only_ in case of emergencies when you have no other way to get an `a` safely 89 | genFromMaybe :: Gen (Maybe a) -> Gen a 90 | genFromMaybe g = 91 | suchThat g isJust >>= \ma -> 92 | case ma of 93 | Just a -> pure a 94 | Nothing -> fail "Disorder.Core.Gen.genFromMaybe: Failed to generate a Just" 95 | 96 | -- | Generate something smaller 97 | smaller :: Gen a -> Gen a 98 | smaller g = 99 | sized $ \s -> resize (s `div` 2) g 100 | 101 | -- | Take list of small generators and list of large generators. 102 | -- Look at the size of what we want to create, and use either small or both. 103 | -- 104 | -- This is useful for generators for recursive datatypes: one can pass generators 105 | -- for the leaf nodes as the first argument, and branches for the second argument. 106 | -- The second arguments will be called with a smaller size, so if this is used 107 | -- recursively, the size will continue to reduce until only leaves are available. 108 | -- 109 | -- For example, a tree might use: 110 | -- 111 | -- > gen_tree = oneofSized 112 | -- > [ Leaf1 <$> arbitrary, Leaf2 <$> arbitrary ] 113 | -- > [ Branch <$> gen_tree ] 114 | -- 115 | -- Because (Branch <$> gen_tree) will only be called when the size is greater than 1, 116 | -- and gen_tree will be called with a smaller size, this makes an infinite chain 117 | -- of branches impossible. 118 | oneofSized :: [Gen a] -> [Gen a] -> Gen a 119 | oneofSized smalls bigs = sized $ \s -> 120 | if s <= 1 121 | then oneof smalls 122 | else oneof (smalls ++ bigs') 123 | where 124 | bigs' = fmap smaller bigs 125 | 126 | -- | Generate a list this big. 127 | listOfSized :: Gen a -> Int -> Gen [a] 128 | listOfSized gen n = take n <$> infiniteListOf gen 129 | 130 | genEnum :: (Bounded a, Enum a) => Gen a 131 | genEnum = 132 | elements [minBound..maxBound] 133 | 134 | listWithIndex :: (Int -> Gen a) -> Gen [a] 135 | listWithIndex g = 136 | sized $ \i -> listOfSizedWithIndex 0 i g 137 | 138 | listOfSizedWithIndex :: Int -> Int -> (Int -> Gen a) -> Gen [a] 139 | listOfSizedWithIndex from to g = 140 | chooseSize from to >>= 141 | mapM g . enumFromTo 0 142 | 143 | newtype GenSeed = 144 | GenSeed { 145 | unGenSeed :: Int 146 | } deriving (Eq, Show) 147 | 148 | -- | Deterministic generator with a default size of 100. 149 | genDeterministic :: GenSeed -> Gen a -> a 150 | genDeterministic = genDeterministic' 100 151 | 152 | -- | Deterministic generator, always produces the same output for the same 153 | -- seed. 154 | genDeterministic' :: Int -> GenSeed -> Gen a -> a 155 | genDeterministic' size (GenSeed seed) (MkGen g) = 156 | let r = mkQCGen seed in 157 | g r size 158 | 159 | -- | Generate a list of a given length containing no duplicates (by the 160 | -- provided comparison function). This is 'vectorOfUnique'' parameterised by 161 | -- equality operator; the same caveats apply, including partiality. 162 | vectorOfUniqueBy' :: (a -> a -> Bool) -> Int -> Int -> Gen a -> Gen [a] 163 | vectorOfUniqueBy' cmp s k g = 164 | scaled (max s) $ go k [] mana 165 | where 166 | go 0 xs _ = pure xs 167 | go _ xs 0 = 168 | fail $ "vectorOfUniqueBy' out of mana - are you trying to generate a list larger than the cardinality of the type? (" <> show (length xs) <> "/" <> show k <> ")" 169 | go n xs mana' = 170 | g >>= \y -> case any (cmp y) xs of 171 | True -> go n xs $ mana' - 1 172 | False -> go (n - 1) (y : xs) mana 173 | 174 | mana :: Int 175 | mana = 10000 176 | 177 | -- scale is in QuickCheck 2.8 178 | scaled f h = sized $ \x -> resize (f x) h 179 | 180 | -- | Generate a list of a given length containing no duplicates (by the 181 | -- provided comparison function). This is 'vectorOfUnique' parameterised by 182 | -- equality operator; the same caveats apply, including partiality. 183 | vectorOfUniqueBy :: (a -> a -> Bool) -> Int -> Gen a -> Gen [a] 184 | vectorOfUniqueBy cmp = vectorOfUniqueBy' cmp 30 185 | 186 | -- | Generate a list of a given length containing no duplicates. 187 | -- 188 | -- As the provided length can be greater than the cardinality of the type 189 | -- (number of distinct representable values), this function is not guaranteed 190 | -- to terminate successfully; it will give up after 10000 consecutive failures 191 | -- to generate a new value. 192 | -- 193 | -- `vectorOfUnique' n` runs the generator with a size equal to the maximum of 194 | -- `n` and the current size parameter; setting this above zero is necessary to 195 | -- use this with sized generators from the QuickCheck test runner. The optimal 196 | -- value depends on the cardinality of the type, how the generator in question 197 | -- uses the size parameter, and the desired number of unique values. 198 | vectorOfUnique' :: Eq a => Int -> Int -> Gen a -> Gen [a] 199 | vectorOfUnique' = vectorOfUniqueBy' (==) 200 | 201 | -- | Generate a list of a given length containing no duplicates. This is 202 | -- 'vectorOfUnique'' with a minimum generator size of 30, which is sufficient 203 | -- for most common sized generators. 204 | -- 205 | -- This generator is not guaranteed to terminate successfully; see 206 | -- 'vectorOfUnique'' for details. 207 | vectorOfUnique :: Eq a => Int -> Gen a -> Gen [a] 208 | vectorOfUnique = vectorOfUnique' 30 209 | 210 | -- | Generates a non-empty list of random length with no duplicate values. 211 | -- The maximum length depends on the size parameter. 212 | listOf1Unique :: Eq a => Gen a -> Gen [a] 213 | listOf1Unique g = 214 | N.toList <$> genNonEmptyUnique g 215 | 216 | -- | Generates a pair of lists of random length with no duplicate 217 | -- values across the combination of the lists . See 'listOf1Unique'. 218 | listOf1UniquePair :: Eq a => Gen a -> Gen ([a], [a]) 219 | listOf1UniquePair g = do 220 | l <- listOf1Unique g 221 | c <- choose (0, length l) 222 | pure $ splitAt c l 223 | 224 | genNonEmpty :: Gen a -> Gen (NonEmpty a) 225 | genNonEmpty g = 226 | (:|) <$> g <*> listOf g 227 | 228 | genNonEmptyUnique :: Eq a => Gen a -> Gen (NonEmpty a) 229 | genNonEmptyUnique g = 230 | N.nub <$> genNonEmpty g 231 | -------------------------------------------------------------------------------- /disorder-core/src/Disorder/Core/IO.hs: -------------------------------------------------------------------------------- 1 | module Disorder.Core.IO ( 2 | stopIO 3 | , testIO 4 | , testPropertyIO 5 | , withCPUTime 6 | ) where 7 | 8 | import Control.Monad (void) 9 | import Control.Monad.IO.Class (liftIO, MonadIO) 10 | 11 | import Test.QuickCheck 12 | import Test.QuickCheck.Monadic 13 | 14 | import System.CPUTime (getCPUTime) 15 | 16 | testIO :: Testable a => IO a -> Property 17 | testIO = testPropertyIO . run 18 | 19 | testPropertyIO :: Testable a => PropertyM IO a -> Property 20 | testPropertyIO = monadicIO . (=<<) (void . stop) 21 | 22 | -- | Perform an action and return the CPU time it takes, in picoseconds 23 | -- (actual precision varies with implementation). 24 | withCPUTime :: MonadIO m => m a -> m (Integer, a) 25 | withCPUTime a = do 26 | t1 <- liftIO getCPUTime 27 | r <- a 28 | t2 <- liftIO getCPUTime 29 | return (t2 - t1, r) 30 | 31 | -- | A IO typed version of Test.QuickCheck.Monadic.stop due to changes in QuickCheck 2.10 32 | stopIO :: (Testable a) => a -> PropertyM IO a 33 | stopIO p = MkPropertyM (\_k -> return (return (property p))) 34 | -------------------------------------------------------------------------------- /disorder-core/src/Disorder/Core/Main.hs: -------------------------------------------------------------------------------- 1 | module Disorder.Core.Main ( 2 | disorderMain 3 | , disorderCliMain 4 | ) where 5 | 6 | import Control.Applicative 7 | import Control.Monad 8 | 9 | import System.Directory 10 | import System.Process 11 | import System.Exit 12 | import System.IO 13 | 14 | import Prelude 15 | 16 | disorderMain :: [IO Bool] -> IO () 17 | disorderMain tests = 18 | sanity >> sequence tests >>= \rs -> unless (and rs) exitFailure 19 | 20 | disorderCliMain :: [String] -> IO () 21 | disorderCliMain arguments = 22 | let ignore p = ".." == p || "." == p || "core" == p 23 | exec t = callProcess ("test/cli/" ++ t ++ "/run") arguments 24 | in sanity >> filter (not . ignore) <$> getDirectoryContents "test/cli/" >>= mapM_ exec 25 | 26 | sanity :: IO () 27 | sanity = 28 | hSetBuffering stdout LineBuffering >> hSetBuffering stderr LineBuffering 29 | -------------------------------------------------------------------------------- /disorder-core/src/Disorder/Core/OrdPair.hs: -------------------------------------------------------------------------------- 1 | module Disorder.Core.OrdPair ( 2 | OrdPair(..) 3 | , toTupleOrd 4 | ) where 5 | 6 | import Control.Applicative 7 | 8 | import Test.QuickCheck 9 | 10 | import Prelude 11 | 12 | data OrdPair a = 13 | OrdPair a a 14 | deriving (Eq, Show) 15 | 16 | instance (Arbitrary a, Ord a) => Arbitrary (OrdPair a) where 17 | arbitrary = 18 | (\a b -> if a < b then OrdPair a b else OrdPair b a) 19 | <$> arbitrary 20 | <*> arbitrary 21 | 22 | toTupleOrd :: OrdPair a -> (a, a) 23 | toTupleOrd (OrdPair a b) = (a, b) 24 | -------------------------------------------------------------------------------- /disorder-core/src/Disorder/Core/Property.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Disorder.Core.Property ( 3 | (=/=) 4 | , (~~~) 5 | , (###) 6 | , (.^.) 7 | , (<=>) 8 | , (=\\=) 9 | , failWith 10 | , neg 11 | ) where 12 | 13 | import Data.AEq (AEq) 14 | import qualified Data.AEq as AEQ 15 | import Data.List ((\\)) 16 | import Data.Text (Text, unpack) 17 | 18 | import Test.QuickCheck.Gen 19 | import Test.QuickCheck.Property 20 | 21 | 22 | #if ! MIN_VERSION_QuickCheck(2, 12, 0) 23 | infix 4 =/= 24 | (=/=) :: (Eq a, Show a) => a -> a -> Property 25 | x =/= y = counterexample (concat [show x, " == ", show y]) $ x /= y 26 | #endif 27 | 28 | infix 4 ~~~ 29 | 30 | -- | Approximately-equal property for floats and things that look like 31 | -- floats. 32 | (~~~) :: (AEq a, Show a) => a -> a -> Property 33 | x ~~~ y = counterexample cex prop 34 | where 35 | cex = concat ["|", show x, " - ", show y, "| > ɛ"] 36 | prop = x AEQ.~== y 37 | 38 | infix 4 ### 39 | 40 | -- | Approximately-equal property for floats, which also verifies that 41 | -- both arguments are real numbers (i.e., not NaN or infinity). 42 | (###) :: (AEq a, Show a, RealFloat a) => a -> a -> Property 43 | x ### y = conjoin [counterexample unreal realProp, x ~~~ y] 44 | where 45 | unreal = unwords ["Argument is not a real number:", show x, show y] 46 | 47 | realProp = all real [x, y] 48 | 49 | real z = (not $ isNaN z) && (not $ isInfinite z) 50 | 51 | failWith :: Text -> Property 52 | failWith = 53 | flip counterexample False . unpack 54 | 55 | -- | 56 | -- Allows you to negate a property and provide a string to hopefully give some clue as to what 57 | -- went wrong. 58 | -- 59 | neg :: (Testable p) => p -> Property 60 | neg x = 61 | let 62 | genRose :: (Testable p) => p -> Gen (Rose Result) 63 | genRose = fmap unProp . unProperty . property 64 | 65 | checkExpectFailure :: Result -> Rose Result -> Rose Result 66 | checkExpectFailure res rose = 67 | if expect res then 68 | rose 69 | else 70 | return $ failed { reason = "expectFailure may not occur inside a negation" } 71 | 72 | negRose :: Rose Result -> Rose Result 73 | negRose rose = do 74 | res <- rose 75 | checkExpectFailure res . return $ case ok res of 76 | Nothing -> res 77 | Just b -> res { ok = Just $ not b } 78 | 79 | 80 | -- Sorry cant think of a more helpful thing to say... Can't change what will get printed by the negated 81 | -- property in a meaningful way.. can only append a "not" to it... 82 | -- 83 | in counterexample "The following properties are ALL true.... NOT!:" . MkProperty $ do 84 | rose <- genRose x 85 | return . MkProp $ negRose rose 86 | 87 | infixr 1 .^. 88 | (.^.) :: (Testable p1, Testable p2) => p1 -> p2 -> Property 89 | p1 .^. p2 = (p1 .||. p2) .&&. neg (p1 .&&. p2) 90 | 91 | infixr 1 <=> 92 | (<=>) :: (Testable p1, Testable p2) => p1 -> p2 -> Property 93 | a <=> b = (a .&&. b) .||. (neg a .&&. neg b) 94 | 95 | infix 4 =\\= 96 | -- | 97 | -- Test equivalence of the lists 98 | -- i.e. if 'ls' and 'rs' contain the same elements, possible in a different order 99 | (=\\=) :: (Eq a, Show a) => [a] -> [a] -> Property 100 | ls =\\= rs = 101 | let els = ls \\ rs 102 | ers = rs \\ ls 103 | in flip counterexample (els ++ ers == []) $ 104 | "Lists are not equivalent: " ++ 105 | "(ls \\\\ rs) == " ++ show els ++ " && " ++ 106 | "(rs \\\\ ls) == " ++ show ers 107 | -------------------------------------------------------------------------------- /disorder-core/src/Disorder/Core/QuickCheck.hs: -------------------------------------------------------------------------------- 1 | module Disorder.Core.QuickCheck ( 2 | module X 3 | ) where 4 | 5 | -- the "dropbear" .&. is bad, and you should feel bad 6 | import Test.QuickCheck as X hiding ((.&.)) 7 | -------------------------------------------------------------------------------- /disorder-core/src/Disorder/Core/Run.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE PatternGuards #-} 4 | module Disorder.Core.Run ( 5 | disorderCheckEnv 6 | , disorderCheckEnvWith 7 | , disorderCheckEnvAll 8 | , disorderCheckAll 9 | , disorderEnvArgs 10 | , ExpectedTestSpeed(..) 11 | ) where 12 | 13 | import Test.QuickCheck 14 | 15 | import System.Environment (lookupEnv) 16 | import System.IO 17 | 18 | import Text.Read (readMaybe) 19 | import Data.Maybe (fromMaybe) 20 | 21 | import Prelude 22 | import Language.Haskell.TH 23 | 24 | data ExpectedTestSpeed 25 | = TestRunMore 26 | | TestRunNormal 27 | | TestRunFewer 28 | deriving (Eq, Ord, Show) 29 | 30 | disorderCheckEnv :: Testable prop => ExpectedTestSpeed -> prop -> IO Result 31 | disorderCheckEnv speed prop = 32 | disorderCheckEnvWith speed stdArgs prop 33 | 34 | disorderCheckEnvWith :: Testable prop => ExpectedTestSpeed -> Args -> prop -> IO Result 35 | disorderCheckEnvWith speed args prop = do 36 | args' <- disorderEnvArgs speed args 37 | quickCheckWithResult args' prop 38 | 39 | disorderEnvArgs :: ExpectedTestSpeed -> Args -> IO Args 40 | disorderEnvArgs speed args = do 41 | env <- readEnv $ disorderSpeedEnvArg speed 42 | return args { maxSuccess = fromMaybe (disorderSpeedDefaultRuns speed) env } 43 | 44 | disorderSpeedEnvArg :: ExpectedTestSpeed -> String 45 | disorderSpeedEnvArg = 46 | \case 47 | TestRunMore -> "DISORDER_RUN_MORE" 48 | TestRunNormal -> "DISORDER_RUN_NORMAL" 49 | TestRunFewer -> "DISORDER_RUN_FEWER" 50 | 51 | disorderSpeedDefaultRuns :: ExpectedTestSpeed -> Int 52 | disorderSpeedDefaultRuns = 53 | \case 54 | TestRunMore -> 1000 55 | TestRunNormal -> 100 56 | TestRunFewer -> 10 57 | 58 | 59 | readEnv :: String -> IO (Maybe Int) 60 | readEnv name = do 61 | v <- lookupEnv name 62 | return 63 | $ case v of 64 | Just vstr -> readMaybe vstr 65 | Nothing -> Nothing 66 | 67 | 68 | disorderCheckEnvAll :: Q Exp 69 | disorderCheckEnvAll = 70 | [| \speed -> $(forAllProperties) (disorderCheckEnv speed) |] 71 | 72 | disorderCheckAll :: Q Exp 73 | disorderCheckAll = 74 | [| $(forAllProperties) (disorderCheckEnv TestRunNormal) |] 75 | -------------------------------------------------------------------------------- /disorder-core/src/Disorder/Core/Tripping.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Disorder.Core.Tripping where 4 | 5 | import Control.Applicative 6 | import Data.Monoid 7 | import Data.Function 8 | import Test.QuickCheck 9 | 10 | import Prelude 11 | 12 | -- | Generalized round-trip property function 13 | tripping :: (Applicative f, Show (f a), Eq (f a)) => (a -> b) -> (b -> f a) -> a -> Property 14 | tripping = trippingOn id 15 | 16 | trippingOn :: (Applicative f, Show (f a), Show (f c), Eq (f c)) => (a -> c) -> (a -> b) -> (b -> f a) -> a -> Property 17 | trippingOn f = trippingWith ((===) `on` fmap f) 18 | 19 | trippingWith :: (Applicative f, Show (f a)) => (f a -> f a -> Property) -> (a -> b) -> (b -> f a) -> a -> Property 20 | trippingWith prop to fro a = 21 | let tripped = (fro . to) a 22 | purea = pure a 23 | in counterexample (show tripped <> " /= " <> show purea) 24 | (prop tripped purea) 25 | -------------------------------------------------------------------------------- /disorder-core/src/Disorder/Core/UniquePair.hs: -------------------------------------------------------------------------------- 1 | module Disorder.Core.UniquePair ( 2 | UniquePair(..) 3 | , toTuple 4 | ) where 5 | 6 | import Control.Applicative 7 | 8 | import Test.QuickCheck 9 | 10 | import Prelude 11 | 12 | data UniquePair a = 13 | UniquePair { 14 | uniquePairFst :: a 15 | , uniquePairSnd :: a 16 | } deriving (Eq, Show) 17 | 18 | instance (Arbitrary a, Eq a) => Arbitrary (UniquePair a) where 19 | arbitrary = suchThat (UniquePair <$> arbitrary <*> arbitrary) (uncurry (/=) . toTuple) 20 | 21 | toTuple :: UniquePair a -> (a, a) 22 | toTuple (UniquePair a b) = (a, b) 23 | -------------------------------------------------------------------------------- /disorder-core/test/Test/Disorder/Core/Combinators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Test.Disorder.Core.Combinators where 3 | 4 | import Disorder.Core.Combinators 5 | import Disorder.Core.Run 6 | 7 | import Test.QuickCheck (Property, (===), expectFailure) 8 | 9 | 10 | prop_testJust_Just :: (Show a, Eq a) => a -> Property 11 | prop_testJust_Just a = 12 | testJust "just" (Just a) $ \ x -> x === a 13 | 14 | 15 | prop_testJust_both :: (Show a, Eq a) => Maybe a -> Property 16 | prop_testJust_both ma = 17 | case ma of 18 | Just _ -> testJust "just" ma $ \ a -> a === a 19 | Nothing -> expectFailure . testJust "nothing" ma $ \ a -> a === a 20 | 21 | 22 | prop_testRight_Right :: (Show a, Eq a) => Either a a -> Property 23 | prop_testRight_Right eaa = 24 | let ra = case eaa of 25 | Left a -> Right a 26 | Right _ -> eaa 27 | in testRight "right" ra $ \ x -> x === x 28 | 29 | 30 | prop_testRight_both :: (Show a, Eq a, Show e) => Either e a -> Property 31 | prop_testRight_both ea = 32 | case ea of 33 | Right _ -> testRight "right" ea $ \ a -> a === a 34 | Left _ -> expectFailure . testRight "left" ea $ \ a -> a === a 35 | 36 | 37 | return [] 38 | tests :: IO Bool 39 | tests = $disorderCheckEnvAll TestRunMore 40 | -------------------------------------------------------------------------------- /disorder-core/test/Test/Disorder/Core/Gen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Test.Disorder.Core.Gen where 3 | 4 | import Data.Maybe 5 | import Data.Monoid ((<>)) 6 | import Data.List (nub, partition, (\\)) 7 | 8 | import Disorder.Core.Gen 9 | import Disorder.Core.IO 10 | import Disorder.Core.OrdPair 11 | import Disorder.Core.Run 12 | 13 | import Test.QuickCheck 14 | 15 | 16 | 17 | prop_vectorOfSize :: OrdPair (Positive Int) -> Positive Int -> Property 18 | prop_vectorOfSize (OrdPair (Positive x) (Positive y)) (Positive s) = testIO $ do 19 | l <- generate . resize s $ vectorOfSize x y (arbitrary :: Gen Int) 20 | return $ length l >= x .&&. length l <= y 21 | 22 | prop_chooseSize :: OrdPair (Positive Int) -> Positive Int -> Property 23 | prop_chooseSize (OrdPair (Positive x) (Positive y)) (Positive s) = testIO $ do 24 | s' <- generate . resize s $ chooseSize x y 25 | return $ s' >= x .&&. s' <= y 26 | 27 | prop_maybeGen :: Property 28 | prop_maybeGen = testIO $ do 29 | ma <- generate $ vectorOf 10000 (maybeGen (arbitrary :: Gen Int)) 30 | -- not the best statistical test but we want to make sure that 31 | -- we have "enough" Nothings in the list 32 | return $ 33 | let (justs, nothings) = partition isJust ma 34 | in (length justs >= 8000) .&. 35 | (length nothings >= 100) 36 | 37 | prop_genFromMaybe :: Property 38 | prop_genFromMaybe = 39 | testIO $ do 40 | ma <- generate $ genFromMaybe (arbitrary :: Gen (Maybe ())) 41 | return $ ma == () 42 | 43 | prop_vectorOfUnique :: Property 44 | prop_vectorOfUnique = 45 | forAll (choose (0, 100)) $ \n -> 46 | forAll (vectorOfUnique n genValidUtf8) $ \xs -> 47 | (xs, length xs) === (nub xs, n) 48 | 49 | prop_vectorOfUnique' :: Property 50 | prop_vectorOfUnique' = 51 | expectFailure $ 52 | forAll (vectorOfUnique' 0 10 genValidUtf8) $ \xs -> 53 | xs === nub xs 54 | 55 | prop_listOf1Unique :: Property 56 | prop_listOf1Unique = 57 | forAll (listOf1Unique genValidUtf8) $ \xs -> 58 | conjoin [ 59 | xs === nub xs 60 | , (length xs >= 1) === True 61 | ] 62 | 63 | prop_listOf1UniquePair :: Property 64 | prop_listOf1UniquePair = 65 | forAll (listOf1UniquePair genValidUtf8) $ \(xs, ys) -> 66 | conjoin [ 67 | xs <> ys === nub (xs <> ys) 68 | , (length (xs <> ys) >= 1) === True 69 | , xs \\ ys === xs 70 | , ys \\ xs === ys 71 | ] 72 | 73 | return [] 74 | tests :: IO Bool 75 | tests = $disorderCheckAll 76 | -------------------------------------------------------------------------------- /disorder-core/test/Test/Disorder/Core/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Test.Disorder.Core.IO where 3 | 4 | import Disorder.Core.IO 5 | import Disorder.Core.Run 6 | 7 | import Control.Monad.IO.Class 8 | import Test.QuickCheck 9 | import Test.QuickCheck.Monadic 10 | 11 | prop_falseFails :: Property 12 | prop_falseFails 13 | = expectFailure $ testPropertyIO $ return False 14 | 15 | -- needs stopID for QuickCheck >= 2.10, as it now takes a Testable so false is a fail 16 | prop_falseDoesNotFail :: Property 17 | prop_falseDoesNotFail = 18 | (monadicIO . (=<<) stopIO . run) $ liftIO $ return True 19 | 20 | return [] 21 | tests :: IO Bool 22 | tests = $disorderCheckEnvAll TestRunFewer 23 | -------------------------------------------------------------------------------- /disorder-core/test/Test/Disorder/Core/OrdPair.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Test.Disorder.Core.OrdPair where 3 | 4 | import Disorder.Core.OrdPair 5 | import Disorder.Core.Run 6 | 7 | import Test.QuickCheck 8 | 9 | 10 | prop_uniquePair :: (Arbitrary a, Show a, Eq a, Ord a) => OrdPair a -> Bool 11 | prop_uniquePair (OrdPair a b) = a <= b 12 | 13 | 14 | return [] 15 | tests :: IO Bool 16 | tests = $disorderCheckEnvAll TestRunMore 17 | -------------------------------------------------------------------------------- /disorder-core/test/Test/Disorder/Core/Property.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Test.Disorder.Core.Property where 3 | 4 | import Data.AEq (AEq) 5 | import qualified Data.AEq as AEQ 6 | import Data.Functor 7 | import Data.List (delete) 8 | import Data.Text (Text) 9 | 10 | import Disorder.Core 11 | 12 | import Numeric.IEEE 13 | 14 | import Test.QuickCheck 15 | import Test.QuickCheck.Instances () 16 | 17 | import Prelude 18 | 19 | prop_failWith :: Text -> Property 20 | prop_failWith t = 21 | neg (failWith t) 22 | 23 | prop_notEquals :: (Arbitrary a, Show a, Eq a) => a -> a -> Property 24 | prop_notEquals x y = 25 | (x /= y) ==> x =/= y 26 | 27 | prop_equalsXor :: (Arbitrary a, Show a, Eq a) => a -> a -> Property 28 | prop_equalsXor x y = 29 | (x === y) .^. (x =/= y) 30 | 31 | prop_approxNotEquals :: (AEq a, Arbitrary a, Show a) => a -> a -> Property 32 | prop_approxNotEquals x y = 33 | (not (x AEQ.~== y)) ==> neg (x ~~~ y) 34 | 35 | prop_idApproxEquals :: (AEq a, Arbitrary a, Show a) => a -> Property 36 | prop_idApproxEquals x = x ~~~ x 37 | 38 | prop_floatApproxEquals :: Double -> Property 39 | prop_floatApproxEquals x = 40 | ((abs x) > 1.0) ==> (x + epsilon) ~~~ x 41 | 42 | prop_floatApproxNotEquals :: Double -> Int -> Property 43 | prop_floatApproxNotEquals x n = 44 | n /= 0 ==> neg ((x + (fromIntegral n)) ~~~ x) 45 | 46 | prop_negEquals :: (Arbitrary a, Show a, Eq a) => a -> a -> Property 47 | prop_negEquals x y = 48 | (x =/= y) <=> neg (x === y) 49 | 50 | -- | 51 | -- @p .^. neg p@ 52 | prop_negXor :: (Arbitrary a, Show a, Eq a) => a -> a -> Property 53 | prop_negXor x y = 54 | (x === y) .^. neg (x === y) 55 | 56 | prop_areEquivalent :: (Eq a, Show a) => [a] -> Property 57 | prop_areEquivalent ls = 58 | forAll (shuf ls) $ \rs -> 59 | ls =\\= rs 60 | where 61 | shuf [] = return [] 62 | shuf xs = do 63 | x <- elements xs 64 | (x:) <$> shuf (delete x xs) 65 | 66 | prop_areNotEquivalent :: (Eq a, Show a) => [a] -> [a] -> Property 67 | prop_areNotEquivalent ls rs = 68 | not (all (`elem`ls) rs && all (`elem`rs) ls) ==> 69 | expectFailure $ ls =\\= rs 70 | 71 | prop_realEq_pos :: Int -> Property 72 | prop_realEq_pos x = 73 | x' ### x' 74 | where 75 | x' :: Double 76 | x' = fromIntegral x 77 | 78 | prop_realEq_neg :: Double -> Property 79 | prop_realEq_neg n = forAll (elements [0 / 0, n / 0] :: Gen Double) $ \bad -> 80 | expectFailure $ bad ### bad 81 | 82 | prop_realEq_neq :: UniquePair Int -> Property 83 | prop_realEq_neq (UniquePair n m) = 84 | expectFailure $ n' ### m' 85 | where 86 | n' :: Double 87 | n' = fromIntegral n 88 | 89 | m' :: Double 90 | m' = fromIntegral m 91 | 92 | return [] 93 | tests :: IO Bool 94 | tests = $disorderCheckEnvAll TestRunMore 95 | -------------------------------------------------------------------------------- /disorder-core/test/Test/Disorder/Core/Tripping.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 4 | module Test.Disorder.Core.Tripping where 5 | 6 | import Data.Function 7 | import Disorder.Core 8 | 9 | import Test.QuickCheck 10 | import Test.QuickCheck.Instances () 11 | 12 | prop_tripping = 13 | tripping id (Just :: Int -> Maybe Int) 14 | 15 | prop_tripping_neg = 16 | neg . property $ tripping id (const Nothing :: Int -> Maybe Int) 17 | 18 | prop_tripping_on = 19 | trippingOn (+1) id (Just :: Int -> Maybe Int) 20 | 21 | prop_tripping_on_neg = 22 | neg . property $ trippingOn (+1) id (const Nothing :: Int -> Maybe Int) 23 | 24 | prop_tripping_with = 25 | trippingWith ((===) `on` fmap (+1)) id (Just :: Int -> Maybe Int) 26 | 27 | prop_tripping_with_neg = 28 | neg . property $ trippingWith ((===) `on` fmap (+1)) id (const Nothing :: Int -> Maybe Int) 29 | 30 | return [] 31 | tests = $disorderCheckEnvAll TestRunMore 32 | -------------------------------------------------------------------------------- /disorder-core/test/Test/Disorder/Core/UniquePair.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Test.Disorder.Core.UniquePair where 3 | 4 | import Disorder.Core.Property 5 | import Disorder.Core.UniquePair 6 | import Disorder.Core.Run 7 | 8 | import Test.QuickCheck 9 | 10 | 11 | prop_uniquePair :: (Arbitrary a, Show a, Eq a) => UniquePair a -> Property 12 | prop_uniquePair (UniquePair a b) = a =/= b 13 | 14 | 15 | return [] 16 | tests :: IO Bool 17 | tests = $disorderCheckEnvAll TestRunMore 18 | -------------------------------------------------------------------------------- /disorder-core/test/cli/arguments/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh -eux 2 | 3 | [ "$1" = "ACK" ] 4 | -------------------------------------------------------------------------------- /disorder-core/test/cli/core/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | echo "This should not run as it is excluded for 'framework' code." 4 | 5 | exit 1 6 | -------------------------------------------------------------------------------- /disorder-core/test/test-cli.hs: -------------------------------------------------------------------------------- 1 | import Disorder.Core.Main 2 | 3 | main :: IO () 4 | main = 5 | disorderCliMain ["ACK"] 6 | -------------------------------------------------------------------------------- /disorder-core/test/test.hs: -------------------------------------------------------------------------------- 1 | import Disorder.Core.Main 2 | import qualified Test.Disorder.Core.Gen 3 | import qualified Test.Disorder.Core.Property 4 | import qualified Test.Disorder.Core.Tripping 5 | import qualified Test.Disorder.Core.UniquePair 6 | import qualified Test.Disorder.Core.OrdPair 7 | import qualified Test.Disorder.Core.IO 8 | import qualified Test.Disorder.Core.Combinators 9 | 10 | main :: IO () 11 | main = disorderMain [ 12 | Test.Disorder.Core.Gen.tests 13 | , Test.Disorder.Core.Property.tests 14 | , Test.Disorder.Core.Tripping.tests 15 | , Test.Disorder.Core.UniquePair.tests 16 | , Test.Disorder.Core.OrdPair.tests 17 | , Test.Disorder.Core.IO.tests 18 | , Test.Disorder.Core.Combinators.tests 19 | ] 20 | -------------------------------------------------------------------------------- /disorder-corpus/.ghci: -------------------------------------------------------------------------------- 1 | :set -XQuasiQuotes 2 | :set prompt ">> " 3 | :set -Wall 4 | -------------------------------------------------------------------------------- /disorder-corpus/ambiata-disorder-corpus.cabal: -------------------------------------------------------------------------------- 1 | name: ambiata-disorder-corpus 2 | version: 0.0.3 3 | license: AllRightsReserved 4 | author: Ambiata 5 | maintainer: Ambiata 6 | copyright: (c) 2015 Ambiata 7 | synopsis: disorder-corpus 8 | category: System 9 | cabal-version: >= 1.22 10 | build-type: Simple 11 | description: disorder-corpus. 12 | 13 | library 14 | build-depends: 15 | base >= 3 && < 5 16 | , QuickCheck >= 2.7 17 | 18 | default-language: 19 | Haskell2010 20 | 21 | ghc-options: 22 | -Wall 23 | 24 | hs-source-dirs: 25 | src 26 | 27 | 28 | exposed-modules: 29 | Disorder.Corpus 30 | 31 | test-suite test 32 | type: exitcode-stdio-1.0 33 | 34 | main-is: test.hs 35 | 36 | ghc-options: -Wall -threaded -O2 37 | 38 | hs-source-dirs: 39 | test 40 | 41 | build-depends: 42 | base 43 | , ambiata-disorder-corpus 44 | , text 45 | , QuickCheck 46 | 47 | default-language: 48 | Haskell2010 49 | -------------------------------------------------------------------------------- /disorder-corpus/mafia: -------------------------------------------------------------------------------- 1 | ../framework/mafia -------------------------------------------------------------------------------- /disorder-corpus/master.toml: -------------------------------------------------------------------------------- 1 | ../framework/master.toml -------------------------------------------------------------------------------- /disorder-corpus/src/Disorder/Corpus.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | module Disorder.Corpus ( 6 | agile 7 | , animals 8 | , boats 9 | , cats 10 | , colours 11 | , cooking 12 | , fruits 13 | , glass 14 | , muppets 15 | , nfl 16 | , nhl 17 | , simpsons 18 | , southpark 19 | , vegetables 20 | , viruses 21 | , waters 22 | , weather 23 | 24 | -- * Deprecated 25 | , genCorpus 26 | , shrinkCorpus 27 | , Cooking(..) 28 | , unCooking 29 | , Muppet(..) 30 | , unMuppet 31 | , Southpark(..) 32 | , unSouthpark 33 | , Simpson(..) 34 | , unSimpson 35 | , Virus(..) 36 | , unVirus 37 | , Colour(..) 38 | , unColour 39 | , Weather(..) 40 | , unWeather 41 | , Water(..) 42 | , unWater 43 | , Boat(..) 44 | , unBoat 45 | , Glass(..) 46 | , unGlass 47 | ) where 48 | 49 | import Data.Data (Data) 50 | import Data.Eq (Eq) 51 | import Data.Functor (fmap) 52 | import qualified Data.List as List 53 | import Data.Monoid ((<>)) 54 | import Data.Ord (Ord) 55 | import Data.String (IsString(..)) 56 | import Data.Typeable (Typeable) 57 | 58 | import GHC.Generics (Generic) 59 | 60 | import Test.QuickCheck (Arbitrary(..), Gen, oneof, elements) 61 | 62 | import Text.Show (Show) 63 | import Text.Read (Read) 64 | 65 | 66 | cooking :: IsString a => [a] 67 | cooking = [ 68 | "salted" 69 | , "stewed" 70 | , "diced" 71 | , "filleted" 72 | , "sauteed" 73 | ] 74 | 75 | muppets :: IsString a => [a] 76 | muppets = [ 77 | "kermit" 78 | , "gonzo" 79 | , "fozzy" 80 | , "chef" 81 | , "statler" 82 | , "waldorf" 83 | , "beaker" 84 | , "animal" 85 | ] 86 | 87 | southpark :: IsString a => [a] 88 | southpark = [ 89 | "kyle" 90 | , "stan" 91 | , "cartman" 92 | , "timmy" 93 | , "token" 94 | , "chef" 95 | , "garrison" 96 | ] 97 | 98 | simpsons :: IsString a => [a] 99 | simpsons = [ 100 | "homer" 101 | , "marge" 102 | , "maggie" 103 | , "lisa" 104 | , "bart" 105 | , "flanders" 106 | , "moe" 107 | , "barney" 108 | ] 109 | 110 | viruses :: IsString a => [a] 111 | viruses = [ 112 | "rotavirus" 113 | , "smallpox" 114 | , "norovirus" 115 | , "chickenpox" 116 | , "camelpox" 117 | , "dengue" 118 | , "echovirus" 119 | , "equine morbillivirus" 120 | , "gou virus" 121 | , "measles" 122 | , "monkeypox" 123 | ] 124 | 125 | colours :: IsString a => [a] 126 | colours = [ 127 | "red" 128 | , "green" 129 | , "blue" 130 | , "yellow" 131 | , "black" 132 | , "grey" 133 | , "purple" 134 | , "orange" 135 | , "pink" 136 | ] 137 | 138 | weather :: IsString a => [a] 139 | weather = [ 140 | "dry" 141 | , "raining" 142 | , "hot" 143 | , "humid" 144 | , "snowing" 145 | , "fresh" 146 | , "windy" 147 | , "freezing" 148 | ] 149 | 150 | waters :: IsString a => [a] 151 | waters = [ 152 | "basin" 153 | , "bay" 154 | , "billabong" 155 | , "canal" 156 | , "channel" 157 | , "creek" 158 | , "estuary" 159 | , "fjord" 160 | , "harbour" 161 | , "lake" 162 | , "loch" 163 | , "marsh" 164 | , "ocean" 165 | , "pond" 166 | , "puddle" 167 | , "reservoir" 168 | , "river" 169 | , "sea" 170 | , "slough" 171 | , "sound" 172 | , "spring" 173 | , "stream" 174 | , "swamp" 175 | , "wetland" 176 | ] 177 | 178 | boats :: IsString a => [a] 179 | boats = [ 180 | "barge" 181 | , "battleship" 182 | , "canoe" 183 | , "catamaran" 184 | , "dinghy" 185 | , "ferry" 186 | , "gondola" 187 | , "jetski" 188 | , "kayak" 189 | , "longship" 190 | , "motorboat" 191 | , "pontoon" 192 | , "powerboat" 193 | , "rowboat" 194 | , "ship" 195 | , "steamboat" 196 | , "tanker" 197 | , "trawler" 198 | , "tugboat" 199 | , "yacht" 200 | ] 201 | 202 | animals :: IsString a => [a] 203 | animals = [ 204 | "alligator" 205 | , "ant" 206 | , "bear" 207 | , "bee" 208 | , "bird" 209 | , "camel" 210 | , "cat" 211 | , "cheetah" 212 | , "chicken" 213 | , "chimpanzee" 214 | , "cow" 215 | , "crocodile" 216 | , "deer" 217 | , "dog" 218 | , "dolphin" 219 | , "duck" 220 | , "eagle" 221 | , "elephant" 222 | , "fish" 223 | , "fly" 224 | , "fox" 225 | , "frog" 226 | , "giraffe" 227 | , "goat" 228 | , "goldfish" 229 | , "hamster" 230 | , "hippopotamus" 231 | , "horse" 232 | , "kangaroo" 233 | , "kitten" 234 | , "lion" 235 | , "lobster" 236 | , "monkey" 237 | , "octopus" 238 | , "owl" 239 | , "panda" 240 | , "pig" 241 | , "puppy" 242 | , "rabbit" 243 | , "rat" 244 | , "scorpion" 245 | , "seal" 246 | , "shark" 247 | , "sheep" 248 | , "snail" 249 | , "snake" 250 | , "spider" 251 | , "squirrel" 252 | , "tiger" 253 | , "turtle" 254 | , "wolf" 255 | , "zebra" 256 | ] 257 | 258 | vegetables :: IsString a => [a] 259 | vegetables = [ 260 | "asparagus" 261 | , "beans" 262 | , "broccoli" 263 | , "cabbage" 264 | , "carrot" 265 | , "celery" 266 | , "corn" 267 | , "cucumber" 268 | , "eggplant" 269 | , "green pepper" 270 | , "lettuce" 271 | , "onion" 272 | , "peas" 273 | , "potato" 274 | , "pumpkin" 275 | , "radish" 276 | , "spinach" 277 | , "sweet potato" 278 | , "tomato" -- Don't be so pedantic! It's a culinary vegetable. 279 | , "turnip" 280 | ] 281 | 282 | fruits :: IsString a => [a] 283 | fruits = [ 284 | "apple" 285 | , "banana" 286 | , "cherry" 287 | , "grapefruit" 288 | , "grapes" 289 | , "lemon" 290 | , "lime" 291 | , "melon" 292 | , "orange" 293 | , "peach" 294 | , "pear" 295 | , "persimmon" 296 | , "pineapple" 297 | , "plum" 298 | , "strawberry" 299 | , "tangerine" 300 | , "watermelon" 301 | ] 302 | 303 | cats :: IsString a => [a] 304 | cats = [ 305 | "american_curl" 306 | , "american_shorthair" 307 | , "angora" 308 | , "british_shorthair" 309 | , "bobtail" 310 | , "exotic_shorthair" 311 | , "himalayan" 312 | , "maine_coon" 313 | , "munchkin" 314 | , "norwegian_forest" 315 | , "persian" 316 | , "ragamuffin" 317 | , "ragdoll" 318 | , "russian_blue" 319 | , "scottish_fold" 320 | , "siamese" 321 | , "siberian" 322 | , "tabby" 323 | ] 324 | 325 | nhl :: IsString a => [a] 326 | nhl = [ 327 | "Anaheim Ducks" 328 | , "Arizona Coyotes" 329 | , "Boston Bruins" 330 | , "Buffalo Sabres" 331 | , "Calgary Flames" 332 | , "Carolina Hurricanes" 333 | , "Chicago Blackhawks" 334 | , "Colorado Avalanche" 335 | , "Columbus Blue Jackets" 336 | , "Dallas Stars" 337 | , "Detroit Red Wings" 338 | , "Edmonton Oilers" 339 | , "Florida Panthers" 340 | , "Los Angeles Kings" 341 | , "Minnesota Wild" 342 | , "Montréal Canadiens" 343 | , "Nashville Predators" 344 | , "New Jersey Devils" 345 | , "New York Islanders" 346 | , "New York Rangers" 347 | , "Ottawa Senators" 348 | , "Philadelphia Flyers" 349 | , "Pittsburgh Penguins" 350 | , "San Jose Sharks" 351 | , "St. Louis Blues" 352 | , "Tampa Bay Lightning" 353 | , "Toronto Maple Leafs" 354 | , "Vancouver Canucks" 355 | , "Vegas Golden Knights" 356 | , "Washington Capitals" 357 | , "Winnipeg Jets" 358 | ] 359 | 360 | nfl :: IsString a => [a] 361 | nfl = [ 362 | "Arizona Cardinals" 363 | , "Atlanta Falcons" 364 | , "Baltimore Ravens" 365 | , "Buffalo Bills" 366 | , "Carolina Panthers" 367 | , "Chicago Bears" 368 | , "Cincinnati Bengals" 369 | , "Cleveland Browns" 370 | , "Dallas Cowboys" 371 | , "Denver Broncos" 372 | , "Detroit Lions" 373 | , "Green Bay Packers" 374 | , "Houston Texans" 375 | , "Indianapolis Colts" 376 | , "Jacksonville Jaguars" 377 | , "Kansas City Chiefs" 378 | , "Miami Dolphins" 379 | , "Minnesota Vikings" 380 | , "New England Patriots" 381 | , "New Orleans Saints" 382 | , "New York Giants" 383 | , "New York Jets" 384 | , "Oakland Raiders" 385 | , "Philadelphia Eagles" 386 | , "Pittsburgh Steelers" 387 | , "San Diego Chargers" 388 | , "San Francisco 49ers" 389 | , "Seattle Seahawks" 390 | , "St. Louis Rams" 391 | , "Tampa Bay Buccaneers" 392 | , "Tennessee Titans" 393 | , "Washington Redskins" 394 | ] 395 | 396 | agile :: IsString a => [a] 397 | agile = [ 398 | "agile" 399 | , "backlog" 400 | , "burn-down chart" 401 | , "epic" 402 | , "extreme programming" 403 | , "information radiator" 404 | , "kanban" 405 | , "lean" 406 | , "pair programming" 407 | , "planning poker" 408 | , "product owner" 409 | , "retrospective" 410 | , "scrum" 411 | , "scrum master" 412 | , "spike" 413 | , "sprint" 414 | , "standup" 415 | , "story points" 416 | , "test driven" 417 | , "user story" 418 | , "velocity" 419 | , "vertical slice" 420 | ] 421 | 422 | -- | How to say "I can eat glass, and it doesn't hurt me." in a few different 423 | -- languages. 424 | -- 425 | -- From: http://kermitproject.org/utf8.html 426 | -- 427 | glass :: IsString a => [a] 428 | glass = [ 429 | "काचं शक्नोम्यत्तुम् । नोपहिनस्ति माम् ॥" -- Sanskrit 430 | , "kācaṃ śaknomyattum; nopahinasti mām." -- Sanskrit (standard transcription) 431 | , "ὕαλον ϕαγεῖν δύναμαι· τοῦτο οὔ με βλάπτει." -- Classical Greek 432 | , "Μπορώ να φάω σπασμένα γυαλιά χωρίς να πάθω τίποτα." -- Greek (monotonic) 433 | , "Μπορῶ νὰ φάω σπασμένα γυαλιὰ χωρὶς νὰ πάθω τίποτα. " -- Greek (polytonic) 434 | , "Vitrum edere possum; mihi non nocet." -- Latin 435 | , "Je puis mangier del voirre. Ne me nuit." -- Old French 436 | , "Je peux manger du verre, ça ne me fait pas mal." -- French 437 | , "Pòdi manjar de veire, me nafrariá pas." -- Provençal / Occitan 438 | , "J'peux manger d'la vitre, ça m'fa pas mal." -- Québécois 439 | , "Dji pou magnî do vêre, çoula m' freut nén må. " -- Walloon 440 | , "Ch'peux mingi du verre, cha m'foé mie n'ma. " -- Picard 441 | , "Mwen kap manje vè, li pa blese'm." -- Kreyòl Ayisyen (Haitï) 442 | , "Kristala jan dezaket, ez dit minik ematen." -- Basque 443 | , "Puc menjar vidre, que no em fa mal." -- Catalan / Català 444 | , "Puedo comer vidrio, no me hace daño." -- Spanish 445 | , "Puedo minchar beire, no me'n fa mal . " -- Aragonés 446 | , "Eu podo xantar cristais e non cortarme." -- Galician 447 | , "Posso comer vidro, não me faz mal." -- European Portuguese 448 | , "Posso comer vidro, não me machuca." -- Brazilian Portuguese 449 | , "M' podê cumê vidru, ca ta maguâ-m '." --Caboverdiano/Kabuverdianu (Cape Verde) 450 | , "Ami por kome glas anto e no ta hasimi daño." -- Papiamentu 451 | , "Posso mangiare il vetro e non mi fa male." -- Italian 452 | , "Sôn bôn de magnà el véder, el me fa minga mal." -- Milanese 453 | , "Me posso magna' er vetro, e nun me fa male." -- Roman 454 | , "M' pozz magna' o'vetr, e nun m' fa mal." -- Napoletano 455 | , "Mi posso magnare el vetro, no'l me fa mae." -- Venetian 456 | , "Pòsso mangiâ o veddro e o no me fà mâ." -- Zeneise (Genovese) 457 | , "Puotsu mangiari u vitru, nun mi fa mali. " -- Sicilian 458 | , "Jau sai mangiar vaider, senza che quai fa donn a mai. " -- Romansch (Grischun) 459 | , "Pot să mănânc sticlă și ea nu mă rănește." -- Romanian 460 | , "Mi povas manĝi vitron, ĝi ne damaĝas min. " -- Esperanto 461 | , "Mý a yl dybry gwéder hag éf ny wra ow ankenya." -- Cornish 462 | , "Dw i'n gallu bwyta gwydr, 'dyw e ddim yn gwneud dolur i mi." -- Welsh 463 | , "Foddym gee glonney agh cha jean eh gortaghey mee." -- Manx Gaelic 464 | , "᚛᚛ᚉᚑᚅᚔᚉᚉᚔᚋ ᚔᚈᚔ ᚍᚂᚐᚅᚑ ᚅᚔᚋᚌᚓᚅᚐ᚜" -- Old Irish (Ogham) 465 | , "Con·iccim ithi nglano. Ním·géna." -- Old Irish (Latin) 466 | , "Is féidir liom gloinne a ithe. Ní dhéanann sí dochar ar bith dom." -- Irish 467 | , "Ithim-s a gloine agus ní miste damh é." --Ulster Gaelic 468 | , "S urrainn dhomh gloinne ithe; cha ghoirtich i mi." -- Scottish Gaelic 469 | , "ᛁᚳ᛫ᛗᚨᚷ᛫ᚷᛚᚨᛋ᛫ᛖᚩᛏᚪᚾ᛫ᚩᚾᛞ᛫ᚻᛁᛏ᛫ᚾᛖ᛫ᚻᛖᚪᚱᛗᛁᚪᚧ᛫ᛗᛖ᛬" -- Anglo-Saxon (Runes) 470 | , "Ic mæg glæs eotan ond hit ne hearmiað me." -- Anglo-Saxon (Latin) 471 | , "Ich canne glas eten and hit hirtiþ me nouȝt." -- Middle English 472 | , "I can eat glass and it doesn't hurt me." -- English 473 | , "[aɪ kæn iːt glɑːs ænd ɪt dɐz nɒt hɜːt miː]" -- English (IPA) 474 | , "⠊⠀⠉⠁⠝⠀⠑⠁⠞⠀⠛⠇⠁⠎⠎⠀⠁⠝⠙⠀⠊⠞⠀⠙⠕⠑⠎⠝⠞⠀⠓⠥⠗⠞⠀⠍⠑" -- English (Braille) 475 | , "Mi kian niam glas han i neba hot mi." -- Jamaican 476 | , "Ah can eat gless, it disnae hurt us. " -- Lalland Scots / Doric 477 | , "𐌼𐌰𐌲 𐌲𐌻𐌴𐍃 𐌹̈𐍄𐌰𐌽, 𐌽𐌹 𐌼𐌹𐍃 𐍅𐌿 𐌽𐌳𐌰𐌽 𐌱𐍂𐌹𐌲𐌲𐌹𐌸." -- Gothic 478 | , "ᛖᚴ ᚷᛖᛏ ᛖᛏᛁ ᚧ ᚷᛚᛖᚱ ᛘᚾ ᚦᛖᛋᛋ ᚨᚧ ᚡᛖ ᚱᚧᚨ ᛋᚨᚱ" -- Old Norse (Runes) 479 | , "Ek get etið gler án þess að verða sár." -- Old Norse (Latin) 480 | , "Eg kan eta glas utan å skada meg." -- Norsk / Norwegian (Nynorsk) 481 | , "Jeg kan spise glass uten å skade meg." -- Norsk / Norwegian (Bokmål) 482 | , "Eg kann eta glas, skaðaleysur." -- Føroyskt / Faroese 483 | , "Ég get etið gler án þess að meiða mig." -- Íslenska / Icelandic 484 | , "Jag kan äta glas utan att skada mig." -- Svenska / Swedish 485 | , "Jeg kan spise glas, det gør ikke ondt på mig." -- Dansk / Danish 486 | , "Æ ka æe glass uhen at det go mæ naue." -- Sønderjysk 487 | , "Ik kin glês ite, it docht me net sear." -- Frysk / Frisian 488 | , "Ik kan glas eten, het doet mij geen kwaad." -- Nederlands / Dutch 489 | , "Iech ken glaas èèse, mer 't deet miech jing pieng." -- Kirchröadsj/Bôchesserplat 490 | , "Ek kan glas eet, maar dit doen my nie skade nie." -- Afrikaans 491 | , "Ech kan Glas iessen, daat deet mir nët wei." -- Lëtzebuergescht / Luxemburgish 492 | , "Ich kann Glas essen, ohne mir zu schaden." -- Deutsch / German 493 | , "Ich kann Glas verkasematuckeln, ohne dattet mich wat jucken tut." -- Ruhrdeutsch 494 | , "Isch kann Jlaas kimmeln, uuhne datt mich datt weh dääd." -- Langenfelder Platt 495 | , "Ich koann Gloos assn und doas dudd merr ni wii." -- Lausitzer Mundart ("Lusatian") 496 | , "Iech konn glaasch voschbachteln ohne dass es mir ebbs daun doun dud." -- Odenwälderisch 497 | , "'sch kann Glos essn, ohne dass'sch mer wehtue." -- Sächsisch / Saxon 498 | , "Isch konn Glass fresse ohne dasses mer ebbes ausmache dud." -- Pfälzisch 499 | , "I kå Glas frässa, ond des macht mr nix!" -- Schwäbisch / Swabian 500 | , "I ka glas eassa, ohne dass mar weh tuat." -- Deutsch (Voralberg) 501 | , "I koh Glos esa, und es duard ma ned wei." -- Bayrisch / Bavarian 502 | , "I kaun Gloos essen, es tuat ma ned weh." -- Allemannisch 503 | , "Ich chan Glaas ässe, das schadt mir nöd." -- Schwyzerdütsch (Zürich) 504 | , "Ech cha Glâs ässe, das schadt mer ned. " -- Schwyzerdütsch (Luzern) 505 | , "Meg tudom enni az üveget, nem lesz tőle bajom." -- Hungarian 506 | , "Voin syödä lasia, se ei vahingoita minua." -- Suomi / Finnish 507 | , "Sáhtán borrat lása, dat ii leat bávččas." -- Sami (Northern) 508 | , "Мон ярсан суликадо, ды зыян эйстэнзэ а ули." -- Erzian 509 | , "Mie voin syvvä lasie ta minla ei ole kipie." -- Northern Karelian 510 | , "Minä voin syvvä st'oklua dai minule ei ole kibie. " -- Southern Karelian 511 | , "Ma võin klaasi süüa, see ei tee mulle midagi." -- Estonian 512 | , "Es varu ēst stiklu, tas man nekaitē." -- Latvian 513 | , "Aš galiu valgyti stiklą ir jis manęs nežeidžia " -- Lithuanian 514 | , "Mohu jíst sklo, neublíží mi." -- Czech 515 | , "Môžem jesť sklo. Nezraní ma." -- Slovak 516 | , "Mogę jeść szkło i mi nie szkodzi." -- Polska / Polish 517 | , "Lahko jem steklo, ne da bi mi škodovalo." -- Slovenian 518 | , "Ja mogu jesti staklo, i to mi ne šteti." -- Bosnian, Croatian, Montenegrin and Serbian (Latin) 519 | , "Ја могу јести стакло, и то ми не штети." -- Bosnian, Montenegrin and Serbian (Cyrillic) 520 | , "Можам да јадам стакло, а не ме штета." -- Macedonian 521 | , "Я могу есть стекло, оно мне не вредит." -- Russian 522 | , "Я магу есці шкло, яно мне не шкодзіць." -- Belarusian (Cyrillic) 523 | , "Ja mahu jeści škło, jano mne ne škodzić." -- Belarusian (Lacinka) 524 | , "Я можу їсти скло, і воно мені не зашкодить." -- Ukrainian 525 | , "Мога да ям стъкло, то не ми вреди." -- Bulgarian 526 | , "მინას ვჭამ და არა მტკივა." -- Georgian 527 | , "Կրնամ ապակի ուտել և ինծի անհանգիստ չըներ։" -- Armenian 528 | , "Unë mund të ha qelq dhe nuk më gjen gjë." -- Albanian 529 | , "Cam yiyebilirim, bana zararı dokunmaz." -- Turkish 530 | , "جام ييه بلورم بڭا ضررى طوقونمز" -- Turkish (Ottoman) 531 | , "Men shisha yeyishim mumkin, ammo u menga zarar keltirmaydi." -- Uzbek / O’zbekcha (Roman) 532 | , "Мен шиша ейишим мумкин, аммо у менга зарар келтирмайди." -- Uzbek / Ўзбекча (Cyrillic) 533 | , "আমি কাঁচ খেতে পারি, তাতে আমার কোনো ক্ষতি হয় না।" -- Bangla / Bengali 534 | , "मी काच खाऊ शकतो, मला ते दुखत नाही." -- Marathi 535 | , "ನನಗೆ ಹಾನಿ ಆಗದೆ, ನಾನು ಗಜನ್ನು ತಿನಬಹುದು" -- Kannada 536 | , "मैं काँच खा सकता हूँ और मुझे उससे कोई चोट नहीं पहुंचती." -- Hindi 537 | , "എനിക്ക് ഗ്ലാസ് തിന്നാം. അതെന്നെ വേദനിപ്പിക്കില്ല." -- Malayam 538 | , "நான் கண்ணாடி சாப்பிடுவேன், அதனால் எனக்கு ஒரு கேடும் வராது." -- Tamil 539 | , "నేను గాజు తినగలను మరియు అలా చేసినా నాకు ఏమి ఇబ్బంది లేదు" -- Telugu 540 | , "මට වීදුරු කෑමට හැකියි. එයින් මට කිසි හානියක් සිදු නොවේ." -- Sinhalese 541 | , "میں کانچ کھا سکتا ہوں اور مجھے تکلیف نہیں ہوتی ۔" -- Urdu 542 | , "زه شيشه خوړلې شم، هغه ما نه خوږوي" -- Pashto 543 | , ".من می توانم بدونِ احساس درد شيشه بخورم" -- Farsi / Persian 544 | , "أنا قادر على أكل الزجاج و هذا لا يؤلمني. " -- Arabic 545 | , "Nista' niekol il-ħ ġieġ u ma jagħmilli xejn." --Maltese 546 | , "אני יכול לאכול זכוכית וזה לא מזיק לי." -- Hebrew 547 | , "איך קען עסן גלאָז און עס טוט מיר נישט װײ. " -- Yiddish 548 | , "Metumi awe tumpan, ɜnyɜ me hwee." -- Twi 549 | , "Inā iya taunar gilāshi kuma in gamā lāfiyā." -- Hausa (Latin) 550 | , "إِنا إِىَ تَونَر غِلَاشِ كُمَ إِن غَمَا لَافِىَا" -- Hausa (Ajami) 551 | , "Mo lè je̩ dígí, kò ní pa mí lára." -- Yoruba 552 | , "Nakokí kolíya biténi bya milungi, ekosála ngáí mabé tɛ́." -- Lingala 553 | , "Naweza kula bilauri na sikunyui." -- (Ki)Swahili 554 | , "Saya boleh makan kaca dan ia tidak mencederakan saya." -- Malay 555 | , "Kaya kong kumain nang bubog at hindi ako masaktan." -- Tagalog 556 | , "Siña yo' chumocho krestat, ti ha na'lalamen yo'." -- Chamorro 557 | , "Au rawa ni kana iloilo, ia au sega ni vakacacani kina." -- Fijian 558 | , "Aku isa mangan beling tanpa lara." -- Javanese 559 | , "က္ယ္ဝန္တော္၊က္ယ္ဝန္မ မ္ယက္စားနုိင္သည္။ ၎က္ရောင္ ထိခုိက္မ္ဟု မရ္ဟိပာ။" -- Burmese (Unicode 4.0) 560 | , "ကျွန်တော် ကျွန်မ မှန်စားနိုင်တယ်။ ၎င်းကြောင့် ထိခိုက်မှုမရှိပါ။" -- Burmese (Unicode 5.0) 561 | , "Tôi có thể ăn thủy tinh mà không hại gì." -- Vietnamese (quốc ngữ) 562 | , "些 𣎏 世 咹 水 晶 𦓡 空 𣎏 害 咦" -- Vietnamese (nôm) 563 | , "ខ្ញុំអាចញុំកញ្ចក់បាន ដោយគ្មានបញ្ហារ" -- Khmer 564 | , "ຂອ້ຍກິນແກ້ວໄດ້ໂດຍທີ່ມັນບໍ່ໄດ້ເຮັດໃຫ້ຂອ້ຍເຈັບ." -- Lao 565 | , "ฉันกินกระจกได้ แต่มันไม่ทำให้ฉันเจ็บ" -- Thai 566 | , "Би шил идэй чадна, надад хортой биш" -- Mongolian (Cyrillic) 567 | , "ᠪᠢ ᠰᠢᠯᠢ ᠢᠳᠡᠶᠦ ᠴᠢᠳᠠᠨᠠ ᠂ ᠨᠠᠳᠤᠷ ᠬᠣᠤᠷᠠᠳᠠᠢ ᠪᠢᠰᠢ " -- Mongolian (Classic) 568 | , "म काँच खान सक्छू र मलाई केहि नी हुन्न् ।" -- Nepali 569 | , "ཤེལ་སྒོ་ཟ་ནས་ང་ན་གི་མ་རེད།" -- Tibetan 570 | , "我能吞下玻璃而不伤身体。" -- Chinese 571 | , "我能吞下玻璃而不傷身體。" -- Chinese (Traditional) 572 | , "Góa ē-t àng chia̍h po-lê, mā bē tio̍h-siong." -- Taiwanese 573 | , "私はガラスを食べられます。それは私を傷つけません。" -- Japanese 574 | , "나는 유리를 먹을 수 있어요. 그래도 아프지 않아요" -- Korean 575 | , "Mi save kakae glas, hemi no save katem mi." -- Bislama 576 | , "Hiki iaʻu ke ʻai i ke aniani; ʻaʻole nō lā au e ʻeha." -- Hawaiian 577 | , "E koʻana e kai i te karahi, mea ʻā, ʻaʻe hauhau." -- Marquesan 578 | , "ᐊᓕᒍᖅ ᓂᕆᔭᕌᖓᒃᑯ ᓱᕋᙱᑦᑐᓐᓇᖅᑐᖓ" -- Inuktitut 579 | , "Naika məkmək kakshət labutay, pi weyk ukuk munk-s ik nay." --Chinook Jargon 580 | , "Tsésǫʼ yishą́ągo bííníshghah dóó doo shił neezgai da. " -- Navajo 581 | , "mi kakne le nu citka le blaci .iku'i le se go'i na xrani mi" -- Lojban 582 | , "Ljœr ye caudran créneþ ý jor cẃran." -- Nórdicg 583 | ] 584 | 585 | ------------------------------------------------------------------------ 586 | -- Deprecated 587 | 588 | -- | Generate something in the corpus or something completely bonkers. 589 | genCorpus :: [a] -> (a -> b) -> Gen a -> Gen b 590 | genCorpus corpus f gen = 591 | oneof [ 592 | fmap f (elements corpus) 593 | , fmap f gen 594 | ] 595 | 596 | -- | Shrinks 'b', preferring to return things from the corpus. If 'b' is 597 | -- already from the corpus then shrinks to nothing. 598 | shrinkCorpus :: Eq a => [a] -> (a -> b) -> (b -> a) -> (a -> [a]) -> b -> [b] 599 | shrinkCorpus corpus f g shrinkA b = 600 | let 601 | a = g b 602 | in 603 | if List.elem a corpus then 604 | [] 605 | else 606 | -- Items at the start of the shrink list are tried first by QuickCheck, 607 | -- so put the corpus items first and hopefully we'll get a nicer 608 | -- counterexample. 609 | fmap f (corpus <> shrinkA a) 610 | 611 | -- 612 | -- The newtypes below have the unXXX function defined separately so that 613 | -- the derived Show instance produces output which is easier to read. 614 | -- 615 | 616 | newtype Cooking a = 617 | Cooking a 618 | deriving (Eq, Ord, Read, Show, Generic, Data, Typeable) 619 | 620 | unCooking :: Cooking a -> a 621 | unCooking (Cooking x) = 622 | x 623 | 624 | instance (Eq a, IsString a, Arbitrary a) => Arbitrary (Cooking a) where 625 | arbitrary = 626 | genCorpus cooking Cooking arbitrary 627 | shrink = 628 | shrinkCorpus cooking Cooking unCooking shrink 629 | 630 | newtype Muppet a = 631 | Muppet a 632 | deriving (Eq, Ord, Read, Show, Generic, Data, Typeable) 633 | 634 | unMuppet :: Muppet a -> a 635 | unMuppet (Muppet x) = 636 | x 637 | 638 | instance (Eq a, IsString a, Arbitrary a) => Arbitrary (Muppet a) where 639 | arbitrary = 640 | genCorpus muppets Muppet arbitrary 641 | shrink = 642 | shrinkCorpus muppets Muppet unMuppet shrink 643 | 644 | newtype Southpark a = 645 | Southpark a 646 | deriving (Eq, Ord, Read, Show, Generic, Data, Typeable) 647 | 648 | unSouthpark :: Southpark a -> a 649 | unSouthpark (Southpark x) = 650 | x 651 | 652 | instance (Eq a, IsString a, Arbitrary a) => Arbitrary (Southpark a) where 653 | arbitrary = 654 | genCorpus southpark Southpark arbitrary 655 | shrink = 656 | shrinkCorpus southpark Southpark unSouthpark shrink 657 | 658 | newtype Simpson a = 659 | Simpson a 660 | deriving (Eq, Ord, Read, Show, Generic, Data, Typeable) 661 | 662 | unSimpson :: Simpson a -> a 663 | unSimpson (Simpson x) = 664 | x 665 | 666 | instance (Eq a, IsString a, Arbitrary a) => Arbitrary (Simpson a) where 667 | arbitrary = 668 | genCorpus simpsons Simpson arbitrary 669 | shrink = 670 | shrinkCorpus simpsons Simpson unSimpson shrink 671 | 672 | 673 | newtype Virus a = 674 | Virus a 675 | deriving (Eq, Ord, Read, Show, Generic, Data, Typeable) 676 | 677 | unVirus :: Virus a -> a 678 | unVirus (Virus x) = 679 | x 680 | 681 | instance (Eq a, IsString a, Arbitrary a) => Arbitrary (Virus a) where 682 | arbitrary = 683 | genCorpus viruses Virus arbitrary 684 | shrink = 685 | shrinkCorpus viruses Virus unVirus shrink 686 | 687 | newtype Colour a = 688 | Colour a 689 | deriving (Eq, Ord, Read, Show, Generic, Data, Typeable) 690 | 691 | unColour :: Colour a -> a 692 | unColour (Colour x) = 693 | x 694 | 695 | instance (Eq a, IsString a, Arbitrary a) => Arbitrary (Colour a) where 696 | arbitrary = 697 | genCorpus colours Colour arbitrary 698 | shrink = 699 | shrinkCorpus colours Colour unColour shrink 700 | 701 | newtype Weather a = 702 | Weather a 703 | deriving (Eq, Ord, Read, Show, Generic, Data, Typeable) 704 | 705 | unWeather :: Weather a -> a 706 | unWeather (Weather x) = 707 | x 708 | 709 | instance (Eq a, IsString a, Arbitrary a) => Arbitrary (Weather a) where 710 | arbitrary = 711 | genCorpus weather Weather arbitrary 712 | shrink = 713 | shrinkCorpus weather Weather unWeather shrink 714 | 715 | newtype Water a = 716 | Water a 717 | deriving (Eq, Ord, Read, Show, Generic, Data, Typeable) 718 | 719 | unWater :: Water a -> a 720 | unWater (Water x) = 721 | x 722 | 723 | instance (Eq a, IsString a, Arbitrary a) => Arbitrary (Water a) where 724 | arbitrary = 725 | genCorpus waters Water arbitrary 726 | shrink = 727 | shrinkCorpus waters Water unWater shrink 728 | 729 | newtype Boat a = 730 | Boat a 731 | deriving (Eq, Ord, Read, Show, Generic, Data, Typeable) 732 | 733 | unBoat :: Boat a -> a 734 | unBoat (Boat x) = 735 | x 736 | 737 | instance (Eq a, IsString a, Arbitrary a) => Arbitrary (Boat a) where 738 | arbitrary = 739 | genCorpus boats Boat arbitrary 740 | shrink = 741 | shrinkCorpus boats Boat unBoat shrink 742 | 743 | newtype Glass a = 744 | Glass a 745 | deriving (Eq, Ord, Read, Show, Generic, Data, Typeable) 746 | 747 | unGlass :: Glass a -> a 748 | unGlass (Glass x) = 749 | x 750 | 751 | instance (Eq a, IsString a, Arbitrary a) => Arbitrary (Glass a) where 752 | arbitrary = 753 | genCorpus glass Glass arbitrary 754 | shrink = 755 | shrinkCorpus glass Glass unGlass shrink 756 | -------------------------------------------------------------------------------- /disorder-corpus/test/Test/Disorder/Corpus.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Test.Disorder.Corpus where 4 | 5 | import Control.Applicative 6 | 7 | import Data.Text 8 | import Data.Monoid 9 | 10 | import Disorder.Corpus 11 | 12 | import Test.QuickCheck 13 | 14 | import Prelude 15 | 16 | -- Not much to test here, this is just an example of using the corpus for maximum humour: 17 | 18 | newtype Laugh = 19 | Laugh Text deriving (Eq, Show) 20 | 21 | instance Arbitrary Laugh where 22 | arbitrary = 23 | let laugh x y = Laugh $ x <> " " <> y 24 | in laugh <$> elements cooking <*> elements muppets 25 | 26 | prop_corpusUsage :: Laugh -> Bool 27 | prop_corpusUsage l = 28 | let isFunny = const True in isFunny l 29 | 30 | return [] 31 | tests :: IO Bool 32 | tests = $quickCheckAll 33 | -------------------------------------------------------------------------------- /disorder-corpus/test/test.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | import qualified Test.Disorder.Corpus 4 | 5 | import System.Exit 6 | import System.IO 7 | 8 | 9 | main :: IO () 10 | main = 11 | hSetBuffering stdout LineBuffering >> mapM id [ 12 | Test.Disorder.Corpus.tests 13 | ] >>= \rs -> when (not . all id $ rs) exitFailure 14 | -------------------------------------------------------------------------------- /disorder-eithert/.ghci: -------------------------------------------------------------------------------- 1 | :set prompt "λ> " 2 | :set -Wall 3 | :set -XOverloadedStrings 4 | :set -XScopedTypeVariables 5 | -------------------------------------------------------------------------------- /disorder-eithert/ambiata-disorder-eithert.cabal: -------------------------------------------------------------------------------- 1 | name: ambiata-disorder-eithert 2 | version: 0.0.3 3 | license: AllRightsReserved 4 | author: Ambiata 5 | maintainer: Ambiata 6 | copyright: (c) 2015 Ambiata 7 | synopsis: disorder-eithert 8 | category: System 9 | cabal-version: >= 1.22 10 | build-type: Simple 11 | description: disorder-eithert. 12 | 13 | library 14 | build-depends: 15 | base >= 3 && < 5 16 | , QuickCheck >= 2.7 17 | , text >= 1.1 && < 1.3 18 | , transformers >= 0.4 && < 1 19 | 20 | default-language: 21 | Haskell2010 22 | 23 | ghc-options: 24 | -Wall 25 | 26 | hs-source-dirs: 27 | src 28 | 29 | 30 | exposed-modules: 31 | Disorder.Either 32 | -------------------------------------------------------------------------------- /disorder-eithert/mafia: -------------------------------------------------------------------------------- 1 | ../framework/mafia -------------------------------------------------------------------------------- /disorder-eithert/master.toml: -------------------------------------------------------------------------------- 1 | ../framework/master.toml -------------------------------------------------------------------------------- /disorder-eithert/src/Disorder/Either.hs: -------------------------------------------------------------------------------- 1 | module Disorder.Either ( 2 | testEither 3 | , testEitherT 4 | ) where 5 | 6 | import Control.Monad.Trans.Except (ExceptT, runExceptT) 7 | 8 | import Data.Text (Text, unpack) 9 | 10 | import Test.QuickCheck.Property 11 | 12 | 13 | testEither :: Testable a => (e -> Text) -> Either e a -> Property 14 | testEither t = 15 | either (flip counterexample False . unpack . t) property 16 | 17 | testEitherT :: (Functor m, Testable a) => (e -> Text) -> ExceptT e m a -> m Property 18 | testEitherT t = 19 | fmap (testEither t) . runExceptT 20 | -------------------------------------------------------------------------------- /disorder-fsm/.ghci: -------------------------------------------------------------------------------- 1 | :set prompt "λ> " 2 | :set -Wall 3 | :set -XOverloadedStrings 4 | :set -XScopedTypeVariables 5 | -------------------------------------------------------------------------------- /disorder-fsm/ambiata-disorder-fsm.cabal: -------------------------------------------------------------------------------- 1 | name: ambiata-disorder-fsm 2 | version: 0.0.3 3 | license: AllRightsReserved 4 | author: Ambiata 5 | maintainer: Ambiata 6 | copyright: (c) 2015 Ambiata 7 | synopsis: Final state machine testing 8 | category: System 9 | cabal-version: >= 1.22 10 | build-type: Simple 11 | description: Final state machine testing. 12 | 13 | library 14 | build-depends: 15 | base >= 3 && < 5 16 | , containers >= 0.5 && < 0.7 17 | , exceptions == 0.8.* 18 | , mtl >= 2.1 && < 2.3 19 | , QuickCheck >= 2.7 && < 2.12 20 | , time 21 | , transformers >= 0.3 && < 1 22 | 23 | default-language: 24 | Haskell2010 25 | 26 | ghc-options: 27 | -Wall 28 | if impl(ghc >= 8.0) 29 | ghc-options: -fno-warn-redundant-constraints 30 | 31 | hs-source-dirs: 32 | src 33 | 34 | 35 | exposed-modules: 36 | Disorder.FSM 37 | Disorder.FSM.Catch 38 | Disorder.FSM.Core 39 | Disorder.FSM.Property 40 | Disorder.FSM.Runner 41 | 42 | test-suite test 43 | type: exitcode-stdio-1.0 44 | 45 | main-is: test.hs 46 | 47 | ghc-options: -Wall -threaded -O2 48 | 49 | hs-source-dirs: 50 | test 51 | 52 | build-depends: 53 | base 54 | , ambiata-disorder-fsm 55 | , containers 56 | , mtl 57 | , QuickCheck 58 | , temporary >= 1.1 && < 1.3 59 | , transformers 60 | 61 | default-language: 62 | Haskell2010 63 | -------------------------------------------------------------------------------- /disorder-fsm/mafia: -------------------------------------------------------------------------------- 1 | ../framework/mafia -------------------------------------------------------------------------------- /disorder-fsm/master.toml: -------------------------------------------------------------------------------- 1 | ../framework/master.toml -------------------------------------------------------------------------------- /disorder-fsm/src/Disorder/FSM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module Disorder.FSM ( 3 | module X 4 | ) where 5 | 6 | import Disorder.FSM.Catch as X 7 | import Disorder.FSM.Core as X 8 | import Disorder.FSM.Property as X 9 | import Disorder.FSM.Runner as X 10 | -------------------------------------------------------------------------------- /disorder-fsm/src/Disorder/FSM/Catch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | module Disorder.FSM.Catch ( 5 | CatchableT(..) 6 | , CatchableContT 7 | , runCatchableContT 8 | , evalCatchableContT 9 | ) where 10 | 11 | import Control.Applicative (Applicative) 12 | import Control.Monad (Monad(..)) 13 | import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) 14 | import Control.Monad.Cont (ContT(..)) 15 | import Control.Monad.IO.Class (MonadIO(..)) 16 | import Control.Monad.Reader (MonadReader(..)) 17 | import Control.Monad.State (MonadState(..)) 18 | import Control.Monad.Trans.Class (MonadTrans(..)) 19 | 20 | import Data.Function ((.), ($), flip) 21 | import Data.Functor (Functor(..)) 22 | 23 | import Test.QuickCheck.Gen (Gen(..)) 24 | import Test.QuickCheck.Monadic (PropertyM(..)) 25 | 26 | 27 | newtype CatchableT m a = CatchableT { 28 | runCatchable :: m a 29 | } deriving ( 30 | Functor 31 | , Applicative 32 | , Monad 33 | , MonadIO 34 | , MonadReader e 35 | , MonadState s 36 | ) 37 | 38 | instance MonadTrans CatchableT where 39 | lift = CatchableT 40 | 41 | instance MonadThrow m => MonadThrow (CatchableT (PropertyM m)) where 42 | throwM = CatchableT . lift . throwM 43 | 44 | instance (MonadCatch m, MonadThrow m) => MonadCatch (CatchableT (PropertyM m)) where 45 | catch (CatchableT (MkPropertyM f)) g = CatchableT . MkPropertyM $ \h -> catchGen (f h) (\e -> unPropertyM (runCatchable (g e)) h) 46 | where 47 | catchGen (MkGen f') g' = MkGen $ \q i -> f' q i `catch` (\e -> unGen (g' e) q i) 48 | 49 | instance MonadThrow m => MonadThrow (CatchableT (ContT r m)) where 50 | throwM = CatchableT . throwM 51 | 52 | instance (MonadCatch m, MonadThrow m) => MonadCatch (CatchableT (ContT r m)) where 53 | catch (CatchableT m) g = CatchableT . ContT $ \c -> runContT m c `catch` (\e -> runContT (runCatchable (g e)) c) 54 | 55 | 56 | type CatchableContT r m = CatchableT (ContT r m) 57 | 58 | runCatchableContT :: CatchableContT r m a -> (a -> m r) -> m r 59 | runCatchableContT = runContT . runCatchable 60 | 61 | evalCatchableContT :: Monad m => CatchableContT r m r -> m r 62 | evalCatchableContT = flip runContT return . runCatchable 63 | -------------------------------------------------------------------------------- /disorder-fsm/src/Disorder/FSM/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | module Disorder.FSM.Core ( 7 | -- * Transition type and constructor 8 | Transition(..) 9 | , mapTransition 10 | , Action(..) 11 | , mapAction 12 | -- * Lift functions for 'Gen' 13 | , liftGen 14 | -- * Transition evaluation 15 | , runFSM 16 | -- * Utility functions 17 | , mapPropertyM 18 | , mapContT' 19 | , pickGen 20 | ) where 21 | 22 | import Control.Applicative (Applicative) 23 | import Control.Exception.Base (AssertionFailed(..)) 24 | import Control.Monad.Trans.Class (MonadTrans(..)) 25 | import Control.Monad (Monad(..)) 26 | import Control.Monad.Catch (MonadCatch(..), MonadThrow(..), catchAll) 27 | import Control.Monad.Cont (ContT(..)) 28 | import Control.Monad.IO.Class (MonadIO(..)) 29 | import Control.Monad.Reader (MonadReader(..)) 30 | import Control.Monad.State (MonadState(..), evalStateT, modify) 31 | 32 | import Data.Function ((.), ($), const) 33 | import Data.Functor (Functor(..)) 34 | import Data.Maybe (Maybe(..)) 35 | import Data.Monoid (Monoid(..), (<>)) 36 | import Data.String (String) 37 | 38 | import Disorder.FSM.Catch 39 | 40 | import Prelude (Show(..)) 41 | 42 | import Test.QuickCheck (Property) 43 | import Test.QuickCheck.Monadic (PropertyM(..)) 44 | import Test.QuickCheck.Gen (Gen(..)) 45 | 46 | 47 | -- | Defines a transition from state to state 48 | data Transition m a = MkTransition { 49 | -- | Display name (used in case of failure) 50 | name :: String 51 | -- | Transition action 52 | , transition :: Action m a 53 | } 54 | 55 | instance Show (Transition m a) where 56 | show = name 57 | 58 | mapTransition :: (m Property -> n Property) -> (n Property -> m Property) -> Transition m a -> Transition n a 59 | mapTransition f g (MkTransition n a) = MkTransition n (mapAction f g a) 60 | 61 | 62 | newtype Action m a = Action { 63 | runAction :: PropertyM m a 64 | } deriving ( 65 | Functor 66 | , Applicative 67 | , MonadIO 68 | ) 69 | 70 | instance (MonadThrow m, MonadState s m) => MonadState s (Action m) where 71 | state = lift . state 72 | 73 | instance (MonadThrow m, MonadReader r m) => MonadReader r (Action m) where 74 | ask = lift ask 75 | local f (Action m) = Action $ do 76 | r <- lift $ ask 77 | mapPropertyM (local f) (local (const r)) m 78 | 79 | instance MonadThrow m => Monad (Action m) where 80 | return = Action . return 81 | Action m >>= k = Action $ m >>= runAction . k 82 | fail = lift . throwM . AssertionFailed 83 | 84 | instance MonadTrans Action where 85 | lift = Action . lift 86 | 87 | -- | Lift generator to 'Action' 88 | liftGen :: (Monad m, Show a) => Gen a -> Action m a 89 | liftGen = Action . pickGen 90 | 91 | mapAction :: (m Property -> n Property) -> (n Property -> m Property) -> Action m a -> Action n a 92 | mapAction f g = Action . mapPropertyM f g . runAction 93 | 94 | 95 | -- | Main basic function for running FSM models 96 | runFSM :: (MonadState s m, MonadCatch m, MonadThrow m, Show s) => PropertyM m (Maybe (Transition m ())) -> PropertyM m () 97 | runFSM g = 98 | runCatchable $ evalStateT go mempty 99 | where 100 | go = do 101 | s <- lift . lift . lift $ get 102 | modify $ (<> "\n(" <> show s <> ") ") 103 | ts1 <- get 104 | mt <- (lift . lift) g `catchAll` handleException ts1 105 | case mt of 106 | Nothing -> return () 107 | Just t -> do 108 | modify $ (<> "-> { " <> name t <> " } -> ") 109 | ts2 <- get 110 | (lift . lift . runAction . transition) t `catchAll` handleException ts2 111 | go 112 | 113 | handleException ts e = fail $ ts <> "Exception thrown: " <> show e 114 | 115 | 116 | mapPropertyM :: (m Property -> n Property) -> (n Property -> m Property) -> PropertyM m a -> PropertyM n a 117 | mapPropertyM f g (MkPropertyM h) = MkPropertyM $ \c -> fmap f (h (fmap g . c)) 118 | 119 | mapContT' :: ((a -> n r) -> (a -> m r)) -> (m r -> n r) -> ContT r m a -> ContT r n a 120 | mapContT' f g m = ContT $ g . runContT m . f 121 | 122 | 123 | pickGen :: Gen a -> PropertyM m a 124 | pickGen g = MkPropertyM $ \c -> g >>= c 125 | -------------------------------------------------------------------------------- /disorder-fsm/src/Disorder/FSM/Property.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE TupleSections #-} 3 | module Disorder.FSM.Property ( 4 | module X 5 | -- * Assert helper functions 6 | , assert 7 | , assertMsg 8 | , (===) 9 | , (=/=) 10 | -- * Biased 'shuffle' with 'frequency'-like coefficients 11 | , frequencyShuffle 12 | ) where 13 | 14 | import Control.Monad 15 | import Control.Monad.Catch (MonadThrow(..)) 16 | 17 | import Data.Bool 18 | import Data.Eq 19 | import Data.Function 20 | import Data.List (foldl') 21 | import Data.Monoid 22 | import Data.Ord 23 | import Data.String 24 | 25 | import Disorder.FSM.Core 26 | 27 | import Prelude (Int, Show(..), Num(..), error) 28 | 29 | import Test.QuickCheck as X hiding ((===)) 30 | import Test.QuickCheck.Monadic as X hiding (assert) 31 | 32 | 33 | -- | FSM implementation of QC 'assert' 34 | assert :: (MonadThrow m) => Bool -> Action m () 35 | assert = flip assertMsg "Assertion failed" 36 | 37 | -- | Like 'assert' but with custom message displayed in case of failure 38 | assertMsg :: (MonadThrow m) => Bool -> String -> Action m () 39 | assertMsg p msg = 40 | unless p $ fail msg 41 | 42 | -- | FSM implementation of QC '(===)' 43 | infix 4 === 44 | (===) :: (Eq a, Show a, Monad m, MonadThrow m) => a -> a -> Action m () 45 | x === y = (x == y) `assertMsg` (show x <> " /= " <> show y) 46 | 47 | infix 4 =/= 48 | (=/=) :: (Eq a, Show a, Monad m, MonadThrow m) => a -> a -> Action m () 49 | x =/= y = (x /= y) `assertMsg` (show x <> " == " <> show y) 50 | 51 | 52 | frequencyShuffle :: [(Int, a)] -> Gen [a] 53 | frequencyShuffle xs = 54 | let s = foldl' (\s' (k,_) -> s'+k) 0 xs 55 | in go s xs 56 | where 57 | go _ [] = return [] 58 | go s kxs = do 59 | n <- choose(1,s) 60 | let ((k,x):kxs') = extract n kxs 61 | xs' <- go (s-k) kxs' 62 | return $ x : xs' 63 | extract n kxs@((k,_):_) | n <= k = kxs 64 | extract n (kx@(k,_):kxs) = 65 | let (kx':kxs') = extract (n-k) kxs 66 | in kx' : kx : kxs' 67 | extract _ [] = error "Invalid input" 68 | -------------------------------------------------------------------------------- /disorder-fsm/src/Disorder/FSM/Runner.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | module Disorder.FSM.Runner ( 9 | -- * Transition type and constructor 10 | ConditionalTransition(..) 11 | , RunnerT 12 | , mkTransition 13 | -- * Combinators to make 'Transition' less trivial 14 | , goif 15 | , goto 16 | -- * Stubs for combinators arguments 17 | , always 18 | , sameState 19 | -- * 20 | , runFSMGen 21 | , runFSMUntil 22 | , runFSMFor 23 | -- * 24 | , limitBy 25 | ) where 26 | 27 | import Control.Applicative (Applicative) 28 | import Control.Monad (Monad(..), mfilter, (<=<)) 29 | import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) 30 | import Control.Monad.IO.Class (MonadIO(..)) 31 | import Control.Monad.Reader (MonadReader(..), ReaderT(..)) 32 | import Control.Monad.RWS (RWST(..), evalRWST) 33 | import Control.Monad.State (MonadState(..), StateT, evalStateT, modify) 34 | import Control.Monad.Trans.Class (MonadTrans(..)) 35 | 36 | import Data.Bool (Bool(..)) 37 | import Data.Function (($), (.), flip, const) 38 | import Data.Functor (Functor(..)) 39 | import Data.Maybe (Maybe(..)) 40 | import Data.Ord ((>=), (<)) 41 | import Data.String (String) 42 | import Data.Time (NominalDiffTime, UTCTime, getCurrentTime, diffUTCTime) 43 | import Data.Tuple (fst, uncurry) 44 | 45 | import Disorder.FSM.Core 46 | 47 | import Prelude (Enum(..), Int, Show(..)) 48 | 49 | import Test.QuickCheck (Gen, Property, arbitrary, suchThatMaybe) 50 | import Test.QuickCheck.Property (rejected) 51 | import Test.QuickCheck.Monadic (PropertyM(..), stop) 52 | 53 | 54 | data ConditionalTransition e s m = ConditionalTransition { 55 | preCond :: e -> s -> Bool 56 | , toTransition :: Transition (RunnerT e s m) () 57 | } 58 | 59 | -- | Constructor for 'ConditionalTransition' 60 | -- Create unconditional 'Transition' which does nothing 61 | mkTransition :: MonadThrow m => String -> ConditionalTransition e s m 62 | mkTransition name' = 63 | ConditionalTransition always $ 64 | MkTransition name' sameState 65 | 66 | -- | Define condition to 'Transition' 67 | goif :: ConditionalTransition e s m -> (s -> Bool) -> ConditionalTransition e s m 68 | goif ct preCond' = ct { preCond = \_ -> preCond' } 69 | 70 | -- | Define transition logic 71 | goto :: ConditionalTransition e s m -> Action (RunnerT e s m) () -> ConditionalTransition e s m 72 | goto ct@(ConditionalTransition _ t) transition' = 73 | ct { toTransition = t { transition = transition' }} 74 | 75 | -- | Do not change the state or eval any monadic actions 76 | sameState :: MonadThrow m => Action m () 77 | sameState = return () 78 | 79 | -- | Make 'Transition' unconditional 80 | always :: e -> s -> Bool 81 | always = const . const True 82 | 83 | newtype RunnerT e s m a = RunnerT { 84 | toRWST :: RWST e () s m a 85 | } deriving ( 86 | Functor 87 | , Applicative 88 | , Monad 89 | , MonadIO 90 | , MonadReader e 91 | , MonadState s 92 | , MonadThrow 93 | , MonadCatch 94 | , MonadTrans 95 | ) 96 | 97 | runRunnerT :: Monad m => e -> s -> RunnerT e s m a -> m a 98 | runRunnerT e s = return . fst <=< (\m -> evalRWST m e s) . toRWST 99 | 100 | 101 | runFSMGen :: (MonadCatch m, Show s) => e -> s -> Gen [Gen (ConditionalTransition e s m)] -> PropertyM m () 102 | runFSMGen e s gs = do 103 | n <- pickGen arbitrary :: PropertyM m Int 104 | runFSMUntil n e s gs 105 | 106 | 107 | runFSMUntil :: (MonadCatch m, Show s) => Int -> e -> s -> Gen [Gen (ConditionalTransition e s m)] -> PropertyM m () 108 | runFSMUntil n e s = 109 | runFSMWith 110 | ((runRunnerT e s) . (runCounter n)) 111 | (lift . lift) 112 | . limitByCount . fromStatefulTransition 113 | 114 | runFSMFor :: (MonadIO m, MonadCatch m, Show s) => NominalDiffTime -> e -> s -> Gen [Gen (ConditionalTransition e s m)] -> PropertyM m () 115 | runFSMFor d e s gs = do 116 | t0 <- liftIO $ getCurrentTime 117 | runFSMWith 118 | ((runRunnerT e s) . (runTimer t0 d)) 119 | (lift . lift) 120 | . limitByTime . fromStatefulTransition $ gs 121 | 122 | 123 | runFSMWith :: (MonadState s m, MonadCatch m, Show s) 124 | => (m Property -> n Property) -> (n Property -> m Property) -> PropertyM m (Maybe (Transition m ())) 125 | -> PropertyM n () 126 | runFSMWith l u = 127 | mapPropertyM l u . runFSM 128 | 129 | 130 | fromStatefulTransition :: Monad m => Gen [Gen (ConditionalTransition e s m)] -> PropertyM (RunnerT e s m) (Maybe (Transition (RunnerT e s m) ())) 131 | fromStatefulTransition ggs = do 132 | e <- lift ask 133 | s <- lift get 134 | gs <- pickGen $ ggs 135 | let go = \case 136 | [] -> stop rejected 137 | (g:gs') -> do 138 | mt <- pickGen $ g `suchThatMaybe` \t -> preCond t e s 139 | case mt of 140 | Nothing -> go gs' 141 | Just t -> return . Just . toTransition $ t 142 | go gs 143 | 144 | 145 | 146 | limitByCount :: Monad m 147 | => PropertyM m (Maybe (Transition m ())) 148 | -> PropertyM (CounterT m) (Maybe (Transition (CounterT m) ())) 149 | limitByCount = 150 | limitBy 151 | (tick >>= return . mfilter (>= 0) . Just) 152 | (const lift) 153 | runCounter 154 | 155 | newtype CounterT m a = CounterT { 156 | toState :: StateT Int m a 157 | } deriving ( 158 | Applicative 159 | , Functor 160 | , Monad 161 | ) 162 | 163 | instance (MonadState s m) => MonadState s (CounterT m) where 164 | state = lift . state 165 | 166 | deriving instance (Monad m, MonadCatch (StateT Int m)) => MonadCatch (CounterT m) 167 | 168 | deriving instance (Monad m, MonadThrow (StateT Int m)) => MonadThrow (CounterT m) 169 | 170 | runCounter :: Monad m => Int -> CounterT m a -> m a 171 | runCounter n = flip evalStateT n . toState 172 | 173 | tick :: Monad m => CounterT m Int 174 | tick = CounterT $ modify pred >> get 175 | 176 | instance MonadTrans CounterT where 177 | lift = CounterT . lift 178 | 179 | 180 | limitByTime :: (Monad m, MonadIO m) 181 | => PropertyM m (Maybe (Transition m ())) 182 | -> PropertyM (TimerT m) (Maybe (Transition (TimerT m) ())) 183 | limitByTime = 184 | limitBy 185 | tock 186 | (const lift) 187 | (uncurry runTimer) 188 | 189 | newtype TimerT m a = TimerT { 190 | toReader :: ReaderT (UTCTime, NominalDiffTime) m a 191 | } deriving ( 192 | Applicative 193 | , Functor 194 | , Monad 195 | , MonadIO 196 | ) 197 | 198 | instance (MonadState s m) => MonadState s (TimerT m) where 199 | state = lift . state 200 | 201 | deriving instance (Monad m, MonadCatch (ReaderT (UTCTime, NominalDiffTime) m)) => MonadCatch (TimerT m) 202 | 203 | deriving instance (Monad m, MonadThrow (ReaderT (UTCTime, NominalDiffTime) m)) => MonadThrow (TimerT m) 204 | 205 | runTimer :: Monad m => UTCTime -> NominalDiffTime -> TimerT m a -> m a 206 | runTimer t d = flip runReaderT (t,d) . toReader 207 | 208 | instance MonadTrans TimerT where 209 | lift = TimerT . lift 210 | 211 | tock :: MonadIO m => TimerT m (Maybe (UTCTime, NominalDiffTime)) 212 | tock = do 213 | t <- liftIO getCurrentTime 214 | (t0, d) <- TimerT ask 215 | return $ if diffUTCTime t t0 < d then (Just (t0, d)) else Nothing 216 | 217 | 218 | limitBy :: (MonadTrans t, Monad m, Monad (t m)) 219 | => t m (Maybe v) -> (v -> m Property -> t m Property) -> (v -> t m Property -> m Property) -> PropertyM m (Maybe (Transition m ())) 220 | -> PropertyM (t m) (Maybe (Transition (t m) ())) 221 | limitBy mp fu fd g = do 222 | mv <- lift mp 223 | case mv of 224 | Nothing -> 225 | return Nothing 226 | Just v -> do 227 | (fmap . fmap) (\(MkTransition n t) -> MkTransition n (Action . mapPropertyM (fu v) (fd v) . runAction $ t)) 228 | . mapPropertyM (fu v) (fd v) $ g 229 | -------------------------------------------------------------------------------- /disorder-fsm/test/Test/Disorder/FSM.hs: -------------------------------------------------------------------------------- 1 | module Test.Disorder.FSM where 2 | 3 | import Control.Applicative 4 | 5 | import qualified Test.Disorder.FSM.Cont 6 | import qualified Test.Disorder.FSM.IO 7 | import qualified Test.Disorder.FSM.Property 8 | 9 | 10 | import Prelude 11 | tests :: IO Bool 12 | tests = and <$> sequence [ 13 | Test.Disorder.FSM.Property.tests 14 | , Test.Disorder.FSM.IO.tests 15 | , Test.Disorder.FSM.Cont.tests 16 | ] 17 | -------------------------------------------------------------------------------- /disorder-fsm/test/Test/Disorder/FSM/Cont.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Test.Disorder.FSM.Cont where 3 | 4 | import Control.Applicative 5 | import Control.Concurrent 6 | import Control.Monad 7 | import Control.Monad.Cont 8 | import Control.Monad.Reader 9 | import Control.Monad.State 10 | 11 | import qualified Data.List as L 12 | import Data.Monoid 13 | import qualified Data.Map.Strict as M 14 | import Data.Maybe 15 | 16 | import Disorder.FSM 17 | 18 | import Prelude 19 | 20 | import System.IO 21 | import System.IO.Temp 22 | 23 | 24 | 25 | -- | Environment of the model is just a root temporary directory 26 | newtype Environment = Environment { 27 | workingDirectory :: FilePath 28 | } 29 | 30 | -- | Model state: simple "file system" 31 | newtype FileSystem = FileSystem { 32 | fileSystemFiles :: M.Map FilePath File 33 | } 34 | 35 | mkFileSystem :: FileSystem 36 | mkFileSystem = FileSystem M.empty 37 | 38 | data File = File { 39 | -- | Nothing if file is closed 40 | fileHandle :: Maybe Handle 41 | -- | Mirrors the actual file content 42 | , fileContent :: [String] 43 | } deriving (Show ) 44 | 45 | instance Show FileSystem where 46 | show = L.unlines . fmap showFile . M.toAscList . fileSystemFiles 47 | where 48 | showFile (fp, f) = fileName fp <> " (" <> showInfo f <> ")" 49 | fileName = L.reverse . L.takeWhile (/='/') . L.reverse 50 | showInfo (File (Just _) c) = "opened, " <> showContent c 51 | showInfo (File Nothing c) = "closed, " <> showContent c 52 | showContent c = show (L.length c) <> " line(s)" 53 | 54 | -- * 'ContT' version of "bracket" system fuctions 55 | 56 | withSystemTempDirectoryCont :: String -> CatchableContT a IO FilePath 57 | withSystemTempDirectoryCont = lift . ContT . withSystemTempDirectory 58 | 59 | withTempDirectoryCont :: FilePath -> String -> CatchableContT a IO FilePath 60 | withTempDirectoryCont d = lift . ContT . withTempDirectory d 61 | 62 | withTempFileCont :: FilePath -> String -> CatchableContT a IO (FilePath, Handle) 63 | withTempFileCont d t = lift . ContT $ \fc -> withTempFile d t (curry fc) 64 | 65 | withFileCont :: FilePath -> IOMode -> CatchableContT a IO Handle 66 | withFileCont fp = lift . ContT . withFile fp 67 | 68 | -- | FSM 'Transition' state 69 | type FileTransition = ConditionalTransition Environment FileSystem (CatchableContT Property IO) 70 | 71 | -- * Model transitions 72 | 73 | -- | Creates new empty file inside 'withTempFile' continuation 74 | -- so the file is deleted after tests 75 | -- file stays open after this step 76 | genCreateFile :: Gen FileTransition 77 | genCreateFile = do 78 | return $ mkTransition "create file" `goto` do 79 | env <- ask 80 | (fp, h) <- lift . lift $ withTempFileCont (workingDirectory env) "file.txt" 81 | modify $ \fs -> fs { 82 | fileSystemFiles = M.insert fp (File (Just h) []) (fileSystemFiles fs) 83 | } 84 | 85 | genSlowCreateFile :: Gen FileTransition 86 | genSlowCreateFile = do 87 | return $ mkTransition "create file" `goto` do 88 | env <- ask 89 | (fp, h) <- lift . lift $ withTempFileCont (workingDirectory env) "file.txt" 90 | liftIO $ threadDelay (100*1000) -- 0.1 sec 91 | modify $ \fs -> fs { 92 | fileSystemFiles = M.insert fp (File (Just h) []) (fileSystemFiles fs) 93 | } 94 | 95 | -- | Closes randomly chosen open file 96 | genCloseFile :: Gen FileTransition 97 | genCloseFile = do 98 | -- is executed only if there is at least one open file in the model (and in 'RealWord') 99 | return $ mkTransition "close file" `goif` anyOpenFile `goto` do 100 | fs <- get 101 | Just (fp, (File (Just h) _)) <- liftGen $ pickOpenFile fs 102 | liftIO $ hClose h 103 | -- update the state of the model (closes the file) 104 | modify $ \fs' -> fs' { 105 | fileSystemFiles = M.adjust (\(File _ c) -> File Nothing c) fp (fileSystemFiles fs) 106 | } 107 | 108 | -- | Writes a line into randomly chosen open file 109 | genWriteFile :: Gen FileTransition 110 | genWriteFile = do 111 | l <- listOf (choose ('A', 'z')) 112 | return $ mkTransition "write line" `goif` anyOpenFile `goto` do 113 | fs <- get 114 | Just (fp, (File (Just h) _)) <- liftGen $ pickOpenFile fs 115 | liftIO $ hPutStrLn h l 116 | -- update the state of the model (add written line to the end of 'fileContent') 117 | modify $ \fs' -> fs' { 118 | fileSystemFiles = M.adjust (\(File h' c) -> File h' (c <> [l])) fp (fileSystemFiles fs) 119 | } 120 | 121 | -- | Reads randomly chosen line from randomly chosen closed file 122 | genReadFile :: Gen FileTransition 123 | genReadFile = do 124 | return $ mkTransition "read line" `goif` anyClosedNonEmptyFile `goto` do 125 | fs <- get 126 | Just (fp, (File Nothing ls)) <- liftGen $ pickClosedNonEmptyFile fs 127 | do 128 | (li, sl) <- liftGen . elements . L.zip [0..] $ ls 129 | -- opens file in continuations so it will be closed at the end of "do" block 130 | fl <- liftIO . evalCatchableContT $ do 131 | h <- withFileCont fp ReadMode 132 | liftIO $ do 133 | -- skips all lines before 'li'-st one 134 | replicateM_ li (hGetLine h) 135 | hGetLine h 136 | -- checks that the read line matches corresponding line from the model 137 | fl === sl 138 | 139 | -- | Invalid reading of file which may fail if the file is empty 140 | -- (the situation which is not checked here) 141 | genInvalidReadFile :: Gen FileTransition 142 | genInvalidReadFile = do 143 | return $ mkTransition "invalid read line" `goif` anyClosedFile `goto` do 144 | fs <- get 145 | Just (fp, _) <- liftGen $ pickClosedFile fs 146 | h <- lift . lift $ withFileCont fp ReadMode 147 | void . liftIO $ hGetLine h 148 | 149 | -- | Invalid writing to file which does not cause IO exception 150 | -- but does not update the state of the model (does not add written line to model 'File') 151 | -- which may lead to assert 'fail' in subsequent transitions 152 | genInvalidWriteFile :: Gen FileTransition 153 | genInvalidWriteFile = do 154 | l <- listOf (choose ('A', 'z')) 155 | return $ mkTransition "invalid write line" `goif` anyOpenFile `goto` do 156 | fs <- get 157 | Just (_, (File (Just h) _)) <- liftGen $ pickOpenFile fs 158 | liftIO $ hPutStrLn h l 159 | 160 | genFailIf :: (FileSystem -> Bool) -> Gen FileTransition 161 | genFailIf p = 162 | return $ mkTransition "failIf" `goif` p `goto` fail "failIf p == True" 163 | 164 | 165 | -- | Valid transition shall never cause test failure 166 | prop_success_chain :: Property 167 | prop_success_chain = monadicCont $ do 168 | d <- lift $ withSystemTempDirectoryCont "prop_success_chain" 169 | runFSMGen (Environment d) mkFileSystem . frequencyShuffle $ [ 170 | (10, genCreateFile) 171 | , (1, genCloseFile) 172 | , (10, genWriteFile) 173 | , (1, genReadFile) 174 | ] 175 | 176 | -- | 'invalid' transitions will eventualy lead to failure 177 | -- either due to assert 'fail' or IO exception thrown due to invalid file operation 178 | prop_failure_chain :: Property 179 | prop_failure_chain = expectFailure . monadicCont $ do 180 | d <- lift $ withSystemTempDirectoryCont "prop_successful_chain" 181 | runFSMGen (Environment d) mkFileSystem . frequencyShuffle $ [ 182 | (10, genCreateFile) 183 | , (1, genCloseFile) 184 | , (10, genWriteFile) 185 | , (1, genReadFile) 186 | -- invalid transitions 187 | , (5, genInvalidReadFile) 188 | , (5, genInvalidWriteFile) 189 | ] 190 | 191 | prop_limitedByCount :: Property 192 | prop_limitedByCount = monadicCont $ do 193 | d <- lift $ withSystemTempDirectoryCont "prop_limitByCount" 194 | runFSMUntil 10 (Environment d) mkFileSystem . shuffle $ [ 195 | genCreateFile 196 | , genFailIf ((>10) . M.size . fileSystemFiles) 197 | ] 198 | 199 | 200 | prop_limitedByTime :: Property 201 | prop_limitedByTime = once . mapSize (const 10) . monadicCont $ do 202 | d <- lift $ withSystemTempDirectoryCont "prop_limitByCount" 203 | runFSMFor (fromRational 1) (Environment d) mkFileSystem . shuffle $ [ 204 | genSlowCreateFile 205 | , genFailIf ((>10) . M.size . fileSystemFiles) 206 | ] 207 | 208 | 209 | pickOpenFile :: FileSystem -> Gen (Maybe (FilePath, File)) 210 | pickOpenFile = pickFile True 211 | 212 | pickClosedFile :: FileSystem -> Gen (Maybe (FilePath, File)) 213 | pickClosedFile = pickFile False 214 | 215 | pickClosedNonEmptyFile :: FileSystem -> Gen (Maybe (FilePath, File)) 216 | pickClosedNonEmptyFile (FileSystem fs) = do 217 | case [ (fp, f) | (fp, f@(File Nothing (_:__))) <- M.toList fs ] of 218 | [] -> return Nothing 219 | rs -> Just <$> elements rs 220 | 221 | pickFile :: Bool -> FileSystem -> Gen (Maybe (FilePath, File)) 222 | pickFile open (FileSystem fs) = do 223 | case [ (fp, f) | (fp, f@(File mh _)) <- M.toList fs, open == isJust mh ] of 224 | [] -> return Nothing 225 | rs -> Just <$> elements rs 226 | 227 | anyOpenFile :: FileSystem -> Bool 228 | anyOpenFile = anyFile True 229 | 230 | anyClosedFile :: FileSystem -> Bool 231 | anyClosedFile = anyFile False 232 | 233 | anyFile :: Bool -> FileSystem -> Bool 234 | anyFile opened = L.any ((== opened) . isJust) . fmap fileHandle . M.elems . fileSystemFiles 235 | 236 | anyClosedNonEmptyFile :: FileSystem -> Bool 237 | anyClosedNonEmptyFile = L.any (\(File mh ls) -> isNothing mh && ls /= []) . M.elems . fileSystemFiles 238 | 239 | monadicCont :: Testable a => PropertyM (CatchableContT Property IO) a -> Property 240 | monadicCont = monadic $ ioProperty . evalCatchableContT 241 | 242 | evalContT :: (Monad m) => ContT r m r -> m r 243 | evalContT = flip runContT return 244 | 245 | 246 | return [] 247 | tests :: IO Bool 248 | tests = $quickCheckAll 249 | -------------------------------------------------------------------------------- /disorder-fsm/test/Test/Disorder/FSM/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Test.Disorder.FSM.IO where 4 | 5 | import Control.Applicative hiding (empty) 6 | import Control.Concurrent 7 | import Control.Monad 8 | import Control.Monad.IO.Class 9 | import Control.Monad.Reader 10 | import Control.Monad.State 11 | 12 | import Data.IORef 13 | import Data.Monoid 14 | 15 | import Disorder.FSM 16 | 17 | import Prelude 18 | 19 | 20 | -- | "External" stateful system "Mutable stack" which is tested here 21 | newtype Stack a = Stack { 22 | _toRef :: IORef [a] 23 | } 24 | 25 | empty :: IO (Stack a) 26 | empty = Stack <$> newIORef [] 27 | 28 | push :: Stack a -> a -> IO () 29 | push (Stack r) a = modifyIORef r (a:) 30 | 31 | pop :: Stack a -> IO a 32 | pop (Stack r) = readIORef r >>= \case 33 | [] -> fail "Empty stack" 34 | (a:ls) -> do 35 | writeIORef r ls 36 | return a 37 | 38 | top :: Stack a -> IO (Maybe a) 39 | top (Stack r) = readIORef r >>= \case 40 | [] -> return Nothing 41 | ls -> return $ Just (head ls) 42 | 43 | size :: Stack a -> IO Int 44 | size (Stack r) = readIORef r >>= return . length 45 | 46 | -- | Environment here is the 'Stack' itself 47 | type Environment a = Stack a 48 | 49 | -- | Model state of the 'Stack' is just a list 50 | type Model a = [a] 51 | 52 | type StackTransition a = ConditionalTransition (Environment a) (Model a) IO 53 | 54 | -- | Pushes random element to stack 55 | genPush :: Gen (StackTransition Int) 56 | genPush = do 57 | a <- arbitrary 58 | return $ mkTransition ("push " ++ show a) `goto` do 59 | s <- ask 60 | liftIO $ push s a 61 | -- updates the model 62 | modify $ (a:) 63 | 64 | -- | Broken 'push' which doesn't actually push negative elements 65 | genInvalidPush :: Gen (StackTransition Int) 66 | genInvalidPush = do 67 | a <- arbitrary 68 | return $ mkTransition ("invalid_push " ++ show a) `goto` do 69 | s <- ask 70 | -- | this is where it is broken 71 | unless (a < 0) $ liftIO $ push s a 72 | -- | it does modify the model correctly (so it won't match the 'RealWorld') 73 | modify $ (a:) 74 | 75 | genSlowPush :: Gen (StackTransition Int) 76 | genSlowPush = do 77 | a <- arbitrary 78 | return $ mkTransition ("push " ++ show a) `goto` do 79 | s <- ask 80 | liftIO $ do 81 | threadDelay $ 100*1000 -- 0.1 sec 82 | push s a 83 | -- updates the model 84 | modify $ (a:) 85 | 86 | -- | Pops an element from 'Stack' 87 | genPop :: Gen (StackTransition Int) 88 | genPop = 89 | return $ mkTransition "pop" `goif` (not . null) `goto` do 90 | s <- ask 91 | a <- liftIO $ pop s 92 | l <- get 93 | -- popped element must match head element in model 94 | a === head l 95 | -- updates the Model 96 | modify $ tail 97 | 98 | -- | Does not specify 'goif' pre-condition so the assertion can fail 99 | -- when it is executed with empty 'Stack' 100 | genInvalidPop :: Gen (StackTransition Int) 101 | genInvalidPop = 102 | return $ mkTransition "invalid_pop" `goto` do 103 | s <- ask 104 | l <- get 105 | -- this may 'fail' 106 | void $ assertMsg (l /= []) "pop on empty stack" 107 | a <- liftIO $ pop s 108 | -- and this may 'fail' if the model is out of sync with 'RealWorld' 109 | a === head l 110 | modify $ tail 111 | 112 | -- | Does not specify 'goif' pre-condition so it may throw exception 113 | genPopException :: Gen (StackTransition Int) 114 | genPopException = 115 | return $ mkTransition "invalid_pop" `goto` do 116 | s <- ask 117 | l <- get 118 | -- will throw exception on empty 'Stack' 119 | a <- liftIO $ pop s 120 | a === head l 121 | modify $ tail 122 | 123 | -- | Reads an element on 'Stack' top 124 | genTop :: Gen (StackTransition Int) 125 | genTop = 126 | return $ mkTransition "top" `goto` do 127 | s <- ask 128 | ma <- liftIO $ top s 129 | l <- get 130 | -- checks with model 131 | case (ma, l) of 132 | (Just a, (x:_)) -> a === x 133 | (Nothing, _) -> assertMsg (l == []) "l is not empty" 134 | inv -> fail $ "invalid state: " <> show inv 135 | 136 | genSize :: Gen (StackTransition Int) 137 | genSize = 138 | return $ mkTransition "size" `goto` do 139 | s <- ask 140 | ss <- liftIO $ size s 141 | l <- get 142 | ss === length l 143 | 144 | genFailIf :: (Model Int -> Bool) -> Gen (StackTransition Int) 145 | genFailIf p = 146 | return $ mkTransition "failIf" `goif` p `goto` fail "failIf p == True" 147 | 148 | 149 | -- | Shall never fail since only correct transitions are used 150 | prop_success :: Property 151 | prop_success = monadicIO $ do 152 | s <- liftIO empty 153 | runFSMGen s [] $ shuffle [genPush, genPop, genTop, genSize] 154 | 155 | prop_test :: Property 156 | prop_test = monadicIO $ do 157 | s <- liftIO empty 158 | runFSMGen s [] $ shuffle [genTop] 159 | 160 | -- | fails due to invalid 'pop' 161 | prop_pop_assert_error :: Property 162 | prop_pop_assert_error = expectFailure . monadicIO $ do 163 | s <- liftIO empty 164 | runFSMGen s [] $ shuffle [genPush, genInvalidPop, genTop, genSize] 165 | 166 | -- | fails due to invalid 'push' 167 | prop_push_assert_error :: Property 168 | prop_push_assert_error = expectFailure . monadicIO $ do 169 | s <- liftIO empty 170 | runFSMGen s [] $ shuffle [genInvalidPush, genPush, genPop, genTop, genSize] 171 | 172 | -- | Produces "invalid" transition less frequently 173 | -- thus generating longer transition list 174 | prop_assert_error_longer_chain :: Property 175 | prop_assert_error_longer_chain = expectFailure . monadicIO $ do 176 | s <- liftIO empty 177 | runFSMUntil 100 s [] . frequencyShuffle $ [ 178 | (10, genPush) 179 | , (1, genInvalidPush) 180 | , (10, genTop) 181 | , (10, genPop) 182 | , (1, genInvalidPop) 183 | , (10, genSize) 184 | ] 185 | 186 | -- | Fails due to exception with output identical to 'fail' failure 187 | prop_state_exception :: Property 188 | prop_state_exception = expectFailure . monadicIO $ do 189 | s <- liftIO empty 190 | runFSMGen s [] $ shuffle [genPush, genPopException, genTop, genSize] 191 | 192 | 193 | prop_limitedByCount :: Property 194 | prop_limitedByCount = once . monadicIO $ do 195 | s <- liftIO empty 196 | runFSMUntil 10 s [] $ shuffle [genPush, genFailIf ((>10) . length)] 197 | 198 | 199 | prop_limitedByTime :: Property 200 | prop_limitedByTime = once . monadicIO $ do 201 | s <- liftIO empty 202 | -- Execution is limited by 1 second 203 | runFSMFor (fromRational 1) s [] $ shuffle [genSlowPush, genFailIf ((>10) . length)] 204 | 205 | 206 | -- Doesn't look like it is possible to specify in QC 207 | -- that the test with 100 "Give up" results is a success 208 | -- commenting it out 209 | -- | Check that FSM testing doesn't stuck if there is no valid transitions available 210 | -- prop_no_valid_transition :: Property 211 | -- prop_no_valid_transition = once . expectFailure . monadicIO $ do 212 | -- s <- liftIO empty 213 | -- runFSMUntil 10 s [] $ pure [genPop] 214 | 215 | 216 | return [] 217 | tests :: IO Bool 218 | tests = $quickCheckAll 219 | -------------------------------------------------------------------------------- /disorder-fsm/test/Test/Disorder/FSM/Property.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Test.Disorder.FSM.Property where 4 | 5 | import Control.Arrow (first) 6 | 7 | import Data.List (sort) 8 | 9 | import Disorder.FSM.Property (frequencyShuffle) 10 | 11 | import Prelude 12 | 13 | import Test.QuickCheck 14 | 15 | 16 | prop_frequencyShuffle_all :: [(Positive Int, Char)] -> Property 17 | prop_frequencyShuffle_all kxs' = 18 | let kxs = fmap (first getPositive) kxs' 19 | in forAll (frequencyShuffle kxs) $ \xs -> 20 | sort xs === sort (fmap snd kxs) 21 | 22 | 23 | return [] 24 | tests :: IO Bool 25 | tests = $quickCheckAll 26 | -------------------------------------------------------------------------------- /disorder-fsm/test/test.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | import qualified Test.Disorder.FSM 4 | 5 | import System.Exit 6 | import System.IO 7 | 8 | 9 | main :: IO () 10 | main = 11 | hSetBuffering stdout LineBuffering >> sequence [ 12 | Test.Disorder.FSM.tests 13 | ] >>= \rs -> unless (and rs) exitFailure 14 | -------------------------------------------------------------------------------- /disorder-jack/.ghci: -------------------------------------------------------------------------------- 1 | :set prompt "λ> " 2 | :set -Wall 3 | :set -XOverloadedStrings 4 | :set -XScopedTypeVariables 5 | -------------------------------------------------------------------------------- /disorder-jack/README.md: -------------------------------------------------------------------------------- 1 | jack 2 | ==== 3 | 4 | ``` 5 | Jack's love of dice has brought him here, where he has taken on the form 6 | of a Haskell library, in order to help you gamble with your properties. 7 | ``` 8 | 9 | ![](img/dice.jpg) 10 | 11 | Jack is an alternative to QuickCheck generators / shrinking. The basic 12 | idea is that instead of generating a random value and using a shrinking 13 | function after the fact, we generate the random value and all the 14 | possible shrinks in a tree. 15 | 16 | ## Why Jack? 17 | 18 | Generating the shrinks when you generate your initial value has many 19 | useful properties, you can easily maintain the invariants of the 20 | generator for example. In QuickCheck if you do `choose (100, 200)` and 21 | then try to shrink it, it will happily shrink to `0`. 22 | 23 | QuickCheck shrinking functions are also invariant, so if you have 24 | a shrinker for `Text` you cannot lift it to a shrinker of `Foo` without 25 | having a mapping in both directions. This breaks the beautiful 26 | applicative syntax that generators can be constructed with. Jack doesn't 27 | have this problem, a `Jack Text` can be turned in to a `Jack Foo` using 28 | only `fmap`, and your `Foo` will be shrunk for free. 29 | 30 | ## Generators 31 | 32 | Here's an example usage of Jack for building up generators. It works 33 | much the same as building up QuickCheck generators except you get 34 | shrinking of sub-terms for free. You can use the `reshrink` function to 35 | apply any additional shrinking: 36 | 37 | ```hs 38 | data Exp = 39 | Con !Int 40 | | Var !Text 41 | | Lam !Text !Exp 42 | | App !Exp !Exp 43 | deriving (Eq, Ord, Show) 44 | 45 | exp :: Jack Exp 46 | exp = 47 | let 48 | text = 49 | T.pack <$> arbitrary 50 | 51 | shrink = \case 52 | Lam _ x -> 53 | [x] 54 | App x y -> 55 | [x, y] 56 | _ -> 57 | [] 58 | in 59 | reshrink shrink $ 60 | oneOfRec [ 61 | Con <$> sizedIntegral 62 | , Var <$> text 63 | ] [ 64 | Lam <$> text <*> exp 65 | , App <$> exp <*> exp 66 | ] 67 | ``` 68 | 69 | ## Properties 70 | 71 | To use a Jack generator in a property test pass it to the `gamble` 72 | function, this is the equivalent to `forAll` in QuickCheck: 73 | 74 | ```hs 75 | prop_example :: Property 76 | prop_example 77 | gamble exp allJack 78 | 79 | -- | Ensure all variable names start with jack. 80 | allJack :: Exp -> Bool 81 | allJack = \case 82 | Con _ -> 83 | True 84 | Var var -> 85 | "jack" `T.isPrefixOf` var 86 | Lam var x -> 87 | "jack" `T.isPrefixOf` var && allJack x 88 | App x1 x2 -> 89 | allJack x1 x2 90 | ``` 91 | 92 | ## QuickCheck Compatibility 93 | 94 | Jack has a compatibility module which makes it a drop-in replacement for 95 | QuickCheck in many cases. Just import `Test.QuickCheck.Jack` instead of 96 | `Test.QuickCheck` and you should get shrinking for free as long as you 97 | are using `forAll` instead of `Arbitrary` instances. 98 | 99 | `Test.QuickCheck.Jack` essentially aliases `Jack` to `Gen` and `gamble` 100 | to `forAll`. Unfortunately you'll need qualified imports if you still 101 | want to use `Arbitrary` instances, however you won't want to do this 102 | anyway as they defeat shrinking for the most part. 103 | -------------------------------------------------------------------------------- /disorder-jack/ambiata-disorder-jack.cabal: -------------------------------------------------------------------------------- 1 | name: ambiata-disorder-jack 2 | version: 0.0.3 3 | license: AllRightsReserved 4 | author: Ambiata 5 | maintainer: Ambiata 6 | copyright: (c) 2015 Ambiata 7 | synopsis: disorder-jack 8 | category: System 9 | cabal-version: >= 1.22 10 | build-type: Simple 11 | description: disorder-jack. 12 | 13 | library 14 | build-depends: 15 | base >= 3 && < 5 16 | , comonad >= 4.2 && < 5.1 17 | , containers >= 0.4 && < 0.6 18 | , deepseq >= 1.2 && < 1.5 19 | , pretty-show >= 1.6 && < 1.7 20 | , QuickCheck >= 2.7 21 | , quickcheck-text >= 0.1 && < 0.2 22 | , random >= 1.1 && < 1.2 23 | , semigroups >= 0.16 && < 0.19 24 | , text >= 1.1 && < 1.3 25 | , transformers >= 0.3 && < 0.6 26 | 27 | default-language: 28 | Haskell2010 29 | 30 | ghc-options: -Wall 31 | 32 | if impl(ghc >= 8.0) 33 | ghc-options: -fno-warn-redundant-constraints 34 | 35 | hs-source-dirs: 36 | src 37 | 38 | 39 | exposed-modules: 40 | Disorder.Jack 41 | Disorder.Jack.Combinators 42 | Disorder.Jack.Core 43 | Disorder.Jack.Property 44 | Disorder.Jack.Property.Diff 45 | Disorder.Jack.Shrink 46 | Disorder.Jack.Tree 47 | Disorder.Jack.Tripping 48 | 49 | Test.QuickCheck.Jack 50 | 51 | test-suite test 52 | type: exitcode-stdio-1.0 53 | 54 | main-is: test.hs 55 | 56 | ghc-options: -Wall -threaded -O2 57 | 58 | if impl(ghc >= 8.0) 59 | ghc-options: -fno-warn-redundant-constraints 60 | 61 | hs-source-dirs: 62 | test 63 | 64 | build-depends: 65 | base >= 3 && < 5 66 | , ambiata-disorder-core 67 | , ambiata-disorder-jack 68 | , comonad 69 | , containers 70 | , pretty-show 71 | -- something is broken in 2.11 and later for jack 72 | -- prop_ap_all_the_things from test/Test/Disorder/Jack/Core.hs:59 fails 73 | , QuickCheck >= 2.7 && < 2.11 74 | , QuickCheck 75 | , quickcheck-instances 76 | , semigroups 77 | , text 78 | , transformers 79 | 80 | default-language: 81 | Haskell2010 82 | -------------------------------------------------------------------------------- /disorder-jack/img/dice.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/icicle-lang/disorder.hs-ambiata/0068d9a0dd9aea45e772fb664cf4e7e71636dbe5/disorder-jack/img/dice.jpg -------------------------------------------------------------------------------- /disorder-jack/mafia: -------------------------------------------------------------------------------- 1 | ../framework/mafia -------------------------------------------------------------------------------- /disorder-jack/master.toml: -------------------------------------------------------------------------------- 1 | ../framework/master.toml -------------------------------------------------------------------------------- /disorder-jack/src/Disorder/Jack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module Disorder.Jack ( 3 | module X 4 | ) where 5 | 6 | import Disorder.Jack.Combinators as X 7 | import Disorder.Jack.Core as X 8 | import Disorder.Jack.Property as X 9 | import Disorder.Jack.Shrink as X 10 | import Disorder.Jack.Tree as X 11 | import Disorder.Jack.Tripping as X 12 | -------------------------------------------------------------------------------- /disorder-jack/src/Disorder/Jack/Combinators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DoAndIfThenElse #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | module Disorder.Jack.Combinators ( 6 | -- * Shrink Modifiers 7 | noShrink 8 | 9 | -- * Size Combinators 10 | , variant 11 | , sized 12 | , resize 13 | , scale 14 | 15 | -- * Sized Generators 16 | , sizedInt 17 | , sizedIntegral 18 | , sizedNat 19 | , sizedNatural 20 | , sizedBounded 21 | , sizedRealFrac 22 | 23 | -- * Bounded Generators 24 | , bounded 25 | , boundedInt 26 | , boundedEnum 27 | 28 | -- * Range Generators 29 | , choose 30 | , chooseInt 31 | , chooseChar 32 | , chooseRealFrac 33 | 34 | -- * List Combinators 35 | , oneOf 36 | , oneOfRec 37 | , frequency 38 | , elements 39 | , sublistOf 40 | , shuffle 41 | , listOf 42 | , listOf1 43 | , listOfN 44 | , vectorOf 45 | 46 | -- * Uncertainty Combinators 47 | , maybeOf 48 | , justOf 49 | , suchThat 50 | , suchThatMaybe 51 | 52 | -- * QuickCheck Compatibility 53 | , arbitrary 54 | ) where 55 | 56 | import Control.Monad (replicateM) 57 | import Control.Applicative (Applicative(..)) 58 | 59 | import Data.Bool (Bool(..), not) 60 | import Data.Char (Char, ord, chr) 61 | import Data.Function (($), (.), id) 62 | import Data.Functor (Functor(..), (<$>)) 63 | import Data.Foldable (Foldable(..), toList) 64 | import Data.Int (Int) 65 | import qualified Data.List as List 66 | import Data.List.NonEmpty (NonEmpty(..)) 67 | import qualified Data.List.NonEmpty as NonEmpty 68 | import Data.Maybe (Maybe(..), isJust) 69 | import Data.Monoid ((<>)) 70 | import Data.Ord (Ord(..)) 71 | import Data.Tuple (fst) 72 | 73 | import Disorder.Jack.Core 74 | import Disorder.Jack.Shrink 75 | import Disorder.Jack.Tree 76 | 77 | import Prelude (Num(..), Bounded(..), Enum(..), Integral, div, RealFrac) 78 | import qualified Prelude as Savage 79 | 80 | import System.Random (Random) 81 | 82 | import qualified Test.QuickCheck as QC 83 | 84 | 85 | -- | Prevent a 'Jack' from shrinking. 86 | noShrink :: Jack a -> Jack a 87 | noShrink = 88 | mapTree $ \(Node x _) -> 89 | Node x [] 90 | 91 | -- | Modifies a generator using an integer seed. 92 | variant :: Integral n => n -> Jack a -> Jack a 93 | variant = 94 | mapGen . QC.variant 95 | 96 | -- | Construct a 'Jack' that depends on the size parameter. 97 | sized :: (Int -> Jack a) -> Jack a 98 | sized f = 99 | Jack $ QC.sized (runJack . f) 100 | 101 | -- | Overrides the size parameter. Returns a 'Jack' which uses the given size 102 | -- instead of the runtime-size parameter. 103 | resize :: Int -> Jack a -> Jack a 104 | resize n = 105 | if n < 0 then 106 | Savage.error "Disorder.Jack.Combinators.resize: negative size" 107 | else 108 | mapGen $ QC.resize n 109 | 110 | -- | Update the current size by mapping a function over it. 111 | scale :: (Int -> Int) -> Jack a -> Jack a 112 | scale f j = 113 | sized $ \n -> 114 | resize (f n) j 115 | 116 | -- | Generates an 'Int'. The number can be positive or negative and its maximum 117 | -- absolute value depends on the size parameter. 118 | sizedInt :: Jack Int 119 | sizedInt = 120 | sizedIntegral 121 | 122 | -- | Generates an integral number. The number can be positive or negative and 123 | -- its maximum absolute value depends on the size parameter. 124 | sizedIntegral :: Integral a => Jack a 125 | sizedIntegral = 126 | mkJack QC.shrinkIntegral QC.arbitrarySizedIntegral 127 | 128 | -- | Generates a fractional number. The number can be positive or negative and 129 | -- its maximum absolute value depends on the size parameter. 130 | sizedRealFrac :: RealFrac a => Jack a 131 | sizedRealFrac = 132 | mkJack QC.shrinkRealFrac QC.arbitrarySizedFractional 133 | 134 | -- | Generates a non-negative 'Int'. The number's maximum value depends on the 135 | -- size parameter. 136 | sizedNat :: Jack Int 137 | sizedNat = 138 | sizedNatural 139 | 140 | -- | Generates a natural number. The number's maximum value depends on 141 | -- the size parameter. 142 | sizedNatural :: Integral a => Jack a 143 | sizedNatural = 144 | mkJack QC.shrinkIntegral QC.arbitrarySizedNatural 145 | 146 | -- | Generates an integral number from a bounded domain. The number is chosen 147 | -- from the entire range of the type, but small numbers are generated more 148 | -- often than big numbers. 149 | sizedBounded :: (Bounded a, Integral a) => Jack a 150 | sizedBounded = 151 | mkJack QC.shrinkIntegral QC.arbitrarySizedBoundedIntegral 152 | 153 | -- | Generates an integral number. The number is chosen from the entire range 154 | -- of the type. 155 | bounded :: (Bounded a, Random a, Integral a) => Jack a 156 | bounded = 157 | mkJack (shrinkTowards 0) $ QC.choose (minBound, maxBound) 158 | 159 | -- | Generates an 'Int'. The number is chosen from the entire range of valid 160 | -- 'Int' values, on 64-bit GHC this is [-2^63, 2^63). 161 | boundedInt :: Jack Int 162 | boundedInt = 163 | bounded 164 | 165 | -- | Generates an element from a bounded enumeration. 166 | boundedEnum :: forall a. (Bounded a, Enum a) => Jack a 167 | boundedEnum = 168 | let 169 | e_min = minBound :: a 170 | e_max = maxBound :: a 171 | in 172 | fmap toEnum $ chooseInt (fromEnum e_min, fromEnum e_max) 173 | 174 | -- | Generates an integral number in the given range. 175 | choose :: (Random a, Integral a) => (a, a) -> Jack a 176 | choose (b0, b1) = 177 | let 178 | b_min = 179 | min b0 b1 180 | 181 | b_max = 182 | max b0 b1 183 | in 184 | mkJack (shrinkTowards b_min) $ QC.choose (b_min, b_max) 185 | 186 | -- | Generates an 'Int' in the given range. 187 | chooseInt :: (Int, Int) -> Jack Int 188 | chooseInt = 189 | choose 190 | 191 | -- | Generates a 'Char' in the given range. 192 | chooseChar :: (Char, Char) -> Jack Char 193 | chooseChar (b0, b1) = 194 | fmap chr $ choose (ord b0, ord b1) 195 | 196 | -- | Generates a 'RealFrac' in the given range. 197 | chooseRealFrac :: (Random a, RealFrac a) => (a, a) -> Jack a 198 | chooseRealFrac (x, y) = 199 | mkJack QC.shrinkRealFrac $ QC.choose (x, y) 200 | 201 | -- | Randomly selects one of the jacks in the list. 202 | -- /The input list must be non-empty./ 203 | oneOf :: [Jack a] -> Jack a 204 | oneOf = \case 205 | [] -> 206 | Savage.error "Disorder.Jack.Combinators.oneOf: used with empty list" 207 | xs -> do 208 | n <- choose (0, List.length xs - 1) 209 | xs List.!! n 210 | 211 | -- | Randomly selects from one of the jacks in either the non-recursive or the 212 | -- recursive list. When a selection is made from the recursive list, the size 213 | -- is halved. When the size gets to one or less, selections are no longer made 214 | -- from the recursive list. 215 | -- /The first argument (i.e. the non-recursive input list) must be non-empty./ 216 | oneOfRec :: [Jack a] -> [Jack a] -> Jack a 217 | oneOfRec nonrec rec = 218 | sized $ \n -> 219 | if n <= 1 then 220 | oneOf nonrec 221 | else 222 | oneOf $ nonrec <> fmap (scale (`div` 2)) rec 223 | 224 | -- | Uses a weighted distribution to randomly select one of the jacks in the list. 225 | -- /The input list must be non-empty./ 226 | frequency :: [(Int, Jack a)] -> Jack a 227 | frequency = \case 228 | [] -> 229 | Savage.error "Disorder.Jack.Combinators.frequency: used with empty list" 230 | xs0 -> do 231 | let 232 | pick n = \case 233 | [] -> 234 | Savage.error "Disorder.Jack.Combinators.frequency/pick: used with empty list" 235 | (k, x) : xs -> 236 | if n <= k then 237 | x 238 | else 239 | pick (n - k) xs 240 | 241 | total = 242 | List.sum (fmap fst xs0) 243 | 244 | n <- choose (1, total) 245 | pick n xs0 246 | 247 | -- | Randomly selects one of the values in the list. 248 | -- /The input list must be non-empty./ 249 | elements :: Foldable b => b a -> Jack a 250 | elements xs = 251 | case toList xs of 252 | [] -> 253 | Savage.error "Disorder.Jack.Combinators.elements: used with empty foldable" 254 | ys -> do 255 | n <- choose (0, List.length ys - 1) 256 | pure $ ys List.!! n 257 | 258 | -- | Generates a random subsequence of the given list. 259 | sublistOf :: [a] -> Jack [a] 260 | sublistOf = 261 | Jack . fmap (unfoldTree id shrinkList) . QC.sublistOf 262 | 263 | -- | Generates a random permutation of the given list. 264 | -- 265 | -- This shrinks towards the order of the list being identical to the input 266 | -- list. 267 | -- 268 | shuffle :: [a] -> Jack [a] 269 | shuffle = \case 270 | [] -> 271 | pure [] 272 | xs0 -> do 273 | n <- choose (0, List.length xs0 - 1) 274 | case List.splitAt n xs0 of 275 | (xs, y : ys) -> 276 | (y :) <$> shuffle (xs <> ys) 277 | (_, []) -> 278 | Savage.error "Disorder.Jack.Combinators.shuffle: internal error, split generated empty list" 279 | 280 | -- | Generates a list of random length. The maximum length depends on the size 281 | -- parameter. 282 | listOf :: Jack a -> Jack [a] 283 | listOf jack = 284 | sized $ \n -> do 285 | Jack $ do 286 | k <- QC.choose (0, n) 287 | fmap sequenceShrinkList . replicateM k $ runJack jack 288 | 289 | -- | Generates a non-empty list of random length. The maximum length depends on 290 | -- the size parameter. 291 | listOf1 :: Jack a -> Jack (NonEmpty a) 292 | listOf1 jack = 293 | sized $ \n -> do 294 | Jack $ do 295 | k <- QC.choose (1, max n 1) 296 | 297 | let 298 | unpack = \case 299 | [] -> 300 | Savage.error "Disorder.Jack.Combinators.list1: internal error, generated empty list" 301 | xs -> 302 | NonEmpty.fromList xs 303 | 304 | go = 305 | fmap unpack . 306 | filterTree (not . List.null) . 307 | sequenceShrinkList 308 | 309 | fmap go . replicateM k $ runJack jack 310 | 311 | -- | Generates a list between 'n' and 'm' in length. 312 | listOfN :: Int -> Int -> Jack a -> Jack [a] 313 | listOfN n m (Jack gen) = 314 | Jack $ do 315 | k <- QC.choose (n, m) 316 | 317 | let 318 | k_min = 319 | min n m 320 | 321 | check xs = 322 | List.length xs >= k_min 323 | 324 | fmap (filterTree check . sequenceShrinkList) $ 325 | replicateM k gen 326 | 327 | -- | Generates a list of the given length. 328 | vectorOf :: Int -> Jack a -> Jack [a] 329 | vectorOf n = 330 | mapGen (fmap sequenceShrinkOne . replicateM n) 331 | 332 | -- | Generates a 'Nothing' some of the time. 333 | maybeOf :: Jack a -> Jack (Maybe a) 334 | maybeOf jack = 335 | sized $ \n -> 336 | frequency [ 337 | (1, pure Nothing) 338 | , (1 + n, Just <$> jack) 339 | ] 340 | 341 | -- | Runs a generator that produces 'Maybe a' until it produces a 'Just'. 342 | justOf :: Jack (Maybe a) -> Jack a 343 | justOf g = do 344 | mx <- suchThat g isJust 345 | case mx of 346 | Just x -> 347 | pure x 348 | Nothing -> 349 | Savage.error "Disorder.Jack.Combinators.justOf: internal error, unexpected Nothing" 350 | 351 | -- | Generates a value that satisfies a predicate. 352 | suchThat :: Jack a -> (a -> Bool) -> Jack a 353 | suchThat (Jack gen) p = 354 | Jack $ 355 | let 356 | loop = do 357 | mx <- tryGen gen p 358 | case mx of 359 | Just x -> 360 | pure x 361 | Nothing -> 362 | QC.sized $ \n -> 363 | QC.resize (n + 1) loop 364 | in 365 | loop 366 | 367 | -- | Tries to generate a value that satisfies a predicate. 368 | suchThatMaybe :: Jack a -> (a -> Bool) -> Jack (Maybe a) 369 | suchThatMaybe (Jack gen) p = 370 | Jack $ do 371 | mx <- tryGen gen p 372 | case mx of 373 | Nothing -> 374 | pure (pure Nothing) 375 | Just x -> 376 | pure (fmap Just x) 377 | 378 | -- More or less the same logic as suchThatMaybe from QuickCheck, except 379 | -- modified to ensure that the shrinks also obey the predicate. 380 | tryGen :: QC.Gen (Tree a) -> (a -> Bool) -> QC.Gen (Maybe (Tree a)) 381 | tryGen gen p = 382 | let 383 | try k = \case 384 | 0 -> 385 | pure Nothing 386 | n -> do 387 | x <- QC.resize (2 * k + n) gen 388 | if p (outcome x) then 389 | pure . Just $ filterTree p x 390 | else 391 | try (k + 1) (n - 1) 392 | in 393 | QC.sized $ try 0 . max 1 394 | 395 | -- | Construct a 'Jack' using a type's QuickCheck 'QC.Arbitrary' instance. 396 | arbitrary :: QC.Arbitrary a => Jack a 397 | arbitrary = 398 | mkJack QC.shrink QC.arbitrary 399 | -------------------------------------------------------------------------------- /disorder-jack/src/Disorder/Jack/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module Disorder.Jack.Core ( 3 | Jack(..) 4 | , mkJack 5 | , mkJack_ 6 | 7 | , mapGen 8 | , mapTree 9 | 10 | , reshrink 11 | , withShrink 12 | ) where 13 | 14 | import Control.Applicative (Applicative(..), liftA2) 15 | import Control.Monad (Monad(..)) 16 | 17 | import Data.Function (($), (.), const, flip, id) 18 | import Data.Functor (Functor(..)) 19 | 20 | import Disorder.Jack.Tree 21 | 22 | import System.Random (split) 23 | 24 | import Test.QuickCheck (Gen) 25 | import qualified Test.QuickCheck.Gen as QC 26 | import Test.QuickCheck.Random (QCGen) 27 | 28 | 29 | -- | Jack's love of dice has brought him here, where he has taken on the form 30 | -- of a Haskell library, in order to help you gamble with your properties. 31 | -- 32 | newtype Jack a = 33 | Jack { 34 | runJack :: Gen (Tree a) 35 | } 36 | 37 | instance Functor Jack where 38 | fmap f = 39 | Jack . fmap (fmap f) . runJack 40 | 41 | instance Applicative Jack where 42 | pure = 43 | Jack . pure . pure 44 | 45 | (<*>) f x = 46 | Jack $ 47 | liftA2 (<*>) (runJack f) (runJack x) 48 | 49 | instance Monad Jack where 50 | return = 51 | pure 52 | 53 | (>>=) m0 k0 = 54 | Jack $ bindGenTree (runJack m0) (runJack . k0) 55 | 56 | -- | Used to implement '(>>=)' for 'Jack'. 57 | bindGenTree :: Gen (Tree a) -> (a -> Gen (Tree b)) -> Gen (Tree b) 58 | bindGenTree m k = 59 | -- It's important to note that we don't use 'traverse' here, we explicitly 60 | -- only split the seed once, this ensures we get the same behaviour for our 61 | -- Monad and Applicative instances. 62 | QC.MkGen $ \seed0 size -> 63 | let 64 | (seed1, seed2) = 65 | split seed0 66 | 67 | runGen :: QCGen -> Gen x -> x 68 | runGen seed gen = 69 | QC.unGen gen seed size 70 | in 71 | runGen seed1 m >>= runGen seed2 . k 72 | 73 | -- | Create a 'Jack' from a shrink function and a 'Gen'. 74 | mkJack :: (a -> [a]) -> Gen a -> Jack a 75 | mkJack shr = 76 | Jack . fmap (unfoldTree id shr) 77 | 78 | -- | Create a non-shrinking 'Jack' from a 'Gen'. 79 | mkJack_ :: Gen a -> Jack a 80 | mkJack_ = 81 | mkJack $ const [] 82 | 83 | -- | Map over the 'Gen' inside of 'Jack'. 84 | mapGen :: (Gen (Tree a) -> Gen (Tree b)) -> Jack a -> Jack b 85 | mapGen f = 86 | Jack . f . runJack 87 | 88 | -- | Map over the 'Tree' inside a 'Jack'. 89 | mapTree :: (Tree a -> Tree b) -> Jack a -> Jack b 90 | mapTree = 91 | mapGen . fmap 92 | 93 | -- | Apply an additional shrinker to all generated trees. 94 | reshrink :: (a -> [a]) -> Jack a -> Jack a 95 | reshrink = 96 | mapTree . expandTree 97 | 98 | -- | Flipped version of 'reshrink'. 99 | withShrink :: Jack a -> (a -> [a]) -> Jack a 100 | withShrink = 101 | flip reshrink 102 | -------------------------------------------------------------------------------- /disorder-jack/src/Disorder/Jack/Property.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE PatternGuards #-} 4 | module Disorder.Jack.Property ( 5 | gamble 6 | , gambleRender 7 | , gambleDisplay 8 | 9 | , shrinking 10 | 11 | , generate 12 | , sample 13 | , sampleTree 14 | , printSample 15 | , printSampleTree 16 | 17 | , (===) 18 | 19 | -- * "Test.QuickCheck" re-exports 20 | 21 | -- ** "Test.QuickCheck.Property" 22 | , Property(..) 23 | , Testable(..) 24 | , counterexample 25 | , failed 26 | , succeeded 27 | , rejected 28 | , (==>) 29 | , (.&&.) 30 | , (.||.) 31 | , conjoin 32 | , disjoin 33 | , once 34 | 35 | -- ** "Test.QuickCheck.Exception" 36 | , discard 37 | 38 | -- ** "Test.QuickCheck.Test" 39 | , Args(..) 40 | , stdArgs 41 | , quickCheck 42 | , quickCheckWithResult 43 | , verboseCheckWithResult 44 | 45 | -- ** "Test.QuickCheck.All" 46 | , quickCheckAll 47 | , verboseCheckAll 48 | , forAllProperties 49 | ) where 50 | 51 | import Data.Eq (Eq(..)) 52 | import Data.Foldable (for_, traverse_) 53 | import Data.Function (($), (.)) 54 | import Data.Functor (Functor(..)) 55 | import qualified Data.List as List 56 | import Data.Monoid ((<>)) 57 | import Data.String (String) 58 | import Data.Text (Text) 59 | import qualified Data.Text as T 60 | 61 | import Disorder.Jack.Core 62 | import Disorder.Jack.Tree 63 | import Disorder.Jack.Property.Diff 64 | import System.IO (IO, putStrLn) 65 | 66 | import Text.Show (Show) 67 | import Text.Show.Pretty (ppShow) 68 | import qualified Text.Show.Pretty as Pretty 69 | import Prelude (Bool(..), Maybe(..)) 70 | 71 | import qualified Test.QuickCheck as QC 72 | import Test.QuickCheck.All (quickCheckAll, verboseCheckAll, forAllProperties) 73 | import Test.QuickCheck.Exception (discard) 74 | import Test.QuickCheck.Gen.Unsafe (promote) 75 | import Test.QuickCheck.Property ((==>), (.&&.), (.||.)) 76 | import Test.QuickCheck.Property (Testable(..), Property(..), Prop(..), Rose(..)) 77 | import Test.QuickCheck.Property (conjoin, disjoin, once) 78 | import Test.QuickCheck.Property (joinRose, counterexample) 79 | import Test.QuickCheck.Property (succeeded, failed, rejected) 80 | import Test.QuickCheck.Test (Args(..), stdArgs) 81 | import Test.QuickCheck.Test (quickCheck, quickCheckWithResult, verboseCheckWithResult) 82 | 83 | 84 | -- | Ask 'Jack' to generate test cases to exercise the given property. 85 | gamble :: (Show a, Testable prop) => Jack a -> (a -> prop) -> Property 86 | gamble = 87 | gambleDisplay ppShow 88 | 89 | -- | Ask 'Jack' to generate test cases, but provide a custom render function 90 | -- for displaying counterexampes. 91 | gambleRender :: Testable prop => (a -> Text) -> Jack a -> (a -> prop) -> Property 92 | gambleRender render = 93 | gambleDisplay (T.unpack . render) 94 | 95 | -- | Ask 'Jack' to generate test cases, but provide a custom render function 96 | -- for displaying counterexampes. 97 | gambleDisplay :: Testable prop => (a -> String) -> Jack a -> (a -> prop) -> Property 98 | gambleDisplay render jack pf = 99 | MkProperty $ do 100 | tree <- runJack jack 101 | unProperty . shrinking tree $ \x -> 102 | counterexample (render x) $ 103 | pf x 104 | 105 | -- | Use an existing 'Tree' to exercise a given property. 106 | shrinking :: Testable prop => Tree a -> (a -> prop) -> Property 107 | shrinking tree pf = 108 | let 109 | props x = 110 | MkRose 111 | (unProperty . property . pf $ outcome x) 112 | (fmap props $ shrinks x) 113 | in 114 | MkProperty . 115 | fmap (MkProp . joinRose . fmap unProp) $ 116 | promote (props tree) 117 | 118 | -- | Generate some example outcomes. 119 | sample :: Jack a -> IO [a] 120 | sample = 121 | fmap (fmap outcome) . QC.sample' . runJack 122 | 123 | -- | Generate a single example. 124 | generate :: Jack a -> IO a 125 | generate = 126 | fmap outcome . QC.generate . runJack 127 | 128 | -- | Generate some example trees. 129 | sampleTree :: Jack a -> IO [Tree a] 130 | sampleTree = 131 | QC.sample' . runJack 132 | 133 | -- | Generate some example outcomes (and shrinks) and prints them to 'stdout'. 134 | printSample :: Show a => Jack a -> IO () 135 | printSample jack = do 136 | forest <- fmap (List.take 5) $ sampleTree jack 137 | for_ forest $ \tree -> do 138 | putStrLn "=== Outcome ===" 139 | putStrLn . ppShow $ outcome tree 140 | putStrLn "=== Shrinks ===" 141 | traverse_ (putStrLn . ppShow . outcome) $ shrinks tree 142 | putStrLn "" 143 | 144 | printSampleTree :: Show a => Jack a -> IO () 145 | printSampleTree jack = do 146 | forest <- fmap (List.take 1) $ sampleTree jack 147 | for_ forest $ \tree -> do 148 | putStrLn $ ppShow tree 149 | 150 | infix 4 === 151 | 152 | (===) :: (Eq a, Show a) => a -> a -> Property 153 | (===) x y = 154 | counterexample "=== Not equal ===" $ 155 | counterexample render (x == y) 156 | where 157 | render 158 | | Just x' <- Pretty.reify x 159 | , Just y' <- Pretty.reify y 160 | = renderDiffs x' y' 161 | | True 162 | = ppShow x <> " /= " <> ppShow y 163 | -------------------------------------------------------------------------------- /disorder-jack/src/Disorder/Jack/Property/Diff.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE PatternGuards #-} 4 | module Disorder.Jack.Property.Diff ( 5 | renderDiffs 6 | ) where 7 | 8 | import Data.Eq (Eq(..)) 9 | import Data.Function (($)) 10 | import Data.Functor (Functor(..)) 11 | import qualified Data.List as List 12 | import Data.Monoid ((<>)) 13 | import Data.String (String) 14 | 15 | import qualified Text.Show.Pretty as Pretty 16 | import Prelude (Num(..), Ord(..)) 17 | import Prelude (Bool(..)) 18 | 19 | 20 | 21 | -- | Attempt to render difference between two MaxML values 22 | renderDiffs :: Pretty.Value -> Pretty.Value -> String 23 | renderDiffs val1 val2 = prints $ go 0 val1 val2 24 | where 25 | go i a b = case (a, b) of 26 | _ 27 | -- If values are same, render normally 28 | | a == b 29 | -> same i (Pretty.valToStr a) 30 | -- If values are different but both fit on one line, just print both 31 | | List.length (List.lines (Pretty.valToStr a)) < 2 32 | , List.length (List.lines (Pretty.valToStr b)) < 2 33 | -> ll i a <> rr i b 34 | 35 | -- Both the same constructor with same number of arguments, so check arguments 36 | (Pretty.Con m us, Pretty.Con n vs) 37 | | n == m 38 | , List.length us == List.length vs 39 | -> same i n <> goes go "" "" "" i (List.zip us vs) 40 | 41 | -- Record constructors, check arguments 42 | (Pretty.Rec m us, Pretty.Rec n vs) 43 | | n == m 44 | , List.length us == List.length vs 45 | , fmap (\(u,_) -> u) us == fmap (\(v,_) -> v) vs 46 | -> same i n 47 | -- Print field name too 48 | <> goes (\i' (ix,u) (_,v) -> same i' (ix <> " =") <> go (i' + 1) u v) "{" "," "}" i (List.zip us vs) 49 | 50 | -- Tuples and lists of same length 51 | (Pretty.Tuple us, Pretty.Tuple vs) 52 | | List.length us == List.length vs 53 | -> goes go "(" "," ")" i (List.zip us vs) 54 | 55 | (Pretty.List us, Pretty.List vs) 56 | | List.length us == List.length vs 57 | -> goes go "[" "," "]" i (List.zip us vs) 58 | 59 | -- Otherwise they are different constructors and we can't descend further, so print both 60 | _ 61 | -> ll i a <> rr i b 62 | 63 | -- Print same 64 | same i n = sho " " i n 65 | -- Print value on left side 66 | ll i v = sho "-" i (Pretty.valToStr v) 67 | -- Print value on right side 68 | rr i v = sho "+" i (Pretty.valToStr v) 69 | 70 | -- Split up multi-line things into same indentation level. 71 | -- Any indentation in the string itself will still be there as spaces. 72 | sho pre i val = fmap (\a -> (pre,i,a)) $ List.lines val 73 | 74 | goes gg l m r i uvs 75 | = same i l <> goes' False gg m i uvs <> same i r 76 | 77 | goes' putSep gg m i ((u,v):uvs) 78 | = let rest = gg (i+1) u v <> goes' True gg m i uvs 79 | in if putSep 80 | then same i m <> rest 81 | else rest 82 | goes' _ _ _ _ [] 83 | = [] 84 | 85 | -- Layout / printing part 86 | prints [] = [] 87 | -- Squash two lines together. 88 | -- If the next line is indented more, we might be able to squeeze them onto a single line. 89 | -- This looks a bit nicer. 90 | -- For example, 91 | -- " ," 92 | -- " Foo" 93 | -- can be condensed onto a single line: 94 | -- " , Foo" 95 | -- 96 | prints ((p1,i1,v1):(p2,i2,v2):fs) 97 | -- Only if their '+' or '-' prefix are the same 98 | | p1 == p2 99 | -- Get end of first line 100 | , end1 <- i1 * tabSize + List.length v1 101 | -- And start of next line 102 | , start2 <- i2 * tabSize 103 | -- Check end fits before start 104 | , end1 < start2 105 | -- Now add extra padding that we lost by condensing, to get to second line's indentation level 106 | = let diff = start2 - end1 107 | in prints ((p1,i1,v1 <> List.replicate diff ' ' <> v2) : fs) 108 | 109 | -- Indent and append all the bits together 110 | prints ((p,i,v):fs) 111 | = let tabs = List.replicate (i * tabSize) ' ' 112 | in p <> tabs <> v <> "\n" <> prints fs 113 | 114 | tabSize = 2 115 | -------------------------------------------------------------------------------- /disorder-jack/src/Disorder/Jack/Shrink.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | module Disorder.Jack.Shrink ( 4 | shrinkTowards 5 | 6 | , sequenceShrink 7 | , sequenceShrinkOne 8 | , sequenceShrinkList 9 | 10 | , shrinkOne 11 | , shrinkList 12 | 13 | , halves 14 | , removes 15 | ) where 16 | 17 | import Data.Eq (Eq(..)) 18 | import Data.Ord (Ord(..)) 19 | import Data.Functor (fmap) 20 | import Data.Function (($), (.)) 21 | import Data.Monoid ((<>)) 22 | import qualified Data.List as List 23 | import Data.Int (Int) 24 | 25 | import Disorder.Jack.Tree 26 | 27 | import Prelude (Num(..), Integral, quot) 28 | 29 | 30 | -- | Shrink an integral by edging towards a destination number. 31 | shrinkTowards :: Integral a => a -> a -> [a] 32 | shrinkTowards destination x = 33 | if destination == x then 34 | [] 35 | else 36 | let 37 | -- We need to halve our operands before subtracting them as they may be using 38 | -- the full range of the type (i.e. 'minBound' and 'maxBound' for 'Int32') 39 | diff = 40 | (x `quot` 2) - (destination `quot` 2) 41 | in 42 | -- We make up for halving the inputs by explicitly prepending the 43 | -- destination as the first element of the list. 44 | destination `consNub` fmap (x -) (halves diff) 45 | 46 | consNub :: Eq a => a -> [a] -> [a] 47 | consNub x = \case 48 | [] -> 49 | x : [] 50 | y : ys -> 51 | if x == y then 52 | y : ys 53 | else 54 | x : y : ys 55 | 56 | -- | Turn a list of trees in to a tree of lists, opting to shrink only the 57 | -- elements of the list (i.e. the size of the list will always be the same). 58 | -- 59 | sequenceShrinkOne :: [Tree a] -> Tree [a] 60 | sequenceShrinkOne = 61 | sequenceShrink (\xs -> shrinkOne shrinks xs) 62 | 63 | -- | Turn a list of trees in to a tree of lists, opting to shrink both the list 64 | -- itself and the elements in the list during traversal. 65 | -- 66 | sequenceShrinkList :: [Tree a] -> Tree [a] 67 | sequenceShrinkList = 68 | sequenceShrink (\xs -> shrinkList xs <> shrinkOne shrinks xs) 69 | 70 | -- | Turn a list of trees in to a tree of lists, using the supplied function to 71 | -- merge shrinking options. 72 | -- 73 | sequenceShrink :: ([Tree a] -> [[Tree a]]) -> [Tree a] -> Tree [a] 74 | sequenceShrink merge xs = 75 | Node 76 | (fmap outcome xs) 77 | (fmap (sequenceShrink merge) $ merge xs) 78 | 79 | -- | Shrink each of the elements in input list using the supplied shrinking 80 | -- function. 81 | -- 82 | shrinkOne :: (a -> [a]) -> [a] -> [[a]] 83 | shrinkOne shr = \case 84 | [] -> 85 | [] 86 | x0 : xs0 -> 87 | [ x1 : xs0 | x1 <- shr x0 ] <> 88 | [ x0 : xs1 | xs1 <- shrinkOne shr xs0 ] 89 | 90 | -- | Produce a smaller permutation of the input list. 91 | -- 92 | shrinkList :: [a] -> [[a]] 93 | shrinkList xs = do 94 | List.concatMap 95 | (\k -> removes k xs) 96 | (halves $ List.length xs) 97 | 98 | -- | Produces a list containing the results of halving a number over and over 99 | -- again. 100 | -- 101 | -- > halves 30 == [30,15,7,3,1] 102 | -- > halves 128 == [128,64,32,16,8,4,2,1] 103 | -- > halves (-10) == [-10,-5,-2,-1] 104 | -- 105 | halves :: Integral a => a -> [a] 106 | halves = 107 | List.takeWhile (/= 0) . 108 | List.iterate (`quot` 2) 109 | 110 | -- | Permutes a list by removing 'k' consecutive elements from it: 111 | -- 112 | -- > removes 2 [1,2,3,4,5,6] == [[3,4,5,6],[1,2,5,6],[1,2,3,4]] 113 | -- 114 | removes :: Int -> [a] -> [[a]] 115 | removes k0 xs0 = 116 | let 117 | loop k n xs = 118 | let 119 | hd = List.take k xs 120 | tl = List.drop k xs 121 | in 122 | if k > n then 123 | [] 124 | else if List.null tl then 125 | [[]] 126 | else 127 | tl : fmap (hd <>) (loop k (n - k) tl) 128 | in 129 | loop k0 (List.length xs0) xs0 130 | -------------------------------------------------------------------------------- /disorder-jack/src/Disorder/Jack/Tree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | module Disorder.Jack.Tree ( 5 | Tree(..) 6 | , foldTree 7 | , foldForest 8 | , unfoldTree 9 | , unfoldForest 10 | , filterTree 11 | , filterForest 12 | , expandTree 13 | ) where 14 | 15 | import Control.Applicative (Applicative(..)) 16 | import Control.Comonad (Comonad(..), ComonadApply(..)) 17 | import Control.DeepSeq (NFData(..)) 18 | import Control.Monad (Monad(..)) 19 | 20 | import Data.Bool (Bool) 21 | import Data.Data (Data) 22 | import Data.Eq (Eq) 23 | import Data.Foldable (Foldable(..)) 24 | import Data.Function (($), (.), id) 25 | import Data.Functor (Functor(..), (<$>)) 26 | import qualified Data.List as List 27 | import Data.Monoid ((<>)) 28 | import Data.Ord (Ord) 29 | import Data.Traversable (Traversable(..)) 30 | import Data.Typeable (Typeable) 31 | 32 | import GHC.Generics (Generic) 33 | 34 | import Prelude (seq) 35 | 36 | import Text.Show (Show) 37 | 38 | 39 | -- | A rose tree which represents a random generated outcome, and all the ways 40 | -- in which it can be made smaller. 41 | -- 42 | -- This tree is exactly the same as 'Data.Tree' in every way except that 43 | -- Applicative '<*>' and Monad '>>=' walk the tree in the reverse order. This 44 | -- modification is critical for shrinking to reach a minimal counterexample. 45 | -- 46 | data Tree a = 47 | Node { 48 | -- | The generated outcome. 49 | outcome :: !a 50 | 51 | -- | All the possible shrinks of this outcome. This should be ordered 52 | -- smallest to largest as if property still fails with the first shrink in 53 | -- the list then we will commit to that path and none of the others will 54 | -- be tried (i.e. there is no backtracking). 55 | , shrinks :: [Tree a] 56 | } deriving (Eq, Ord, Show, Generic, Data, Typeable) 57 | 58 | instance Functor Tree where 59 | fmap f (Node x xs) = 60 | Node (f x) $ fmap (fmap f) xs 61 | 62 | instance Applicative Tree where 63 | pure x = 64 | Node x [] 65 | 66 | (<*>) (Node f fs) x@(Node y ys) = 67 | Node (f y) $ 68 | -- Data.Tree would have `fmap (f <$>) ys <> fmap (<*> x) fs` 69 | fmap (<*> x) fs <> 70 | fmap (f <$>) ys 71 | 72 | instance Monad Tree where 73 | return = 74 | pure 75 | 76 | (>>=) (Node x xs) k = 77 | let 78 | Node y ys = k x 79 | in 80 | Node y $ 81 | -- Data.Tree would have `ys <> fmap (>>= k) xs` 82 | fmap (>>= k) xs <> ys 83 | 84 | instance Traversable Tree where 85 | traverse f (Node x xs) = 86 | Node <$> f x <*> traverse (traverse f) xs 87 | 88 | instance Foldable Tree where 89 | foldMap f (Node x xs) = 90 | f x <> foldMap (foldMap f) xs 91 | 92 | instance Comonad Tree where 93 | extract (Node x _) = 94 | x 95 | 96 | duplicate x@(Node _ ys) = 97 | Node x (fmap duplicate ys) 98 | 99 | instance ComonadApply Tree where 100 | (<@>) = 101 | (<*>) 102 | 103 | (<@) = 104 | (<*) 105 | 106 | (@>) = 107 | (*>) 108 | 109 | instance NFData a => NFData (Tree a) where 110 | rnf (Node x xs) = 111 | rnf x `seq` rnf xs 112 | 113 | -- | Fold over a 'Tree'. 114 | foldTree :: (a -> x -> b) -> ([b] -> x) -> Tree a -> b 115 | foldTree f g (Node x xs) = 116 | f x (foldForest f g xs) 117 | 118 | -- | Fold over a list of trees. 119 | foldForest :: (a -> x -> b) -> ([b] -> x) -> [Tree a] -> x 120 | foldForest f g = 121 | g . fmap (foldTree f g) 122 | 123 | -- | Build a 'Tree' from an unfolding function and a seed value. 124 | unfoldTree :: (b -> a) -> (b -> [b]) -> b -> Tree a 125 | unfoldTree f g x = 126 | Node (f x) (unfoldForest f g x) 127 | 128 | -- | Build a list of trees from an unfolding function and a seed value. 129 | unfoldForest :: (b -> a) -> (b -> [b]) -> b -> [Tree a] 130 | unfoldForest f g = 131 | fmap (unfoldTree f g) . g 132 | 133 | -- | Apply an additional unfolding function to an existing tree. 134 | -- 135 | -- The root outcome remains intact, only the shrinks are affected, this 136 | -- applies recursively, so shrinks can only ever be added using this 137 | -- function. 138 | -- 139 | -- If you want to replace the shrinks altogether, try: 140 | -- 141 | -- > unfoldTree f (outcome oldTree) 142 | -- 143 | expandTree :: (a -> [a]) -> Tree a -> Tree a 144 | expandTree f (Node x xs) = 145 | -- 146 | -- Ideally we could put the 'unfoldForest' nodes before the 'fmap expandTree' 147 | -- nodes, so that we're culling from the top down and we would be able to 148 | -- terminate our search faster, but this prevents minimal shrinking. 149 | -- 150 | -- We'd need some kind of tree transpose to do this properly. 151 | -- 152 | Node x (fmap (expandTree f) xs <> unfoldForest id f x) 153 | 154 | -- | Recursively discard any shrinks whose outcome does not pass the predicate. 155 | -- /Note that the root outcome can never be discarded./ 156 | filterTree :: (a -> Bool) -> Tree a -> Tree a 157 | filterTree f (Node x xs) = 158 | Node x (filterForest f xs) 159 | 160 | -- | Recursively discard any trees whose outcome does not pass the predicate. 161 | filterForest :: (a -> Bool) -> [Tree a] -> [Tree a] 162 | filterForest f = 163 | fmap (filterTree f) . List.filter (f . outcome) 164 | -------------------------------------------------------------------------------- /disorder-jack/src/Disorder/Jack/Tripping.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module Disorder.Jack.Tripping ( 3 | tripping 4 | , trippingRender 5 | , trippingString 6 | ) where 7 | 8 | import Disorder.Jack.Property 9 | import Disorder.Jack.Property.Diff 10 | 11 | import Control.Applicative (Applicative(..)) 12 | 13 | import Data.Eq (Eq(..)) 14 | import Data.Function (($), (.)) 15 | import qualified Data.List as List 16 | import Data.Maybe (fromMaybe) 17 | import Data.String (String) 18 | import Data.Text (Text) 19 | import qualified Data.Text as T 20 | 21 | import Text.Show (Show(..)) 22 | import Text.Show.Pretty (ppShow, parseValue) 23 | 24 | 25 | tripping :: (Applicative f, Eq (f a), Show (f a)) => (a -> b) -> (b -> f a) -> a -> Property 26 | tripping = 27 | trippingString ppShow 28 | 29 | trippingRender :: (Applicative f, Eq (f a)) => (f a -> Text) -> (a -> b) -> (b -> f a) -> a -> Property 30 | trippingRender render = 31 | trippingString (T.unpack . render) 32 | 33 | trippingString :: (Applicative f, Eq (f a)) => (f a -> String) -> (a -> b) -> (b -> f a) -> a -> Property 34 | trippingString render to fro x = 35 | let 36 | roundtrip = 37 | (fro . to) x 38 | 39 | original = 40 | pure x 41 | 42 | diff = do 43 | o <- parseValue $ render original 44 | r <- parseValue $ render roundtrip 45 | pure [ 46 | "=== - Original / + Roundtrip ===" 47 | , renderDiffs o r 48 | ] 49 | 50 | comparison = [ 51 | "=== Original ===" 52 | , render original 53 | , "" 54 | , "=== Roundtrip ===" 55 | , render roundtrip 56 | ] 57 | in 58 | counterexample "" . 59 | counterexample "Roundtrip failed." . 60 | counterexample "" . 61 | counterexample (List.intercalate "\n" $ fromMaybe comparison diff) $ 62 | property (roundtrip == original) 63 | -------------------------------------------------------------------------------- /disorder-jack/src/Test/QuickCheck/Jack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | -- | Can be used as a drop-in replacement for "Test.QuickCheck" in some cases. 3 | module Test.QuickCheck.Jack ( 4 | Gen 5 | , forAll 6 | , arbitraryBoundedEnum 7 | , oneof 8 | , listOf1 9 | , module X 10 | ) where 11 | 12 | import qualified Disorder.Jack as Jack 13 | import Disorder.Jack as X hiding (listOf1) 14 | 15 | import Data.Function ((.)) 16 | import Data.Functor (fmap) 17 | import Data.Foldable (toList) 18 | 19 | import Prelude (Bounded, Enum) 20 | 21 | import Text.Show (Show) 22 | 23 | import Test.QuickCheck as X (Arbitrary) 24 | 25 | 26 | type Gen = 27 | Jack 28 | 29 | forAll :: (Show a, Testable prop) => Gen a -> (a -> prop) -> Property 30 | forAll = 31 | gamble 32 | 33 | arbitraryBoundedEnum :: (Bounded a, Enum a) => Jack a 34 | arbitraryBoundedEnum = 35 | boundedEnum 36 | 37 | oneof :: [Jack a] -> Jack a 38 | oneof = 39 | oneOf 40 | 41 | listOf1 :: Jack a -> Jack [a] 42 | listOf1 = 43 | fmap toList . Jack.listOf1 44 | -------------------------------------------------------------------------------- /disorder-jack/test/Test/Disorder/Jack/Combinators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | module Test.Disorder.Jack.Combinators where 6 | 7 | import Control.Applicative (Applicative(..)) 8 | import Control.Comonad (duplicate) 9 | import Control.Monad (Monad(..)) 10 | 11 | import Data.Bool (Bool(..), (&&)) 12 | import Data.Char (Char) 13 | import Data.Eq (Eq(..)) 14 | import qualified Data.Foldable as Foldable 15 | import Data.Function (($), (.), flip) 16 | import Data.Int (Int) 17 | import qualified Data.List as List 18 | import qualified Data.List.NonEmpty as NonEmpty 19 | import Data.Ord (Ord(..)) 20 | import qualified Data.Set as Set 21 | 22 | import Disorder.Jack.Combinators 23 | import Disorder.Jack.Core 24 | import Disorder.Jack.Property 25 | import Disorder.Jack.Tree 26 | 27 | import Prelude (even) 28 | 29 | import System.IO (IO) 30 | 31 | 32 | prop_noShrink :: Property 33 | prop_noShrink = 34 | gamble (mapTree duplicate $ noShrink boundedInt) $ \(Node _ xs) -> 35 | List.null xs 36 | 37 | prop_choose :: Property 38 | prop_choose = 39 | gamble boundedInt $ \n -> 40 | gamble boundedInt $ \m -> 41 | gamble (mapTree duplicate $ chooseInt (n, m)) $ \xs -> 42 | let 43 | x_min = 44 | min n m 45 | 46 | x_max = 47 | max n m 48 | 49 | valid x = 50 | x >= x_min && x <= x_max 51 | in 52 | -- it takes an enormous amount of time to expore the entire shrink space, 53 | -- so we just check the first 1000 in a depth first search of the tree 54 | List.all valid . List.take 1000 $ Foldable.toList xs 55 | 56 | prop_oneof :: Property 57 | prop_oneof = 58 | gamble (mapTree duplicate $ oneOf [pure 'A', pure 'B', pure 'C']) isABC 59 | 60 | prop_elements :: Property 61 | prop_elements = 62 | gamble (mapTree duplicate $ elements ['A', 'B', 'C']) isABC 63 | 64 | prop_frequency :: Property 65 | prop_frequency = 66 | gamble (mapTree duplicate $ frequency [(1, pure 'A'), (1, pure 'B'), (1, pure 'C')]) isABC 67 | 68 | isABC :: Tree Char -> Bool 69 | isABC (Node x xs) = 70 | case x of 71 | 'A' -> 72 | List.null xs 73 | 'B' -> 74 | xs == [ 75 | Node 'A' [] 76 | ] 77 | _ -> 78 | xs == [ 79 | Node 'A' [] 80 | , Node 'B' [Node 'A' []] 81 | ] 82 | 83 | prop_sublistOf :: Property 84 | prop_sublistOf = 85 | let 86 | xs = Set.fromList "abcdef" 87 | in 88 | gamble (sublistOf $ Set.toList xs) $ \(ys :: [Char]) -> 89 | List.all (flip Set.member xs) ys 90 | 91 | prop_shuffle :: Property 92 | prop_shuffle = 93 | gamble (shuffle "abcdef") $ \(xs :: [Char]) -> 94 | List.sort xs == "abcdef" 95 | 96 | prop_listOf1 :: Property 97 | prop_listOf1 = 98 | gamble (mapTree duplicate . listOf1 $ pure ("x" :: [Char])) $ 99 | -- This might seem silly, but we're really just testing that the "internal 100 | -- error" case doesn't come up. 101 | List.all (\xs -> NonEmpty.length xs > 0) . List.take 1000 . Foldable.toList 102 | 103 | prop_vectorOf :: Property 104 | prop_vectorOf = 105 | gamble (choose (0, 1000)) $ \n -> 106 | gamble (mapTree duplicate . vectorOf n $ pure ("x" :: [Char])) $ 107 | Foldable.all (\xs -> n == List.length xs) 108 | 109 | prop_suchThat :: Property 110 | prop_suchThat = 111 | gamble (mapTree duplicate $ bounded `suchThat` even) $ \(xs :: Tree Int) -> 112 | List.all even . List.take 1000 $ Foldable.toList xs 113 | 114 | return [] 115 | tests :: IO Bool 116 | tests = 117 | $forAllProperties . quickCheckWithResult $ stdArgs { maxSuccess = 100 } 118 | -------------------------------------------------------------------------------- /disorder-jack/test/Test/Disorder/Jack/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Test.Disorder.Jack.Core where 4 | 5 | import Control.Applicative (Applicative(..)) 6 | import Control.Monad (Monad(..), ap) 7 | 8 | import Data.Bool (Bool, (&&)) 9 | import Data.Eq (Eq(..)) 10 | import Data.Functor (Functor(..), (<$>)) 11 | import Data.Function (($), (.)) 12 | 13 | import Disorder.Jack.Combinators 14 | import Disorder.Jack.Core 15 | import Disorder.Jack.Property 16 | import Disorder.Jack.Tree 17 | 18 | import System.IO (IO) 19 | 20 | import Text.Show (Show) 21 | import Text.Show.Pretty (ppShow) 22 | 23 | import qualified Test.QuickCheck as QC 24 | import qualified Test.QuickCheck.Gen as QC 25 | 26 | 27 | data Info a b = 28 | Info { 29 | infoA :: Tree a 30 | , infoB :: Tree b 31 | , infoTreeApply :: Tree (a, b) 32 | , infoTreeMonad :: Tree (a, b) 33 | , infoJackApply :: Tree (a, b) 34 | , infoJackMonad :: Tree (a, b) 35 | } deriving (Show) 36 | 37 | genTrees :: Jack a -> Jack b -> QC.Gen (Info a b) 38 | genTrees ja jb = 39 | QC.MkGen $ \r n -> 40 | let 41 | run g = 42 | QC.unGen g r n 43 | 44 | (a, b) = 45 | run $ do 46 | a0 <- runJack ja 47 | b0 <- runJack jb 48 | pure (a0, b0) 49 | in 50 | Info { 51 | infoA = a 52 | , infoB = b 53 | , infoTreeApply = (,) <$> a <*> b 54 | , infoTreeMonad = (,) `fmap` a `ap` b 55 | , infoJackApply = run . runJack $ (,) <$> ja <*> jb 56 | , infoJackMonad = run . runJack $ (,) `fmap` ja `ap` jb 57 | } 58 | 59 | prop_ap_all_the_things :: Property 60 | prop_ap_all_the_things = 61 | let 62 | aa = chooseInt (1, 5) 63 | bb = chooseChar ('a', 'e') 64 | in 65 | QC.forAll (genTrees aa bb) $ \(Info a b ta tm ja jm) -> 66 | QC.counterexample "=== A ===" . 67 | QC.counterexample (ppShow a) . 68 | QC.counterexample "=== B ===" . 69 | QC.counterexample (ppShow b) $ 70 | QC.counterexample "=== Tree Applicative ===" . 71 | QC.counterexample (ppShow ta) $ 72 | QC.counterexample "=== Tree Monad ===" . 73 | QC.counterexample (ppShow tm) $ 74 | QC.counterexample "=== Jack Applicative ===" . 75 | QC.counterexample (ppShow ja) $ 76 | QC.counterexample "=== Jack Monad ===" . 77 | QC.counterexample (ppShow jm) $ 78 | ta == tm && 79 | tm == ja && 80 | ja == jm 81 | 82 | return [] 83 | tests :: IO Bool 84 | tests = 85 | $forAllProperties . quickCheckWithResult $ stdArgs { maxSuccess = 1000 } 86 | -------------------------------------------------------------------------------- /disorder-jack/test/Test/Disorder/Jack/Minimal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | module Test.Disorder.Jack.Minimal where 5 | 6 | import Control.Applicative (Applicative(..), Alternative(..)) 7 | import Control.Comonad (duplicate) 8 | import Control.Monad (Monad(..)) 9 | 10 | import Data.Bool (Bool(..), (&&)) 11 | import Data.Foldable (foldl) 12 | import Data.Function (($), (.)) 13 | import Data.Functor (Functor(..), (<$>)) 14 | import Data.Int (Int) 15 | import qualified Data.List as List 16 | import Data.Maybe (Maybe(..)) 17 | import Data.Text (Text) 18 | import qualified Data.Text as T 19 | 20 | import Disorder.Jack.Combinators 21 | import Disorder.Jack.Core 22 | import Disorder.Jack.Property 23 | import Disorder.Jack.Tree 24 | 25 | import System.IO (IO) 26 | 27 | import Text.Show (Show) 28 | import Text.Show.Pretty (ppShow) 29 | 30 | 31 | data Exp = 32 | Var !Text 33 | | Con !Int 34 | | Lam !Text !Exp 35 | | App !Exp !Exp 36 | deriving (Show) 37 | 38 | exp :: Jack Exp 39 | exp = 40 | let 41 | text = 42 | T.pack <$> arbitrary 43 | 44 | shrink = \case 45 | Lam _ x -> 46 | [x] 47 | App x y -> 48 | [x, y] 49 | _ -> 50 | [] 51 | in 52 | reshrink shrink $ 53 | oneOfRec [ 54 | Con <$> sizedIntegral 55 | , Var <$> text 56 | ] [ 57 | Lam <$> text <*> exp 58 | , App <$> exp <*> exp 59 | ] 60 | 61 | noAppCon10 :: Exp -> Bool 62 | noAppCon10 = \case 63 | Con _ -> 64 | True 65 | Var _ -> 66 | True 67 | Lam _ x -> 68 | noAppCon10 x 69 | App _ (Con 10) -> 70 | False 71 | App x1 x2 -> 72 | noAppCon10 x1 && noAppCon10 x2 73 | 74 | smallestFailure :: (a -> Bool) -> Tree a -> Maybe a 75 | smallestFailure f (Node x xs) = 76 | if f x then 77 | Nothing 78 | else 79 | foldl (<|>) empty (fmap (smallestFailure f) xs) <|> Just x 80 | 81 | prop_listOf_minimal :: Property 82 | prop_listOf_minimal = 83 | gamble (mapTree duplicate $ listOf exp) $ \xs -> 84 | case smallestFailure (List.all noAppCon10) xs of 85 | Nothing -> 86 | property succeeded 87 | -- The tree must be organised such that smallest fail is found by greedy 88 | -- traversal with a predicate. 89 | Just [App (Con 0) (Con 10)] -> 90 | property succeeded 91 | Just x -> 92 | counterexample "" . 93 | counterexample "Greedy traversal with predicate did not yield the minimal shrink." . 94 | counterexample "" . 95 | counterexample "=== Minimal ===" . 96 | counterexample (ppShow [App (Con 0) (Con 10)]) . 97 | counterexample "=== Actual ===" . 98 | counterexample (ppShow x) $ 99 | property failed 100 | 101 | return [] 102 | tests :: IO Bool 103 | tests = 104 | $forAllProperties . quickCheckWithResult $ stdArgs { maxSuccess = 100 } 105 | -------------------------------------------------------------------------------- /disorder-jack/test/Test/Disorder/Jack/Property/Diff.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 6 | module Test.Disorder.Jack.Property.Diff where 7 | 8 | import Control.Monad (Monad(..)) 9 | 10 | import Data.Bool (Bool(..)) 11 | import Data.Eq (Eq(..)) 12 | import Data.Function (($), (.)) 13 | import qualified Data.List as List 14 | import Data.Maybe (Maybe(..)) 15 | import Data.Either (Either(..)) 16 | import Data.String (String) 17 | 18 | import Disorder.Jack 19 | import Disorder.Jack.Property.Diff 20 | 21 | import Text.Show (Show(..)) 22 | import qualified Text.Show.Pretty as Pretty 23 | 24 | import Prelude (Int) 25 | 26 | import System.IO (IO) 27 | 28 | checkDiff :: Show a => a -> a -> [String] -> Property 29 | checkDiff left right expect = 30 | let Just left' = Pretty.reify left 31 | Just right' = Pretty.reify right 32 | actual = renderDiffs left' right' 33 | expect' = List.unlines expect 34 | in counterexample "=== Left ===" 35 | $ counterexample (show left) 36 | $ counterexample "=== Right ===" 37 | $ counterexample (show right) 38 | $ counterexample "=== Expect ===" 39 | $ counterexample expect' 40 | $ counterexample "=== Actual ===" 41 | $ counterexample actual 42 | ( actual == expect' ) 43 | 44 | -- If the difference fits on single line, the outer constructors should appear in diff 45 | prop_eg1 :: Property 46 | prop_eg1 = 47 | checkDiff 48 | (Just 1) 49 | (Just 2) 50 | [ "-Just 1" 51 | , "+Just 2" ] 52 | 53 | prop_eg2 :: Property 54 | prop_eg2 = 55 | checkDiff 56 | [1,2,3,4] 57 | [1,2,3,5] 58 | [ "-[ 1 , 2 , 3 , 4 ]" 59 | , "+[ 1 , 2 , 3 , 5 ]" ] 60 | 61 | -- If we have a big enough list that it won't fit on a single line, 62 | -- it should dig down into the nested parts to show the diff 63 | data SomethingLong 64 | = SomethingReallyReallyLongThatDontFitOnASingleLine 65 | deriving Show 66 | 67 | prop_eg3 :: Property 68 | prop_eg3 = 69 | checkDiff 70 | [Right SomethingReallyReallyLongThatDontFitOnASingleLine, Left 4] 71 | [Right SomethingReallyReallyLongThatDontFitOnASingleLine, Left 5] 72 | [ " [ Right SomethingReallyReallyLongThatDontFitOnASingleLine" 73 | , " ," 74 | , "- Left 4" 75 | , "+ Left 5" 76 | , " ]" 77 | ] 78 | 79 | -- Records show full field names 80 | data RecordWithFields 81 | = RecordWithFields 82 | { field1 :: Int 83 | , field2 :: Maybe Int 84 | , field3 :: [RecordWithFields] 85 | } 86 | deriving Show 87 | 88 | prop_eg4 :: Property 89 | prop_eg4 = 90 | checkDiff 91 | (RecordWithFields 0 (Just 1) [RecordWithFields 2 Nothing []]) 92 | (RecordWithFields 0 Nothing [RecordWithFields 2 (Just 1) []]) 93 | [ " RecordWithFields" 94 | , " { field1 =" 95 | , " 0" 96 | , " , field2 =" 97 | , "- Just 1" 98 | , "+ Nothing" 99 | , " , field3 =" 100 | , " [" 101 | , "- RecordWithFields { field1 = 2 , field2 = Nothing , field3 = [] }" 102 | , "+ RecordWithFields { field1 = 2 , field2 = Just 1 , field3 = [] }" 103 | , " ]" 104 | , " }" 105 | ] 106 | 107 | return [] 108 | tests :: IO Bool 109 | tests = 110 | $forAllProperties . quickCheckWithResult $ stdArgs { maxSuccess = 1 } 111 | 112 | -------------------------------------------------------------------------------- /disorder-jack/test/Test/Disorder/Jack/Shrink.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | module Test.Disorder.Jack.Shrink where 6 | 7 | import Control.Monad (Monad(..)) 8 | 9 | import Data.Bool (Bool(..), (&&)) 10 | import Data.Eq (Eq(..)) 11 | import Data.Function (($), (.)) 12 | import qualified Data.List as List 13 | import Data.Ord (Ord(..), min, max) 14 | 15 | import Disorder.Jack.Combinators 16 | import Disorder.Jack.Property 17 | import Disorder.Jack.Shrink 18 | 19 | import System.IO (IO) 20 | 21 | 22 | prop_shrinkTowards_unique :: Property 23 | prop_shrinkTowards_unique = 24 | gamble boundedInt $ \x -> 25 | gamble boundedInt $ \y -> 26 | let 27 | ss = shrinkTowards x y 28 | in 29 | List.nub ss == ss 30 | 31 | prop_shrinkTowards_range :: Property 32 | prop_shrinkTowards_range = 33 | gamble boundedInt $ \x -> 34 | gamble boundedInt $ \y -> 35 | let 36 | s_min = min x y 37 | s_max = max x y 38 | valid s = 39 | s >= s_min && s <= s_max 40 | in 41 | List.all valid $ shrinkTowards x y 42 | 43 | return [] 44 | tests :: IO Bool 45 | tests = 46 | $forAllProperties . quickCheckWithResult $ stdArgs { maxSuccess = 100 } 47 | -------------------------------------------------------------------------------- /disorder-jack/test/Test/Disorder/Jack/Tree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Test.Disorder.Jack.Tree where 4 | 5 | import Control.Applicative (Applicative(..)) 6 | import Control.Comonad (duplicate) 7 | import Control.Monad (Monad(..), ap) 8 | 9 | import Data.Bool (Bool) 10 | import Data.Eq (Eq(..)) 11 | import Data.Functor (Functor(..)) 12 | import Data.Function (($), (.)) 13 | 14 | import Disorder.Jack.Combinators 15 | import Disorder.Jack.Core 16 | import Disorder.Jack.Property 17 | import Disorder.Jack.Tree 18 | 19 | import System.IO (IO) 20 | 21 | import Text.Show (Show) 22 | import Text.Show.Pretty (ppShow) 23 | 24 | 25 | prop_ap :: Property 26 | prop_ap = 27 | gamble (treeOf $ chooseInt (1, 5)) $ \x -> 28 | gamble (treeOf $ chooseChar ('a', 'e')) $ \y -> 29 | law_ap x y 30 | 31 | treeOf :: Jack a -> Jack (Tree a) 32 | treeOf = 33 | mapTree duplicate 34 | 35 | law_ap :: (Show a, Show b, Eq a, Eq b) => Tree a -> Tree b -> Property 36 | law_ap x y = 37 | let 38 | s = (,) `fmap` x <*> y 39 | t = (,) `fmap` x `ap` y 40 | in 41 | counterexample "=== Left ===" . 42 | counterexample (ppShow s) . 43 | counterexample "=== Right ===" . 44 | counterexample (ppShow t) $ 45 | s == t 46 | 47 | return [] 48 | tests :: IO Bool 49 | tests = 50 | $forAllProperties . quickCheckWithResult $ stdArgs { maxSuccess = 1000 } 51 | -------------------------------------------------------------------------------- /disorder-jack/test/Test/Disorder/Jack/Tripping.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Test.Disorder.Jack.Tripping where 4 | 5 | import Control.Monad (return) 6 | 7 | import Disorder.Core.Property (neg) 8 | import Disorder.Jack 9 | 10 | import Data.Bool (Bool) 11 | import Data.Function (($), (.), id, const) 12 | import Data.Int (Int) 13 | import Data.Maybe (Maybe(..)) 14 | 15 | import System.IO (IO) 16 | 17 | 18 | prop_tripping :: Property 19 | prop_tripping = 20 | gamble bounded $ 21 | tripping id (Just :: Int -> Maybe Int) 22 | 23 | prop_tripping_neg :: Property 24 | prop_tripping_neg = 25 | gamble bounded $ 26 | neg . tripping id (const Nothing :: Int -> Maybe Int) 27 | 28 | return [] 29 | tests :: IO Bool 30 | tests = 31 | $quickCheckAll 32 | -------------------------------------------------------------------------------- /disorder-jack/test/test.hs: -------------------------------------------------------------------------------- 1 | import Disorder.Core.Main 2 | 3 | import qualified Test.Disorder.Jack.Combinators 4 | import qualified Test.Disorder.Jack.Core 5 | import qualified Test.Disorder.Jack.Minimal 6 | import qualified Test.Disorder.Jack.Property.Diff 7 | import qualified Test.Disorder.Jack.Shrink 8 | import qualified Test.Disorder.Jack.Tree 9 | 10 | main :: IO () 11 | main = 12 | disorderMain [ 13 | Test.Disorder.Jack.Combinators.tests 14 | , Test.Disorder.Jack.Core.tests 15 | , Test.Disorder.Jack.Minimal.tests 16 | , Test.Disorder.Jack.Property.Diff.tests 17 | , Test.Disorder.Jack.Shrink.tests 18 | , Test.Disorder.Jack.Tree.tests 19 | ] 20 | -------------------------------------------------------------------------------- /disorder-lens/ambiata-disorder-lens.cabal: -------------------------------------------------------------------------------- 1 | name: ambiata-disorder-lens 2 | version: 0.0.3 3 | license: AllRightsReserved 4 | author: Ambiata 5 | maintainer: Ambiata 6 | copyright: (c) 2015 Ambiata 7 | synopsis: disorder-lens 8 | category: System 9 | cabal-version: >= 1.22 10 | build-type: Simple 11 | description: disorder-lens. 12 | 13 | library 14 | build-depends: 15 | base >= 3 && < 5 16 | , lens >= 4.6 && < 4.18 17 | , QuickCheck >= 2.8 18 | 19 | default-language: 20 | Haskell2010 21 | 22 | ghc-options: 23 | -Wall 24 | if impl(ghc >= 8.0) 25 | ghc-options: -fno-warn-redundant-constraints 26 | 27 | hs-source-dirs: 28 | src 29 | 30 | 31 | exposed-modules: 32 | Disorder.Lens 33 | 34 | test-suite test 35 | type: exitcode-stdio-1.0 36 | 37 | main-is: test.hs 38 | 39 | ghc-options: -Wall -threaded -O2 40 | if impl(ghc >= 8.0) 41 | ghc-options: -fno-warn-redundant-constraints 42 | 43 | hs-source-dirs: 44 | test 45 | 46 | build-depends: 47 | base 48 | , ambiata-disorder-lens 49 | , lens 50 | , QuickCheck 51 | 52 | default-language: 53 | Haskell2010 54 | -------------------------------------------------------------------------------- /disorder-lens/mafia: -------------------------------------------------------------------------------- 1 | ../framework/mafia -------------------------------------------------------------------------------- /disorder-lens/master.toml: -------------------------------------------------------------------------------- 1 | ../framework/master.toml -------------------------------------------------------------------------------- /disorder-lens/src/Disorder/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module Disorder.Lens ( 3 | -- * Prism Laws 4 | prismSymmetry 5 | , prismConverseSymmetry 6 | , prismLaws 7 | -- * Traversal Laws 8 | , traversalPure 9 | ) where 10 | 11 | import Control.Applicative as A ( pure ) 12 | import Control.Lens ( Traversal', Prism', (^.) , (^?), (.~), mapped, re ) 13 | import Test.QuickCheck ( Arbitrary, Property, (===), conjoin, property ) 14 | 15 | import Prelude 16 | 17 | -- Prism Laws 18 | 19 | prismSymmetry :: (Show a, Eq a) => Prism' s a -> a -> Property 20 | prismSymmetry l y = (y ^. re l) ^? l === A.pure y 21 | 22 | prismConverseSymmetry :: (Show s, Eq s) => Prism' s a -> s -> Property 23 | prismConverseSymmetry l x = fmap (^. re l) (x ^? l) === (mapped .~ x) (x ^? l) 24 | 25 | -- | 26 | -- Prisms must satisfy the Symmetry and Converse Symmetry laws as well as the Traversal Laws. 27 | -- 28 | prismLaws :: (Show a, Eq a, Arbitrary a, Show s, Eq s, Arbitrary s) => Prism' s a -> Property 29 | prismLaws p = conjoin [ 30 | property $ prismSymmetry p 31 | , property $ prismConverseSymmetry p 32 | , property $ traversalPure p 33 | ] 34 | 35 | -- Traversal Laws 36 | 37 | -- The `fmap (t f) . t g ≡ getCompose . t (Compose . fmap f . g)` law isnt here yet, 38 | -- but I *think* parametricity (combined with `traversalPure`) will cover it (?). 39 | 40 | traversalPure :: (Show s, Eq s) => Traversal' s a -> s -> Property 41 | traversalPure t x = t Just x === Just x 42 | -------------------------------------------------------------------------------- /disorder-lens/test/Test/Disorder/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Test.Disorder.Lens where 3 | 4 | import Disorder.Lens 5 | 6 | import Control.Lens ( _Just, Prism' ) 7 | import Data.Traversable 8 | 9 | import Test.QuickCheck 10 | 11 | import Prelude 12 | 13 | prop_prismSymmetry :: (Arbitrary a, Show a, Eq a) => a -> Property 14 | prop_prismSymmetry = prismSymmetry _Just 15 | 16 | prop_ConverseSymmetry :: (Arbitrary a, Show a, Eq a) => Maybe a -> Property 17 | prop_ConverseSymmetry = prismConverseSymmetry _Just 18 | 19 | prop_prismLaws :: Property 20 | prop_prismLaws = prismLaws (_Just :: Prism' (Maybe Int) Int) 21 | 22 | prop_traversalPure :: (Arbitrary a, Show a, Eq a) => [a] -> Property 23 | prop_traversalPure = traversalPure traverse 24 | 25 | return [] 26 | tests :: IO Bool 27 | tests = $quickCheckAll 28 | -------------------------------------------------------------------------------- /disorder-lens/test/test.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | import qualified Test.Disorder.Lens 4 | 5 | import System.Exit 6 | import System.IO 7 | 8 | 9 | main :: IO () 10 | main = 11 | hSetBuffering stdout LineBuffering >> sequence [ 12 | Test.Disorder.Lens.tests 13 | ] >>= \rs -> unless (and rs) exitFailure 14 | -------------------------------------------------------------------------------- /framework/mafia: -------------------------------------------------------------------------------- 1 | #!/bin/bash -eu 2 | 3 | : ${MAFIA_HOME:=$HOME/.mafia} 4 | : ${MAFIA_VERSIONS:=$MAFIA_HOME/versions} 5 | : ${MAFIA_GIT_URL:="https://github.com/ambiata/mafia"} 6 | : ${MAFIA_GIT_BRANCH:="ambiata"} 7 | 8 | latest_version () { 9 | git ls-remote ${MAFIA_GIT_URL} | grep "refs/heads/$MAFIA_GIT_BRANCH" | cut -f 1 10 | } 11 | 12 | build_version() { 13 | MAFIA_VERSION="$1" 14 | MAFIA_TEMP=$(mktemp -d 2>/dev/null || mktemp -d -t 'exec_mafia') 15 | MAFIA_FILE=mafia-$MAFIA_VERSION 16 | MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE 17 | mkdir -p $MAFIA_VERSIONS 18 | echo "Building $MAFIA_FILE in $MAFIA_TEMP" 19 | git clone ${MAFIA_GIT_URL} $MAFIA_TEMP 20 | git --git-dir="$MAFIA_TEMP/.git" --work-tree="$MAFIA_TEMP" reset --hard $MAFIA_VERSION || { 21 | echo "mafia version ($MAFIA_VERSION) could not be found." >&2 22 | exit 1 23 | } 24 | (cd "$MAFIA_TEMP" && ./bin/bootstrap) || { 25 | got=$? 26 | echo "mafia version ($MAFIA_VERSION) could not be built." >&2 27 | exit "$got" 28 | } 29 | chmod +x "$MAFIA_TEMP/.cabal-sandbox/bin/mafia" 30 | # Ensure executable is on same file-system so final mv is atomic. 31 | mv -f "$MAFIA_TEMP/.cabal-sandbox/bin/mafia" "$MAFIA_PATH.$$" 32 | mv "$MAFIA_PATH.$$" "$MAFIA_PATH" || { 33 | rm -f "$MAFIA_PATH.$$" 34 | echo "INFO: mafia version ($MAFIA_VERSION) already exists not overiding," >&2 35 | echo "INFO: this is expected if parallel builds of the same version of" >&2 36 | echo "INFO: mafia occur, we are playing by first in, wins." >&2 37 | exit 0 38 | } 39 | } 40 | 41 | enable_version() { 42 | if [ $# -eq 0 ]; then 43 | MAFIA_VERSION="$(latest_version)" 44 | echo "INFO: No explicit mafia version requested installing latest ($MAFIA_VERSION)." >&2 45 | else 46 | MAFIA_VERSION="$1" 47 | fi 48 | [ -x "${MAFIA_VERSIONS}/mafia-$MAFIA_VERSION" ] || build_version "$MAFIA_VERSION" 49 | ln -sf "${MAFIA_VERSIONS}/mafia-$MAFIA_VERSION" "${MAFIA_VERSIONS}/mafia" 50 | } 51 | 52 | exec_mafia () { 53 | [ -x "${MAFIA_VERSIONS}/mafia" ] || enable_version 54 | "${MAFIA_VERSIONS}/mafia" "$@" 55 | } 56 | 57 | # 58 | # The actual start of the script..... 59 | # 60 | 61 | case "${1:-}" in 62 | upgrade) shift; enable_version "$@" ;; 63 | *) exec_mafia "$@" 64 | esac 65 | -------------------------------------------------------------------------------- /framework/master.toml: -------------------------------------------------------------------------------- 1 | [master] 2 | runner = "s3://ambiata-dispensary-v2/dist/master/master-haskell/linux/x86_64/20190103044641-3857bee/master-haskell-20190103044641-3857bee" 3 | version = 1 4 | sha1 = "c8396097bdf46fa16aae6660f8d1f3ea7a4bce72" 5 | 6 | [global] 7 | CACHE = "true" 8 | 9 | [build.dist-8-2] 10 | GHC_VERSION = "8.2.2" 11 | CABAL_VERSION = "2.0.0.1" 12 | 13 | [build.branches-8-2] 14 | GHC_VERSION = "8.2.2" 15 | CABAL_VERSION = "2.0.0.1" 16 | 17 | [build.dist-7-10] 18 | GHC_VERSION = "7.10.2" 19 | CABAL_VERSION = "1.24.0.2" 20 | 21 | [build.branches-7-10] 22 | GHC_VERSION = "7.10.2" 23 | CABAL_VERSION = "1.24.0.2" 24 | 25 | [build.dist-8-0] 26 | HADDOCK = "true" 27 | HADDOCK_S3 = "$AMBIATA_HADDOCK_MASTER" 28 | GHC_VERSION = "8.0.2" 29 | CABAL_VERSION = "1.24.0.2" 30 | 31 | [build.branches-8-0] 32 | HADDOCK = "true" 33 | HADDOCK_S3 = "$AMBIATA_HADDOCK_BRANCHES" 34 | GHC_VERSION = "8.0.2" 35 | CABAL_VERSION = "1.24.0.2" 36 | --------------------------------------------------------------------------------