-- Copyright (c) 2020, Shayne Fletcher. All rights reserved.
-- SPDX-License-Identifier: BSD-3-Clause.
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
#include "ghclib_api.h"
import Test.Tasty
import Test.Tasty.HUnit
import System.Directory as Directory
import System.Environment
import qualified System.FilePath as FilePath
import System.IO.Extra
import Control.Monad
import Language.Haskell.GhclibParserEx.Parse
import Language.Haskell.GhclibParserEx.Dump
import Language.Haskell.GhclibParserEx.Fixity
#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)
import GHC.Hs
#else
import HsSyn
#endif
import DynFlags
import Lexer
import Outputable
import ErrUtils
import RdrHsSyn
#if defined (GHCLIB_API_808)
import Bag
#endif
main :: IO ()
main = do
setEnv "TASTY_NUM_THREADS" "1"
setUnsafeGlobalDynFlags (defaultDynFlags fakeSettings fakeLlvmConfig)
defaultMain tests
tests :: TestTree
tests = testGroup " All tests" [parseTests, fixityTests]
chkParseResult :: (DynFlags -> WarningMessages -> String) -> DynFlags -> ParseResult a -> IO ()
chkParseResult report flags = \case
POk s _ -> do
let (wrns, errs) = getMessages s flags
when (not (null errs) || not (null wrns)) $
assertFailure (report flags wrns ++ report flags errs)
#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)
PFailed s -> assertFailure (report flags $ snd (getMessages s flags))
#else
PFailed _ loc err -> assertFailure (report flags $ unitBag $ mkPlainErrMsg flags loc err)
#endif
parseTests :: TestTree
parseTests = testGroup "Parse tests"
[
testCase "Expression" $ do
let flags = defaultDynFlags fakeSettings fakeLlvmConfig
chkParseResult report flags $
parseExpr "unfoldr $ listToMaybe . concatMap reads . tails" flags
, testCase "Import" $ do
let flags = defaultDynFlags fakeSettings fakeLlvmConfig
chkParseResult report flags $
parseImport "import qualified \"foo-lib\" Foo as Bar hiding ((<.>))" flags
, testCase "Declaration" $ do
let flags = defaultDynFlags fakeSettings fakeLlvmConfig
chkParseResult report flags $
parseDeclaration (
unlines [
"fact :: Int -> Int"
, "fact n = if n <= 1 then 1 else n * fact (n - 1)"
]) flags
, testCase "File" $ do
foo <- makeFile "Foo.hs" $ unlines
[ "module Foo (readMany) where"
, "import Data.List"
, "import Data.Maybe"
, "readMany = unfoldr $ listToMaybe . concatMap reads . tails"
]
s <- readFile' foo
parsePragmasIntoDynFlags (defaultDynFlags fakeSettings fakeLlvmConfig) foo s >>= \case
Left msg -> assertFailure msg
Right flags ->
chkParseResult report flags $ parseFile foo (flags `gopt_set` Opt_KeepRawTokenStream) s
]
where
report flags msgs = concat [ showSDoc flags msg | msg <- pprErrMsgBagWithLoc msgs ]
fixityTests :: TestTree
fixityTests = testGroup "Fixity tests"
[
testCase "Expression" $ do
let flags = defaultDynFlags fakeSettings fakeLlvmConfig
case parseExpr "1 + 2 * 3" flags of
POk s e ->
#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)
case unP (runECP_P e >>= \e -> return e) s :: ParseResult (LHsExpr GhcPs) of
POk _ e ->
#endif
assertBool "parse tree not affected" $
showSDocUnsafe (showAstData BlankSrcSpan e) /=
showSDocUnsafe (showAstData BlankSrcSpan (applyFixities [] e))
#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)
PFailed{} -> assertFailure "ecp failure"
#endif
PFailed{} -> assertFailure "parse error"
, testCase "Pattern" $ do
let flags = defaultDynFlags fakeSettings fakeLlvmConfig
case parseDeclaration "f (1 : 2 :[]) = 1" flags of
POk _ d ->
assertBool "parse tree not affected" $
showSDocUnsafe (showAstData BlankSrcSpan d) /=
showSDocUnsafe (showAstData BlankSrcSpan (applyFixities [] d))
PFailed{} -> assertFailure "parse error"
]
makeFile :: FilePath -> String -> IO FilePath
makeFile relPath contents = do
Directory.createDirectoryIfMissing True $ FilePath.takeDirectory relPath
writeFile relPath contents
return relPath