QuickCheck.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module UnitTests.Distribution.Solver.Modular.QuickCheck (tests) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Control.Arrow ((&&&))
import Data.Either (lefts)
import Data.List (groupBy, isInfixOf)

import Text.Show.Pretty (parseValue, valToStr)

import Test.QuickCheck (Arbitrary (..), Blind (..), Gen, Positive (..), counterexample, elements, frequency, listOf, oneof, shrinkList, shrinkNothing, shuffle, sublistOf, vectorOf, (===), (==>))
import Test.QuickCheck.Instances.Cabal ()
import Test.Tasty (TestTree)

import Distribution.Types.Flag (FlagName)
import Distribution.Utils.ShortText (ShortText, fromShortText)

import Distribution.Client.Setup (defaultMaxBackjumps)

import Distribution.Types.LibraryVisibility
import Distribution.Types.PackageName
import Distribution.Types.UnqualComponentName

import Distribution.Solver.Types.ComponentDeps
  ( Component (..)
  , ComponentDep
  , ComponentDeps
  )
import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackageConstraint
import qualified Distribution.Solver.Types.PackagePath as P
import Distribution.Solver.Types.PkgConfigDb
  ( pkgConfigDbFromList
  )
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.Variable
import Distribution.Verbosity
import Distribution.Version

import UnitTests.Distribution.Solver.Modular.DSL
import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils
  ( ArbitraryOrd (..)
  , testPropertyWithSeed
  )

