From 553158d39e9692da22f709e4a5ac6451bfadffd2 Mon Sep 17 00:00:00 2001 From: Harrison Kaiser Date: Tue, 25 Aug 2020 21:25:23 -0400 Subject: [PATCH 1/4] Added QuickCheck for property to Interval This commit includes only one very basic property for intervals at the time of the commit the property successfully runs for 100 instances. --- chords.cabal | 14 ++++++++++---- package.yaml | 2 ++ src/Base/Core/Quality/IQuality.hs | 10 +++++++++- src/Base/Interval.hs | 16 ++++++++++++++-- 4 files changed, 35 insertions(+), 7 deletions(-) diff --git a/chords.cabal b/chords.cabal index 1a9149c..a914980 100644 --- a/chords.cabal +++ b/chords.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: ee4c89d7bed6b5301ea76804b74ab74db2265473402e362135317ea273e7ff33 +-- hash: f837b4f562ba53b2d2f26f2e7af5f96f55ac5c2865d732d975cabd9a52a90dc1 name: chords version: 0.1.0.0 @@ -51,8 +51,10 @@ library hs-source-dirs: src build-depends: - base >=4.7 && <5 + QuickCheck + , base >=4.7 && <5 , containers + , generic-random , parsec default-language: Haskell2010 @@ -64,9 +66,11 @@ executable chords-exe app ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + QuickCheck + , base >=4.7 && <5 , chords , containers + , generic-random , parsec default-language: Haskell2010 @@ -79,8 +83,10 @@ test-suite chords-test test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + QuickCheck + , base >=4.7 && <5 , chords , containers + , generic-random , parsec default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 49685bc..f56c417 100644 --- a/package.yaml +++ b/package.yaml @@ -23,6 +23,8 @@ dependencies: - base >= 4.7 && < 5 - containers - parsec +- generic-random +- QuickCheck library: source-dirs: src diff --git a/src/Base/Core/Quality/IQuality.hs b/src/Base/Core/Quality/IQuality.hs index acd916e..6694b87 100644 --- a/src/Base/Core/Quality/IQuality.hs +++ b/src/Base/Core/Quality/IQuality.hs @@ -1,8 +1,13 @@ +{-# LANGUAGE DeriveGeneric #-} module Base.Core.Quality.IQuality ( Quality(..) , baseQuality ) where +import GHC.Generics +import Generic.Random +import Test.QuickCheck + import Common.Utils (modByFrom) data Quality @@ -11,7 +16,10 @@ data Quality | Minor | Diminished Int | Augmented Int - deriving Show + deriving (Show, Generic) + +instance Arbitrary Quality where + arbitrary = genericArbitrary uniform baseQuality :: Int -> Quality baseQuality n diff --git a/src/Base/Interval.hs b/src/Base/Interval.hs index b915383..cf6a59d 100644 --- a/src/Base/Interval.hs +++ b/src/Base/Interval.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} module Base.Interval ( Interval , getQuality @@ -9,8 +10,13 @@ module Base.Interval , jumpIntervalFromNote , (|+|) , (|-|) + , propInvertSum ) where +import GHC.Generics +import Generic.Random +import Test.QuickCheck hiding (getSize) + import Base.Core.Accidental import Base.Core.Note import Base.Core.Quality.IQuality @@ -23,11 +29,17 @@ import Base.PitchClass import Common.Utils (modByFrom) -import Data.Maybe (fromJust) +import Data.Maybe (isJust, fromJust) data Interval = Interval { getQuality :: Quality , getSize :: Int - } + } deriving (Generic) + +instance Arbitrary Interval where + arbitrary = suchThat (genericArbitrary uniform) (isJust . intervalToDistance) + +propInvertSum :: Interval -> Bool +propInvertSum i = (invert i) |+| i == (intervalFrom Perfect 1) instance Eq Interval where int1 == int2 = intervalToDistance int1 == intervalToDistance int2 From c52483f408f0fec9017afdcd9dca11df50961fbd Mon Sep 17 00:00:00 2001 From: Harrison Kaiser Date: Wed, 26 Aug 2020 17:25:42 -0400 Subject: [PATCH 2/4] Extra paren --- src/Base/Interval.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Base/Interval.hs b/src/Base/Interval.hs index 712286a..8b49aec 100644 --- a/src/Base/Interval.hs +++ b/src/Base/Interval.hs @@ -40,7 +40,7 @@ instance Arbitrary Interval where arbitrary = suchThat (genericArbitrary uniform) (isJust . intervalToDistance) propInvertSum :: Interval -> Bool -propInvertSum i = (invert i) |+| i == (intervalFrom Perfect 1) +propInvertSum i = invert i |+| i == intervalFrom Perfect 1 instance Eq Interval where int1 == int2 = intervalToDistance int1 == intervalToDistance int2 From 0b0ec3ea63f9e0932757ba9f5680519fd0487a6d Mon Sep 17 00:00:00 2001 From: Harrison Kaiser Date: Wed, 26 Aug 2020 17:30:07 -0400 Subject: [PATCH 3/4] Add todo about Arbitrary instance for Interval --- src/Base/Interval.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Base/Interval.hs b/src/Base/Interval.hs index 8b49aec..7085efd 100644 --- a/src/Base/Interval.hs +++ b/src/Base/Interval.hs @@ -36,6 +36,8 @@ data Interval = Interval { getQuality :: Quality , getSize :: Int } deriving (Generic) +-- TODO: change to use a Maybe returning smart constructor when +-- such a thing becomes avalible. instance Arbitrary Interval where arbitrary = suchThat (genericArbitrary uniform) (isJust . intervalToDistance) From 84633c873ea300faba916a44f299ac444b815d98 Mon Sep 17 00:00:00 2001 From: Harrison Kaiser Date: Wed, 26 Aug 2020 17:42:37 -0400 Subject: [PATCH 4/4] Added implemention note to TODO --- src/Base/Interval.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Base/Interval.hs b/src/Base/Interval.hs index 7085efd..2d34f57 100644 --- a/src/Base/Interval.hs +++ b/src/Base/Interval.hs @@ -38,6 +38,10 @@ data Interval = Interval { getQuality :: Quality -- TODO: change to use a Maybe returning smart constructor when -- such a thing becomes avalible. +-- The implemention of arbitrary will look something like: +-- suchThatMap +-- (genericArbitrary uniform) +-- (\(size, quality) -> intConstructor size quality) instance Arbitrary Interval where arbitrary = suchThat (genericArbitrary uniform) (isJust . intervalToDistance)