Enable (almost) all GHC warning, fix warnings

This commit is contained in:
David Pätzel 2020-05-02 17:42:04 +02:00
parent 30e6f08e27
commit 3976e09506
4 changed files with 27 additions and 14 deletions

View File

@ -34,6 +34,7 @@ library
, random-shuffle , random-shuffle
, text , text
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -Wno-name-shadowing -Wno-orphans
hs-source-dirs: src hs-source-dirs: src
exposed-modules: GA exposed-modules: GA
, Seminar , Seminar
@ -55,6 +56,7 @@ executable haga
, random-shuffle , random-shuffle
, text , text
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -Wno-name-shadowing -Wno-orphans
hs-source-dirs: src hs-source-dirs: src
main-is: Main.hs main-is: Main.hs
other-modules: GA other-modules: GA
@ -62,7 +64,7 @@ executable haga
, Pretty , Pretty
, Szenario191 , Szenario191
executable haga-tests executable haga-test
build-depends: base ^>=4.13.0.0 build-depends: base ^>=4.13.0.0
, Cabal , Cabal
, extra , extra
@ -78,9 +80,10 @@ executable haga-tests
, random-shuffle , random-shuffle
, text , text
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -Wno-name-shadowing -Wno-orphans
hs-source-dirs: src hs-source-dirs: src
main-is: Test.hs main-is: Test.hs
other-modules: GA other-modules: GA
, Seminar , Seminar
, Pretty , Pretty
, Szenario191 , Szenario191

View File