tests :: [TestTree]
tests =
  [ testPropertyWithSeed "solver does not throw exceptions" $
      \test goalOrder reorderGoals indepGoals prefOldest ->
        let r =
              solve
                (EnableBackjumping True)
                (FineGrainedConflicts True)
                reorderGoals
                (CountConflicts True)
                indepGoals
                prefOldest
                (getBlind <$> goalOrder)
                test
         in resultPlan r `seq` ()
  , -- This test checks that certain solver parameters do not affect the
    -- existence of a solution. It runs the solver twice, and only sets those
    -- parameters on the second run. The test also applies parameters that
    -- can affect the existence of a solution to both runs.
    testPropertyWithSeed "target and goal order do not affect solvability" $
      \test targetOrder mGoalOrder1 mGoalOrder2 indepGoals ->
        let r1 = solve' mGoalOrder1 test
            r2 = solve' mGoalOrder2 test{testTargets = targets2}
            solve' goalOrder =
              solve
                (EnableBackjumping True)
                (FineGrainedConflicts True)
                (ReorderGoals False)
                (CountConflicts True)
                indepGoals
                (PreferOldest False)
                (getBlind <$> goalOrder)
            targets = testTargets test
            targets2 = case targetOrder of
              SameOrder -> targets
              ReverseOrder -> reverse targets
         in counterexample (showResults r1 r2) $
              noneReachedBackjumpLimit [r1, r2] ==>
                isRight (resultPlan r1) === isRight (resultPlan r2)
  , testPropertyWithSeed
      "solvable without --independent-goals => solvable with --independent-goals"
      $ \test reorderGoals ->
        let r1 = solve' (IndependentGoals False) test
            r2 = solve' (IndependentGoals True) test
            solve' indep =
              solve
                (EnableBackjumping True)
                (FineGrainedConflicts True)
                reorderGoals
                (CountConflicts True)
                indep
                (PreferOldest False)
                Nothing
         in counterexample (showResults r1 r2) $
              noneReachedBackjumpLimit [r1, r2] ==>
                isRight (resultPlan r1) `implies` isRight (resultPlan r2)
  , testPropertyWithSeed "backjumping does not affect solvability" $
      \test reorderGoals indepGoals ->
        let r1 = solve' (EnableBackjumping True) test
            r2 = solve' (EnableBackjumping False) test
            solve' enableBj =
              solve
                enableBj
                (FineGrainedConflicts False)
                reorderGoals
                (CountConflicts True)
                indepGoals
                (PreferOldest False)
                Nothing
         in counterexample (showResults r1 r2) $
              noneReachedBackjumpLimit [r1, r2] ==>
                isRight (resultPlan r1) === isRight (resultPlan r2)
  , testPropertyWithSeed "fine-grained conflicts does not affect solvability" $
      \test reorderGoals indepGoals ->
        let r1 = solve' (FineGrainedConflicts True) test
            r2 = solve' (FineGrainedConflicts False) test
            solve' fineGrainedConflicts =
              solve
                (EnableBackjumping True)
                fineGrainedConflicts
                reorderGoals
                (CountConflicts True)
                indepGoals
                (PreferOldest False)
                Nothing
         in counterexample (showResults r1 r2) $
              noneReachedBackjumpLimit [r1, r2] ==>
                isRight (resultPlan r1) === isRight (resultPlan r2)
  , testPropertyWithSeed "prefer oldest does not affect solvability" $
      \test reorderGoals indepGoals ->
        let r1 = solve' (PreferOldest True) test
            r2 = solve' (PreferOldest False) test
            solve' prefOldest =
              solve
                (EnableBackjumping True)
                (FineGrainedConflicts True)
                reorderGoals
                (CountConflicts True)
                indepGoals
                prefOldest
                Nothing
         in counterexample (showResults r1 r2) $
              noneReachedBackjumpLimit [r1, r2] ==>
                isRight (resultPlan r1) === isRight (resultPlan r2)
  , -- The next two tests use --no-count-conflicts, because the goal order used
    -- with --count-conflicts depends on the total set of conflicts seen by the
    -- solver. The solver explores more of the tree and encounters more
    -- conflicts when it doesn't backjump. The different goal orders can lead to
    -- different solutions and cause the test to fail.
    -- TODO: Find a faster way to randomly sort goals, and then use a random
    -- goal order in these tests.

    testPropertyWithSeed
      "backjumping does not affect the result (with static goal order)"
      $ \test reorderGoals indepGoals ->
        let r1 = solve' (EnableBackjumping True) test
            r2 = solve' (EnableBackjumping False) test
            solve' enableBj =
              solve
                enableBj
                (FineGrainedConflicts False)
                reorderGoals
                (CountConflicts False)
                indepGoals
                (PreferOldest False)
                Nothing
         in counterexample (showResults r1 r2) $
              noneReachedBackjumpLimit [r1, r2] ==>
                resultPlan r1 === resultPlan r2
  , testPropertyWithSeed
      "fine-grained conflicts does not affect the result (with static goal order)"
      $ \test reorderGoals indepGoals ->
        let r1 = solve' (FineGrainedConflicts True) test
            r2 = solve' (FineGrainedConflicts False) test
            solve' fineGrainedConflicts =
              solve
                (EnableBackjumping True)
                fineGrainedConflicts
                reorderGoals
                (CountConflicts False)
                indepGoals
                (PreferOldest False)
                Nothing
         in counterexample (showResults r1 r2) $
              noneReachedBackjumpLimit [r1, r2] ==>
                resultPlan r1 === resultPlan r2
  ]
  where
    noneReachedBackjumpLimit :: [Result] -> Bool
    noneReachedBackjumpLimit =
      not . any (\r -> resultPlan r == Left BackjumpLimitReached)

    showResults :: Result -> Result -> String
    showResults r1 r2 = showResult 1 r1 ++ showResult 2 r2

    showResult :: Int -> Result -> String
    showResult n result =
      unlines $
        ["", "Run " ++ show n ++ ":"]
          ++ resultLog result
          ++ ["result: " ++ show (resultPlan result)]

    implies :: Bool -> Bool -> Bool
    implies x y = not x || y

    isRight :: Either a b -> Bool
    isRight (Right _) = True
    isRight _ = False

newtype VarOrdering = VarOrdering
  { unVarOrdering :: Variable P.QPN -> Variable P.QPN -> Ordering
  }

instance Arbitrary VarOrdering where
  arbitrary = VarOrdering <$> arbitraryCompare

