content: {-# OPTIONS_GHC -fno-warn-orphans #-}
  {-# LANGUAGE CPP               #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  module ArgonSpec (spec)
      where
  
  import           Data.Aeson          (encode)
  import           Data.List           (sort)
  import           GHC.Stack           (HasCallStack)
  import           Text.Printf         (printf)
  #if __GLASGOW_HASKELL__ < 710
  import           Control.Applicative ((<$>), (<*>))
  #endif
  import qualified FastString          as GHC
  import           Pipes               (Producer, (>->), each)
  import qualified SrcLoc              as GHC
  import           System.Console.ANSI (Color (..), ConsoleIntensity(BoldIntensity), setSGRCode,
                                        SGR(SetColor, SetConsoleIntensity),
                                        ConsoleLayer(Foreground), ColorIntensity(Dull))
  import           System.FilePath     ((</>))
  import           System.IO.Unsafe    (unsafePerformIO)
  import           Test.Hspec          (describe, it, Expectation, shouldBe,
                                        shouldContain, Spec, expectationFailure,
                                        shouldReturn)
  import           Test.QuickCheck     (Arbitrary, arbitrary, shrink, property, elements)
  import qualified Pipes.Prelude       as P
  import           Data.Foldable       (traverse_)
  
  import           Argon
  
  instance Arbitrary ComplexityBlock where
      arbitrary = (\a b c -> CC (a, b, c)) <$> arbitrary
                                           <*> arbitrary
                                           <*> arbitrary
      shrink (CC t) = map CC $ shrink t
  
  instance Arbitrary OutputMode where
      arbitrary = elements [BareText, Colored, JSON]
  
  ones :: Loc
  ones = (1, 1)
  
  lo :: Int -> Loc
  lo s = (s, 1)
  
  realSpan :: Int -> Int -> GHC.SrcSpan
  realSpan a b = GHC.mkSrcSpan (mkLoc a b) $ mkLoc (-a) (b + 24)
      where mkLoc = GHC.mkSrcLoc (GHC.mkFastString "real loc")
  
  shouldContainErrors :: HasCallStack => FilePath -> [String] -> Expectation
  shouldContainErrors f errs = do
      r <- analyze defaultConfig (path f)
      case r of
          (_, Right _)  -> expectationFailure $ "Test did not fail" ++ show r
          (_, Left msg) -> traverse_ (msg `shouldContain`) errs
  
  path :: String -> FilePath
  path f = "test" </> "data" </> f
  
  shouldAnalyze :: HasCallStack => String -> AnalysisResult -> Expectation
  shouldAnalyze f = shouldAnalyzeC (f, defaultConfig)
  
  shouldAnalyzeC :: HasCallStack => (String, Config) -> AnalysisResult -> Expectation
  shouldAnalyzeC (f, config) r = analyze config p `shouldReturn` (p, r)
      where p = path f
  
  -- Disabled until I figure out why Argon.Walker tests fail only on Travis
  {-shouldProduceS :: Producer FilePath (SafeT IO) () -> [FilePath] -> Expectation-}
  {-shouldProduceS prod res = do-}
      {-paths <- runSafeT $ P.toListM prod-}
      {-paths `shouldBe` res-}
  
  shouldProduce :: (Eq a, Show a) => Producer a IO () -> [a] -> Expectation
  shouldProduce prod res = P.toListM prod >>= (`shouldBe` res)
  
  produceError, produceResult :: Producer (FilePath, AnalysisResult) IO ()
  produceError  = each [("path/f.hs", Left "err!")]
  produceResult = each [("f.hs", Right [ CC (ones, "g", 3)
                                       , CC (lo 2, "h", 5)
                                       , CC (lo 5, "f", 6)
                                       , CC (lo 7, "m", 10)
                                       , CC ((9, 2), "n", 15)
                                       ])]
  
  -- | ANSI bold color
  bold :: String
  bold = setSGRCode [SetConsoleIntensity BoldIntensity]
  
  -- | Make a ANSI foreground color sequence
  fore :: Color -> String
  fore color = setSGRCode [SetColor Foreground Dull color]
  
  -- | ANSI sequence for reset
  reset :: String
  reset = setSGRCode []
  
  spec :: Spec
  spec = do
      describe "analyze" $ do
          it "accounts for case" $
              "case.hs" `shouldAnalyze` Right [CC (ones, "func", 3)]
          it "accounts for if..then..else" $
              "ifthenelse.hs" `shouldAnalyze` Right [CC (ones, "f", 2)]
          it "accounts for lambda case" $
              "lambdacase.hs" `shouldAnalyze` Right [CC (lo 2, "g", 3)]
          it "accounts for multi way if" $
              "multiif.hs" `shouldAnalyze` Right [CC (lo 2, "f", 4)]
          it "accounts for || operator" $
              "orop.hs" `shouldAnalyze` Right [CC (lo 1, "g", 3)]
          it "accounts for && operator" $
              "andop.hs" `shouldAnalyze` Right [CC (lo 1, "g", 3)]
          it "counts everything in a real example" $
              "stack-setup.hs" `shouldAnalyze`
                  Right [ CC (lo 3, "ensureCompiler", 14)
                        , CC ((4, 9), "wc", 1)
                        , CC ((21, 9), "needLocal", 4)
                        , CC ((27, 9), "isWanted", 1)
                        , CC ((41, 17), "installedCompiler", 2)
                        , CC ((81, 37), "tool", 1)
                        , CC ((94, 17), "idents", 1)
                        , CC ((103, 21), "m", 1)
                        ]
          describe "extensions" $ do
  -- Not even GHC 7.8.4 is able to run the file below, so it's not an Argon bug
  #if __GLASGOW_HASKELL__ >= 710
              it "correctly applies CPP" $
                  "cpp-psyn.hs" `shouldAnalyze` Right []
  #endif
              it "applies CPP when needed" $
                  "cpp.hs" `shouldAnalyze` Right [CC (lo 5, "f", 4)]
              it "works with TemplateHaskell" $
                  "th.hs" `shouldAnalyze` Right [CC (lo 7, "foo", 1)]
              it "works with DataKinds, GADTs, KindSignatures" $
                  "datakinds.hs" `shouldAnalyze`
                      Right [ CC (lo 16, "taskOneWorker", 1)
                            , CC (lo 20, "main", 1)]
              it "works with ScopedTypeVariables" $
                  "scopedtypevariables.hs" `shouldAnalyze`
                      Right [CC (lo 9, "catchNonAsync", 1)]
              it "works with TypeFamilies" $
                  "typefamilies.hs" `shouldAnalyze` Right []
              it "works with ForeignImport" $
                  "foreignimports.hs" `shouldAnalyze` Right []
              it "works with Arrows" $
                  "arrows.hs" `shouldAnalyze` Right [CC (lo 7, "getAnchor", 1)]
          describe "errors" $ do
              it "catches syntax errors" $
                  "syntaxerror.hs" `shouldContainErrors`
                  ["parse error (possibly incorrect indentation or mismatched brackets)"]
              it "catches syntax errors (missing CPP)" $
                  "missingcpp.hs" `shouldAnalyze`
  #if __GLASGOW_HASKELL__ < 800
                      Left "1:2 lexical error at character 'i'"
  #else
                      Left "1:1 parse error on input \8216#\8217"
  #endif
  #if __GLASGOW_HASKELL__ < 800
  -- The analysis of "missingmacros.hs" will succeed in newest GHC versions.
              it "catches syntax errors (missing cabal macros)" $
                  "missingmacros.hs" `shouldContainErrors`
                  ["error: missing binary operator before token "]
  #endif
              it "catches syntax errors (missing include dir)" $
                  "missingincluded.hs" `shouldContainErrors`
                  ["fatal error", "necessaryInclude.h"]
              it "catches CPP parsing errors" $
                   "cpp-error.hs" `shouldContainErrors`
                   ["error: unterminated"]
          describe "config" $ do
              it "reads default extensions from Cabal file" $
                  ("missingcpp.hs", unsafePerformIO
                      (do loadedExts <- parseExts $ path "test.cabal"
                          return $ defaultConfig { exts = loadedExts }))
                      `shouldAnalyzeC`
                      Right [CC (lo 4, "f", 1)]
              it "reads other extensions from Cabal file" $
                  ("missingcpp.hs", unsafePerformIO
                      (do loadedExts <- parseExts $ path "test-other.cabal"
                          return $ defaultConfig { exts = loadedExts }))
                      `shouldAnalyzeC`
                      Right [CC (lo 4, "f", 1)]
              it "reads old extensions from Cabal file" $
                  ("missingcpp.hs", unsafePerformIO
                      (do loadedExts <- parseExts $ path "test-old.cabal"
                          return $ defaultConfig { exts = loadedExts }))
                      `shouldAnalyzeC`
                      Right [CC (lo 4, "f", 1)]
  #if __GLASGOW_HASKELL__ < 800
              it "includes Cabal macros for preprocessing" $
                  ( "missingmacros.hs"
                  , defaultConfig { headers = [path "cabal_macros.h"] }
                  ) `shouldAnalyzeC` Right [CC (lo 3, "f", 2)]
  #endif
              it "includes directory from include-dir for preprocessing" $
                  ( "missingincluded.hs"
                  , defaultConfig { includeDirs = [path "include"] }
                  ) `shouldAnalyzeC` Right [CC (lo 5, "f", 3)]
      describe "Argon.Loc" $ do
          describe "srcSpanToLoc" $ do
              it "can convert a real src span to loc" $
                  property $ \a b -> srcSpanToLoc (realSpan a b) == (a, b)
              it "can convert a bad src span to loc" $
                  srcSpanToLoc GHC.noSrcSpan `shouldBe` (0, 0)
          describe "locToString" $
              it "can convert a loc to string" $
                  locToString (1, 30) `shouldBe` "1:30"
          describe "tagMsg" $
              it "can tag messages" $
                  tagMsg (2, 3) "my custom msg" `shouldBe` "2:3 my custom msg"
      describe "Argon.Results" $ do
          describe "order" $ do
              it "does not error on empty list" $
                  order [] `shouldBe` []
              it "orders by complexity (descending)" $
                  order [CC (ones, "f", 1), CC (lo 2, "f", 2)] `shouldBe`
                      [CC (lo 2, "f", 2), CC (ones, "f", 1)]
              it "orders by lines (ascending)" $
                  order [CC (lo 11, "f", 3), CC (ones, "f", 3)] `shouldBe`
                      [CC (ones, "f", 3), CC (lo 11, "f", 3)]
              it "orders by function name (ascending)" $
                  order [CC (lo 11, "g", 3), CC (lo 11, "f", 3)] `shouldBe`
                      [CC (lo 11, "f", 3), CC (lo 11, "g", 3)]
              it "does not add or remove elements" $
                  property $ \xs -> sort xs == sort (order xs)
              it "is idempotent" $
                  property $ \xs -> order xs == order (order xs)
          describe "filterNulls" $ do
              it "allows errors" $
                  filterNulls ("", Left "err") `shouldBe` True
              it "disallows empty results" $
                  filterNulls ("", Right []) `shouldBe` False
              it "always allows non-empty results" $
                  property $ \x -> filterNulls ("", Right [x])
          describe "filterResults" $ do
              it "discards results with too low complexity" $
                  filterResults (Config 3 [] [] [] BareText )
                                ("p", Right [ CC (ones, "f", 3)
                                            , CC (lo 2, "g", 2)
                                            , CC (lo 4, "h", 10)
                                            , CC (lo 3, "l", 1)])
                                `shouldBe`
                                ("p", Right [ CC (lo 4, "h", 10)
                                            , CC (ones, "f", 3)])
              it "does nothing on Left" $
                  property $ \m o p err -> filterResults (Config m [] [] [] o)
                                                         (p, Left err) ==
                                                         (p, Left err)
      describe "Argon.Formatters" $ do
          describe "bareTextFormatter" $ do
              it "correctly formats errors" $
                  (produceError >-> bareTextFormatter) `shouldProduce`
                      ["path/f.hs", "\terror: err!"]
              it "correctly formats results" $
                  (produceResult >-> bareTextFormatter) `shouldProduce`
                      [ "f.hs"
                      , "\t1:1 g - 3"
                      , "\t2:1 h - 5"
                      , "\t5:1 f - 6"
                      , "\t7:1 m - 10"
                      , "\t9:2 n - 15"
                      ]
          describe "coloredTextFormatter" $ do
              it "correctly formats errors" $
                  (produceError >-> coloredTextFormatter) `shouldProduce`
                      [ bold ++ "path/f.hs" ++ reset
                      , "\t" ++ fore Red ++ "error" ++ reset ++ ": err!"
                      ]
              it "correctly formats results" $
                  (produceResult >-> coloredTextFormatter) `shouldProduce`
                      [ bold ++ "f.hs" ++ reset
                      , printf "\t1:1 %sg%s - %sA (3)%s" (fore Cyan) reset
                                                         (fore Green) reset
                      , printf "\t2:1 %sh%s - %sA (5)%s" (fore Cyan) reset
                                                         (fore Green) reset
                      , printf "\t5:1 %sf%s - %sB (6)%s" (fore Cyan) reset
                                                         (fore Yellow) reset
                      , printf "\t7:1 %sm%s - %sB (10)%s" (fore Cyan) reset
                                                          (fore Yellow) reset
                      , printf "\t9:2 %sn%s - %sC (15)%s" (fore Magenta) reset
                                                          (fore Red) reset
                      ]
      describe "Argon.Types" $ do
          describe "ComplexityBlock" $ do
              it "implements Show correctly" $
                  show (CC ((2, 3), "bla bla", 32)) `shouldBe`
                      "CC ((2,3),\"bla bla\",32)"
              it "implements Eq correctly" $
                  CC ((1, 4), "fun", 13) `shouldBe` CC ((1, 4), "fun", 13)
              it "implements Ord correctly" $
                  CC (lo 1, "g", 2) < CC (lo 2, "f", 1) `shouldBe` True
          describe "OutputMode" $ do
              it "implements Show correctly" $
                  show [JSON, Colored, BareText] `shouldBe`
                      "[JSON,Colored,BareText]"
              it "implements Eq correctly" $
                  [JSON, Colored, BareText] `shouldBe` [JSON, Colored, BareText]
          describe "ToJSON instance" $ do
              it "is implemented by ComplexityResult" $
                  encode (CC ((1, 3), "f", 4)) `shouldBe`
                      "{\"complexity\":4,\"name\":\"f\",\"lineno\":1,\"col\":3}"
              it "is implemented by (FilePath, AnalysisResult)" $
                  encode ("f.hs" :: String, Right [] :: AnalysisResult)
                      `shouldBe`
                      "{\"blocks\":[],\"path\":\"f.hs\",\"type\":\"result\"}"
              it "is implemented by (FilePath, AnalysisResult) II" $
                  encode ("f.hs" :: String, Left "err" :: AnalysisResult)
                      `shouldBe`
                      "{\"path\":\"f.hs\",\"type\":\"error\",\"message\":\"err\"}"
  #if 0
      describe "Argon.Walker" $
          describe "allFiles" $ do
              it "traverses the filesystem depth-first" $
                  allFiles ("test" </> "tree") `shouldProduceS`
                      [ "test" </> "tree" </> "sub"  </> "b.hs"
                      , "test" </> "tree" </> "sub"  </> "c.hs"
                      , "test" </> "tree" </> "sub2" </> "a.hs"
                      , "test" </> "tree" </> "sub2" </> "e.hs"
                      , "test" </> "tree" </> "a.hs"
                      ]
              it "includes starting files in the result" $
                  allFiles ("test" </> "tree" </> "a.hs") `shouldProduceS`
                      ["test" </> "tree" </> "a.hs"]
  #endif
  