content: module TestSuite.Tests.Compilation (testGroupCompilation) where
  
  import Control.Monad
  import Data.IORef
  import Data.Monoid
  import System.Exit
  import System.FilePath
  import System.Process
  import Test.HUnit
  import Test.Tasty
  import qualified Data.ByteString.Lazy.UTF8  as L
  import qualified Data.ByteString.Lazy.Char8 as L (unlines)
  import qualified Data.Text                  as T
  
  import IdeSession
  import TestSuite.State
  import TestSuite.Session
  import TestSuite.Assertions
  
  testGroupCompilation :: TestSuiteEnv -> TestTree
  testGroupCompilation env = testGroup "Compilation" [
      stdTest env "Compile a project: A depends on B, error in A"                                         test_AdependsB_errorA
    , stdTest env "Compile a project: A depends on B, error in B"                                         test_AdependsB_errorB
    , stdTest env "Compile and run a project with some .lhs files"                                        test_lhs
    , stdTest env "Test recursive modules"                                                                test_recursiveModules
    , stdTest env "Test recursive modules with dynamic include path change"                               test_dynamicIncludePathChange
    , stdTest env "Test CPP: ifdefed module header"                                                       test_CPP_ifdefModuleHeader
    , stdTest env "Reject a wrong CPP directive"                                                          test_rejectWrongCPP
    , stdTest env "Reject a program requiring -XNamedFieldPuns, then set the option"                      test_NamedFieldPuns
    , stdTest env "Don't recompile unnecessarily (single module)"                                         test_DontRecompile_SingleModule
    , stdTest env "Don't recompile unnecessarily (A depends on B)"                                        test_DontRecompile_Depends
    , stdTest env "Support for hs-boot files (#155)"                                                      test_HsBoot
    , stdTest env "Support for lhs-boot files (#155)"                                                     test_LhsBoot
    , stdTest env "Support for hs-boot files from a subdirectory (#177)"                                  test_HsBoot_SubDir
    , stdTest env "Support for hs-boot files from a subdirectory (#177) with dynamic include path change" test_HsBoot_SubDir_InclPathChange
    , stdTest env "Relative include paths (#156)"                                                         test_RelInclPath
    , stdTest env "Relative include paths (#156) with dynamic include path change"                        test_RelInclPath_InclPathChange
    , stdTest env "Parse ghc 'Compiling' messages"                                                        test_ParseCompiling
    , stdTest env "Parse ghc 'Compiling' messages (with TH)"                                              test_ParseCompiling_TH
    , stdTest env "Reject a module with mangled header"                                                   test_RejectMangledHeader
    ]
  
  test_AdependsB_errorA :: TestSuiteEnv -> Assertion
  test_AdependsB_errorA env = withAvailableSession env $ \session -> do
      loadModulesFrom session "TestSuite/inputs/AerrorB"
      assertSourceErrors session [[(Just "A.hs", "No instance for (Num (IO ()))")]]
  
  test_AdependsB_errorB :: TestSuiteEnv -> Assertion
  test_AdependsB_errorB env = withAvailableSession env $ \session -> do
      loadModulesFrom session "TestSuite/inputs/ABerror"
      assertSourceErrors session [[(Just "B.hs", "No instance for (Num (IO ()))")]]
  
  test_lhs :: TestSuiteEnv -> Assertion
  test_lhs env = withAvailableSession env $ \session -> do
      loadModulesFrom session "TestSuite/inputs/compiler/utils"
      assertNoErrors session
      let update2 = updateCodeGeneration True
      updateSessionD session update2 4
      assertNoErrors session
      runActions <- runStmt session "Maybes" "main"
      (output, result) <- runWaitAll runActions
      assertEqual "" RunOk result
      assertEqual "" output "False\n"
  
  test_recursiveModules :: TestSuiteEnv -> Assertion
  test_recursiveModules env = withAvailableSession' env (withIncludes ["TestSuite/inputs/bootMods"]) $ \session -> do
      loadModulesFrom session "TestSuite/inputs/bootMods"
      assertNoErrors session
  
      ifTestingExe env $ do
         let m = "Main"
             upd = buildExe [] [(T.pack m, "C" <.> "hs")]
         updateSessionD session upd 7
         distDir <- getDistDir session
         buildStderr <- readFile $ distDir </> "build/ide-backend-exe.stderr"
         assertEqual "buildStderr empty" "" buildStderr
         status <- getBuildExeStatus session
         assertEqual "after exe build" (Just ExitSuccess) status
         out <- readProcess (distDir </> "build" </> m </> m) [] []
         assertEqual "" "C\n" out
         runActionsExe <- runExe session m
         (outExe, statusExe) <- runWaitAll runActionsExe
         assertEqual "Output from runExe"
                     "C\n"
                     outExe
         assertEqual "after runExe" ExitSuccess statusExe
  
  test_dynamicIncludePathChange :: TestSuiteEnv -> Assertion
  test_dynamicIncludePathChange env = withAvailableSession env $ \session -> do
      loadModulesFrom session "TestSuite/inputs/bootMods"
      assertOneError session
  
      updateSessionD session
                     (updateRelativeIncludes ["TestSuite/inputs/bootMods"])
                     4
      assertNoErrors session
  
      ifTestingExe env $ do
         let m = "Main"
             upd = buildExe [] [(T.pack m, "C" <.> "hs")]
         updateSessionD session upd 7
         distDir <- getDistDir session
         buildStderr <- readFile $ distDir </> "build/ide-backend-exe.stderr"
         assertEqual "buildStderr empty" "" buildStderr
         status <- getBuildExeStatus session
         assertEqual "after exe build" (Just ExitSuccess) status
         out <- readProcess (distDir </> "build" </> m </> m) [] []
         assertEqual "" "C\n" out
         runActionsExe <- runExe session m
         (outExe, statusExe) <- runWaitAll runActionsExe
         assertEqual "Output from runExe"
                     "C\n"
                     outExe
         assertEqual "after runExe" ExitSuccess statusExe
  
  test_CPP_ifdefModuleHeader :: TestSuiteEnv -> Assertion
  test_CPP_ifdefModuleHeader env = withAvailableSession' env (withGhcOpts ["-XCPP"]) $ \session -> do
      updateSessionD session update 1
      assertNoErrors session
      assertIdInfo session "Good" (8,1,8,2) "x" VarName "[a]" "main:Good" "Good.hs@8:1-8:2" "" "binding occurrence"
    where
      update = updateSourceFile "Good.hs" $ L.unlines
        [ "#if __GLASGOW_HASKELL__ < 600"
        , "module Bad where"
        , "import Data.List"
        , "#else"
        , "module Good where"
        , "import Data.Monoid"
        , "#endif"
        , "x = mappend [] []"
        ]
  
  test_rejectWrongCPP :: TestSuiteEnv -> Assertion
  test_rejectWrongCPP env = withAvailableSession' env (withGhcOpts ["-XCPP"]) $ \session -> do
      updateSessionD session update 1
      -- Due to a GHC bug there are now 2 errors. TODO; when it's fixed,
      -- assert a single specific error here.
      assertSomeErrors session
      assertRaises "runStmt session Main main"
        (== userError "Module \"Main\" not successfully loaded, when trying to run code.")
        (runStmt session "Main" "main")
    where
      update = loadModule "M.hs" "#ifdef"
            <> updateCodeGeneration True
  
  
  test_NamedFieldPuns :: TestSuiteEnv -> Assertion
  test_NamedFieldPuns env = withAvailableSession' env (withGhcOpts ["-hide-package monads-tf"]) $ \session -> do
      withCurrentDirectory "TestSuite/inputs/Puns" $ do
        loadModulesFrom session "."
        assertMoreErrors session
        let punOpts = ["-XNamedFieldPuns", "-XRecordWildCards"]
            update2 = updateGhcOpts punOpts
        (_, lm) <- getModules session
        updateSessionD session update2 (length lm)
      assertNoErrors session
  
      ifTestingExe env $ do
         let m = "GHC.RTS.Events"
             upd2 = buildExe [] [(T.pack m, "GHC/RTS/Events.hs")]
         updateSessionD session upd2 4
         distDir <- getDistDir session
         buildStderr <- readFile $ distDir </> "build/ide-backend-exe.stderr"
         assertEqual "buildStderr empty" "" buildStderr
  
  test_DontRecompile_SingleModule :: TestSuiteEnv -> Assertion
  test_DontRecompile_SingleModule env = withAvailableSession env $ \session -> do
      updateAndExpectProgressCount session upd 1
      updateAndExpectProgressCount session upd 0
    where
      upd = (updateCodeGeneration True)
         <> (updateSourceFile "A.hs" . L.unlines $
              [ "module A where"
              , "a :: IO ()"
              , "a = print 'a'"
              ])
  
  test_DontRecompile_Depends :: TestSuiteEnv -> Assertion
  test_DontRecompile_Depends env = withAvailableSession env $ \session -> do
      -- Initial compilation needs to recompile for A and B
      updateAndExpectProgressCount session upd 2
      -- Overwriting B with the same code requires no compilation at all
      updateAndExpectProgressCount session (updB 0) 0
      -- Nor does overwriting A with the same code
      updateAndExpectProgressCount session (updA 0) 0
      -- Giving B a new interface means both A and B need to be recompiled
      updateAndExpectProgressCount session (updB 1) 2
      -- Changing the interface of A only requires recompilation of A
      updateAndExpectProgressCount session (updA 1) 1
    where
      -- 'updA' is defined so that the interface of 'updA n' is different
      -- to the interface of 'updA m' (with n /= m)
      updA n = updateSourceFile "A.hs" . L.unlines $
                 [ "module A where"
                 , "import B"
                 ]
                ++
                 [ L.fromString $ "a" ++ show i ++ " = b" ++ show i
                 | i <- [0 .. n :: Int]
                 ]
      updB n = updateSourceFile "B.hs" . L.unlines $
                 [ "module B where"
                 ]
                ++
                 [ L.fromString $ "b" ++ show i ++ " = return () :: IO ()"
                 | i <- [0 .. n :: Int]
                 ]
      upd = updateCodeGeneration True <> updA 0 <> updB 0
  
  test_HsBoot :: TestSuiteEnv -> Assertion
  test_HsBoot env = withAvailableSession env $ \session -> do
      updateSessionD session upd 3
      assertNoErrors session
  
      ifTestingExe env $ do
         let m = "A"
             updE = buildExe ["-rtsopts", "-O1"] [(T.pack m, m <.> "hs")]
         updateSessionD session updE 4
         distDir <- getDistDir session
         buildStderr <- readFile $ distDir </> "build/ide-backend-exe.stderr"
         assertEqual "buildStderr empty" "" buildStderr
         status <- getBuildExeStatus session
         assertEqual "after exe build" (Just ExitSuccess) status
         out <- readProcess (distDir </> "build" </> m </> m)
                            ["+RTS", "-C0.005", "-RTS"] []
         assertEqual "" "[1,1,2,3,5,8,13,21,34,55]\n" out
         runActionsExe <- runExe session m
         (outExe, statusExe) <- runWaitAll runActionsExe
         assertEqual "Output from runExe"
                     "[1,1,2,3,5,8,13,21,34,55]\n"
                     outExe
         assertEqual "after runExe" ExitSuccess statusExe
    where
      upd = (updateCodeGeneration True)
         <> (updateSourceFile "A.hs" $ L.unlines [
                "module A where"
  
              , "import {-# SOURCE #-} B"
  
              , "f :: Int -> Int"
              , "f 0 = 1"
              , "f 1 = 1"
              , "f n = g (n - 1) + g (n - 2)"
  
              , "main :: IO ()"
              , "main = print $ map f [0..9]"
              ])
         <> (updateSourceFile "B.hs" $ L.unlines [
                "module B where"
  
              , "import A"
  
              , "g :: Int -> Int"
              , "g = f"
              ])
         <> (updateSourceFile "B.hs-boot" $ L.unlines [
                "module B where"
  
              , "g :: Int -> Int"
              ])
  
  test_LhsBoot :: TestSuiteEnv -> Assertion
  test_LhsBoot env = withAvailableSession env $ \session -> do
      updateSessionD session upd 3
      assertNoErrors session
  
      ifTestingExe env $ do
          let m = "A"
              updE = buildExe [] [(T.pack m, m <.> "lhs")]
          updateSessionD session updE 5 -- TODO: Main may be compiled twice (#189)
          distDir <- getDistDir session
          buildStderr <- readFile $ distDir </> "build/ide-backend-exe.stderr"
          assertEqual "buildStderr empty" "" buildStderr
          status <- getBuildExeStatus session
          assertEqual "after exe build" (Just ExitSuccess) status
          out <- readProcess (distDir </> "build" </> m </> m) [] []
          assertEqual "" "[1,1,2,3,5,8,13,21,34,55]\n" out
          runActionsExe <- runExe session m
          (outExe, statusExe) <- runWaitAll runActionsExe
          assertEqual "Output from runExe"
                      "[1,1,2,3,5,8,13,21,34,55]\n"
                      outExe
          assertEqual "after runExe" ExitSuccess statusExe
    where
      upd = (updateCodeGeneration True)
         <> (updateSourceFile "A.lhs" $ L.unlines [
                "> module A where"
  
              , "> import {-# SOURCE #-} B"
  
              , "> f :: Int -> Int"
              , "> f 0 = 1"
              , "> f 1 = 1"
              , "> f n = g (n - 1) + g (n - 2)"
  
              , "> main :: IO ()"
              , "> main = print $ map f [0..9]"
              ])
         <> (updateSourceFile "B.lhs" $ L.unlines [
                "> module B where"
  
              , "> import A"
  
              , "> g :: Int -> Int"
              , "> g = f"
              ])
         <> (updateSourceFile "B.lhs-boot" $ L.unlines [
                "> module B where"
  
              , "> g :: Int -> Int"
              ])
  
  test_HsBoot_SubDir :: TestSuiteEnv -> Assertion
  test_HsBoot_SubDir env = withAvailableSession' env (withIncludes ["src"]) $ \session -> do
      updateSessionD session update 3
      assertNoErrors session
  
      ifTestingExe env $ do
         let m = "B"
             updE = buildExe [] [(T.pack m, m <.> "hs")]
         updateSessionD session updE 4
         distDir <- getDistDir session
         buildStderr <- readFile $ distDir </> "build/ide-backend-exe.stderr"
         assertEqual "buildStderr empty" "" buildStderr
         status <- getBuildExeStatus session
         assertEqual "after exe build" (Just ExitSuccess) status
         out <- readProcess (distDir </> "build" </> m </> m) [] []
         assertEqual "" "42\n" out
         runActionsExe <- runExe session m
         (outExe, statusExe) <- runWaitAll runActionsExe
         assertEqual "Output from runExe"
                     "42\n"
                     outExe
         assertEqual "after runExe" ExitSuccess statusExe
    where
      ahs     = "module A where\nimport B( TB(..) )\nnewtype TA = MkTA Int\nf :: TB -> TA\nf (MkTB x) = MkTA x"
      ahsboot = "module A where\nnewtype TA = MkTA Int"
      bhs     = "module B where\nimport {-# SOURCE #-} A( TA(..) )\ndata TB = MkTB !Int\ng :: TA -> TB\ng (MkTA x) = MkTB x\nmain = print 42"
  
      update = updateSourceFile "src/A.hs" ahs
            <> updateSourceFile "src/A.hs-boot" ahsboot
            <> updateSourceFile "src/B.hs" bhs
            <> updateCodeGeneration True
  
  test_HsBoot_SubDir_InclPathChange :: TestSuiteEnv -> Assertion
  test_HsBoot_SubDir_InclPathChange env = withAvailableSession env $ \session -> do
      updateSessionD session update 3
      assertOneError session
  
      updateSessionD session
                     (updateRelativeIncludes ["src"])
                     3
      assertNoErrors session
  
      ifTestingExe env $ do
         let m = "B"
             updE = buildExe [] [(T.pack m, m <.> "hs")]
         updateSessionD session updE 4
         distDir <- getDistDir session
         buildStderr <- readFile $ distDir </> "build/ide-backend-exe.stderr"
         assertEqual "buildStderr empty" "" buildStderr
         status <- getBuildExeStatus session
         assertEqual "after exe build" (Just ExitSuccess) status
         out <- readProcess (distDir </> "build" </> m </> m) [] []
         assertEqual "" "42\n" out
         runActionsExe <- runExe session m
         (outExe, statusExe) <- runWaitAll runActionsExe
         assertEqual "Output from runExe"
                     "42\n"
                     outExe
         assertEqual "after runExe" ExitSuccess statusExe
    where
      ahs     = "module A where\nimport B( TB(..) )\nnewtype TA = MkTA Int\nf :: TB -> TA\nf (MkTB x) = MkTA x"
      ahsboot = "module A where\nnewtype TA = MkTA Int"
      bhs     = "module B where\nimport {-# SOURCE #-} A( TA(..) )\ndata TB = MkTB !Int\ng :: TA -> TB\ng (MkTA x) = MkTB x\nmain = print 42"
  
      update = updateSourceFile "src/A.hs" ahs
            <> updateSourceFile "src/A.hs-boot" ahsboot
            <> updateSourceFile "src/B.hs" bhs
            <> updateCodeGeneration True
  
  test_RelInclPath :: TestSuiteEnv -> Assertion
  test_RelInclPath env = withAvailableSession' env (withIncludes ["TestSuite/inputs/ABnoError"]) $ \session -> do
      -- Since we set the target explicitly, ghc will need to be able to find
      -- the other module (B) on its own; that means it will need an include
      -- path to <ideSourcesDir>/TestSuite/inputs/ABnoError
      loadModulesFrom' session "TestSuite/inputs/ABnoError" (TargetsInclude ["TestSuite/inputs/ABnoError/A.hs"])
      assertNoErrors session
  
      ifTestingExe env $ do
         let updE = buildExe [] [(T.pack "Main", "TestSuite/inputs/ABnoError/A.hs")]
         updateSessionD session updE 3
         status <- getBuildExeStatus session
         assertEqual "after exe build" (Just ExitSuccess) status
  
         let updE2 = buildExe [] [(T.pack "Main", "A.hs")]
         updateSessionD session updE2 0
         status2 <- getBuildExeStatus session
         assertEqual "after exe build" (Just ExitSuccess) status2
  
  test_RelInclPath_InclPathChange :: TestSuiteEnv -> Assertion
  test_RelInclPath_InclPathChange env = withAvailableSession env $ \session -> do
      -- Since we set the target explicitly, ghc will need to be able to find
      -- the other module (B) on its own; that means it will need an include
      -- path to <ideSourcesDir>/TestSuite/inputs/ABnoError
      loadModulesFrom' session "TestSuite/inputs/ABnoError" (TargetsInclude ["TestSuite/inputs/ABnoError/A.hs"])
      assertOneError session
  
      updateSessionD session
                     (updateRelativeIncludes ["TestSuite/inputs/ABnoError"])
                     2  -- note the recompilation
      assertNoErrors session
  
      ifTestingExe env $ do
         let updE = buildExe [] [(T.pack "Main", "TestSuite/inputs/ABnoError/A.hs")]
         updateSessionD session updE 1
         status <- getBuildExeStatus session
         -- Path "" no longer in include paths here!
         assertEqual "after exe build" (Just $ ExitFailure 1) status
  
         let updE2 = buildExe [] [(T.pack "Main", "A.hs")]
         updateSessionD session updE2 2
         status2 <- getBuildExeStatus session
         assertEqual "after exe build" (Just ExitSuccess) status2
  
  test_ParseCompiling :: TestSuiteEnv -> Assertion
  test_ParseCompiling env = withAvailableSession env $ \session -> do
      progressUpdates <- updateAndCollectProgress session upd
      assertNoErrors session
      assertEqual "" [(1, 2, Just "Compiling A"), (2, 2, Just "Compiling B")]
                     (map abstract progressUpdates)
    where
      upd = (updateCodeGeneration True)
         <> (updateSourceFile "A.hs" . L.unlines $
              [ "module A where"
              , "printA :: IO ()"
              , "printA = putStr \"A\""
              ])
         <> (updateSourceFile "B.hs" . L.unlines $
              [ "module B where"
              , "import A"
              , "printAB :: IO ()"
              , "printAB = printA >> putStr \"B\""
              ])
  
      abstract (Progress {..}) = ( progressStep
                                 , progressNumSteps
                                 , T.unpack `liftM` progressParsedMsg
                                 )
  
  test_ParseCompiling_TH :: TestSuiteEnv -> Assertion
  test_ParseCompiling_TH env = withAvailableSession env $ \session -> do
      progressUpdates <- updateAndCollectProgress session upd
      assertNoErrors session
      assertEqual "" [(1, 2, Just "Compiling A"), (2, 2, Just "Compiling Main")]
                     (map abstract progressUpdates)
  
      -- Now we touch A, triggering recompilation of both A and B
      -- This will cause ghc to report "[TH]" as part of the progress message
      -- (at least on the command line). It doesn't seem to happen with the
      -- API; but just in case, we check that we still get the right messages
      -- (and not, for instance, '[TH]' as the module name).
  
      progressUpdates2 <- updateAndCollectProgress session upd2
      assertNoErrors session
      assertEqual "" [(1, 2, Just "Compiling A"), (2, 2, Just "Compiling Main")]
                     (map abstract progressUpdates2)
    where
      upd = (updateCodeGeneration True)
         <> (updateSourceFile "A.hs" . L.unlines $
              [ "{-# LANGUAGE TemplateHaskell #-}"
              , "module A where"
              , "import Language.Haskell.TH"
              , "foo :: Q Exp"
              , "foo = [| True |]"
              ])
         <> (updateSourceFile "Main.hs" . L.unlines $
              [ "{-# LANGUAGE TemplateHaskell #-}"
              , "module Main where"
              , "import A"
              , "main :: IO ()"
              , "main = print $foo"
              ])
  
      upd2 = (updateSourceFile "A.hs" . L.unlines $
              [ "{-# LANGUAGE TemplateHaskell #-}"
              , "module A where"
              , "import Language.Haskell.TH"
              , "foo :: Q Exp"
              , "foo = [| False |]"
              ])
  
      abstract (Progress {..}) = ( progressStep
                                 , progressNumSteps
                                 , T.unpack `liftM` progressParsedMsg
                                 )
  
  test_RejectMangledHeader :: TestSuiteEnv -> Assertion
  test_RejectMangledHeader env = withAvailableSession env $ \session -> do
      updateSessionD session update 1
      assertSourceErrors' session ["parse error on input `very'"]
  
      updateSessionD session update2 1
      assertSourceErrors' session ["parse error on input `.'"]
    where
      update  = updateSourceFile "M.hs" "module very-wrong where"
      update2 = updateSourceFile "M.hs" "module M.1.2.3.8.T where"
  