From 3976e09506ddb2ae7a08cedf65f23bcaed224b03 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?David=20P=C3=A4tzel?= Date: Sat, 2 May 2020 17:42:04 +0200 Subject: [PATCH] Enable (almost) all GHC warning, fix warnings --- haga.cabal | 7 +++++-- src/GA.hs | 19 ++++++++++++------- src/Seminar.hs | 14 ++++++++++---- src/Szenario191.hs | 1 - 4 files changed, 27 insertions(+), 14 deletions(-) diff --git a/haga.cabal b/haga.cabal index afa334d..9742e2c 100644 --- a/haga.cabal +++ b/haga.cabal @@ -34,6 +34,7 @@ library , random-shuffle , text default-language: Haskell2010 + ghc-options: -Wall -Wno-name-shadowing -Wno-orphans hs-source-dirs: src exposed-modules: GA , Seminar @@ -55,6 +56,7 @@ executable haga , random-shuffle , text default-language: Haskell2010 + ghc-options: -Wall -Wno-name-shadowing -Wno-orphans hs-source-dirs: src main-is: Main.hs other-modules: GA @@ -62,7 +64,7 @@ executable haga , Pretty , Szenario191 -executable haga-tests +executable haga-test build-depends: base ^>=4.13.0.0 , Cabal , extra @@ -78,9 +80,10 @@ executable haga-tests , random-shuffle , text default-language: Haskell2010 + ghc-options: -Wall -Wno-name-shadowing -Wno-orphans hs-source-dirs: src main-is: Test.hs other-modules: GA , Seminar , Pretty - , Szenario191 \ No newline at end of file + , Szenario191 diff --git a/src/GA.hs b/src/GA.hs index d9e1033..872c43f 100644 --- a/src/GA.hs +++ b/src/GA.hs @@ -24,18 +24,14 @@ function. module GA where import Control.Arrow hiding (first, second) -import qualified Data.List as L import Data.List.NonEmpty ((<|)) import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty.Extra as NE (appendl, sortOn) import Data.Random -import Data.Random.Distribution.Categorical -import Data.Random.Sample import Pipes -import Pretty import Protolude import Test.QuickCheck hiding (sample, shuffle) -import Test.QuickCheck.Instances +import Test.QuickCheck.Instances () import Test.QuickCheck.Monadic -- TODO there should be a few 'shuffle's here @@ -122,6 +118,8 @@ children nX (i1 :| [i2]) = children2 nX i1 i2 children nX (i1 :| i2 : is') = (<>) <$> children2 nX i1 i2 <*> children nX (NE.fromList is') +prop_children_asManyAsParents + :: (Individual a, Show a) => N -> NonEmpty a -> Property prop_children_asManyAsParents nX is = again $ monadicIO @@ -168,6 +166,7 @@ bestsBy' k f = fmap (NE.take k . fmap fst . NE.sortBy (comparing (Down . snd))) . traverse (\i -> (i,) <$> f i) +prop_bestsBy_isBestsBy' :: Individual a => Int -> Population a -> Property prop_bestsBy_isBestsBy' k pop = k > 0 ==> monadicIO @@ -176,6 +175,7 @@ prop_bestsBy_isBestsBy' k pop = b <- bestsBy' k fitness pop assert $ NE.toList a == b +prop_bestsBy_lengths :: Individual a => Int -> Population a -> Property prop_bestsBy_lengths k pop = k > 0 ==> monadicIO $ do (bests, rest) <- bestsBy k fitness pop @@ -230,6 +230,8 @@ stepSteady select nParents nX pElite pop = do where nBest = floor . (pElite *) . fromIntegral $ NE.length pop +prop_stepSteady_constantPopSize + :: (Individual a, Show a) => NonEmpty a -> Property prop_stepSteady_constantPopSize pop = forAll ( (,) @@ -300,6 +302,7 @@ selected multiple times, see 'chain'). tournament :: (Individual i, MonadRandom m) => N -> Selection m i tournament nTrnmnt = chain (tournament1 nTrnmnt) +prop_tournament_selectsN :: Individual a => Int -> Int -> NonEmpty a -> Property prop_tournament_selectsN nTrnmnt n pop = 0 < nTrnmnt && nTrnmnt < length pop && 0 < n ==> monadicIO @@ -322,7 +325,6 @@ tournament1 nTrnmnt pop | otherwise = trnmnt >>= fmap (NE.head . fst) . bests 1 where trnmnt = withoutReplacement nTrnmnt pop - size = length pop {-| Selects @n@ individuals uniformly at random from the population (without @@ -340,6 +342,7 @@ withoutReplacement n pop | otherwise = fmap NE.fromList . sample . shuffleNofM n (length pop) $ NE.toList pop +prop_withoutReplacement_selectsN :: Int -> NonEmpty a -> Property prop_withoutReplacement_selectsN n pop = 0 < n && n <= length pop ==> monadicIO $ do pop' <- lift $ withoutReplacement n pop @@ -365,7 +368,7 @@ steps tEnd _ t = t >= tEnd Shuffles a non-empty list. -} shuffle' :: (MonadRandom m) => NonEmpty a -> m (NonEmpty a) -shuffle' xs@(x :| []) = return xs +shuffle' xs@(_ :| []) = return xs shuffle' xs = do i <- sample . uniform 0 $ NE.length xs - 1 -- slightly unsafe (!!) used here so deletion is faster @@ -375,10 +378,12 @@ shuffle' xs = do where deleteI i xs = fst (NE.splitAt i xs) ++ snd (NE.splitAt (i + 1) xs) +prop_shuffle_length :: NonEmpty a -> Property prop_shuffle_length xs = monadicIO $ do xs' <- lift $ shuffle' xs assert $ length xs' == length xs return [] +runTests :: IO Bool runTests = $quickCheckAll diff --git a/src/Seminar.hs b/src/Seminar.hs index 1f0fa84..7ed9924 100644 --- a/src/Seminar.hs +++ b/src/Seminar.hs @@ -8,13 +8,11 @@ module Seminar where import Data.List ((!!), (\\), lookup, zipWith3) import Data.List.Extra (nubOrd, nubOrdOn) import Data.Random -import Data.Random.Distribution.Uniform import qualified Data.Text as T import GA import Pretty import Protolude import Test.QuickCheck hiding (sample, shuffle) -import Test.QuickCheck.Instances import Test.QuickCheck.Monadic (assert, monadicIO) instance Pretty Text where @@ -85,11 +83,14 @@ The priority value given by a student to a topic. prioOf :: Priorities -> Student -> Topic -> Int prioOf p s t = fromMaybe (lowestPriority p + 1) $ lookup s (unP p) >>= lookup t +prop_prioOf_empty :: Bool prop_prioOf_empty = prioOf (P []) "S" "T" == 1 +prop_prioOf_singletonFound :: Bool prop_prioOf_singletonFound = prioOf (P [("S", [("Existing topic", 10)])]) "S" "Existing topic" == 10 +prop_prioOf_singletonNotFound :: Bool prop_prioOf_singletonNotFound = prioOf (P [("S", [("Existing topic", 10)])]) "S" "Non-existing topic" == 11 @@ -105,7 +106,7 @@ data I = I Priorities Assignment deriving (Eq, Show) instance Pretty I where - pretty i@(I p a) = + pretty (I p a) = T.unlines (gene <$> a) where gene :: (Student, Maybe Topic) -> Text @@ -119,7 +120,7 @@ The priority value given by a student to a topic including the case of her not receiving a topic. -} prioOf' :: Priorities -> Student -> Maybe Topic -> Int -prioOf' p s Nothing = lowestPriority p + 2 +prioOf' p _ Nothing = lowestPriority p + 2 prioOf' p s (Just t) = prioOf p s t instance Individual I where @@ -192,15 +193,18 @@ valid p a = studentsAssigned = fmap fst a topicsAssigned = fmap snd a +prop_new_valid :: Priorities -> Property prop_new_valid p = monadicIO $ do I _ a <- lift $ new (I p []) assert $ valid p a +prop_mutate_valid :: Priorities -> Property prop_mutate_valid p = monadicIO $ do a <- lift . new $ I p [] I _ a <- lift $ mutate a assert $ valid p a +prop_crossover1_valid :: Priorities -> Property prop_crossover1_valid p = monadicIO $ do a1 <- lift . new $ I p [] a2 <- lift . new $ I p [] @@ -217,6 +221,7 @@ elements. noDupsList :: (Arbitrary a, Eq a, Ord a) => Gen [a] noDupsList = nubOrd <$> arbitrary +prop_noDupsList :: Property prop_noDupsList = forAll (noDupsList :: Gen [Int]) unique {-| @@ -227,4 +232,5 @@ unique xs = length xs == (length . nubOrd) xs return [] +runTests :: IO Bool runTests = $quickCheckAll diff --git a/src/Szenario191.hs b/src/Szenario191.hs index 088a43f..83db7e1 100644 --- a/src/Szenario191.hs +++ b/src/Szenario191.hs @@ -9,7 +9,6 @@ module Szenario191 where import GA hiding (runTests) -import Protolude import Seminar hiding (runTests) prios :: Priorities