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
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)
......
......@@ -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
......@@ -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 ()
......
......@@ -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:"
......
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
This diff is collapsed.
#!/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
{-# LANGUAGE FunctionalPatterns, Records #-}
type Foo = { foo :: Bool }
f1 (id v@x) = x
f2 (id ~(v:vs)) = v
f3 (id { foo = bar }) = bar
--- Restrictions for occurrences of functional patterns
--- Redmine - curry-frontend - bug #780
{-# LANGUAGE FunctionalPatterns #-}
firstLastCaseFun ([x] ++ _ ++ [y]) = (x, y)
......
module Kindcheck where
module KindCheck where
data Foo a a = Foo a a
......
module MultipleDefinitions where
data Rec0 = Rec
data Rec = Rec { int :: Int }
data Rec2 = R2 { int2 :: Int }
{-# LANGUAGE FunctionalPatterns #-}
data Foo = Foo { foo :: Bool }
f1 (id v@x) = x
f2 (id ~(v:vs)) = v
f3 (id Foo { foo = bar }) = bar
--- Internal error when function and label identifier coincide
--- Redmine - curry-frontend - bug #1276
data Record = Record { id :: Int }
id :: a -> a
......
--- 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 ()
--- 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
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
-- NEW: Anonymous variable
{-# LANGUAGE AnonFreeVars #-}
f _ = _
......
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 }
}
{-# LANGUAGE FunctionalPatterns #-}
f x = g x &> x
where
g (h y) = success
......
--- 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:
......
{-# LANGUAGE FunctionalPatterns #-}
f (v@[] ++ v@(x:xs)) = x:xs ++ v
g (id ((:) x xs)) = x:xs
......
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 }
module A where
module Hierarchical where
import B.C (foo)
main = print foo
\ No newline at end of file
main = print foo
module Newtype where
module Newtype1 where
newtype D a = D a
......
import Newtype
import Newtype1
main :: Int
main = access val
......
{-# 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
--- 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
This diff is collapsed.
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 }
module RecordTest2 where
import RecordTest
import RecordTest1
updLN = mike { lastName = "Doe" }
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 ($))