--------------------------------------------------------------------------------
-- Test Suite for the Curry Frontend
--------------------------------------------------------------------------------
--
-- This Test Suite supports three kinds of tests:
--
-- 1) tests which should pass
-- 2) tests which should pass with a specific warning
-- 3) tests which should fail yielding a specific error message
--
-- In order to add a test to this suite, proceed as follows:
--
-- 1) Store your test code in a file (please use descriptive names) and put it
--    in the corresponding subfolder (i.e. test/pass for passing tests,
--    test/fail for failing tests and test/warning for passing tests producing
--    warnings)
-- 2) Extend the corresponding test information list (there is one for each test
--    group at the end of this file) with the required information (i.e. name of
--    the Curry module to be tested and expected warning/failure message(s))
-- 3) Run 'cabal test'

{-# LANGUAGE CPP #-}
module TestFrontend (tests) where

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative    ((<$>))
#endif
import qualified Control.Exception as E (SomeException, catch)

import           Data.List              (isInfixOf, sort)
import qualified Data.Map as Map        (insert)
import           Distribution.TestSuite ( Test (..), TestInstance (..)
                                        , Progress (..), Result (..)
                                        , OptionDescr)
import           System.FilePath        (FilePath, (</>), (<.>))

import           Curry.Base.Message     (Message, message, ppMessages, ppError)
import           Curry.Base.Monad       (CYIO, runCYIO)
import           Curry.Base.Pretty      (text)
import qualified CompilerOpts as CO     ( Options (..), WarnOpts (..)
                                        , WarnFlag (..), Verbosity (VerbQuiet)
                                        , CppOpts (..)
                                        , defaultOptions)
import CurryBuilder                     (buildCurry)

tests :: IO [Test]
tests = return [failingTests, passingTests, warningTests]

runSecure :: CYIO a -> IO (Either [Message] (a, [Message]))
runSecure act = runCYIO act `E.catch` handler
  where handler e = return (Left [message $ text $ show (e :: E.SomeException)])

-- Execute a test by calling cymake
runTest :: CO.Options -> String -> [String] -> IO Progress
runTest opts test errorMsgs =
  if null errorMsgs
    then passOrFail <$> runSecure (buildCurry opts' test)
    else catchE     <$> runSecure (buildCurry opts' test)
  where
    cppOpts       = CO.optCppOpts opts
    cppDefs       = Map.insert "__PAKCS__" 3 (CO.cppDefinitions cppOpts)
    wOpts         = CO.optWarnOpts opts
    wFlags        =   CO.WarnUnusedBindings
                    : CO.WarnUnusedGlobalBindings
                    : CO.wnWarnFlags wOpts
    opts'         = opts { CO.optForce    = True
                         , CO.optWarnOpts = wOpts
                            { CO.wnWarnFlags    = wFlags  }
                         , CO.optCppOpts  = cppOpts
                            { CO.cppDefinitions = cppDefs }
                         }
    passOrFail    = Finished . either fail (const Pass)
    catchE        = Finished . either pass (pass . snd)
    fail msgs
      | null msgs = Pass
      | otherwise = Fail $ "An unexpected failure occurred: " ++
                           showMessages msgs
    pass msgs
      | null otherMsgs = Pass
      | otherwise      = Fail $ "Expected warnings/failures did not occur: " ++
                                unwords otherMsgs
      where
        errorStr  = showMessages msgs
        otherMsgs = filter (not . flip isInfixOf errorStr) errorMsgs

showMessages :: [Message] -> String
showMessages = show . ppMessages ppError . sort

-- group of test which should fail yielding a specific error message
failingTests :: Test
failingTests = Group { groupName    = "Failing Tests"
, concurrently = False
, groupTests   = map (mkTest "test/fail/") failInfos
}

-- group of tests which should pass
passingTests :: Test
passingTests = Group { groupName    = "Passing Tests"
                     , concurrently = False
                     , groupTests   = map (mkTest "test/pass/") passInfos
                     }

-- group of tests which should pass producing a specific warning message
warningTests :: Test
warningTests = Group { groupName    = "Warning Tests"
                     , concurrently = False
                     , groupTests   = map (mkTest "test/warning/") warnInfos
                     }

-- create a new test
mkTest :: FilePath -> TestInfo -> Test
mkTest path (testName, testTags, testOpts, mSetOpts, errorMsgs) =
  let file = path </> testName <.> "curry"
      opts = CO.defaultOptions { CO.optVerbosity   = CO.VerbQuiet
                               , CO.optImportPaths = [path]
                               }
      test = TestInstance
        { run       = runTest opts file errorMsgs
        , name      = testName
        , tags      = testTags
        , options   = testOpts
        , setOption = maybe (\_ _ -> Right test) id mSetOpts
        }
  in Test test

-- Information for a test instance:
-- * name of test
-- * tags to classify a test
-- * options
-- * function to set options
-- * optional warning/error message which should be thrown on execution of test
type TestInfo = (String, [String], [OptionDescr], Maybe SetOption, [String])

type SetOption = String -> String -> Either String TestInstance

--------------------------------------------------------------------------------
-- Definition of failing tests
--------------------------------------------------------------------------------

-- generate a simple failing test
mkFailTest :: String -> [String] -> TestInfo
mkFailTest name errorMsgs = (name, [], [], Nothing, errorMsgs)

-- To add a failing test to the test suite simply add the module name of the
-- test code and the expected error message(s) to the following list
failInfos :: [TestInfo]
failInfos = map (uncurry mkFailTest)
  [ ("DataFail",
      [ "Missing instance for Prelude.Data Test1"
      , "Missing instance for Prelude.Data (Test2"
      , "Missing instance for Prelude.Data (Test2"
      , "Missing instance for Prelude.Data Test1"
      ]
    )
  , ("ErrorMultipleSignature", ["More than one type signature for `f'"])
  , ("ErrorMultipleSignature", ["More than one type signature for `f'"])
  , ("ExportCheck/AmbiguousName", ["Ambiguous name `not'"])
  , ("ExportCheck/AmbiguousType", ["Ambiguous type `Bool'"])
  , ("ExportCheck/ModuleNotImported", ["Module `Foo' not imported"])
  , ("ExportCheck/MultipleName", ["Multiple exports of name `not'"])
  , ("ExportCheck/MultipleType", ["Multiple exports of type `Bool'"])
  , ("ExportCheck/NoDataType", ["`Foo' is not a data type"])
  , ("ExportCheck/OutsideTypeConstructor", ["Data constructor `False' outside type export in export list"])
  , ("ExportCheck/OutsideTypeLabel", ["Label `value' outside type export in export list"])
  , ("ExportCheck/UndefinedElement", ["`foo' is not a constructor or label of type `Bool'"])
  , ("ExportCheck/UndefinedName", ["Undefined name `foo' in export list"])
  , ("ExportCheck/UndefinedType", ["Undefined type or class `Foo' in export list"])
  , ("FP_Cyclic", ["Function `g' used in functional pattern depends on `f'  causing a cyclic dependency"])
  , ("FP_Restrictions",
      [ "Functional patterns are not supported inside a case expression"
      , "Functional patterns are not supported inside a case expression"
      , "Functional patterns are not supported inside a list comprehension"
      , "Functional patterns are not supported inside a do sequence"
      ]
    )
  , ("HaskellRecordsFail", ["Unexpected token `,'"])
  , ("FP_NonGlobal", ["Function `f1' in functional pattern is not global"])
  , ("ImportError",
      [ "Module Prelude does not export foo"
      , "Module Prelude does not export bar"
      ]
    )
  , ("KindCheck",
      [ "Type variable a occurs more than once in left hand side of type declaration"
      , "Type variable b occurs more than once in left hand side of type declaration"
      ]
    )
  , ("MissingLabelInUpdate",
      ["Undefined record label `l1'"] )
  , ("MultipleArities", ["Equations for `test' have different arities"])
  , ("MultipleDefinitions",
      ["Multiple definitions for data/record constructor `Rec'"]
    )
  , ("MultiplePrecedence",
      ["More than one fixity declaration for `f'"]
    )
  , ("PatternRestrictions",
      [ "Lazy patterns are not supported inside a functional pattern"]
    )
  , ("PragmaError", ["Unknown language extension"])
  , ("PrecedenceRange", ["Precedence out of range"])
  , ("RecordLabelIDs", ["Multiple declarations of `RecordLabelIDs.id'"])
  , ("RecursiveTypeSyn", ["Mutually recursive synonym and/or renaming types A and B (line 12.6)"])
  , ("SyntaxError", ["Type error in application"])
  , ("TypedFreeVariables",
      ["Variable x has a polymorphic type", "Type error in equation"]
    )
  , ("TypeError1", ["Type error in explicitly typed expression"])
  , ("TypeError2", ["Missing instance for Prelude.Num Prelude.Bool"])
  , ("TypeSigTooGeneral",
      [ "Type signature too general"
      , "Function: h"
      , "Type signature too general"
      , "Function: g'"
      , "Type signature too general"
      , "Function: n"
      ]
    )
  , ("UnboundTypeVariable",
      [ "Unbound type variable b"
      , "Unbound type variable c"
      ]
    )
  ]

--------------------------------------------------------------------------------
-- Definition of passing tests
--------------------------------------------------------------------------------

-- generate a simple passing test
mkPassTest :: String -> TestInfo
mkPassTest = flip mkFailTest []

-- To add a passing test to the test suite simply add the module name of the
-- test code to the following list
passInfos :: [TestInfo]
passInfos = map mkPassTest
  [ "AbstractCurryBug"
  , "ACVisibility"
  , "AnonymVar"
  , "CaseComplete"
  , "DataPass"
  , "DefaultPrecedence"
  , "Dequeue"
  , "EmptyWhere"
  , "ExplicitLayout"
  , "FCase"
  , "FP_Lifting"
  , "FP_NonCyclic"
  , "FP_NonLinearity"
  , "FunctionalPatterns"
  , "HaskellRecords"
  , "HaskellRecordsPass"
  , "Hierarchical"
  , "ImportRestricted"
  , "ImportRestricted2"
  , "Infix"
  , "Inline"
  , "Lambda"
  , "Maybe"
  , "NegLit"
  , "Newtype1"
  , "Newtype2"
  , "NonLinearLHS"
  , "OperatorDefinition"
  , "PatDecl"
  , "Prelude"
  , "Pretty"
  , "RecordsPolymorphism"
  , "RecordTest1"
  , "RecordTest2"
  , "RecordTest3"
  , "ReexportTest"
  , "SelfExport"
  , "SpaceLeak"
  , "TyConsTest"
  , "TypedExpr"
  , "UntypedAcy"
  , "Unzip"
  , "WhereAfterDo"
  ]

--------------------------------------------------------------------------------
-- Definition of warning tests
--------------------------------------------------------------------------------

-- To add a warning test to the test suite simply add the module name of the
-- test code and the expected warning message(s) to the following list
warnInfos :: [TestInfo]
warnInfos = map (uncurry mkFailTest)
  [
    ("AliasClash",
      [ "The module alias `AliasClash' overlaps with the current module name"
      , "Overlapping module aliases"
      , "Module List is imported more than once"
      ]
    )
  , ("Case1", ["Pattern matches are non-exhaustive", "In an equation for `h'"])
  , ("Case2",
      [ "An fcase expression is potentially non-deterministic due to overlapping rules"
      , "Pattern matches are non-exhaustive", "In an fcase alternative"
      , "In a case alternative", "In an equation for `fp'"
      , "Pattern matches are potentially unreachable"
      , "Function `fp' is potentially non-deterministic due to overlapping rules"
      , "Pattern matches are non-exhaustive"
      ]
    )
  , ("CaseModeH",
      [ "Wrong case mode in symbol `B' due to selected case mode `haskell`, try renaming to b instead"
      , "Wrong case mode in symbol `B' due to selected case mode `haskell`, try renaming to b instead"
      , "Wrong case mode in symbol `Xs' due to selected case mode `haskell`, try renaming to xs instead"
      , "Wrong case mode in symbol `c' due to selected case mode `haskell`, try renaming to C instead"
      , "Wrong case mode in symbol `f' due to selected case mode `haskell`, try renaming to F instead"
      ]
    )
  , ("CaseModeP",
      [ "Wrong case mode in symbol `a' due to selected case mode `prolog`, try renaming to A instead"
      , "Wrong case mode in symbol `a' due to selected case mode `prolog`, try renaming to A instead"
      , "Wrong case mode in symbol `mf' due to selected case mode `prolog`, try renaming to Mf instead"
      , "Wrong case mode in symbol `E' due to selected case mode `prolog`, try renaming to e instead"
      ]
    )
  , ("CheckSignature",
      [ "Top-level binding with no type signature: hw"
      , "Top-level binding with no type signature: f"
      , "Unused declaration of variable `answer'"
      ]
    )
  , ("NonExhaustivePattern",
      [ "Pattern matches are non-exhaustive", "In a case alternative"
      , "In an equation for `test2'", "In an equation for `and'"
      , "In an equation for `plus'", "In an equation for `len2'"
      , "In an equation for `tuple'", "In an equation for `tuple2'"
      , "In an equation for `g'", "In an equation for `rec'"]
    )
  , ("NoRedundant", [])
  , ("OverlappingPatterns",
      [ "Pattern matches are potentially unreachable", "In a case alternative"
      , "An fcase expression is potentially non-deterministic due to overlapping rules"
      , "Function `i' is potentially non-deterministic due to overlapping rules"
      , "Function `j' is potentially non-deterministic due to overlapping rules"
      , "Function `k' is potentially non-deterministic due to overlapping rules"
      ]
    )
  , ("QualRedundant",
      [ "Redundant context in type signature for function `f': 'P.Eq a'"]
    )
  , ("Redundant",
      [ "Redundant context in type signature for function `f': 'Eq a'"]
    )
  , ("ShadowingSymbols",
      [ "Unused declaration of variable `x'", "Shadowing symbol `x'"])
  , ("TabCharacter",
      [ "Tab character"])
  , ("UnexportedFunction",
      [ "Unused declaration of variable `q'"
      , "Unused declaration of variable `g'" ]
    )
  ]
