Commits

dave4420 committed ad9f63e

Implemented `resolvePropertyTester` properly.

Comments (0)

Files changed (1)

 
 ensureUsingQuickCheck :: Int -> G.Ghc ()
 ensureUsingQuickCheck i
-  = do  (candidates, impostors) <- partition isQuickCheck <$> getPackagesExposingModule "Test.QuickCheck"
+  = do  (candidates, impostors) <- partition (isQuickCheck i) <$> getPackagesExposingModule "Test.QuickCheck"
         dynFlags <- G.getSessionDynFlags
         G.setSessionDynFlags dynFlags {G.packageFlags = concat [exposingBest candidates,
                                                                 hidingAll impostors,
                                                                 G.packageFlags dynFlags]}
         return ()
-  where isQuickCheck (G.InstalledPackageInfo {G.sourcePackageId = packageId})
-              = pkgName packageId == PackageName "QuickCheck" && [i] `isPrefixOf` versionBranch (pkgVersion packageId)
-        hidingAll = map (G.HidePackage . nameOfPackage) . filter G.exposed
+  where hidingAll = map (G.HidePackage . nameOfPackage) . filter G.exposed
         exposingBest []         = error "Can't use QuickCheck-1 as it is not installed"
         exposingBest candidates
               = case filter G.exposed candidates of
               = intercalate "-" [n, showVersion v]
         byVersion = compare `on` pkgVersion . G.sourcePackageId
 
+isQuickCheck :: Int -> G.InstalledPackageInfo_ a -> Bool
+isQuickCheck i (G.InstalledPackageInfo {G.sourcePackageId = packageId})
+              = pkgName packageId == PackageName "QuickCheck" && [i] `isPrefixOf` versionBranch (pkgVersion packageId)
+
+resolvePropertyTester :: Maybe PropertyTester -> G.Ghc PropertyTester
+resolvePropertyTester = maybe check return
+  where check = do      (qc2s, notQc2s) <- partition (isQuickCheck 2) <$> getPackagesExposingModule "Test.QuickCheck"
+                        case (qc2s, partition (isQuickCheck 1) notQc2s) of
+                             ([], ([], _)) -> G.liftIO $ hPutStrLn stderr "Cannot find QUickCheck-2 or QuickCheck-1" >> exitWith (ExitFailure 3)
+                             ([], _)       -> return QuickCheck1
+                             _             -> return QuickCheck2
+
 
 runGhc :: Flags -> G.Ghc a -> IO a
 runGhc flags act = G.runGhc (Just G.libdir) (G.defaultErrorHandler G.defaultDynFlags $ init >> act)
                                 covert a
                                 return a
 
-resolvePropertyTester :: Maybe PropertyTester -> G.Ghc PropertyTester
-resolvePropertyTester = maybe (return QuickCheck1) return
-