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/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
-done
-
-for comp in $compilers; do
-  echo -e "$comp\n============"
-
-  # clean up before using the compiler
-  rm -f  $comp/*
-  rm -rf $subdir
-  if [ ! -d $comp ]; then
-    mkdir $comp
-  fi
-  ln -s  $comp/  $subdir
-
-  # compile targets
-  for mdl in $modules; do
-    for tgt in $targets; do
-      $comp -e -i $importdir --$tgt $mdl
-    done
-  done
-done
-
-rm -rf $subdir
-
-# show differences
-echo "Differences"
-echo "==========="
-diff -brq $compilers
-

test/errors/FunctionalPatterns.curry

-{-# LANGUAGE FunctionalPatterns, Records #-}
-type Foo = { foo :: Bool }
-
-f1 (id v@x) = x
-f2 (id ~(v:vs)) = v
-f3 (id { foo = bar }) = bar

test/Bug780.curry → test/fail/FP_Restrictions.curry

+--- Restrictions for occurrences of functional patterns
+--- Redmine - curry-frontend - bug #780
+
 {-# LANGUAGE FunctionalPatterns #-}
 
 firstLastCaseFun ([x] ++ _ ++ [y]) = (x, y)

test/Kindcheck.curry → test/fail/KindCheck.curry

-module Kindcheck where
+module KindCheck where
 
 data Foo a a = Foo a a
 

test/fail/MultipleDefinitions.curry

+module MultipleDefinitions where
+
+data Rec0 = Rec
+
+data Rec  = Rec { int  :: Int }
+data Rec2 = R2 { int2 :: Int }

test/fail/PatternRestrictions.curry

+{-# LANGUAGE FunctionalPatterns #-}
+data Foo = Foo { foo :: Bool }
+
+f1 (id v@x) = x
+f2 (id ~(v:vs)) = v
+f3 (id Foo { foo = bar }) = bar

test/Bug1276.curry → test/fail/RecordLabelIDs.curry

+--- Internal error when function and label identifier coincide
+--- Redmine - curry-frontend - bug #1276
+
 data Record = Record { id :: Int }
 
 id :: a -> a

test/fail/RecursiveTypeSyn.curry

+--- Recursive type synonyms
+--- Redmine - curry-frontend - bug #489
+
+--- 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 RecursiveTypeSyn where
+
+type A = B
+type B = A
+
+i = Just ()

test/Bug480.curry → test/fail/TypedFreeVariables.curry

+--- Polymorphically typed free variables
+--- Redmine - curry-frontend - bug #480
+
 test :: a
 test = x
   where
@@ -23,4 +26,4 @@ test5 :: (Bool, ())
 test5 = (x, x)
   where
     x :: a
-    x = unknown
\ No newline at end of file
+    x = unknown

test/pass/ACVisibility.curry

+module ACVisibility (T(..), Array, f') where
+
+data T = T
+
+data Array b = Array (Int -> b) (Entry b)
+
+data Entry b = Entry b (Entry b) (Entry b) | Empty
+
+f' :: [a] -> [a]
+f' xs = g' (reverse xs)
+ where
+  g' :: [b] -> [b]
+  g' ys = xs ++ ys

test/AnonymVar.curry → test/pass/AnonymVar.curry

 -- NEW: Anonymous variable
+{-# LANGUAGE AnonFreeVars #-}
 
 f _ = _
 

test/pass/ExplicitLayout.curry

+module Layout where
+{ f x = let { y = 1; z = 2 } in x + y + z
+; g x = case x of { True -> False; False -> True }
+; h x = do { y <- return x; return y }
+}

test/FP_Lifting.curry → test/pass/FP_Lifting.curry

+{-# LANGUAGE FunctionalPatterns #-}
+
 f x = g x &> x
  where
   g (h y) = success

test/Bug1226.curry → test/pass/FP_NonLinearity.curry

+--- Non-linearity between functional and other pattern is not handled correctly
+--- Redmine - curry-frontend - bug #1226
+
 {-
 Nonlinear patterns such as @f x x = x@ should be replaced
 by fresh variables and strict equations:

test/FunctionalPatterns.curry → test/pass/FunctionalPatterns.curry

+{-# LANGUAGE FunctionalPatterns #-}
+
 f (v@[] ++ v@(x:xs)) = x:xs ++ v
 
 g (id ((:) x xs)) = x:xs

test/pass/HaskellRecords.curry

+module HaskellRecords where
+
+data R1 a = C { l :: Int, x :: a }
+          | D { l :: Int }
+
+-- construction
+r1 :: R1 Bool
+r1 = C { l = 42, x = True }
+
+r2 :: R1 a
+r2 = C {}
+
+-- pattern matching
+fun :: R1 a -> Bool
+fun C { l = 42 } = True
+
+fun2 :: R1 a -> Bool
+fun2 C {} = False
+
+-- update
+upd :: R1 Bool -> R1 Bool
+upd r = r { x = False, l = 0 }
+
+-- selection
+getL :: R1 a -> Int
+getL r = l r
+
+data R2 = E { label :: Int, l2 :: Bool }
+
+r :: R2
+r = E { label = 42, l2 = True }
+
+r' :: R2
+r' = r { label = 73 }
+
+unr :: R2
+unr = E { l2 = True }

test/A.curry → test/pass/Hierarchical.curry

-module A where
+module Hierarchical where
 
 import B.C (foo)
 
-main = print foo
\ No newline at end of file
+main = print foo

test/Newtype.curry → test/pass/Newtype1.curry

-module Newtype where
+module Newtype1 where
 
 newtype D a = D a
 

test/Newtype2.curry → test/pass/Newtype2.curry

-import Newtype
+import Newtype1
 
 main :: Int
 main = access val

test/NonLinearLHS.curry → test/pass/NonLinearLHS.curry

+{-# LANGUAGE FunctionalPatterns #-}
+
 double x x = True
 
 multi x y y x = x + y
@@ -15,5 +17,3 @@ leftB a b (_ ++ [a,b] ++ _) = success
 f x (_ ++ [x]) [x] | not x = x
 
 test [x] (x ++ x) (x ++ x) x | null x = x
-
-test2 [x] (id x) ~True | null x = x

test/pass/OperatorDefinition.curry

+--- Parsing error for operator definitions which directly follow an import
+--- statement
+--- Redmine - curry-frontend - bug #494
+
+import Prelude
+
+($) :: (a -> b) -> a -> b
+($) f x = f x

test/RecordTest.curry → test/pass/RecordTest1.curry

-module RecordTest (Agent, lastName, trueIdentity, mike) where
+module RecordTest1 where
 
 data Person = Person { firstName :: String, lastName :: String }
             | Agent  { lastName :: String, trueIdentity :: Person }
 
 mike :: Person
-mike = Person { firstName = "Mike", lastName = "Smith" }
\ No newline at end of file
+mike = Person { firstName = "Mike", lastName = "Smith" }
+
+jim = Person { lastName = "Parson", firstName = "Jim" }
+
+jd :: Person
+jd = Agent {}
+
+newId :: Person -> Person -> Person
+newId p i = p { trueIdentity = i }

test/RecordTest2.curry → test/pass/RecordTest2.curry

 module RecordTest2 where
 
-import RecordTest
+import RecordTest1
 
 updLN = mike { lastName = "Doe" }
 

test/Ticket9.curry → test/pass/RecordTest3.curry

-module Ticket9 where
+--- Internal error in record parsing
+--- Redmine - curry-frontend - bug #9
 
-type Options = { optHelp :: Bool }
+module RecordTest3 where
+
+data Options = Opts { optHelp :: Bool }
 
 options :: [Options -> Options]
 options = []
 
 parseOpts :: Options
-parseOpts = foldl (flip ($)) { optHelp = False } opts
+parseOpts = foldl (flip ($))