solve
  :: EnableBackjumping
  -> FineGrainedConflicts
  -> ReorderGoals
  -> CountConflicts
  -> IndependentGoals
  -> PreferOldest
  -> Maybe VarOrdering
  -> SolverTest
  -> Result
solve enableBj fineGrainedConflicts reorder countConflicts indep prefOldest goalOrder test =
  let (lg, result) =
        runProgress $
          exResolve
            (unTestDb (testDb test))
            Nothing
            Nothing
            (Just $ pkgConfigDbFromList [])
            (map unPN (testTargets test))
            -- The backjump limit prevents individual tests from using
            -- too much time and memory.
            (Just defaultMaxBackjumps)
            countConflicts
            fineGrainedConflicts
            (MinimizeConflictSet False)
            indep
            prefOldest
            reorder
            (AllowBootLibInstalls False)
            OnlyConstrainedNone
            enableBj
            (SolveExecutables True)
            (unVarOrdering <$> goalOrder)
            (testConstraints test)
            (testPreferences test)
            normal
            (EnableAllTests False)

      failure :: String -> Failure
      failure msg
        | "Backjump limit reached" `isInfixOf` msg = BackjumpLimitReached
        | otherwise = OtherFailure
   in Result
        { resultLog = lg
        , resultPlan =
            -- Force the result so that we check for internal errors when we check
            -- for success or failure. See D.C.Dependency.validateSolverResult.
            force $ either (Left . failure) (Right . extractInstallPlan) result
        }

-- | How to modify the order of the input targets.
data TargetOrder = SameOrder | ReverseOrder
  deriving (Show)

instance Arbitrary TargetOrder where
  arbitrary = elements [SameOrder, ReverseOrder]

  shrink SameOrder = []
  shrink ReverseOrder = [SameOrder]

data Result = Result
  { resultLog :: [String]
  , resultPlan :: Either Failure [(ExamplePkgName, ExamplePkgVersion)]
  }

data Failure = BackjumpLimitReached | OtherFailure
  deriving (Eq, Generic, Show)

instance NFData Failure

-- | Package name.
newtype PN = PN {unPN :: String}
  deriving (Eq, Ord, Show)

instance Arbitrary PN where
  arbitrary = PN <$> elements ("base" : [[pn] | pn <- ['A' .. 'G']])

-- | Package version.
newtype PV = PV {unPV :: Int}
  deriving (Eq, Ord, Show)

instance Arbitrary PV where
  arbitrary = PV <$> elements [1 .. 10]

type TestPackage = Either ExampleInstalled ExampleAvailable

getName :: TestPackage -> PN
getName = PN . either exInstName exAvName

getVersion :: TestPackage -> PV
getVersion = PV . either exInstVersion exAvVersion

data SolverTest = SolverTest
  { testDb :: TestDb
  , testTargets :: [PN]
  , testConstraints :: [ExConstraint]
  , testPreferences :: [ExPreference]
  }

-- | Pretty-print the test when quickcheck calls 'show'.
instance Show SolverTest where
  show test =
    let str =
          "SolverTest {testDb = "
            ++ show (testDb test)
            ++ ", testTargets = "
            ++ show (testTargets test)
            ++ ", testConstraints = "
            ++ show (testConstraints test)
            ++ ", testPreferences = "
            ++ show (testPreferences test)
            ++ "}"
     in maybe str valToStr $ parseValue str

instance Arbitrary SolverTest where
  arbitrary = do
    db <- arbitrary
    let pkgVersions = nub $ map (getName &&& getVersion) (unTestDb db)
        pkgs = nub $ map fst pkgVersions
    Positive n <- arbitrary
    targets <- randomSubset n pkgs
    constraints <- case pkgVersions of
      [] -> return []
      _ -> boundedListOf 1 $ arbitraryConstraint pkgVersions
    prefs <- case pkgVersions of
      [] -> return []
      _ -> boundedListOf 3 $ arbitraryPreference pkgVersions
    return (SolverTest db targets constraints prefs)

  shrink test =
    [test{testDb = db} | db <- shrink (testDb test)]
      ++ [test{testTargets = targets} | targets <- shrink (testTargets test)]
      ++ [test{testConstraints = cs} | cs <- shrink (testConstraints test)]
      ++ [test{testPreferences = prefs} | prefs <- shrink (testPreferences test)]

