content: {-# OPTIONS_GHC -fno-warn-orphans #-}
  module Rules.Selftest (selftestRules) where
  
  import Hadrian.Haskell.Cabal
  import Test.QuickCheck
  
  import Base
  import Context
  import Oracles.ModuleFiles
  import Oracles.Setting
  import Packages
  import Settings
  import Target
  import Utilities
  
  instance Arbitrary Way where
      arbitrary = wayFromUnits <$> arbitrary
  
  instance Arbitrary WayUnit where
      arbitrary = arbitraryBoundedEnum
  
  test :: Testable a => a -> Action ()
  test = liftIO . quickCheck
  
  selftestRules :: Rules ()
  selftestRules =
      "selftest" ~> do
          testBuilder
          testChunksOfSize
          testDependencies
          testLookupAll
          testModuleName
          testPackages
          testWay
  
  testBuilder :: Action ()
  testBuilder = do
      putBuild "==== trackArgument"
      let make = target undefined (Make undefined) undefined undefined
      test $ forAll (elements ["-j", "MAKEFLAGS=-j", "THREADS="])
           $ \prefix (NonNegative n) ->
              not (trackArgument make prefix) &&
              not (trackArgument make ("-j" ++ show (n :: Int)))
  
  testChunksOfSize :: Action ()
  testChunksOfSize = do
      putBuild "==== chunksOfSize"
      test $ chunksOfSize 3 [  "a", "b", "c" ,  "defg" ,  "hi" ,  "jk"  ]
                         == [ ["a", "b", "c"], ["defg"], ["hi"], ["jk"] ]
      test $ \n xs ->
          let res = chunksOfSize n xs
          in concat res == xs && all (\r -> length r == 1 || length (concat r) <= n) res
  
  testDependencies :: Action ()
  testDependencies = do
      putBuild "==== pkgDependencies"
      let pkgs = ghcPackages \\ [libffi] -- @libffi@ does not have a Cabal file.
      depLists <- mapM pkgDependencies pkgs
      test $ and [ deps == sort deps | deps <- depLists ]
      putBuild "==== Dependencies of the 'ghc-bin' binary"
      ghcDeps <- pkgDependencies ghc
      test $ pkgName compiler `elem` ghcDeps
      stage0Deps <- contextDependencies (vanillaContext Stage0 ghc)
      stage1Deps <- contextDependencies (vanillaContext Stage1 ghc)
      stage2Deps <- contextDependencies (vanillaContext Stage2 ghc)
      test $ vanillaContext Stage0 compiler `notElem` stage1Deps
      test $ vanillaContext Stage1 compiler `elem`    stage1Deps
      test $ vanillaContext Stage2 compiler `notElem` stage1Deps
      test $ stage1Deps /= stage0Deps
      test $ stage1Deps == stage2Deps
  
  testLookupAll :: Action ()
  testLookupAll = do
      putBuild "==== lookupAll"
      test $ lookupAll ["b"    , "c"            ] [("a", 1), ("c", 3), ("d", 4)]
                    == [Nothing, Just (3 :: Int)]
      test $ forAll dicts $ \dict -> forAll extras $ \extra ->
          let items = sort $ map fst dict ++ extra
          in lookupAll items (sort dict) == map (`lookup` dict) items
    where
      dicts :: Gen [(Int, Int)]
      dicts = nubBy (\x y -> fst x == fst y) <$> vector 20
      extras :: Gen [Int]
      extras = vector 20
  
  testModuleName :: Action ()
  testModuleName = do
      putBuild "==== Encode/decode module name"
      test $ encodeModule "Data/Functor" "Identity.hs" == "Data.Functor.Identity"
      test $ encodeModule "" "Prelude"                 == "Prelude"
  
      test $ decodeModule "Data.Functor.Identity" == ("Data/Functor", "Identity")
      test $ decodeModule "Prelude"               == ("", "Prelude")
  
      test $ forAll names $ \n -> uncurry encodeModule (decodeModule n) == n
    where
      names = intercalate "." <$> listOf1 (listOf1 $ elements "abcABC123_'")
  
  testPackages :: Action ()
  testPackages = do
      putBuild "==== Check system configuration"
      win <- windowsHost -- This depends on the @boot@ and @configure@ scripts.
      putBuild "==== Packages, interpretInContext, configuration flags"
      forM_ [Stage0 ..] $ \stage -> do
          pkgs <- stagePackages stage
          when (win32 `elem` pkgs) . test $ win
          when (unix  `elem` pkgs) . test $ not win
          test $ pkgs == nubOrd pkgs
  
  testWay :: Action ()
  testWay = do
      putBuild "==== Read Way, Show Way"
      test $ \(x :: Way) -> read (show x) == x
  