Added a simple cabal test suite and reorganized test folder

CHANGELOG.md

@@ -4,6 +4,9 @@ Change log for curry-frontend
 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)
   * Split checking and expansion of export specification into two
     subsequent steps (by Yannik Potdevin, fixes #1335)

curry-frontend.cabal

@@ -128,3 +128,11 @@ Executable cymake
   else
     build-depends: network < 2.6
   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

src/Base/Messages.hs

@@ -17,17 +17,20 @@ import System.Exit                (exitFailure)
 
 import Curry.Base.Message         ( Message, message, posMessage, ppMessage
                                   , ppMessages, ppWarning, ppError)
+import Curry.Base.Monad           (CYIO, failMessages)
+import Curry.Base.Pretty          (text)
 import CompilerOpts               (Options (..), WarnOpts (..), Verbosity (..))
 
 status :: MonadIO m => Options -> String -> m ()
 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
-  liftIO $ putErrLn (show $ ppMessages ppWarning $ sort msgs)
-  when (wnWarnAsError opts) $ liftIO $ do
-    putErrLn "Failed due to -Werror"
-    exitFailure
+  if wnWarnAsError opts
+    then failMessages (msgs ++ [message $ text "Failed due to -Werror"])
+    else liftIO $ putErrLn (show $ ppMessages ppWarning $ sort msgs)
 
 -- |Print a message on 'stdout'
 putMsg :: MonadIO m => String -> m ()

src/Html/CurryHtml.hs

@@ -29,7 +29,7 @@ import Curry.Syntax          (Module (..), lexSource)
 
 import Html.SyntaxColoring
 
-import Base.Messages         (warn, message)
+import Base.Messages         (message)
 import CompilerOpts          (Options (..), WarnOpts (..))
 import CurryBuilder          (buildCurry, findCurry)
 import Modules               (loadAndCheckModule)
@@ -48,16 +48,16 @@ source2html opts s = do
   let outDir  = fromMaybe "." $ optHtmlDir opts
       outFile = outDir </> htmlFile mid
   liftIO $ writeFile outFile doc
-  updateCSSFile opts outDir
+  updateCSSFile outDir
 
 -- |Update the CSS file
-updateCSSFile :: Options -> FilePath -> CYIO ()
-updateCSSFile opts dir = do
+updateCSSFile :: FilePath -> CYIO ()
+updateCSSFile dir = do
   src <- liftIO $ getDataFileName cssFile
   let target = dir </> cssFile
   srcExists <- liftIO $ doesFileExist src
   if srcExists then liftIO $ copyFile src target
-               else warn (optWarnOpts opts) [message $ missingStyleFile src ]
+               else failMessages [message $ missingStyleFile src]
   where
   missingStyleFile f = vcat
     [ text "Could not copy CSS style file:"

test/Bug445.lcurry

-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.

test/Bug489.lcurry

-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 ()

test/Bug494.curry

-import Prelude
-
-($) :: (a -> b) -> a -> b
-($) f x = f x
\ No newline at end of file

test/Export1.curry

-module Export1 (f) where
-
-f :: a -> a
-f x = x

test/Export2.curry

-module Export2 (module Export1) where
-
-import Export1

test/Export3.curry

-module Export3 where
-
-import Export2
-
-main :: Int
-main = f 42

test/HaskellRecords.curry

-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 }

test/MissingCaseCompletion.curry

--- 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

test/OptionsCymake.curry

-{-# OPTIONS_CYMAKE -e -ddump-all #-}
-module OptionsCymake where
-
-type F = { f :: Bool }
\ No newline at end of file

test/PragmaRecords.curry

-{-# LANGUAGE Records #-}
-module PragmaRecords where
-
-type Rec = { bool :: Bool, int :: Int }

test/Qual.curry

-module Qual where
-
-f :: a -> ()
-f x = g (Qual.g x)
-  where g y = y
-
-g :: a -> ()
-g _ = ()

test/RecIdent.curry

-{-# LANGUAGE Records #-}
-module RecIdent where
-
-data Rec0 = Rec
-
-type Rec  = { int  :: Int }
-type Rec2 = { int2 :: Int }

test/RecordTest3.curry

-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 }

test/RecursiveRecords.curry

-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/TestFrontend.hs

+--------------------------------------------------------------------------------
+-- 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'"
+      ]
+    )
+  , ("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'"]
+    )
+  , ("OverlappingPatterns",
+      [ "Pattern matches are unreachable", "In a case alternative"
+      , "An fcase expression is non-deterministic due to overlapping rules"
+      , "Function `i' is non-deterministic due to overlapping rules"
+      , "Function `j' is non-deterministic due to overlapping rules"
+      , "Function `k' is non-deterministic due to overlapping rules"
+      ]
+    )
+  , ("ShadowingSymbols",
+      [ "Unused declaration of variable `x'", "Shadowing symbol `x'"])
+  ]

test/check.sh

-#!/bin/bash
-
-subdir=".curry"
-compilers="cymake cymake_pakcs"
-modules="*.curry"
-targets="flat xml acy uacy"
-importdir="."
-
-function usage()
-{
-  echo "Usage: check.sh [OPTIONS] modules"
-  echo "Compare old and new frontend against each other"
-  echo ""
-  echo "  -i DIR  , --import-dir DIR   Search for libraries in DIR"
-  echo "  -i EXTS , --targets EXTS     Create the target types EXTS (some of flat, xml, acy, uacy)"
-  echo "  -h      , --help             Show this help and exit"
-}
-
-while [ "$1" != "" ]; do
-  case $1 in
-    -i | --import-dir  )    shift
-                            importdir=$1
-                            ;;
-    -t | --targets     )    shift
-                            targets=$1
-                            ;;
-    -h | --help )           usage
-                            exit
-                            ;;
-    * )                     modules=$*
-                            break
-  esac
-  shift