-- | Collection of source and installed packages.
newtype TestDb = TestDb {unTestDb :: ExampleDb}
  deriving (Show)

instance Arbitrary TestDb where
  arbitrary = do
    -- Avoid cyclic dependencies by grouping packages by name and only
    -- allowing each package to depend on packages in the groups before it.
    groupedPkgs <-
      shuffle . groupBy ((==) `on` fst) . nub . sort
        =<< boundedListOf 10 arbitrary
    db <- foldM nextPkgs (TestDb []) groupedPkgs
    TestDb <$> shuffle (unTestDb db)
    where
      nextPkgs :: TestDb -> [(PN, PV)] -> Gen TestDb
      nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> traverse (nextPkg db) pkgs

      nextPkg :: TestDb -> (PN, PV) -> Gen TestPackage
      nextPkg db (pn, v) = do
        installed <- arbitrary
        if installed
          then Left <$> arbitraryExInst pn v (lefts $ unTestDb db)
          else Right <$> arbitraryExAv pn v db

  shrink (TestDb pkgs) = map TestDb $ shrink pkgs

arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable
arbitraryExAv pn v db =
  (\cds -> ExAv (unPN pn) (unPV v) cds []) <$> arbitraryComponentDeps pn db

arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled
arbitraryExInst pn v pkgs = do
  pkgHash <- vectorOf 10 $ elements $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9']
  numDeps <- min 3 <$> arbitrary
  deps <- randomSubset numDeps pkgs
  return $ ExInst (unPN pn) (unPV v) pkgHash (map exInstHash deps)

arbitraryComponentDeps :: PN -> TestDb -> Gen (ComponentDeps Dependencies)
arbitraryComponentDeps _ (TestDb []) = return $ CD.fromLibraryDeps (dependencies [])
arbitraryComponentDeps pn db = do
  -- dedupComponentNames removes components with duplicate names, for example,
  -- 'ComponentExe x' and 'ComponentTest x', and then CD.fromList combines
  -- duplicate unnamed components.
  cds <-
    CD.fromList . dedupComponentNames . filter (isValid . fst)
      <$> boundedListOf 5 (arbitraryComponentDep db)
  return $
    if isCompleteComponentDeps cds
      then cds
      else -- Add a library if the ComponentDeps isn't complete.
        CD.fromLibraryDeps (dependencies []) <> cds
  where
    isValid :: Component -> Bool
    isValid (ComponentSubLib name) = name /= mkUnqualComponentName (unPN pn)
    isValid _ = True

    dedupComponentNames =
      nubBy ((\x y -> isJust x && isJust y && x == y) `on` componentName . fst)

    componentName :: Component -> Maybe UnqualComponentName
    componentName ComponentLib = Nothing
    componentName ComponentSetup = Nothing
    componentName (ComponentSubLib n) = Just n
    componentName (ComponentFLib n) = Just n
    componentName (ComponentExe n) = Just n
    componentName (ComponentTest n) = Just n
    componentName (ComponentBench n) = Just n

-- | Returns true if the ComponentDeps forms a complete package, i.e., it
-- contains a library, exe, test, or benchmark.
isCompleteComponentDeps :: ComponentDeps a -> Bool
isCompleteComponentDeps = any (completesPkg . fst) . CD.toList
  where
    completesPkg ComponentLib = True
    completesPkg (ComponentExe _) = True
    completesPkg (ComponentTest _) = True
    completesPkg (ComponentBench _) = True
    completesPkg (ComponentSubLib _) = False
    completesPkg (ComponentFLib _) = False
    completesPkg ComponentSetup = False

