Commit 5b31c12c authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky

Added a simple cabal test suite and reorganized test folder

parent 53527adc
...@@ -4,6 +4,9 @@ Change log for curry-frontend ...@@ -4,6 +4,9 @@ Change log for curry-frontend
Under development (0.4.1) Under development (0.4.1)
================= =================
* Added a simple cabal test suite
* Split import of interfaces/modules and expansion and checking of
import specifications into two modules.
* Improved error messages generated by export check (fixes #1253) * Improved error messages generated by export check (fixes #1253)
* Split checking and expansion of export specification into two * Split checking and expansion of export specification into two
subsequent steps (by Yannik Potdevin, fixes #1335) subsequent steps (by Yannik Potdevin, fixes #1335)
......
...@@ -128,3 +128,11 @@ Executable cymake ...@@ -128,3 +128,11 @@ Executable cymake
else else
build-depends: network < 2.6 build-depends: network < 2.6
ghc-options: -Wall ghc-options: -Wall
Test-Suite test-frontend
type: detailed-0.9
hs-source-dirs: test
default-language: Haskell2010
test-module: TestFrontend
build-depends: base == 4.*, Cabal >= 1.10, curry-base == 0.4.1
, curry-frontend == 0.4.1, filepath
...@@ -17,17 +17,20 @@ import System.Exit (exitFailure) ...@@ -17,17 +17,20 @@ import System.Exit (exitFailure)
import Curry.Base.Message ( Message, message, posMessage, ppMessage import Curry.Base.Message ( Message, message, posMessage, ppMessage
, ppMessages, ppWarning, ppError) , ppMessages, ppWarning, ppError)
import Curry.Base.Monad (CYIO, failMessages)
import Curry.Base.Pretty (text)
import CompilerOpts (Options (..), WarnOpts (..), Verbosity (..)) import CompilerOpts (Options (..), WarnOpts (..), Verbosity (..))
status :: MonadIO m => Options -> String -> m () status :: MonadIO m => Options -> String -> m ()
status opts msg = unless (optVerbosity opts < VerbStatus) (putMsg msg) status opts msg = unless (optVerbosity opts < VerbStatus) (putMsg msg)
warn :: MonadIO m => WarnOpts -> [Message] -> m () -- TODO: bad code: Extend Curry monads (CYT / CYIO) to also track warnings
-- (see ticket 1246)
warn :: WarnOpts -> [Message] -> CYIO ()
warn opts msgs = when (wnWarn opts && not (null msgs)) $ do warn opts msgs = when (wnWarn opts && not (null msgs)) $ do
liftIO $ putErrLn (show $ ppMessages ppWarning $ sort msgs) if wnWarnAsError opts
when (wnWarnAsError opts) $ liftIO $ do then failMessages (msgs ++ [message $ text "Failed due to -Werror"])
putErrLn "Failed due to -Werror" else liftIO $ putErrLn (show $ ppMessages ppWarning $ sort msgs)
exitFailure
-- |Print a message on 'stdout' -- |Print a message on 'stdout'
putMsg :: MonadIO m => String -> m () putMsg :: MonadIO m => String -> m ()
......
...@@ -29,7 +29,7 @@ import Curry.Syntax (Module (..), lexSource) ...@@ -29,7 +29,7 @@ import Curry.Syntax (Module (..), lexSource)
import Html.SyntaxColoring import Html.SyntaxColoring
import Base.Messages (warn, message) import Base.Messages (message)
import CompilerOpts (Options (..), WarnOpts (..)) import CompilerOpts (Options (..), WarnOpts (..))
import CurryBuilder (buildCurry, findCurry) import CurryBuilder (buildCurry, findCurry)
import Modules (loadAndCheckModule) import Modules (loadAndCheckModule)
...@@ -48,16 +48,16 @@ source2html opts s = do ...@@ -48,16 +48,16 @@ source2html opts s = do
let outDir = fromMaybe "." $ optHtmlDir opts let outDir = fromMaybe "." $ optHtmlDir opts
outFile = outDir </> htmlFile mid outFile = outDir </> htmlFile mid
liftIO $ writeFile outFile doc liftIO $ writeFile outFile doc
updateCSSFile opts outDir updateCSSFile outDir
-- |Update the CSS file -- |Update the CSS file
updateCSSFile :: Options -> FilePath -> CYIO () updateCSSFile :: FilePath -> CYIO ()
updateCSSFile opts dir = do updateCSSFile dir = do
src <- liftIO $ getDataFileName cssFile src <- liftIO $ getDataFileName cssFile
let target = dir </> cssFile let target = dir </> cssFile
srcExists <- liftIO $ doesFileExist src srcExists <- liftIO $ doesFileExist src
if srcExists then liftIO $ copyFile src target if srcExists then liftIO $ copyFile src target
else warn (optWarnOpts opts) [message $ missingStyleFile src ] else failMessages [message $ missingStyleFile src]
where where
missingStyleFile f = vcat missingStyleFile f = vcat
[ text "Could not copy CSS style file:" [ text "Could not copy CSS style file:"
......
I don't know if it's really a bug or I only don't understand records well.
The following gives a compiling error:
> fun :: a -> Bool
> fun _ = True
> fun3 :: a -> a -> Bool
> fun3 _ _ = False
> type Rec a = { a :: a, b :: Bool }
> testRecSel1 = { a := 'c', b := True } :> a
> testRecSel2 x y = { a := fun x, b := fun3 y y } :> a
The type of the record used in testRecSel1 somehow propagates
to the type of the record used in testRecSel2.
If one comments the definition of testRecSel1 then there is no error.
Loading this module (in pakcs) leads to cymake <<loop>>.
it might be interesting that the last line is important for this error to
occur; if the last line is omitted or changed to "i = 3" then the expected
error "recursive synonym types" is properly printed.
> module Bug489 where
> type A = B
> type B = A
> i = Just ()
import Prelude
($) :: (a -> b) -> a -> b
($) f x = f x
\ No newline at end of file
module Export1 (f) where
f :: a -> a
f x = x
module Export2 (module Export1) where
import Export1
module Export3 where
import Export2
main :: Int
main = f 42
module HaskellRecords where
-- data R a = C { l :: Int, x :: a }
-- | D { l :: Int }
--
-- -- construction
-- r1 :: R Bool
-- r1 = C { l = 42, x = True }
--
-- r2 :: R a
-- r2 = C {}
--
-- -- pattern matching
-- fun :: R a -> Bool
-- fun C { l = 42 } = True
--
-- fun2 :: R a -> Bool
-- fun2 C {} = False
--
-- -- update
-- upd :: R Bool -> R Bool
-- upd r = r { x = False, l = 0 }
--
-- -- selection
-- getL :: R a -> Int
-- getL r = l r
data R = C { label :: Int, l2 :: Bool }
r :: R
r = C { label = 42, l2 = True }
r' :: R
r' = r { label = 73 }
unr :: R
unr = C { l2 = True }
-- This module belongs to the ticket 1324
module MissingCaseCompletion where
-- The missing constructor False should not be expanded to "False -> Failed".
-- Instead it should be omitted.
f :: Bool -> Int
f b = case b of
True -> 1
-- The catch all pattern should be expanded to "False -> 0".
g :: Bool -> Int
g b = case b of
True -> 1
_ -> 0
-- The catch all pattern should be expanded to "False -> failed"
h :: Bool -> Int
h b = case b of
True -> 1
_ -> failed
-- To summarize the issue: If a case expression explicitely ignores at least one
-- constructor (i.e. it does not enumerate everyone and does not use a default
-- pattern), do not fill up with missing constructors and failed expressions.
\ No newline at end of file
{-# OPTIONS_CYMAKE -e -ddump-all #-}
module OptionsCymake where
type F = { f :: Bool }
\ No newline at end of file
{-# LANGUAGE Records #-}
module PragmaRecords where
type Rec = { bool :: Bool, int :: Int }
module Qual where
f :: a -> ()
f x = g (Qual.g x)
where g y = y
g :: a -> ()
g _ = ()
{-# LANGUAGE Records #-}
module RecIdent where
data Rec0 = Rec
type Rec = { int :: Int }
type Rec2 = { int2 :: Int }
import RecursiveRecords
import RecordTest2
r :: R Int
r = { f1 := 4, f2 := "hello" }
e = showR r
-- type R1 a b = { f1 :: a, f2 :: b }
-- type R2 = { f3 :: Int }
--
-- type R3 a b = { f5 :: a, f4 :: Maybe b }
--
-- type Person = { name :: String, age :: Int }
--
-- type Address = { person :: Person, street :: String, city :: String }
--
-- smith :: Person
-- smith = { name := "Smith", age := 20 }
--
-- a :: Address
-- a = { person := smith, street := "Main Street", city := "New York" }
-- p2 = { name := "Doe" }
-- data T = T (R3 Int)
--f :: R1 -> R1
--f x = x + 1
--g :: R3 Int -> R3 Int
--g x = not x
--r1 = { f1 := False, f2 := "" }
-- r2 :: R2
-- r2 = { f3 := Just 1 }
-- r3 :: R1 Bool String
--r3 = { f4 := Just 1, f5 := "" }
--inc :: Int -> Int
--inc = (+1)
-- e :: Maybe Bool
--sel1 = (r3 :> f5)
-- upd1 = { f1 := True | r2 }
-- upd2 = { f3 := True | r2 }
-- pat1 { name = "Smith", age = 25 } = True
-- pat2 { person = p | _} = p
--r1 :: R1
--r1 = { f1 := False, f2 := r2 }
--r3 :: R3 Int
--r3 = { f4 := "", f5 := Just 1 }
--e = { f2 := r3 | r1}
--type RR = { f6 :: RR }
type R a = { f1 :: a, f2 :: String }
type Person = { name :: String, age :: Int, friends :: [Person] }
john = { name := "John", age := 21, friends := [tim] }
tim = { name := "Tim", age := 26, friends := [john] }
ann = { name := "Ann", age := 20, friends := [john,ann] }
getFriends :: Person -> [Person]
getFriends p = p :> friends
addFriend :: Person -> Person -> Person
addFriend p friend = { friends := friend : (getFriends p) | p }
getNames :: Person -> [String]
getNames { friends = fs | _ } = map (\p -> p :> name) fs
--------------------------------------------------------------------------------
type R1 = { r2 :: R2 }
type R2 = { r1 :: R1 }
rec1 = { r2 := rec2 }
rec2 = { r1 := rec1 }
type R3 = { r3 :: TSR3 }
type TSR3 = R3
\ No newline at end of file
--------------------------------------------------------------------------------
-- 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'
module TestFrontend (tests) where
import Data.List (isInfixOf, sort)
import Distribution.TestSuite
import System.FilePath (FilePath, (</>), (<.>))
import Curry.Base.Message (Message, ppMessages, ppError)
import Curry.Base.Monad (runCYIO)
import qualified CompilerOpts as CO ( Options (..), WarnOpts (..)
, Verbosity (VerbQuiet)
, defaultOptions, defaultWarnOpts)
import CurryBuilder (buildCurry)
tests :: IO [Test]
tests = return [passingTests, warningTests, failingTests]
-- Execute a test by calling cymake
runTest :: CO.Options -> String -> [String] -> IO Progress
runTest opts test [] = runCYIO (buildCurry opts test) >>= passOrFail
where
passOrFail = (Finished <$>) . either fail pass
fail msgs
| null msgs = return Pass
| otherwise = return $ Fail $ "An unexpected failure occurred"
pass _ = return Pass
runTest opts test errorMsgs = runCYIO (buildCurry opts' test) >>= catchE
where
opts' = opts { CO.optWarnOpts =
CO.defaultWarnOpts { CO.wnWarnAsError = True } }
catchE = (Finished <$>) . either pass fail
pass msgs = let errorStr = showMessages msgs
in if all (`isInfixOf` errorStr) errorMsgs
then return Pass
else return $ Fail $ "Expected warning/failure did not occur: " ++ errorStr
fail _ = return $ Fail "Expected warning/failure did not occur"
showMessages :: [Message] -> String
showMessages = show . ppMessages ppError . sort
-- group of tests which should pass
passingTests :: Test
passingTests = Group { groupName = "Passing Tests"
, concurrently = False
, groupTests = map (mkTest "test/pass/") passInfos
}
-- 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 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 passing tests
--------------------------------------------------------------------------------
-- generate a simple passing test
mkPassTest :: String -> TestInfo
mkPassTest name = (name, [], [], Nothing, [])
-- 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"
, "DefaultPrecedence"
, "Dequeue"
, "ExplicitLayout"
, "FCase"
, "FP_Lifting"
, "FP_NonLinearity"
, "FunctionalPatterns"
, "HaskellRecords"
, "Hierarchical"
, "Infix"
, "Inline"
, "Lambda"
, "Maybe"
, "NegLit"
, "Newtype1"
, "Newtype2"
, "NonLinearLHS"
, "OperatorDefinition"
, "PatDecl"
, "Prelude"
, "Pretty"
, "RecordsPolymorphism"
, "RecordTest1"
, "RecordTest2"
, "RecordTest3"
, "ReexportTest"
, "SelfExport"
, "SpaceLeak"
, "TyConsTest"
, "TypedExpr"
, "UntypedAcy"
, "Unzip"
]
--------------------------------------------------------------------------------
-- 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)
[ ("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 `Foo' in export list"])
, ("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"
]
)
, ("ImportError",
[ "Module Prelude does not export foo"
, "Module Prelude does not export bar"
]
)
, ("KindCheck",
[ "Type variable a occurs more than once on left hand side of type declaration"
, "Type variable b occurs more than once on left hand side of type declaration"
]
)
, ("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", ["Recursive synonym types A and B"])
, ("SyntaxError", ["Type error in application"])
, ("TypedFreeVariables",
["Free variable x has a polymorphic type", "Type signature too general"]
)
, ("TypeError1",
[ "Type error in explicitly typed expression"
, "Type signature too general"
]
)
, ("TypeError2", ["Type error in infix application"])
]
--------------------------------------------------------------------------------
-- 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 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 unreachable"
, "Function `fp' is non-deterministic due to overlapping rules"
, "Pattern matches are non-exhaustive"
]
)
, ("CheckSignature",
[ "Top-level binding with no type signature: hw"
, "Top-level binding with no type signature: f"
, "Unused declaration of variable `answer'"
]
)