content: {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE CPP #-}
  
  module Language.Fortran.RewriterSpec
    ( spec
    )
  where
  
  import           Test.Hspec
  import           Control.Exception.Base         ( try
                                                  , throw
                                                  )
  import           Control.Monad                  ( foldM
                                                  , unless
                                                  )
  import qualified Data.Map                      as M
  import           System.Directory               ( copyFile
                                                  , createDirectory
                                                  , getCurrentDirectory
                                                  , doesDirectoryExist
                                                  )
  import           Language.Fortran.Rewriter
  import qualified Data.ByteString.Lazy.Char8    as BC
  
  spec :: Spec
  spec = do
    describe "ReplacementMap" $ do
      it "Initialize ReplacementMap" $ do
        let
          rm = M.fromList
            [ ( "foo.f" :: String
              , [ Replacement
                    (SourceRange (SourceLocation 0 0) (SourceLocation 1 1))
                    ""
                ]
              )
            , ("bar.f", [])
            ]
        rm `shouldBe` M.fromList
          [ ( "foo.f"
            , [ Replacement
                  (SourceRange (SourceLocation 0 0) (SourceLocation 1 1))
                  ""
              ]
            )
          , ("bar.f", [])
          ]
      it "Process ReplacementMap (empty; should not die)" $ do
        let rm = M.empty
        processReplacements rm
      it "Process ReplacementMap (simple replacements)" $ do
        base <- getCurrentDirectory
        let
          body workDir = processReplacements $ M.fromList
            [ ( workDir ++ "001_foo.f"
              , [ Replacement
                    (SourceRange (SourceLocation 1 12) (SourceLocation 1 16))
                    "cccc"
                ]
              )
            , ( workDir ++ "002_foo.f"
              , [ Replacement
                    (SourceRange (SourceLocation 1 7) (SourceLocation 1 16))
                    ""
                ]
              )
            , ( workDir ++ "003_foo.f"
              , [ Replacement
                  (SourceRange (SourceLocation 1 12) (SourceLocation 1 17))
                  "cccc1"
                , Replacement
                  (SourceRange (SourceLocation 3 12) (SourceLocation 3 17))
                  "cccc2"
                ]
              )
            , ( workDir ++ "004_unicode.f"
              , [ Replacement
                    (SourceRange (SourceLocation 3 17) (SourceLocation 3 28))
                    "int(z'deadbeef')"
                ]
              )
            , ( workDir ++ "005_unicode.f"
              , [ Replacement
                    (SourceRange (SourceLocation 3 21) (SourceLocation 3 21))
                    ""
                ]
              )
            ]
        wrapReplacementsMapInvocationTestHelper
          body
          base
          Nothing
          "replacementsmap-simple"
          [ "001_foo.f"
          , "002_foo.f"
          , "003_foo.f"
          , "004_unicode.f"
          , "005_unicode.f"
          ]
      it "Process ReplacementMap (insertions)" $ do
        base <- getCurrentDirectory
        let body workDir = processReplacements $ M.fromList
              [ ( workDir ++ "001_foo.f"
                , [ Replacement
                      (SourceRange (SourceLocation 0 24) (SourceLocation 0 24))
                      "\n       call bbbb"
                  ]
                )
              ]
        wrapReplacementsMapInvocationTestHelper body
                                                base
                                                Nothing
                                                "replacementsmap-insertion"
                                                ["001_foo.f"]
      it "Process ReplacementMap (overlapping)" $ do
        base <- getCurrentDirectory
        let
          r1 = Replacement
            (SourceRange (SourceLocation 1 12) (SourceLocation 1 16))
            "cccc"
          r2 = Replacement
            (SourceRange (SourceLocation 1 7) (SourceLocation 1 16))
            "call dddd"
          body workDir =
            processReplacements $ M.fromList [(workDir ++ "001_foo.f", [r1, r2])]
        wrapReplacementsMapInvocationTestHelper
          body
          base
          (Just $ OverlappingError [(r2, r1)])
          "replacementsmap-overlapping"
          ["001_foo.f"]
      it "Process ReplacementMap (overlapping filtered)" $ do
        base <- getCurrentDirectory
        let r1 = Replacement
              (SourceRange (SourceLocation 1 12) (SourceLocation 1 16))
              "cccc"
            r2 = Replacement
              (SourceRange (SourceLocation 1 7) (SourceLocation 1 16))
              "call dddd"
            (repls, overlapping) = partitionOverlapping [r1, r2]
            body workDir =
              processReplacements $ M.fromList [(workDir ++ "001_foo.f", repls)]
        repls `shouldBe` [r1]
        wrapReplacementsMapInvocationTestHelper
          body
          base
          Nothing
          "replacementsmap-overlapping-filtered"
          ["001_foo.f"]
        overlapping `shouldBe` [r2]
  #ifndef FS_DISABLE_WIN_BROKEN_TESTS
      -- TODO fails on Windows, perhaps problem with temp files or filenames?
      it "Process ReplacementMap (invalid range; start line)" $ do
        base <- getCurrentDirectory
        let
          body workDir = processReplacements $ M.fromList
            [ ( workDir ++ "001_foo.f"
              , [ Replacement
                    (SourceRange (SourceLocation 9 12) (SourceLocation 9 15))
                    ""
                ]
              )
            ]
        wrapReplacementsMapInvocationTestHelper body
                                                base
                                                (Just InvalidRangeError)
                                                "replacementsmap-overlapping"
                                                ["001_foo.f"]
      it "Process ReplacementMap (invalid range; start column)" $ do
        base <- getCurrentDirectory
        let
          body workDir = processReplacements $ M.fromList
            [ ( workDir ++ "001_foo.f"
              , [ Replacement
                    (SourceRange (SourceLocation 1 112) (SourceLocation 1 115))
                    ""
                ]
              )
            ]
        wrapReplacementsMapInvocationTestHelper body
                                                base
                                                (Just InvalidRangeError)
                                                "replacementsmap-overlapping"
                                                ["001_foo.f"]
      it "Process ReplacementMap (invalid range; end line)" $ do
        base <- getCurrentDirectory
        let
          body workDir = processReplacements $ M.fromList
            [ ( workDir ++ "001_foo.f"
              , [ Replacement
                    (SourceRange (SourceLocation 1 13) (SourceLocation 19 115))
                    ""
                ]
              )
            ]
        wrapReplacementsMapInvocationTestHelper body
                                                base
                                                (Just InvalidRangeError)
                                                "replacementsmap-overlapping"
                                                ["001_foo.f"]
      it "Process ReplacementMap (invalid range; end column)" $ do
        base <- getCurrentDirectory
        let
          body workDir = processReplacements $ M.fromList
            [ ( workDir ++ "001_foo.f"
              , [ Replacement
                    (SourceRange (SourceLocation 1 13) (SourceLocation 1 115))
                    ""
                ]
              )
            ]
        wrapReplacementsMapInvocationTestHelper body
                                                base
                                                (Just InvalidRangeError)
                                                "replacementsmap-overlapping"
                                                ["001_foo.f"]
      it "Process ReplacementMap (column limit)" $ do
        base <- getCurrentDirectory
        let
          body workDir = processReplacements $ M.fromList
            [ ( workDir ++ "001_foo.f"
              , [ Replacement
                    (SourceRange (SourceLocation 3 42) (SourceLocation 3 43))
                    "999999999999999999999"
                ]
              )
            -- TODO fails on Windows due to some line ending/spacing bug
            , ( workDir ++ "002_other.f"
              , [ Replacement
                    (SourceRange (SourceLocation 4 61) (SourceLocation 4 62))
                    "999999999999"
                ]
              )
            -- TODO fails on Windows due to some line ending/spacing bug
            , ( workDir ++ "003_multiline.f"
              , [ Replacement
                    (SourceRange (SourceLocation 4 61) (SourceLocation 4 62))
                    "9 .and. \n     + 4 .lt. 4\n     + .or. .true."
                ]
              )
            , ( workDir ++ "004_comment.f"
              , [ Replacement
                  (SourceRange (SourceLocation 2 18) (SourceLocation 2 19))
                  "foobar"
                , Replacement
                  (SourceRange (SourceLocation 8 16) (SourceLocation 8 27))
                  "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
                ]
              )
            , ( workDir ++ "005_removals.f"
              , [ Replacement
                  (SourceRange (SourceLocation 2 50) (SourceLocation 3 24))
                  ""
                , Replacement
                  (SourceRange (SourceLocation 8 55) (SourceLocation 9 22))
                  ""
                ]
              )
            , ( workDir ++ "006_linewrap_heuristic.f"
              , [ Replacement
                  (SourceRange (SourceLocation 3 19) (SourceLocation 3 23))
                  "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
                , Replacement
                  (SourceRange (SourceLocation 4 23) (SourceLocation 4 27))
                  "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
                , Replacement
                  (SourceRange (SourceLocation 5 28) (SourceLocation 5 32))
                  "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
                , Replacement
                  (SourceRange (SourceLocation 6 28) (SourceLocation 6 32))
                  "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
                , Replacement
                  (SourceRange (SourceLocation 7 19) (SourceLocation 7 23))
                  "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
                , Replacement
                  (SourceRange (SourceLocation 8 6) (SourceLocation 8 24))
                  "call testcommons_logarray_settori_findex(logical_1_to_4(test), 1)"
                , Replacement
                  (SourceRange (SourceLocation 11 12) (SourceLocation 11 28))
                  "call testcommons_set_logical2var(logical_2_to_4(l2))"
                , Replacement
                  (SourceRange (SourceLocation 12 12) (SourceLocation 12 12))
                  "call testcommons_set_logical2var(logical_2_to_4(l2))"
                , Replacement
                  (SourceRange (SourceLocation 13 12) (SourceLocation 13 13))
                  "call testcommons_set_logical2var(logical_2_to_4(l2))"
                ]
              )
            ]
        wrapReplacementsMapInvocationTestHelper
          body
          base
          Nothing
          "replacementsmap-columnlimit"
          [ "001_foo.f"
          , "002_other.f"
          , "003_multiline.f"
          , "004_comment.f"
          , "005_removals.f"
          , "006_linewrap_heuristic.f"
          ]
  #endif
      it "implicit comment removal" $ do
        base <- getCurrentDirectory
        let
          body workDir = processReplacements $ M.fromList
            [ ( workDir ++ "001_foo.f"
              , [ Replacement
                    (SourceRange (SourceLocation 1 0) (SourceLocation 3 0))
                    $ unlines [ "      ! This is a long comment that goes over the 72 columns"
                              , "      integer*4 hello"
                              , "      integer*2 hello2"
                              ]
                ]
              )
            ]
        wrapReplacementsMapInvocationTestHelper
          body
          base
          Nothing
          "replacementsmap-padimplicitcomment"
          [ "001_foo.f" ]
  
    describe "Filtering overlapping replacements" $ do
      it "Simple overlap" $ do
        let
          r1 = Replacement
            (SourceRange (SourceLocation 0 0) (SourceLocation 0 2))
            "a"
          r2 = Replacement
            (SourceRange (SourceLocation 0 1) (SourceLocation 0 3))
            "b"
          (disjoint, overlapping) = partitionOverlapping [r1, r2]
        disjoint `shouldBe` [r1]
        overlapping `shouldBe` [r2]
      it "Reversed order" $ do
        let
          r1 = Replacement
            (SourceRange (SourceLocation 0 1) (SourceLocation 0 3))
            "a"
          r2 = Replacement
            (SourceRange (SourceLocation 0 0) (SourceLocation 0 2))
            "b"
          (disjoint, overlapping) = partitionOverlapping [r1, r2]
        disjoint `shouldBe` [r1]
        overlapping `shouldBe` [r2]
      it "Middle overlap" $ do
        let
          r1 = Replacement
            (SourceRange (SourceLocation 0 0) (SourceLocation 0 2))
            "a"
          r2 = Replacement
            (SourceRange (SourceLocation 0 1) (SourceLocation 0 3))
            "b"
          r3 = Replacement
            (SourceRange (SourceLocation 0 2) (SourceLocation 0 4))
            "c"
          (disjoint, overlapping) = partitionOverlapping [r1, r2, r3]
        disjoint `shouldBe` [r1, r3]
        overlapping `shouldBe` [r2]
      it "Middle overlap out of order" $ do
        let
          r1 = Replacement
            (SourceRange (SourceLocation 0 1) (SourceLocation 0 3))
            "a"
          r2 = Replacement
            (SourceRange (SourceLocation 0 0) (SourceLocation 0 2))
            "b"
          r3 = Replacement
            (SourceRange (SourceLocation 0 2) (SourceLocation 0 4))
            "c"
          (disjoint, overlapping) = partitionOverlapping [r1, r2, r3]
        disjoint `shouldBe` [r1]
        overlapping `shouldBe` [r2, r3]
      it "Exact overlap" $ do
        let
          r1 = Replacement
            (SourceRange (SourceLocation 0 1) (SourceLocation 0 3))
            "a"
          r2 = Replacement
            (SourceRange (SourceLocation 0 1) (SourceLocation 0 3))
            "b"
          (disjoint, overlapping) = partitionOverlapping [r1, r2]
        disjoint `shouldBe` [r1]
        overlapping `shouldBe` [r2]
      it "Overlapping beginning" $ do
        let
          r1 = Replacement
            (SourceRange (SourceLocation 0 1) (SourceLocation 0 3))
            "a"
          r2 = Replacement
            (SourceRange (SourceLocation 0 1) (SourceLocation 0 2))
            "b"
          (disjoint, overlapping) = partitionOverlapping [r1, r2]
        disjoint `shouldBe` [r1]
        overlapping `shouldBe` [r2]
      it "Some overlapping" $ do
        let
          r1 = Replacement
            (SourceRange (SourceLocation 0 1) (SourceLocation 0 3))
            "a"
          r2 = Replacement
            (SourceRange (SourceLocation 0 5) (SourceLocation 0 7))
            "b"
          r3 = Replacement
            (SourceRange (SourceLocation 0 3) (SourceLocation 0 5))
            "b"
          r4 = Replacement
            (SourceRange (SourceLocation 0 6) (SourceLocation 0 8))
            "b"
          (disjoint, overlapping) = partitionOverlapping [r1, r2, r3, r4]
        disjoint `shouldBe` [r1, r2, r3]
        overlapping `shouldBe` [r4]
  
  
  wrapReplacementsMapInvocationTestHelper
    :: (String -> IO ())
    -> FilePath
    -> Maybe ReplacementError
    -> String
    -> [String]
    -> Expectation
  wrapReplacementsMapInvocationTestHelper invocation baseDir Nothing ctx files =
    do
      (inputContextDir, outputContextDir, invokeResult) <-
        wrapReplacementsMapInvocationTestHelper_ invocation baseDir ctx files
      case invokeResult of
        Left  e -> error $ "Test failed unexpectedly; should pass: " <> show e
        Right _ -> do
          let res = foldM
                (\acc file -> do
                  let expected = inputContextDir ++ "/" ++ file ++ ".expected"
                  let output   = outputContextDir ++ "/" ++ file
                  ok <- compareFile expected output
                  return (acc && ok)
                )
                True
                files
          res `shouldReturn` True
  wrapReplacementsMapInvocationTestHelper invocation baseDir (Just expExcp) ctx files
    = do
      (_, _, invokeResult) <- wrapReplacementsMapInvocationTestHelper_
        invocation
        baseDir
        ctx
        files
      case invokeResult of
        Left  ex -> throw ex `shouldThrow` (== expExcp)
        Right _  -> error "Test passed unexpectedly; should fail"
  
  wrapReplacementsMapInvocationTestHelper_
    :: (String -> IO ())
    -> FilePath
    -> String
    -> [String]
    -> IO (String, String, Either ReplacementError ())
  wrapReplacementsMapInvocationTestHelper_ invocation baseDir ctx files = do
    let inputContextDir  = baseDir ++ "/test-data/rewriter/" ++ ctx
        outputDir        = baseDir ++ "/test/rewriter-test-output"
        outputContextDir = outputDir ++ "/" ++ ctx
    doesDirectoryExist outputDir
      >>= (\x -> unless x $ createDirectory outputDir)
    doesDirectoryExist outputContextDir
      >>= (\x -> unless x $ createDirectory outputContextDir)
    mapM_
      (\file -> copyFile (inputContextDir ++ "/" ++ file)
                         (outputContextDir ++ "/" ++ file)
      )
      files
    result <-
      try (invocation $ outputContextDir ++ "/") :: IO
        (Either ReplacementError ())
    return (inputContextDir, outputContextDir, result)
  
  --------------------------------------------------------------------------------
  
  -- | Utility function to compare file content.
  compareFile :: FilePath -> FilePath -> IO Bool
  compareFile expected actual = do
    c1 <- BC.readFile expected
    c2 <- BC.readFile actual
    compareByteString c1 c2
  
  -- XXX: It appears the rewriter has different behaviour on Windows and Linux --
  --      specifically relating to newlines. So we use a custom equality check
  --      that skips Windows newlines (@\r@ characters are skipped).
  --
  --      (This is morally grey: the issue is unlikely to rear its head in
  --      practical usage, _but_ if you were to be comparing rewriter output from
  --      different platforms, you may encounter it. Most cross-platform text
  --      tooling recognises/ignores Windows newlines, however.)
  compareByteString :: BC.ByteString -> BC.ByteString -> IO Bool
  compareByteString expected actual = if expected `eqSkipWinNewlines` actual
    then return True
    else do
      BC.putStrLn ">>>>>>> EXPECTED"
      BC.putStrLn expected
      BC.putStrLn ">>>>>>> ACTUAL"
      BC.putStrLn actual
      return False
  
  eqSkipWinNewlines :: BC.ByteString -> BC.ByteString -> Bool
  eqSkipWinNewlines x1 x2 = go (BC.uncons x1) (BC.uncons x2)
    where
      go :: Maybe (Char, BC.ByteString) -> Maybe (Char, BC.ByteString) -> Bool
  
      -- both reached EOF simultaneously: identical
      go Nothing Nothing = True
  
      -- next character in either bytestring is @\r@: skip
      go (Just ('\r', bs1)) bs2 = go (BC.uncons bs1) bs2
      go bs1 (Just ('\r', bs2)) = go bs1 (BC.uncons bs2)
  
      -- only one bytestring is EOF: different
      go Nothing (Just _)       = False
      go (Just _) Nothing       = False
  
      -- main case: check equality of next words
      go (Just (b1, bs1)) (Just (b2, bs2)) =
          if   b1 == b2
          then go (BC.uncons bs1) (BC.uncons bs2)
          else False
  