arbitraryComponentDep :: TestDb -> Gen (ComponentDep Dependencies)
arbitraryComponentDep db = do
  comp <- arbitrary
  deps <- case comp of
    ComponentSetup -> smallListOf (arbitraryExDep db SetupDep)
    _ -> boundedListOf 5 (arbitraryExDep db NonSetupDep)
  return
    ( comp
    , Dependencies
        { depsExampleDependencies = deps
        , -- TODO: Test different values for visibility and buildability.
          depsVisibility = LibraryVisibilityPublic
        , depsIsBuildable = True
        }
    )

-- | Location of an 'ExampleDependency'. It determines which values are valid.
data ExDepLocation = SetupDep | NonSetupDep

arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency
arbitraryExDep db@(TestDb pkgs) level =
  let flag =
        ExFlagged
          <$> arbitraryFlagName
          <*> arbitraryDeps db
          <*> arbitraryDeps db
      other =
        -- Package checks require dependencies on "base" to have bounds.
        let notBase = filter ((/= PN "base") . getName) pkgs
         in [ExAny . unPN <$> elements (map getName notBase) | not (null notBase)]
              ++ [
                   -- existing version
                   let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg)
                    in fixed <$> elements pkgs
                 , -- random version of an existing package
                   ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary)
                 ]
   in oneof $
        case level of
          NonSetupDep -> flag : other
          SetupDep -> other

arbitraryDeps :: TestDb -> Gen Dependencies
arbitraryDeps db =
  frequency
    [ (1, return unbuildableDependencies)
    , (20, dependencies <$> smallListOf (arbitraryExDep db NonSetupDep))
    ]

arbitraryFlagName :: Gen String
arbitraryFlagName = (: []) <$> elements ['A' .. 'E']

arbitraryConstraint :: [(PN, PV)] -> Gen ExConstraint
arbitraryConstraint pkgs = do
  (PN pn, v) <- elements pkgs
  let anyQualifier = ScopeAnyQualifier (mkPackageName pn)
  oneof
    [ ExVersionConstraint anyQualifier <$> arbitraryVersionRange v
    , ExStanzaConstraint anyQualifier <$> sublistOf [TestStanzas, BenchStanzas]
    ]

arbitraryPreference :: [(PN, PV)] -> Gen ExPreference
arbitraryPreference pkgs = do
  (PN pn, v) <- elements pkgs
  oneof
    [ ExStanzaPref pn <$> sublistOf [TestStanzas, BenchStanzas]
    , ExPkgPref pn <$> arbitraryVersionRange v
    ]

arbitraryVersionRange :: PV -> Gen VersionRange
arbitraryVersionRange (PV v) =
  let version = mkSimpleVersion v
   in elements
        [ thisVersion version
        , notThisVersion version
        , earlierVersion version
        , orLaterVersion version
        , noVersion
        ]

instance Arbitrary ReorderGoals where
  arbitrary = ReorderGoals <$> arbitrary

  shrink (ReorderGoals reorder) = [ReorderGoals False | reorder]

instance Arbitrary IndependentGoals where
  arbitrary = IndependentGoals <$> arbitrary

  shrink (IndependentGoals indep) = [IndependentGoals False | indep]

instance Arbitrary PreferOldest where
  arbitrary = PreferOldest <$> arbitrary

  shrink (PreferOldest prefOldest) = [PreferOldest False | prefOldest]

instance Arbitrary Component where
  arbitrary =
    oneof
      [ return ComponentLib
      , ComponentSubLib <$> arbitraryUQN
      , ComponentExe <$> arbitraryUQN
      , ComponentFLib <$> arbitraryUQN
      , ComponentTest <$> arbitraryUQN
      , ComponentBench <$> arbitraryUQN
      , return ComponentSetup
      ]

  shrink ComponentLib = []
  shrink _ = [ComponentLib]

-- The "component-" prefix prevents component names and build-depends
-- dependency names from overlapping.
-- TODO: Remove the prefix once the QuickCheck tests support dependencies on
-- internal libraries.
arbitraryUQN :: Gen UnqualComponentName
arbitraryUQN =
  mkUnqualComponentName <$> (\c -> "component-" ++ [c]) <$> elements "ABC"

