Commit 1ce872e2 authored by Kai-Oliver Prott's avatar Kai-Oliver Prott

Fix some tests that fail with the new data-class

parent 4650672a
......@@ -1174,8 +1174,9 @@ tcFuncPattern _ spi _ f ts ps ty [] =
tcFuncPattern p spi doc f ts ps ty (t':ts') = do
(alpha, beta) <-
tcArrow p "functional pattern" (doc $-$ text "Term:" <+> pPrintPrec 0 t) ty
(ps', t'') <- tcPatternArg p "functional pattern" doc ps alpha t'
tcFuncPattern p spi doc f (ts . (t'' :)) ps' beta ts'
let ps' = Set.insert (Pred qDataId alpha) ps
(ps'', t'') <- tcPatternArg p "functional pattern" doc ps' alpha t'
tcFuncPattern p spi doc f (ts . (t'' :)) ps'' beta ts'
where t = FunctionPattern spi ty f (ts [])
tcPatternArg :: HasPosition p => p -> String -> Doc -> PredSet -> Type
......@@ -1212,7 +1213,7 @@ tcExpr _ _ (Literal spi _ l) = do
tcExpr _ _ (Variable spi _ v) = do
m <- getModuleIdent
vEnv <- getValueEnv
(ps, ty) <- if isAnonId (unqualify v) then freshPredType []
(ps, ty) <- if isAnonId (unqualify v) then freshPredType [qDataId]
else inst (snd $ funType m v vEnv)
return (ps, ty, Variable spi ty v)
tcExpr _ _ (Constructor spi _ c) = do
......
......@@ -506,7 +506,7 @@ parseCppDefinition arg optErr
= onCppOpts (addCppDefinition s v) optErr
| otherwise
= addErr (cppDefinitionErr arg) optErr
where (s, v) = fmap (drop 1) $ break ('=' ==) arg
where (s, v) = drop 1 <$> break ('=' ==) arg
addCppDefinition :: String -> String -> CppOpts -> CppOpts
addCppDefinition s v opts =
......
......@@ -26,6 +26,7 @@ import Prelude hiding (fail)
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)
......@@ -36,11 +37,12 @@ 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 [passingTests, warningTests, failingTests]
tests = return [failingTests, passingTests, warningTests]
runSecure :: CYIO a -> IO (Either [Message] (a, [Message]))
runSecure act = runCYIO act `E.catch` handler
......@@ -48,40 +50,47 @@ runSecure act = runCYIO act `E.catch` handler
-- Execute a test by calling cymake
runTest :: CO.Options -> String -> [String] -> IO Progress
runTest opts test [] = passOrFail <$> runSecure (buildCurry opts' test)
where
wOpts = CO.optWarnOpts opts
wFlags = CO.WarnUnusedBindings
: CO.WarnUnusedGlobalBindings
: CO.wnWarnFlags wOpts
opts' = opts { CO.optForce = True
, CO.optWarnOpts = wOpts { CO.wnWarnFlags = wFlags }
}
passOrFail = Finished . either fail pass
fail msgs
| null msgs = Pass
| otherwise = Fail $ "An unexpected failure occurred: " ++ showMessages msgs
pass _ = Pass
runTest opts test errorMsgs = catchE <$> runSecure (buildCurry opts' test)
where
wOpts = CO.optWarnOpts opts
wFlags = CO.WarnUnusedBindings
: CO.WarnUnusedGlobalBindings
: CO.wnWarnFlags wOpts
opts' = opts { CO.optForce = True
, CO.optWarnOpts = wOpts { CO.wnWarnFlags = wFlags }
}
catchE = Finished . either pass fail
pass msgs = let errorStr = showMessages msgs
leftOverMsgs = filter (not . flip isInfixOf errorStr) errorMsgs
in if null leftOverMsgs
then Pass
else Fail $ "Expected warnings/failures did not occur: " ++ unwords leftOverMsgs
fail = pass . snd
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"
......@@ -89,13 +98,6 @@ passingTests = Group { groupName = "Passing Tests"
, 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"
......@@ -129,72 +131,6 @@ 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 = 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"
, "ChurchEncoding"
, "ClassMethods"
, "DataPass"
, "DefaultPrecedence"
, "Dequeue"
, "EmptyWhere"
, "ExplicitLayout"
, "FCase"
, "FP_Lifting"
, "FP_NonCyclic"
, "FP_NonLinearity"
, "FunctionalPatterns"
, "HaskellRecords"
, "Hierarchical"
, "ImportRestricted"
, "ImportRestricted2"
, "ImpredDollar"
, "Infix"
, "Inline"
, "Lambda"
, "Maybe"
, "Monad"
, "NegLit"
, "Newtype1"
, "Newtype2"
, "NonLinearLHS"
, "OperatorDefinition"
, "PatDecl"
, "Prelude"
, "Pretty"
, "RankNTypes"
, "RankNTypesFuncPats"
, "RankNTypesImport"
, "RecordsPolymorphism"
, "RecordTest1"
, "RecordTest2"
, "RecordTest3"
, "ReexportTest"
, "ScottEncoding"
, "SelfExport"
, "SpaceLeak"
, "Subsumption"
, "TermInv"
, "TyConsTest"
, "TypedExpr"
, "UntypedAcy"
, "Unzip"
, "WhereAfterDo"
]
--------------------------------------------------------------------------------
-- Definition of failing tests
--------------------------------------------------------------------------------
......@@ -218,8 +154,8 @@ failInfos = map (uncurry mkFailTest)
)
, ("DataFail",
[ "Missing instance for Prelude.Data Test1"
, "Missing instance for Prelude.Data (Test2 _3)"
, "Missing instance for Prelude.Data (Test2 _5)"
, "Missing instance for Prelude.Data (Test2"
, "Missing instance for Prelude.Data (Test2"
, "Missing instance for Prelude.Data Test1"
]
)
......@@ -334,6 +270,7 @@ failInfos = map (uncurry mkFailTest)
, ("PragmaError", ["Unknown language extension"])
, ("PrecedenceRange", ["Precedence out of range"])
, ("RankNTypes", ["Arbitrary-rank types are not supported in standard Curry."])
, ("RankNTypesFuncPats", ["Missing instance for Prelude.Data (Prelude.Int ->"])
, ("RecordLabelIDs", ["Multiple declarations of `RecordLabelIDs.id'"])
, ("RecursiveTypeSyn", ["Mutually recursive synonym and/or renaming types A and B (line 12.6)"])
, ("Subsumption",
......@@ -370,6 +307,71 @@ failInfos = map (uncurry mkFailTest)
)
]
--------------------------------------------------------------------------------
-- 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"
, "ChurchEncoding"
, "ClassMethods"
, "DataPass"
, "DefaultPrecedence"
, "Dequeue"
, "EmptyWhere"
, "ExplicitLayout"
, "FCase"
, "FP_Lifting"
, "FP_NonCyclic"
, "FP_NonLinearity"
, "FunctionalPatterns"
, "HaskellRecords"
, "Hierarchical"
, "ImportRestricted"
, "ImportRestricted2"
, "ImpredDollar"
, "Infix"
, "Inline"
, "Lambda"
, "Maybe"
, "Monad"
, "NegLit"
, "Newtype1"
, "Newtype2"
, "NonLinearLHS"
, "OperatorDefinition"
, "PatDecl"
, "Prelude"
, "Pretty"
, "RankNTypes"
, "RankNTypesImport"
, "RecordsPolymorphism"
, "RecordTest1"
, "RecordTest2"
, "RecordTest3"
, "ReexportTest"
, "ScottEncoding"
, "SelfExport"
, "SpaceLeak"
, "Subsumption"
, "TermInv"
, "TyConsTest"
, "TypedExpr"
, "UntypedAcy"
, "Unzip"
, "WhereAfterDo"
]
--------------------------------------------------------------------------------
-- Definition of warning tests
--------------------------------------------------------------------------------
......
......@@ -3,9 +3,19 @@
data Bag _ a = Bag a
data Elem _ a = Elem a
instance Functor (Bag s) where
fmap f (Bag a) = Bag (f a)
instance Applicative (Bag s) where
pure = returnBag
mf <*> ma = do
f <- mf
a <- ma
return (f a)
instance Monad (Bag s) where
(>>=) = bindBag
return = returnBag
(>>=) = bindBag
bindBag :: Bag s a -> (a -> Bag s b) -> Bag s b
bindBag b f = case b of
......
This diff is collapsed.
......@@ -27,6 +27,13 @@ append xs ys = ChurchList (\k z -> runList xs k (runList ys k z))
instance Functor ChurchList where
fmap f xs = ChurchList (\k z -> runList xs (\x xs' -> k (f x) xs') z)
instance Applicative ChurchList where
pure = singleton
mf <*> ma = do
f <- mf
a <- ma
return (f a)
instance Monad ChurchList where
return = singleton
xs >>= f = runList xs (\x -> append (f x)) empty
......@@ -64,6 +71,13 @@ instance Show a => Show (ChurchMaybe a) where
instance Functor ChurchMaybe where
fmap f (ChurchMaybe m) = ChurchMaybe (\n j -> m n (j . f))
instance Applicative ChurchMaybe where
pure x = ChurchMaybe (\_ j -> j x)
mf <*> ma = do
f <- mf
a <- ma
return (f a)
instance Monad ChurchMaybe where
return x = ChurchMaybe (\_ j -> j x)
ChurchMaybe m >>= f = m nothing f
\ No newline at end of file
ChurchMaybe m >>= f = m nothing f
......@@ -2,18 +2,17 @@
f x = g x &> x
where
g (h y) = success
-- causes an error since h is not global
--h y = x
g (h y) = success
where z = y :: Int
h y = error "undefined"
main = f z
where z free
{-
f2 x = g2 x x &> x
g2 x1 z = h2 x2 y =:<= z &> x1 =:= x2 &> success
g2 x1 z = h2 x2 (y :: Int) =:<= z &> x1 =:= x2 &> success
where x2, y free
h2 x y = x
......@@ -24,6 +23,7 @@ main2 = f2 z
f3 x = g3 x x &> x
g3 x (h3 x y) = success
where z = y :: Int
h3 x y = x
......@@ -34,4 +34,3 @@ patid x (id x) = x
f5 (id x) (id x) = x
-}
......@@ -56,19 +56,19 @@ k a b | id x =:<= a &> id y =:<= b &> x =:= y = x
{-# LANGUAGE FunctionalPatterns #-}
f :: a -> a -> a
f :: Data a => a -> a -> a
f x (id x) = x
-- Expected translation:
-- f x y = let z free in id z =:<= y &> x =:= z &> x
g :: a -> a -> a
g :: Data a => a -> a -> a
g (id x) (id x) = x
-- Expected translation:
-- g x y = let a, b free in id a =:<= x &> id b =:<= y &> a =:= b &> a
h :: (a, a) -> a
h :: Data a => (a, a) -> a
h (pair x x) = x
-- Expected translation:
......
This diff is collapsed.
......@@ -116,9 +116,19 @@ type EqFunc = forall a. Eq a => a -> a -> Bool
data Bag _ a = Bag a
data Elem _ a = Elem a
instance Functor (Bag s) where
fmap f (Bag a) = Bag (f a)
instance Applicative (Bag s) where
pure = returnBag
mf <*> ma = do
f <- mf
a <- ma
return (f a)
instance Monad (Bag s) where
(>>=) = bindBag
return = returnBag
(>>=) = bindBag
bindBag :: Bag s a -> (a -> Bag s b) -> Bag s b
bindBag b f = case b of
......
This diff is collapsed.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment