guide/REPL/test/Spec.hs

{-# LANGUAGE OverloadedStrings #-}

import Test.Tasty
import Test.Tasty.HUnit
import Data.Ord
import Text.Megaparsec
import Text.Megaparsec.Text
import Data.Either (isRight, either)
import qualified Data.Text as T
import Data.Monoid ((<>))
import System.FilePath((</>))
import HackageArchive
import Common

import qualified Data.Text.IO as TIO

testWorkingDir :: String
testWorkingDir = "testworkdir"

parseTests = testGroup "Hackage archive parsing tests"
  [
    testPath "filecollection/0.1.1.9/filecollection.cabal" "filecollection" True
    , testPath "filecollection/0.1.1.9/filecollection.cabal" "filecollectionz" False
    , testPath "file-collection/0.1.1.9/file-collection.cabal" "file-collection" True
    , testPath "file-collection/0.1.1.9/file-collection.cabal" "filecollection" False
  ]

testPath :: T.Text -> T.Text -> Bool -> TestTree
testPath text val match = testCase (T.unpack ("Parsing " <> expect match <> " \'" <> text <> "\'")) $
  assertBool "Failed" $ ((fst <$> parsePath (T.unpack text)) == Just (T.unpack val)) == match

{-
parseStackageTests = testGroup "Stackage parsing tests"
  [
    testParse parsePackageLine "              ztail ==1.2" True
    , testParse parsePackageLine "             adjunctions ==4.3," True
    , testParse parsePackageLine "ztail ==1.2" True
    , testParse parsePackageLine "adjunctions ==4.3," True

    , testParse parseLTS "-- Stackage snapshot from: http://www.stackage.org/snapshot/lts-2.10" True
    , testParse parseLTS "-- Stackage snapshot from: http://www.stackage.org/snapshot/lts-2.$10" True
    , testParse parseLTS "-- Please place this file next to your .cabal file as cabal.config" False
    , testParse parseLTS "-- To only use tested packages, uncomment the following line:" False
    , testParse parseLTS "-- remote-repo: stackage-lts-2.10:http://www.stackage.org/lts-2.10" False
    , testParse parseLTS "constraints: abstract-deque ==0.3," False
    , testParse parseLTS "abstract-par ==0.3.3," False
    , testParse parseLTS "zlib-lens ==0.1.2" False
    , testParse parseLTS "-- Stackage snapshot from: http://www.stackage.org/snapshot/nightly-2017-06-10" True
  ]

parseCabalConfig = testGroup "Cabal config parsing tests"
  [
    testStackagePackageLines parseStackageLTS "sometestfile.cnf"
    , testStackagePackageLines parseStackageLTS "sometestfile2.cnf"
    , testFileJustParse parseStackageLTS "sometestfile3.cnf" True
  ]
-}

-- Well this is code duplication. Somehow need to use testParse function here

testFileJustParse :: Parser a -> FilePath -> Bool -> TestTree
testFileJustParse p file match = testCase ("Testing file: " ++ file) $ do 
  fileText <- TIO.readFile (testWorkingDir </> file)
  assertBool "Failed" (isRight (runParser p "" fileText) == match)

testStackagePackageLines :: Parser StackageLTS -> FilePath -> TestTree
testStackagePackageLines p file = testFileParse (testWorkingDir </> file) 
  p countPackageLines matchWithStackageLTS

countPackageLines :: T.Text -> Int
countPackageLines text = length $ filter isPackageLine lns
  where lns = T.lines text
        isPackageLine ln = not ("--" `T.isInfixOf` ln) 
          && (("installed" `T.isInfixOf` ln) || ("==" `T.isInfixOf` ln))

matchWithStackageLTS :: Int -> StackageLTS -> Bool
matchWithStackageLTS count1 stackage = count1 == (length.snd) stackage

expect :: Bool -> T.Text
expect True = "expect success"
expect False = "expect fail"

testParse :: Parser a -> T.Text -> Bool -> TestTree
testParse p text match = testCase (T.unpack ("Parsing " <> expect match <> " \'" <> text <> "\'")) $
  assertBool "Failed" (isRight (runParser p "" text) == match)

testFileParse :: FilePath -> Parser a -> (T.Text -> b) -> (b -> a -> Bool) -> TestTree
testFileParse file p textFunc matchFunc = 
  testCase ("Testing file: " ++ file) $ do
    fileText <- TIO.readFile file -- got the file
    let textVal = textFunc fileText
    let eVal = matchFunc textVal <$> runParser p "" fileText
    assertBool "Failed" (either (const False) id eVal)

tests :: TestTree
tests = testGroup "REPL tests" [parseTests]

main = defaultMain tests