instance Arbitrary ExampleInstalled where
  arbitrary = error "arbitrary not implemented: ExampleInstalled"

  shrink ei =
    [ ei{exInstBuildAgainst = deps}
    | deps <- shrinkList shrinkNothing (exInstBuildAgainst ei)
    ]

instance Arbitrary ExampleAvailable where
  arbitrary = error "arbitrary not implemented: ExampleAvailable"

  shrink ea = [ea{exAvDeps = deps} | deps <- shrink (exAvDeps ea)]

instance (Arbitrary a, Monoid a) => Arbitrary (ComponentDeps a) where
  arbitrary = error "arbitrary not implemented: ComponentDeps"

  shrink = filter isCompleteComponentDeps . map CD.fromList . shrink . CD.toList

instance Arbitrary ExampleDependency where
  arbitrary = error "arbitrary not implemented: ExampleDependency"

  shrink (ExAny _) = []
  shrink (ExFix "base" _) = [] -- preserve bounds on base
  shrink (ExFix pn _) = [ExAny pn]
  shrink (ExFlagged flag th el) =
    depsExampleDependencies th
      ++ depsExampleDependencies el
      ++ [ExFlagged flag th' el | th' <- shrink th]
      ++ [ExFlagged flag th el' | el' <- shrink el]
  shrink dep = error $ "Dependency not handled: " ++ show dep

instance Arbitrary Dependencies where
  arbitrary = error "arbitrary not implemented: Dependencies"

  shrink deps =
    [deps{depsVisibility = v} | v <- shrink $ depsVisibility deps]
      ++ [deps{depsIsBuildable = b} | b <- shrink $ depsIsBuildable deps]
      ++ [deps{depsExampleDependencies = ds} | ds <- shrink $ depsExampleDependencies deps]

instance Arbitrary ExConstraint where
  arbitrary = error "arbitrary not implemented: ExConstraint"

  shrink (ExStanzaConstraint scope stanzas) =
    [ExStanzaConstraint scope stanzas' | stanzas' <- shrink stanzas]
  shrink (ExVersionConstraint scope vr) =
    [ExVersionConstraint scope vr' | vr' <- shrink vr]
  shrink _ = []

instance Arbitrary ExPreference where
  arbitrary = error "arbitrary not implemented: ExPreference"

  shrink (ExStanzaPref pn stanzas) =
    [ExStanzaPref pn stanzas' | stanzas' <- shrink stanzas]
  shrink (ExPkgPref pn vr) = [ExPkgPref pn vr' | vr' <- shrink vr]

instance Arbitrary OptionalStanza where
  arbitrary = error "arbitrary not implemented: OptionalStanza"

  shrink BenchStanzas = [TestStanzas]
  shrink TestStanzas = []

instance ArbitraryOrd pn => ArbitraryOrd (Variable pn)
instance ArbitraryOrd a => ArbitraryOrd (P.Qualified a)
instance ArbitraryOrd P.PackagePath
instance ArbitraryOrd P.Qualifier
instance ArbitraryOrd P.Namespace
instance ArbitraryOrd OptionalStanza
instance ArbitraryOrd FlagName
instance ArbitraryOrd PackageName
instance ArbitraryOrd ShortText where
  arbitraryCompare = do
    strc <- arbitraryCompare
    pure $ \l r -> strc (fromShortText l) (fromShortText r)

deriving instance Generic (Variable pn)
deriving instance Generic (P.Qualified a)
deriving instance Generic P.PackagePath
deriving instance Generic P.Namespace
deriving instance Generic P.Qualifier

randomSubset :: Int -> [a] -> Gen [a]
randomSubset n xs = take n <$> shuffle xs

boundedListOf :: Int -> Gen a -> Gen [a]
boundedListOf n gen = take n <$> listOf gen

-- | Generates lists with average length less than 1.
smallListOf :: Gen a -> Gen [a]
smallListOf gen =
  frequency
    [ (fr, vectorOf n gen)
    | (fr, n) <- [(3, 0), (5, 1), (2, 2)]
    ]