@ -24,18 +24,14 @@ function.
module GA where module GA where
import Control.Arrow hiding (first, second) import Control.Arrow hiding (first, second)
import qualified Data.List as L
import Data.List.NonEmpty ((<|)) import Data.List.NonEmpty ((<|))
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import qualified Data.List.NonEmpty.Extra as NE (appendl, sortOn) import qualified Data.List.NonEmpty.Extra as NE (appendl, sortOn)
import Data.Random import Data.Random
import Data.Random.Distribution.Categorical
import Data.Random.Sample
import Pipes import Pipes
import Pretty
import Protolude import Protolude
import Test.QuickCheck hiding (sample, shuffle) import Test.QuickCheck hiding (sample, shuffle)
import Test.QuickCheck.Instances import Test.QuickCheck.Instances ()
import Test.QuickCheck.Monadic import Test.QuickCheck.Monadic
-- TODO there should be a few 'shuffle's here -- 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') = children nX (i1 :| i2 : is') =
(<>) <$> children2 nX i1 i2 <*> children nX (NE.fromList 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 = prop_children_asManyAsParents nX is =
again again
$ monadicIO $ monadicIO
@ -168,6 +166,7 @@ bestsBy' k f =
fmap (NE.take k . fmap fst . NE.sortBy (comparing (Down . snd))) fmap (NE.take k . fmap fst . NE.sortBy (comparing (Down . snd)))
. traverse (\i -> (i,) <$> f i) . traverse (\i -> (i,) <$> f i)
prop_bestsBy_isBestsBy' :: Individual a => Int -> Population a -> Property
prop_bestsBy_isBestsBy' k pop = prop_bestsBy_isBestsBy' k pop =
k > 0 k > 0
==> monadicIO ==> monadicIO
@ -176,6 +175,7 @@ prop_bestsBy_isBestsBy' k pop =
b <- bestsBy' k fitness pop b <- bestsBy' k fitness pop
assert $ NE.toList a == b assert $ NE.toList a == b
prop_bestsBy_lengths :: Individual a => Int -> Population a -> Property
prop_bestsBy_lengths k pop = prop_bestsBy_lengths k pop =
k > 0 ==> monadicIO $ do k > 0 ==> monadicIO $ do
(bests, rest) <- bestsBy k fitness pop (bests, rest) <- bestsBy k fitness pop
@ -230,6 +230,8 @@ stepSteady select nParents nX pElite pop = do
where where
nBest = floor . (pElite *) . fromIntegral $ NE.length pop nBest = floor . (pElite *) . fromIntegral $ NE.length pop
prop_stepSteady_constantPopSize
:: (Individual a, Show a) => NonEmpty a -> Property
prop_stepSteady_constantPopSize pop = prop_stepSteady_constantPopSize pop =
forAll forAll
( (,) ( (,)
@ -300,6 +302,7 @@ selected multiple times, see 'chain').
tournament :: (Individual i, MonadRandom m) => N -> Selection m i tournament :: (Individual i, MonadRandom m) => N -> Selection m i
tournament nTrnmnt = chain (tournament1 nTrnmnt) tournament nTrnmnt = chain (tournament1 nTrnmnt)
prop_tournament_selectsN :: Individual a => Int -> Int -> NonEmpty a -> Property
prop_tournament_selectsN nTrnmnt n pop = prop_tournament_selectsN nTrnmnt n pop =
0 < nTrnmnt && nTrnmnt < length pop 0 < nTrnmnt && nTrnmnt < length pop
&& 0 < n ==> monadicIO && 0 < n ==> monadicIO
@ -322,7 +325,6 @@ tournament1 nTrnmnt pop
| otherwise = trnmnt >>= fmap (NE.head . fst) . bests 1 | otherwise = trnmnt >>= fmap (NE.head . fst) . bests 1
where where
trnmnt = withoutReplacement nTrnmnt pop trnmnt = withoutReplacement nTrnmnt pop
size = length pop
{-| {-|
Selects @n@ individuals uniformly at random from the population (without Selects @n@ individuals uniformly at random from the population (without
@ -340,6 +342,7 @@ withoutReplacement n pop
| otherwise = | otherwise =
fmap NE.fromList . sample . shuffleNofM n (length pop) $ NE.toList pop fmap NE.fromList . sample . shuffleNofM n (length pop) $ NE.toList pop
prop_withoutReplacement_selectsN :: Int -> NonEmpty a -> Property
prop_withoutReplacement_selectsN n pop = prop_withoutReplacement_selectsN n pop =
0 < n && n <= length pop ==> monadicIO $ do 0 < n && n <= length pop ==> monadicIO $ do
pop' <- lift $ withoutReplacement n pop pop' <- lift $ withoutReplacement n pop
@ -365,7 +368,7 @@ steps tEnd _ t = t >= tEnd
Shuffles a non-empty list. Shuffles a non-empty list.
-} -}
shuffle' :: (MonadRandom m) => NonEmpty a -> m (NonEmpty a) shuffle' :: (MonadRandom m) => NonEmpty a -> m (NonEmpty a)
shuffle' xs@(x :| []) = return xs shuffle' xs@(_ :| []) = return xs
shuffle' xs = do shuffle' xs = do
i <- sample . uniform 0 $ NE.length xs - 1 i <- sample . uniform 0 $ NE.length xs - 1
-- slightly unsafe (!!) used here so deletion is faster -- slightly unsafe (!!) used here so deletion is faster
@ -375,10 +378,12 @@ shuffle' xs = do
where where
deleteI i xs = fst (NE.splitAt i xs) ++ snd (NE.splitAt (i + 1) xs) 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 prop_shuffle_length xs = monadicIO $ do
xs' <- lift $ shuffle' xs xs' <- lift $ shuffle' xs
assert $ length xs' == length xs assert $ length xs' == length xs
return [] return []
runTests :: IO Bool
runTests = $quickCheckAll runTests = $quickCheckAll

View File

@ -8,13 +8,11 @@ module Seminar where
import Data.List ((!!), (\\), lookup, zipWith3) import Data.List ((!!), (\\), lookup, zipWith3)
import Data.List.Extra (nubOrd, nubOrdOn) import Data.List.Extra (nubOrd, nubOrdOn)
import Data.Random import Data.Random
import Data.Random.Distribution.Uniform
import qualified Data.Text as T import qualified Data.Text as T
import GA import GA
import Pretty import Pretty
import Protolude import Protolude
import Test.QuickCheck hiding (sample, shuffle) import Test.QuickCheck hiding (sample, shuffle)
import Test.QuickCheck.Instances
import Test.QuickCheck.Monadic (assert, monadicIO) import Test.QuickCheck.Monadic (assert, monadicIO)
instance Pretty Text where instance Pretty Text where
@ -85,11 +83,14 @@ The priority value given by a student to a topic.
prioOf :: Priorities -> Student -> Topic -> Int prioOf :: Priorities -> Student -> Topic -> Int
prioOf p s t = fromMaybe (lowestPriority p + 1) $ lookup s (unP p) >>= lookup t 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_empty = prioOf (P []) "S" "T" == 1
prop_prioOf_singletonFound :: Bool
prop_prioOf_singletonFound = prop_prioOf_singletonFound =
prioOf (P [("S", [("Existing topic", 10)])]) "S" "Existing topic" == 10 prioOf (P [("S", [("Existing topic", 10)])]) "S" "Existing topic" == 10
prop_prioOf_singletonNotFound :: Bool
prop_prioOf_singletonNotFound = prop_prioOf_singletonNotFound =
prioOf (P [("S", [("Existing topic", 10)])]) "S" "Non-existing topic" == 11 prioOf (P [("S", [("Existing topic", 10)])]) "S" "Non-existing topic" == 11
@ -105,7 +106,7 @@ data I = I Priorities Assignment
deriving (Eq, Show) deriving (Eq, Show)
instance Pretty I where instance Pretty I where
pretty i@(I p a) = pretty (I p a) =
T.unlines (gene <$> a) T.unlines (gene <$> a)
where where
gene :: (Student, Maybe Topic) -> Text 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. receiving a topic.
-} -}
prioOf' :: Priorities -> Student -> Maybe Topic -> Int 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 prioOf' p s (Just t) = prioOf p s t
instance Individual I where instance Individual I where
@ -192,15 +193,18 @@ valid p a =
studentsAssigned = fmap fst a studentsAssigned = fmap fst a
topicsAssigned = fmap snd a topicsAssigned = fmap snd a
prop_new_valid :: Priorities -> Property
prop_new_valid p = monadicIO $ do prop_new_valid p = monadicIO $ do
I _ a <- lift $ new (I p []) I _ a <- lift $ new (I p [])
assert $ valid p a assert $ valid p a
prop_mutate_valid :: Priorities -> Property
prop_mutate_valid p = monadicIO $ do prop_mutate_valid p = monadicIO $ do
a <- lift . new $ I p [] a <- lift . new $ I p []
I _ a <- lift $ mutate a I _ a <- lift $ mutate a
assert $ valid p a assert $ valid p a
prop_crossover1_valid :: Priorities -> Property
prop_crossover1_valid p = monadicIO $ do prop_crossover1_valid p = monadicIO $ do
a1 <- lift . new $ I p [] a1 <- lift . new $ I p []
a2 <- lift . new $ I p [] a2 <- lift . new $ I p []
@ -217,6 +221,7 @@ elements.
noDupsList :: (Arbitrary a, Eq a, Ord a) => Gen [a] noDupsList :: (Arbitrary a, Eq a, Ord a) => Gen [a]
noDupsList = nubOrd <$> arbitrary noDupsList = nubOrd <$> arbitrary
prop_noDupsList :: Property
prop_noDupsList = forAll (noDupsList :: Gen [Int]) unique prop_noDupsList = forAll (noDupsList :: Gen [Int]) unique
{-| {-|
@ -227,4 +232,5 @@ unique xs = length xs == (length . nubOrd) xs
return [] return []
runTests :: IO Bool
runTests = $quickCheckAll runTests = $quickCheckAll

View File

@ -9,7 +9,6 @@ module Szenario191
where where
import GA hiding (runTests) import GA hiding (runTests)
import Protolude
import Seminar hiding (runTests) import Seminar hiding (runTests)
prios :: Priorities prios :: Priorities