From 5b31c12caa2bacbd4e11ead140118862a9f3f960 Mon Sep 17 00:00:00 2001 From: Jan Tikovsky Date: Thu, 10 Mar 2016 09:45:34 +0100 Subject: [PATCH] Added a simple cabal test suite and reorganized test folder --- CHANGELOG.md | 3 + curry-frontend.cabal | 8 + src/Base/Messages.hs | 13 +- src/Html/CurryHtml.hs | 10 +- test/A.curry | 5 - test/Bug1276.curry | 4 - test/Bug445.lcurry | 18 - test/Bug489.lcurry | 11 - test/Bug494.curry | 4 - test/Export1.curry | 4 - test/Export2.curry | 3 - test/Export3.curry | 6 - test/HaskellRecords.curry | 37 - test/MissingCaseCompletion.curry | 24 - test/OptionsCymake.curry | 4 - test/PragmaRecords.curry | 4 - test/Qual.curry | 8 - test/RecIdent.curry | 7 - test/RecordTest.curry | 7 - test/RecordTest3.curry | 64 -- test/RecursiveRecords.curry | 30 - test/TestFrontend.hs | 273 ++++++ test/Ticket9.curry | 10 - test/check.sh | 61 -- test/errors/FunctionalPatterns.curry | 6 - test/{ => fail}/Bool.curry | 0 test/{ => fail}/ErrorMultipleSignature.curry | 0 .../ExportCheck}/AmbiguousName.curry | 0 .../ExportCheck}/AmbiguousType.curry | 0 .../ExportCheck}/ModuleNotImported.curry | 0 .../ExportCheck}/MultipleName.curry | 0 .../ExportCheck}/MultipleType.curry | 0 .../ExportCheck}/NoDataType.curry | 0 .../ExportCheck}/OutsideTypeConstructor.curry | 0 .../ExportCheck}/OutsideTypeLabel.curry | 0 .../ExportCheck}/UndefinedElement.curry | 0 .../ExportCheck}/UndefinedName.curry | 0 .../ExportCheck}/UndefinedType.curry | 0 .../FP_Restrictions.curry} | 3 + test/{ => fail}/ImportError.curry | 0 .../{Kindcheck.curry => fail/KindCheck.curry} | 2 +- test/{ => fail}/MultipleArities.curry | 0 test/fail/MultipleDefinitions.curry | 6 + .../{errors => fail}/MultiplePrecedence.curry | 0 test/fail/PatternRestrictions.curry | 6 + test/{ => fail}/PragmaError.curry | 0 .../PrecedenceRange.curry} | 0 test/{ => fail}/Prelude.curry | 0 test/fail/RecordLabelIDs.curry | 7 + test/fail/RecursiveTypeSyn.curry | 14 + test/{ => fail}/SyntaxError.curry | 0 test/{Typed.curry => fail/TypeError1.curry} | 0 .../TypeError2.curry} | 0 .../TypedFreeVariables.curry} | 5 +- test/pass/ACVisibility.curry | 13 + test/{ => pass}/AbstractCurryBug.curry | 0 test/{ => pass}/AnonymVar.curry | 1 + test/{ => pass}/B/C.curry | 0 test/{ => pass}/CaseComplete.curry | 0 test/{ => pass}/DefaultPrecedence.curry | 0 test/{ => pass}/Dequeue.curry | 0 test/pass/ExplicitLayout.curry | 5 + test/{ => pass}/FCase.curry | 0 test/{ => pass}/FP_Lifting.curry | 2 + .../FP_NonLinearity.curry} | 3 + test/{ => pass}/FunctionalPatterns.curry | 2 + test/pass/HaskellRecords.curry | 37 + test/pass/Hierarchical.curry | 5 + test/{ => pass}/Infix.curry | 0 test/{ => pass}/Inline.curry | 0 test/{ => pass}/Lambda.curry | 0 test/{ => pass}/List.curry | 0 test/{ => pass}/Maybe.curry | 0 test/{ => pass}/NegLit.curry | 0 test/{Newtype.curry => pass/Newtype1.curry} | 2 +- test/{ => pass}/Newtype2.curry | 2 +- test/{ => pass}/NonLinearLHS.curry | 4 +- test/pass/OperatorDefinition.curry | 8 + test/{ => pass}/PatDecl.curry | 0 test/pass/Prelude.curry | 861 ++++++++++++++++++ test/{ => pass}/Pretty.curry | 0 test/pass/RecordTest1.curry | 15 + test/{ => pass}/RecordTest2.curry | 2 +- test/pass/RecordTest3.curry | 13 + test/pass/RecordsPolymorphism.curry | 21 + test/{Main.curry => pass/ReexportTest.curry} | 2 + test/{ => pass}/SelfExport.curry | 0 test/{ => pass}/Set.curry | 0 test/{ => pass}/SpaceLeak.curry | 0 test/{ => pass}/TyConsTest.curry | 0 test/{ => pass}/TypedExpr.curry | 0 test/{ => pass}/UntypedAcy.curry | 0 test/{ => pass}/Unzip.curry | 0 test/{ => warning}/AliasClash.curry | 0 test/{Case.curry => warning/Case1.curry} | 0 test/{ => warning}/Case2.curry | 0 test/{ => warning}/CheckSignature.curry | 0 test/warning/List.curry | 5 + test/warning/Maybe.curry | 72 ++ test/{ => warning}/NonExhaustivePattern.curry | 5 +- test/{ => warning}/OverlappingPatterns.curry | 0 test/warning/Prelude.curry | 861 ++++++++++++++++++ .../ShadowingSymbols.curry} | 4 +- 103 files changed, 2273 insertions(+), 339 deletions(-) delete mode 100644 test/A.curry delete mode 100644 test/Bug1276.curry delete mode 100644 test/Bug445.lcurry delete mode 100644 test/Bug489.lcurry delete mode 100644 test/Bug494.curry delete mode 100644 test/Export1.curry delete mode 100644 test/Export2.curry delete mode 100644 test/Export3.curry delete mode 100644 test/HaskellRecords.curry delete mode 100644 test/MissingCaseCompletion.curry delete mode 100644 test/OptionsCymake.curry delete mode 100644 test/PragmaRecords.curry delete mode 100644 test/Qual.curry delete mode 100644 test/RecIdent.curry delete mode 100644 test/RecordTest.curry delete mode 100644 test/RecordTest3.curry delete mode 100644 test/RecursiveRecords.curry create mode 100644 test/TestFrontend.hs delete mode 100644 test/Ticket9.curry delete mode 100755 test/check.sh delete mode 100644 test/errors/FunctionalPatterns.curry rename test/{ => fail}/Bool.curry (100%) rename test/{ => fail}/ErrorMultipleSignature.curry (100%) rename test/{exportcheck => fail/ExportCheck}/AmbiguousName.curry (100%) rename test/{exportcheck => fail/ExportCheck}/AmbiguousType.curry (100%) rename test/{exportcheck => fail/ExportCheck}/ModuleNotImported.curry (100%) rename test/{exportcheck => fail/ExportCheck}/MultipleName.curry (100%) rename test/{exportcheck => fail/ExportCheck}/MultipleType.curry (100%) rename test/{exportcheck => fail/ExportCheck}/NoDataType.curry (100%) rename test/{exportcheck => fail/ExportCheck}/OutsideTypeConstructor.curry (100%) rename test/{exportcheck => fail/ExportCheck}/OutsideTypeLabel.curry (100%) rename test/{exportcheck => fail/ExportCheck}/UndefinedElement.curry (100%) rename test/{exportcheck => fail/ExportCheck}/UndefinedName.curry (100%) rename test/{exportcheck => fail/ExportCheck}/UndefinedType.curry (100%) rename test/{Bug780.curry => fail/FP_Restrictions.curry} (77%) rename test/{ => fail}/ImportError.curry (100%) rename test/{Kindcheck.curry => fail/KindCheck.curry} (67%) rename test/{ => fail}/MultipleArities.curry (100%) create mode 100644 test/fail/MultipleDefinitions.curry rename test/{errors => fail}/MultiplePrecedence.curry (100%) create mode 100644 test/fail/PatternRestrictions.curry rename test/{ => fail}/PragmaError.curry (100%) rename test/{Precedence.curry => fail/PrecedenceRange.curry} (100%) rename test/{ => fail}/Prelude.curry (100%) create mode 100644 test/fail/RecordLabelIDs.curry create mode 100644 test/fail/RecursiveTypeSyn.curry rename test/{ => fail}/SyntaxError.curry (100%) rename test/{Typed.curry => fail/TypeError1.curry} (100%) rename test/{TypeError.curry => fail/TypeError2.curry} (100%) rename test/{Bug480.curry => fail/TypedFreeVariables.curry} (76%) create mode 100644 test/pass/ACVisibility.curry rename test/{ => pass}/AbstractCurryBug.curry (100%) rename test/{ => pass}/AnonymVar.curry (68%) rename test/{ => pass}/B/C.curry (100%) rename test/{ => pass}/CaseComplete.curry (100%) rename test/{ => pass}/DefaultPrecedence.curry (100%) rename test/{ => pass}/Dequeue.curry (100%) create mode 100644 test/pass/ExplicitLayout.curry rename test/{ => pass}/FCase.curry (100%) rename test/{ => pass}/FP_Lifting.curry (90%) rename test/{Bug1226.curry => pass/FP_NonLinearity.curry} (93%) rename test/{ => pass}/FunctionalPatterns.curry (68%) create mode 100644 test/pass/HaskellRecords.curry create mode 100644 test/pass/Hierarchical.curry rename test/{ => pass}/Infix.curry (100%) rename test/{ => pass}/Inline.curry (100%) rename test/{ => pass}/Lambda.curry (100%) rename test/{ => pass}/List.curry (100%) rename test/{ => pass}/Maybe.curry (100%) rename test/{ => pass}/NegLit.curry (100%) rename test/{Newtype.curry => pass/Newtype1.curry} (72%) rename test/{ => pass}/Newtype2.curry (77%) rename test/{ => pass}/NonLinearLHS.curry (87%) create mode 100644 test/pass/OperatorDefinition.curry rename test/{ => pass}/PatDecl.curry (100%) create mode 100644 test/pass/Prelude.curry rename test/{ => pass}/Pretty.curry (100%) create mode 100644 test/pass/RecordTest1.curry rename test/{ => pass}/RecordTest2.curry (76%) create mode 100644 test/pass/RecordTest3.curry create mode 100644 test/pass/RecordsPolymorphism.curry rename test/{Main.curry => pass/ReexportTest.curry} (56%) rename test/{ => pass}/SelfExport.curry (100%) rename test/{ => pass}/Set.curry (100%) rename test/{ => pass}/SpaceLeak.curry (100%) rename test/{ => pass}/TyConsTest.curry (100%) rename test/{ => pass}/TypedExpr.curry (100%) rename test/{ => pass}/UntypedAcy.curry (100%) rename test/{ => pass}/Unzip.curry (100%) rename test/{ => warning}/AliasClash.curry (100%) rename test/{Case.curry => warning/Case1.curry} (100%) rename test/{ => warning}/Case2.curry (100%) rename test/{ => warning}/CheckSignature.curry (100%) create mode 100644 test/warning/List.curry create mode 100644 test/warning/Maybe.curry rename test/{ => warning}/NonExhaustivePattern.curry (69%) rename test/{ => warning}/OverlappingPatterns.curry (100%) create mode 100644 test/warning/Prelude.curry rename test/{Shadow.curry => warning/ShadowingSymbols.curry} (67%) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1637f4e7..4db51a9e 100644 --- a/CHANGELOG.md +++ b/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) diff --git a/curry-frontend.cabal b/curry-frontend.cabal index eb11f9e7..e429794d 100644 --- a/curry-frontend.cabal +++ b/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 diff --git a/src/Base/Messages.hs b/src/Base/Messages.hs index 32247240..04a10e1e 100644 --- a/src/Base/Messages.hs +++ b/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 () diff --git a/src/Html/CurryHtml.hs b/src/Html/CurryHtml.hs index ba6cd7a1..838faf95 100644 --- a/src/Html/CurryHtml.hs +++ b/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:" diff --git a/test/A.curry b/test/A.curry deleted file mode 100644 index 4e4eddad..00000000 --- a/test/A.curry +++ /dev/null @@ -1,5 +0,0 @@ -module A where - -import B.C (foo) - -main = print foo \ No newline at end of file diff --git a/test/Bug1276.curry b/test/Bug1276.curry deleted file mode 100644 index 199daf86..00000000 --- a/test/Bug1276.curry +++ /dev/null @@ -1,4 +0,0 @@ -data Record = Record { id :: Int } - -id :: a -> a -id x = x diff --git a/test/Bug445.lcurry b/test/Bug445.lcurry deleted file mode 100644 index 00ee4628..00000000 --- a/test/Bug445.lcurry +++ /dev/null @@ -1,18 +0,0 @@ -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. diff --git a/test/Bug489.lcurry b/test/Bug489.lcurry deleted file mode 100644 index f50d4015..00000000 --- a/test/Bug489.lcurry +++ /dev/null @@ -1,11 +0,0 @@ -Loading this module (in pakcs) leads to cymake <>. -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 () diff --git a/test/Bug494.curry b/test/Bug494.curry deleted file mode 100644 index 560146b9..00000000 --- a/test/Bug494.curry +++ /dev/null @@ -1,4 +0,0 @@ -import Prelude - -($) :: (a -> b) -> a -> b -($) f x = f x \ No newline at end of file diff --git a/test/Export1.curry b/test/Export1.curry deleted file mode 100644 index cea80d30..00000000 --- a/test/Export1.curry +++ /dev/null @@ -1,4 +0,0 @@ -module Export1 (f) where - -f :: a -> a -f x = x diff --git a/test/Export2.curry b/test/Export2.curry deleted file mode 100644 index 182f62c3..00000000 --- a/test/Export2.curry +++ /dev/null @@ -1,3 +0,0 @@ -module Export2 (module Export1) where - -import Export1 diff --git a/test/Export3.curry b/test/Export3.curry deleted file mode 100644 index 44660ee8..00000000 --- a/test/Export3.curry +++ /dev/null @@ -1,6 +0,0 @@ -module Export3 where - -import Export2 - -main :: Int -main = f 42 diff --git a/test/HaskellRecords.curry b/test/HaskellRecords.curry deleted file mode 100644 index 25f907d3..00000000 --- a/test/HaskellRecords.curry +++ /dev/null @@ -1,37 +0,0 @@ -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 } diff --git a/test/MissingCaseCompletion.curry b/test/MissingCaseCompletion.curry deleted file mode 100644 index 910f4a4e..00000000 --- a/test/MissingCaseCompletion.curry +++ /dev/null @@ -1,24 +0,0 @@ --- 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 diff --git a/test/OptionsCymake.curry b/test/OptionsCymake.curry deleted file mode 100644 index 08b94021..00000000 --- a/test/OptionsCymake.curry +++ /dev/null @@ -1,4 +0,0 @@ -{-# OPTIONS_CYMAKE -e -ddump-all #-} -module OptionsCymake where - -type F = { f :: Bool } \ No newline at end of file diff --git a/test/PragmaRecords.curry b/test/PragmaRecords.curry deleted file mode 100644 index 601efebe..00000000 --- a/test/PragmaRecords.curry +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE Records #-} -module PragmaRecords where - -type Rec = { bool :: Bool, int :: Int } diff --git a/test/Qual.curry b/test/Qual.curry deleted file mode 100644 index 48d739d4..00000000 --- a/test/Qual.curry +++ /dev/null @@ -1,8 +0,0 @@ -module Qual where - -f :: a -> () -f x = g (Qual.g x) - where g y = y - -g :: a -> () -g _ = () diff --git a/test/RecIdent.curry b/test/RecIdent.curry deleted file mode 100644 index 22203416..00000000 --- a/test/RecIdent.curry +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE Records #-} -module RecIdent where - -data Rec0 = Rec - -type Rec = { int :: Int } -type Rec2 = { int2 :: Int } diff --git a/test/RecordTest.curry b/test/RecordTest.curry deleted file mode 100644 index 076ad959..00000000 --- a/test/RecordTest.curry +++ /dev/null @@ -1,7 +0,0 @@ -module RecordTest (Agent, lastName, trueIdentity, mike) 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 diff --git a/test/RecordTest3.curry b/test/RecordTest3.curry deleted file mode 100644 index 15402055..00000000 --- a/test/RecordTest3.curry +++ /dev/null @@ -1,64 +0,0 @@ -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 } diff --git a/test/RecursiveRecords.curry b/test/RecursiveRecords.curry deleted file mode 100644 index b61007ae..00000000 --- a/test/RecursiveRecords.curry +++ /dev/null @@ -1,30 +0,0 @@ -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 diff --git a/test/TestFrontend.hs b/test/TestFrontend.hs new file mode 100644 index 00000000..80f35954 --- /dev/null +++ b/test/TestFrontend.hs @@ -0,0 +1,273 @@ +-------------------------------------------------------------------------------- +-- 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'"]) + ] diff --git a/test/Ticket9.curry b/test/Ticket9.curry deleted file mode 100644 index 6e65a1dd..00000000 --- a/test/Ticket9.curry +++ /dev/null @@ -1,10 +0,0 @@ -module Ticket9 where - -type Options = { optHelp :: Bool } - -options :: [Options -> Options] -options = [] - -parseOpts :: Options -parseOpts = foldl (flip ($)) { optHelp = False } opts - where opts = options diff --git a/test/check.sh b/test/check.sh deleted file mode 100755 index c21eb8e8..00000000 --- a/test/check.sh +++ /dev/null @@ -1,61 +0,0 @@ -#!/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 - diff --git a/test/errors/FunctionalPatterns.curry b/test/errors/FunctionalPatterns.curry deleted file mode 100644 index 314647d3..00000000 --- a/test/errors/FunctionalPatterns.curry +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE FunctionalPatterns, Records #-} -type Foo = { foo :: Bool } - -f1 (id v@x) = x -f2 (id ~(v:vs)) = v -f3 (id { foo = bar }) = bar diff --git a/test/Bool.curry b/test/fail/Bool.curry similarity index 100% rename from test/Bool.curry rename to test/fail/Bool.curry diff --git a/test/ErrorMultipleSignature.curry b/test/fail/ErrorMultipleSignature.curry similarity index 100% rename from test/ErrorMultipleSignature.curry rename to test/fail/ErrorMultipleSignature.curry diff --git a/test/exportcheck/AmbiguousName.curry b/test/fail/ExportCheck/AmbiguousName.curry similarity index 100% rename from test/exportcheck/AmbiguousName.curry rename to test/fail/ExportCheck/AmbiguousName.curry diff --git a/test/exportcheck/AmbiguousType.curry b/test/fail/ExportCheck/AmbiguousType.curry similarity index 100% rename from test/exportcheck/AmbiguousType.curry rename to test/fail/ExportCheck/AmbiguousType.curry diff --git a/test/exportcheck/ModuleNotImported.curry b/test/fail/ExportCheck/ModuleNotImported.curry similarity index 100% rename from test/exportcheck/ModuleNotImported.curry rename to test/fail/ExportCheck/ModuleNotImported.curry diff --git a/test/exportcheck/MultipleName.curry b/test/fail/ExportCheck/MultipleName.curry similarity index 100% rename from test/exportcheck/MultipleName.curry rename to test/fail/ExportCheck/MultipleName.curry diff --git a/test/exportcheck/MultipleType.curry b/test/fail/ExportCheck/MultipleType.curry similarity index 100% rename from test/exportcheck/MultipleType.curry rename to test/fail/ExportCheck/MultipleType.curry diff --git a/test/exportcheck/NoDataType.curry b/test/fail/ExportCheck/NoDataType.curry similarity index 100% rename from test/exportcheck/NoDataType.curry rename to test/fail/ExportCheck/NoDataType.curry diff --git a/test/exportcheck/OutsideTypeConstructor.curry b/test/fail/ExportCheck/OutsideTypeConstructor.curry similarity index 100% rename from test/exportcheck/OutsideTypeConstructor.curry rename to test/fail/ExportCheck/OutsideTypeConstructor.curry diff --git a/test/exportcheck/OutsideTypeLabel.curry b/test/fail/ExportCheck/OutsideTypeLabel.curry similarity index 100% rename from test/exportcheck/OutsideTypeLabel.curry rename to test/fail/ExportCheck/OutsideTypeLabel.curry diff --git a/test/exportcheck/UndefinedElement.curry b/test/fail/ExportCheck/UndefinedElement.curry similarity index 100% rename from test/exportcheck/UndefinedElement.curry rename to test/fail/ExportCheck/UndefinedElement.curry diff --git a/test/exportcheck/UndefinedName.curry b/test/fail/ExportCheck/UndefinedName.curry similarity index 100% rename from test/exportcheck/UndefinedName.curry rename to test/fail/ExportCheck/UndefinedName.curry diff --git a/test/exportcheck/UndefinedType.curry b/test/fail/ExportCheck/UndefinedType.curry similarity index 100% rename from test/exportcheck/UndefinedType.curry rename to test/fail/ExportCheck/UndefinedType.curry diff --git a/test/Bug780.curry b/test/fail/FP_Restrictions.curry similarity index 77% rename from test/Bug780.curry rename to test/fail/FP_Restrictions.curry index 62434632..4880f2ca 100644 --- a/test/Bug780.curry +++ b/test/fail/FP_Restrictions.curry @@ -1,3 +1,6 @@ +--- Restrictions for occurrences of functional patterns +--- Redmine - curry-frontend - bug #780 + {-# LANGUAGE FunctionalPatterns #-} firstLastCaseFun ([x] ++ _ ++ [y]) = (x, y) diff --git a/test/ImportError.curry b/test/fail/ImportError.curry similarity index 100% rename from test/ImportError.curry rename to test/fail/ImportError.curry diff --git a/test/Kindcheck.curry b/test/fail/KindCheck.curry similarity index 67% rename from test/Kindcheck.curry rename to test/fail/KindCheck.curry index 245b7ea3..6fa70702 100644 --- a/test/Kindcheck.curry +++ b/test/fail/KindCheck.curry @@ -1,4 +1,4 @@ -module Kindcheck where +module KindCheck where data Foo a a = Foo a a diff --git a/test/MultipleArities.curry b/test/fail/MultipleArities.curry similarity index 100% rename from test/MultipleArities.curry rename to test/fail/MultipleArities.curry diff --git a/test/fail/MultipleDefinitions.curry b/test/fail/MultipleDefinitions.curry new file mode 100644 index 00000000..73df5cb3 --- /dev/null +++ b/test/fail/MultipleDefinitions.curry @@ -0,0 +1,6 @@ +module MultipleDefinitions where + +data Rec0 = Rec + +data Rec = Rec { int :: Int } +data Rec2 = R2 { int2 :: Int } diff --git a/test/errors/MultiplePrecedence.curry b/test/fail/MultiplePrecedence.curry similarity index 100% rename from test/errors/MultiplePrecedence.curry rename to test/fail/MultiplePrecedence.curry diff --git a/test/fail/PatternRestrictions.curry b/test/fail/PatternRestrictions.curry new file mode 100644 index 00000000..05aac907 --- /dev/null +++ b/test/fail/PatternRestrictions.curry @@ -0,0 +1,6 @@ +{-# LANGUAGE FunctionalPatterns #-} +data Foo = Foo { foo :: Bool } + +f1 (id v@x) = x +f2 (id ~(v:vs)) = v +f3 (id Foo { foo = bar }) = bar diff --git a/test/PragmaError.curry b/test/fail/PragmaError.curry similarity index 100% rename from test/PragmaError.curry rename to test/fail/PragmaError.curry diff --git a/test/Precedence.curry b/test/fail/PrecedenceRange.curry similarity index 100% rename from test/Precedence.curry rename to test/fail/PrecedenceRange.curry diff --git a/test/Prelude.curry b/test/fail/Prelude.curry similarity index 100% rename from test/Prelude.curry rename to test/fail/Prelude.curry diff --git a/test/fail/RecordLabelIDs.curry b/test/fail/RecordLabelIDs.curry new file mode 100644 index 00000000..0cfe4dcf --- /dev/null +++ b/test/fail/RecordLabelIDs.curry @@ -0,0 +1,7 @@ +--- Internal error when function and label identifier coincide +--- Redmine - curry-frontend - bug #1276 + +data Record = Record { id :: Int } + +id :: a -> a +id x = x diff --git a/test/fail/RecursiveTypeSyn.curry b/test/fail/RecursiveTypeSyn.curry new file mode 100644 index 00000000..fc4e0c68 --- /dev/null +++ b/test/fail/RecursiveTypeSyn.curry @@ -0,0 +1,14 @@ +--- Recursive type synonyms +--- Redmine - curry-frontend - bug #489 + +--- Loading this module (in pakcs) leads to cymake <>. +--- 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 () diff --git a/test/SyntaxError.curry b/test/fail/SyntaxError.curry similarity index 100% rename from test/SyntaxError.curry rename to test/fail/SyntaxError.curry diff --git a/test/Typed.curry b/test/fail/TypeError1.curry similarity index 100% rename from test/Typed.curry rename to test/fail/TypeError1.curry diff --git a/test/TypeError.curry b/test/fail/TypeError2.curry similarity index 100% rename from test/TypeError.curry rename to test/fail/TypeError2.curry diff --git a/test/Bug480.curry b/test/fail/TypedFreeVariables.curry similarity index 76% rename from test/Bug480.curry rename to test/fail/TypedFreeVariables.curry index 7ee53d76..4a37cf82 100644 --- a/test/Bug480.curry +++ b/test/fail/TypedFreeVariables.curry @@ -1,3 +1,6 @@ +--- 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 diff --git a/test/pass/ACVisibility.curry b/test/pass/ACVisibility.curry new file mode 100644 index 00000000..8ab6fd72 --- /dev/null +++ b/test/pass/ACVisibility.curry @@ -0,0 +1,13 @@ +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 diff --git a/test/AbstractCurryBug.curry b/test/pass/AbstractCurryBug.curry similarity index 100% rename from test/AbstractCurryBug.curry rename to test/pass/AbstractCurryBug.curry diff --git a/test/AnonymVar.curry b/test/pass/AnonymVar.curry similarity index 68% rename from test/AnonymVar.curry rename to test/pass/AnonymVar.curry index 67a48fc3..56d3552d 100644 --- a/test/AnonymVar.curry +++ b/test/pass/AnonymVar.curry @@ -1,4 +1,5 @@ -- NEW: Anonymous variable +{-# LANGUAGE AnonFreeVars #-} f _ = _ diff --git a/test/B/C.curry b/test/pass/B/C.curry similarity index 100% rename from test/B/C.curry rename to test/pass/B/C.curry diff --git a/test/CaseComplete.curry b/test/pass/CaseComplete.curry similarity index 100% rename from test/CaseComplete.curry rename to test/pass/CaseComplete.curry diff --git a/test/DefaultPrecedence.curry b/test/pass/DefaultPrecedence.curry similarity index 100% rename from test/DefaultPrecedence.curry rename to test/pass/DefaultPrecedence.curry diff --git a/test/Dequeue.curry b/test/pass/Dequeue.curry similarity index 100% rename from test/Dequeue.curry rename to test/pass/Dequeue.curry diff --git a/test/pass/ExplicitLayout.curry b/test/pass/ExplicitLayout.curry new file mode 100644 index 00000000..32856d34 --- /dev/null +++ b/test/pass/ExplicitLayout.curry @@ -0,0 +1,5 @@ +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 } +} diff --git a/test/FCase.curry b/test/pass/FCase.curry similarity index 100% rename from test/FCase.curry rename to test/pass/FCase.curry diff --git a/test/FP_Lifting.curry b/test/pass/FP_Lifting.curry similarity index 90% rename from test/FP_Lifting.curry rename to test/pass/FP_Lifting.curry index 0abe3ae1..95290737 100644 --- a/test/FP_Lifting.curry +++ b/test/pass/FP_Lifting.curry @@ -1,3 +1,5 @@ +{-# LANGUAGE FunctionalPatterns #-} + f x = g x &> x where g (h y) = success diff --git a/test/Bug1226.curry b/test/pass/FP_NonLinearity.curry similarity index 93% rename from test/Bug1226.curry rename to test/pass/FP_NonLinearity.curry index 7e113f81..dbc3234c 100644 --- a/test/Bug1226.curry +++ b/test/pass/FP_NonLinearity.curry @@ -1,3 +1,6 @@ +--- 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: diff --git a/test/FunctionalPatterns.curry b/test/pass/FunctionalPatterns.curry similarity index 68% rename from test/FunctionalPatterns.curry rename to test/pass/FunctionalPatterns.curry index 09195723..1aa5d49e 100644 --- a/test/FunctionalPatterns.curry +++ b/test/pass/FunctionalPatterns.curry @@ -1,3 +1,5 @@ +{-# LANGUAGE FunctionalPatterns #-} + f (v@[] ++ v@(x:xs)) = x:xs ++ v g (id ((:) x xs)) = x:xs diff --git a/test/pass/HaskellRecords.curry b/test/pass/HaskellRecords.curry new file mode 100644 index 00000000..f6a1013a --- /dev/null +++ b/test/pass/HaskellRecords.curry @@ -0,0 +1,37 @@ +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 } diff --git a/test/pass/Hierarchical.curry b/test/pass/Hierarchical.curry new file mode 100644 index 00000000..1eaf8abd --- /dev/null +++ b/test/pass/Hierarchical.curry @@ -0,0 +1,5 @@ +module Hierarchical where + +import B.C (foo) + +main = print foo diff --git a/test/Infix.curry b/test/pass/Infix.curry similarity index 100% rename from test/Infix.curry rename to test/pass/Infix.curry diff --git a/test/Inline.curry b/test/pass/Inline.curry similarity index 100% rename from test/Inline.curry rename to test/pass/Inline.curry diff --git a/test/Lambda.curry b/test/pass/Lambda.curry similarity index 100% rename from test/Lambda.curry rename to test/pass/Lambda.curry diff --git a/test/List.curry b/test/pass/List.curry similarity index 100% rename from test/List.curry rename to test/pass/List.curry diff --git a/test/Maybe.curry b/test/pass/Maybe.curry similarity index 100% rename from test/Maybe.curry rename to test/pass/Maybe.curry diff --git a/test/NegLit.curry b/test/pass/NegLit.curry similarity index 100% rename from test/NegLit.curry rename to test/pass/NegLit.curry diff --git a/test/Newtype.curry b/test/pass/Newtype1.curry similarity index 72% rename from test/Newtype.curry rename to test/pass/Newtype1.curry index c173322c..b8ad0ce7 100644 --- a/test/Newtype.curry +++ b/test/pass/Newtype1.curry @@ -1,4 +1,4 @@ -module Newtype where +module Newtype1 where newtype D a = D a diff --git a/test/Newtype2.curry b/test/pass/Newtype2.curry similarity index 77% rename from test/Newtype2.curry rename to test/pass/Newtype2.curry index 5990e2cc..3f4d3207 100644 --- a/test/Newtype2.curry +++ b/test/pass/Newtype2.curry @@ -1,4 +1,4 @@ -import Newtype +import Newtype1 main :: Int main = access val diff --git a/test/NonLinearLHS.curry b/test/pass/NonLinearLHS.curry similarity index 87% rename from test/NonLinearLHS.curry rename to test/pass/NonLinearLHS.curry index b3f7d9fe..4fec272b 100644 --- a/test/NonLinearLHS.curry +++ b/test/pass/NonLinearLHS.curry @@ -1,3 +1,5 @@ +{-# 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 diff --git a/test/pass/OperatorDefinition.curry b/test/pass/OperatorDefinition.curry new file mode 100644 index 00000000..ccf0b6e5 --- /dev/null +++ b/test/pass/OperatorDefinition.curry @@ -0,0 +1,8 @@ +--- 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 diff --git a/test/PatDecl.curry b/test/pass/PatDecl.curry similarity index 100% rename from test/PatDecl.curry rename to test/pass/PatDecl.curry diff --git a/test/pass/Prelude.curry b/test/pass/Prelude.curry new file mode 100644 index 00000000..75dce400 --- /dev/null +++ b/test/pass/Prelude.curry @@ -0,0 +1,861 @@ +---------------------------------------------------------------------------- +--- The standard prelude of Curry. +--- All top-level functions defined in this module +--- are always available in any Curry program. +--- +--- @category general +---------------------------------------------------------------------------- + +{-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-overlapping #-} + +module Prelude where + +-- Lines beginning with "--++" are part of the prelude +-- but cannot parsed by the compiler + +-- Infix operator declarations: + + +infixl 9 !! +infixr 9 . +infixl 7 *, `div`, `mod`, `quot`, `rem` +infixl 6 +, - +-- infixr 5 : -- declared together with list +infixr 5 ++ +infix 4 =:=, ==, /=, <, >, <=, >=, =:<= +infix 4 `elem`, `notElem` +infixr 3 && +infixr 2 || +infixl 1 >>, >>= +infixr 0 $, $!, $!!, $#, $##, `seq`, &, &>, ? + + +-- externally defined types for numbers and characters +data Int +data Float +data Char + + +type String = [Char] + +-- Some standard combinators: + +--- Function composition. +(.) :: (b -> c) -> (a -> b) -> (a -> c) +f . g = \x -> f (g x) + +--- Identity function. +id :: a -> a +id x = x + +--- Constant function. +const :: a -> _ -> a +const x _ = x + +--- Converts an uncurried function to a curried function. +curry :: ((a,b) -> c) -> a -> b -> c +curry f a b = f (a,b) + +--- Converts an curried function to a function on pairs. +uncurry :: (a -> b -> c) -> (a,b) -> c +uncurry f (a,b) = f a b + +--- (flip f) is identical to f but with the order of arguments reversed. +flip :: (a -> b -> c) -> b -> a -> c +flip f x y = f y x + +--- Repeats application of a function until a predicate holds. +until :: (a -> Bool) -> (a -> a) -> a -> a +until p f x = if p x then x else until p f (f x) + +--- Evaluates the first argument to head normal form (which could also +--- be a free variable) and returns the second argument. +seq :: _ -> a -> a +x `seq` y = const y $! x + +--- Evaluates the argument to head normal form and returns it. +--- Suspends until the result is bound to a non-variable term. +ensureNotFree :: a -> a +ensureNotFree external + +--- Evaluates the argument to spine form and returns it. +--- Suspends until the result is bound to a non-variable spine. +ensureSpine :: [a] -> [a] +ensureSpine l = ensureList (ensureNotFree l) + where ensureList [] = [] + ensureList (x:xs) = x : ensureSpine xs + +--- Right-associative application. +($) :: (a -> b) -> a -> b +f $ x = f x + +--- Right-associative application with strict evaluation of its argument +--- to head normal form. +($!) :: (a -> b) -> a -> b +($!) external + +--- Right-associative application with strict evaluation of its argument +--- to normal form. +($!!) :: (a -> b) -> a -> b +($!!) external + +--- Right-associative application with strict evaluation of its argument +--- to a non-variable term. +($#) :: (a -> b) -> a -> b +f $# x = f $! (ensureNotFree x) + +--- Right-associative application with strict evaluation of its argument +--- to ground normal form. +($##) :: (a -> b) -> a -> b +($##) external + +--- Aborts the execution with an error message. +error :: String -> _ +error x = prim_error $## x + +prim_error :: String -> _ +prim_error external + +--- A non-reducible polymorphic function. +--- It is useful to express a failure in a search branch of the execution. +--- It could be defined by: `failed = head []` +failed :: _ +failed external + + +-- Boolean values +-- already defined as builtin, since it is required for if-then-else +data Bool = False | True + +--- Sequential conjunction on Booleans. +(&&) :: Bool -> Bool -> Bool +True && x = x +False && _ = False + + +--- Sequential disjunction on Booleans. +(||) :: Bool -> Bool -> Bool +True || _ = True +False || x = x + + +--- Negation on Booleans. +not :: Bool -> Bool +not True = False +not False = True + +--- Useful name for the last condition in a sequence of conditional equations. +otherwise :: Bool +otherwise = True + + +--- The standard conditional. It suspends if the condition is a free variable. +if_then_else :: Bool -> a -> a -> a +if_then_else b t f = case b of True -> t + False -> f + +--- Enforce a Boolean condition to be true. +--- The computation fails if the argument evaluates to `False`. +solve :: Bool -> Bool +solve True = True + +--- Conditional expression. +--- An expression like `(c &> e)` is evaluated by evaluating the first +--- argument to `True` and then evaluating `e`. +--- The expression has no value if the condition does not evaluate to `True`. +(&>) :: Bool -> a -> a +True &> x = x + +--- Equality on finite ground data terms. +(==) :: a -> a -> Bool +(==) external + +--- Disequality. +(/=) :: a -> a -> Bool +x /= y = not (x==y) + +--- The equational constraint. +--- `(e1 =:= e2)` is satisfiable if both sides `e1` and `e2` can be +--- reduced to a unifiable data term (i.e., a term without defined +--- function symbols). +(=:=) :: a -> a -> Bool +(=:=) external + +--- Concurrent conjunction. +--- An expression like `(c1 & c2)` is evaluated by evaluating +--- the `c1` and `c2` in a concurrent manner. +(&) :: Bool -> Bool -> Bool +(&) external + + +--- Ordering type. Useful as a result of comparison functions. +data Ordering = LT | EQ | GT + +--- Comparison of arbitrary ground data terms. +--- Data constructors are compared in the order of their definition +--- in the datatype declarations and recursively in the arguments. +compare :: a -> a -> Ordering +compare x y | x == y = EQ + | x <= y = LT + | otherwise = GT + +--- Less-than on ground data terms. +(<) :: a -> a -> Bool +x < y = not (y <= x) + +--- Greater-than on ground data terms. +(>) :: a -> a -> Bool +x > y = not (x <= y) + +--- Less-or-equal on ground data terms. +(<=) :: a -> a -> Bool +(<=) external + +--- Greater-or-equal on ground data terms. +(>=) :: a -> a -> Bool +x >= y = not (x < y) + +--- Maximum of ground data terms. +max :: a -> a -> a +max x y = if x >= y then x else y + +--- Minimum of ground data terms. +min :: a -> a -> a +min x y = if x <= y then x else y + + +-- Pairs + +--++ data (a,b) = (a,b) + +--- Selects the first component of a pair. +fst :: (a,_) -> a +fst (x,_) = x + +--- Selects the second component of a pair. +snd :: (_,b) -> b +snd (_,y) = y + + +-- Unit type +--++ data () = () + + +-- Lists + +--++ data [a] = [] | a : [a] + +--- Computes the first element of a list. +head :: [a] -> a +head (x:_) = x + +--- Computes the remaining elements of a list. +tail :: [a] -> [a] +tail (_:xs) = xs + +--- Is a list empty? +null :: [_] -> Bool +null [] = True +null (_:_) = False + +--- Concatenates two lists. +--- Since it is flexible, it could be also used to split a list +--- into two sublists etc. +(++) :: [a] -> [a] -> [a] +[] ++ ys = ys +(x:xs) ++ ys = x : xs++ys + +--- Computes the length of a list. +length :: [_] -> Int +length xs = len xs 0 + where + len [] n = n + len (_:ys) n = let np1 = n + 1 in len ys $!! np1 +--length [] = 0 +--length (_:xs) = 1 + length xs + +--- List index (subscript) operator, head has index 0. +(!!) :: [a] -> Int -> a +(x:xs) !! n | n==0 = x + | n>0 = xs !! (n-1) + +--- Map a function on all elements of a list. +map :: (a->b) -> [a] -> [b] +map _ [] = [] +map f (x:xs) = f x : map f xs + +--- Accumulates all list elements by applying a binary operator from +--- left to right. Thus, +--- +--- foldl f z [x1,x2,...,xn] = (...((z `f` x1) `f` x2) ...) `f` xn +foldl :: (a -> b -> a) -> a -> [b] -> a +foldl _ z [] = z +foldl f z (x:xs) = foldl f (f z x) xs + +--- Accumulates a non-empty list from left to right. +foldl1 :: (a -> a -> a) -> [a] -> a +foldl1 f (x:xs) = foldl f x xs + +--- Accumulates all list elements by applying a binary operator from +--- right to left. Thus, +--- +--- foldr f z [x1,x2,...,xn] = (x1 `f` (x2 `f` ... (xn `f` z)...)) +foldr :: (a->b->b) -> b -> [a] -> b +foldr _ z [] = z +foldr f z (x:xs) = f x (foldr f z xs) + +--- Accumulates a non-empty list from right to left: +foldr1 :: (a -> a -> a) -> [a] -> a +foldr1 _ [x] = x +foldr1 f (x1:x2:xs) = f x1 (foldr1 f (x2:xs)) + +--- Filters all elements satisfying a given predicate in a list. +filter :: (a -> Bool) -> [a] -> [a] +filter _ [] = [] +filter p (x:xs) = if p x then x : filter p xs + else filter p xs + +--- Joins two lists into one list of pairs. If one input list is shorter than +--- the other, the additional elements of the longer list are discarded. +zip :: [a] -> [b] -> [(a,b)] +zip [] _ = [] +zip (_:_) [] = [] +zip (x:xs) (y:ys) = (x,y) : zip xs ys + +--- Joins three lists into one list of triples. If one input list is shorter +--- than the other, the additional elements of the longer lists are discarded. +zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] +zip3 [] _ _ = [] +zip3 (_:_) [] _ = [] +zip3 (_:_) (_:_) [] = [] +zip3 (x:xs) (y:ys) (z:zs) = (x,y,z) : zip3 xs ys zs + +--- Joins two lists into one list by applying a combination function to +--- corresponding pairs of elements. Thus `zip = zipWith (,)` +zipWith :: (a->b->c) -> [a] -> [b] -> [c] +zipWith _ [] _ = [] +zipWith _ (_:_) [] = [] +zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys + +--- Joins three lists into one list by applying a combination function to +--- corresponding triples of elements. Thus `zip3 = zipWith3 (,,)` +zipWith3 :: (a->b->c->d) -> [a] -> [b] -> [c] -> [d] +zipWith3 _ [] _ _ = [] +zipWith3 _ (_:_) [] _ = [] +zipWith3 _ (_:_) (_:_) [] = [] +zipWith3 f (x:xs) (y:ys) (z:zs) = f x y z : zipWith3 f xs ys zs + +--- Transforms a list of pairs into a pair of lists. +unzip :: [(a,b)] -> ([a],[b]) +unzip [] = ([],[]) +unzip ((x,y):ps) = (x:xs,y:ys) where (xs,ys) = unzip ps + +--- Transforms a list of triples into a triple of lists. +unzip3 :: [(a,b,c)] -> ([a],[b],[c]) +unzip3 [] = ([],[],[]) +unzip3 ((x,y,z):ts) = (x:xs,y:ys,z:zs) where (xs,ys,zs) = unzip3 ts + +--- Concatenates a list of lists into one list. +concat :: [[a]] -> [a] +concat l = foldr (++) [] l + +--- Maps a function from elements to lists and merges the result into one list. +concatMap :: (a -> [b]) -> [a] -> [b] +concatMap f = concat . map f + +--- Infinite list of repeated applications of a function f to an element x. +--- Thus, `iterate f x = [x, f x, f (f x),...]` +iterate :: (a -> a) -> a -> [a] +iterate f x = x : iterate f (f x) + +--- Infinite list where all elements have the same value. +--- Thus, `repeat x = [x, x, x,...]` +repeat :: a -> [a] +repeat x = x : repeat x + +--- List of length n where all elements have the same value. +replicate :: Int -> a -> [a] +replicate n x = take n (repeat x) + +--- Returns prefix of length n. +take :: Int -> [a] -> [a] +take n l = if n<=0 then [] else takep n l + where takep _ [] = [] + takep m (x:xs) = x : take (m-1) xs + +--- Returns suffix without first n elements. +drop :: Int -> [a] -> [a] +drop n l = if n<=0 then l else dropp n l + where dropp _ [] = [] + dropp m (_:xs) = drop (m-1) xs + +--- (splitAt n xs) is equivalent to (take n xs, drop n xs) +splitAt :: Int -> [a] -> ([a],[a]) +splitAt n l = if n<=0 then ([],l) else splitAtp n l + where splitAtp _ [] = ([],[]) + splitAtp m (x:xs) = let (ys,zs) = splitAt (m-1) xs in (x:ys,zs) + +--- Returns longest prefix with elements satisfying a predicate. +takeWhile :: (a -> Bool) -> [a] -> [a] +takeWhile _ [] = [] +takeWhile p (x:xs) = if p x then x : takeWhile p xs else [] + +--- Returns suffix without takeWhile prefix. +dropWhile :: (a -> Bool) -> [a] -> [a] +dropWhile _ [] = [] +dropWhile p (x:xs) = if p x then dropWhile p xs else x:xs + +--- (span p xs) is equivalent to (takeWhile p xs, dropWhile p xs) +span :: (a -> Bool) -> [a] -> ([a],[a]) +span _ [] = ([],[]) +span p (x:xs) + | p x = let (ys,zs) = span p xs in (x:ys, zs) + | otherwise = ([],x:xs) + +--- (break p xs) is equivalent to (takeWhile (not.p) xs, dropWhile (not.p) xs). +--- Thus, it breaks a list at the first occurrence of an element satisfying p. +break :: (a -> Bool) -> [a] -> ([a],[a]) +break p = span (not . p) + +--- Breaks a string into a list of lines where a line is terminated at a +--- newline character. The resulting lines do not contain newline characters. +lines :: String -> [String] +lines [] = [] +lines (x:xs) = let (l,xs_l) = splitline (x:xs) in l : lines xs_l + where splitline [] = ([],[]) + splitline (c:cs) = if c=='\n' + then ([],cs) + else let (ds,es) = splitline cs in (c:ds,es) + +--- Concatenates a list of strings with terminating newlines. +unlines :: [String] -> String +unlines ls = concatMap (++"\n") ls + +--- Breaks a string into a list of words where the words are delimited by +--- white spaces. +words :: String -> [String] +words s = let s1 = dropWhile isSpace s + in if s1=="" then [] + else let (w,s2) = break isSpace s1 + in w : words s2 + where + isSpace c = c == ' ' || c == '\t' || c == '\n' || c == '\r' + +--- Concatenates a list of strings with a blank between two strings. +unwords :: [String] -> String +unwords ws = if ws==[] then [] + else foldr1 (\w s -> w ++ ' ':s) ws + +--- Reverses the order of all elements in a list. +reverse :: [a] -> [a] +reverse = foldl (flip (:)) [] + +--- Computes the conjunction of a Boolean list. +and :: [Bool] -> Bool +and = foldr (&&) True + +--- Computes the disjunction of a Boolean list. +or :: [Bool] -> Bool +or = foldr (||) False + +--- Is there an element in a list satisfying a given predicate? +any :: (a -> Bool) -> [a] -> Bool +any p = or . map p + +--- Is a given predicate satisfied by all elements in a list? +all :: (a -> Bool) -> [a] -> Bool +all p = and . map p + +--- Element of a list? +elem :: a -> [a] -> Bool +elem x = any (x==) + +--- Not element of a list? +notElem :: a -> [a] -> Bool +notElem x = all (x/=) + +--- Looks up a key in an association list. +lookup :: a -> [(a,b)] -> Maybe b +lookup _ [] = Nothing +lookup k ((x,y):xys) + | k==x = Just y + | otherwise = lookup k xys + +--- Generates an infinite sequence of ascending integers. +enumFrom :: Int -> [Int] -- [n..] +enumFrom n = n : enumFrom (n+1) + +--- Generates an infinite sequence of integers with a particular in/decrement. +enumFromThen :: Int -> Int -> [Int] -- [n1,n2..] +enumFromThen n1 n2 = iterate ((n2-n1)+) n1 + +--- Generates a sequence of ascending integers. +enumFromTo :: Int -> Int -> [Int] -- [n..m] +enumFromTo n m = if n>m then [] else n : enumFromTo (n+1) m + +--- Generates a sequence of integers with a particular in/decrement. +enumFromThenTo :: Int -> Int -> Int -> [Int] -- [n1,n2..m] +enumFromThenTo n1 n2 m = takeWhile p (enumFromThen n1 n2) + where p x | n2 >= n1 = (x <= m) + | otherwise = (x >= m) + + +--- Converts a character into its ASCII value. +ord :: Char -> Int +ord c = prim_ord $# c + +prim_ord :: Char -> Int +prim_ord external + +--- Converts a Unicode value into a character, fails iff the value is out of bounds +chr :: Int -> Char +chr n | n >= 0 = prim_chr $# n +-- chr n | n < 0 || n > 1114111 = failed +-- | otherwise = prim_chr $# n + +prim_chr :: Int -> Char +prim_chr external + + +-- Types of primitive arithmetic functions and predicates + +--- Adds two integers. +(+) :: Int -> Int -> Int +(+) external + +--- Subtracts two integers. +(-) :: Int -> Int -> Int +(-) external + +--- Multiplies two integers. +(*) :: Int -> Int -> Int +(*) external + +--- Integer division. The value is the integer quotient of its arguments +--- and always truncated towards negative infinity. +--- Thus, the value of 13 `div` 5 is 2, +--- and the value of -15 `div` 4 is -4. +div :: Int -> Int -> Int +div external + +--- Integer remainder. The value is the remainder of the integer division and +--- it obeys the rule x `mod` y = x - y * (x `div` y). +--- Thus, the value of 13 `mod` 5 is 3, +--- and the value of -15 `mod` 4 is -3. +mod :: Int -> Int -> Int +mod external + +--- Returns an integer (quotient,remainder) pair. +--- The value is the integer quotient of its arguments +--- and always truncated towards negative infinity. +divMod :: Int -> Int -> (Int, Int) +divMod external + +--- Integer division. The value is the integer quotient of its arguments +--- and always truncated towards zero. +--- Thus, the value of 13 `quot` 5 is 2, +--- and the value of -15 `quot` 4 is -3. +quot :: Int -> Int -> Int +quot external + +--- Integer remainder. The value is the remainder of the integer division and +--- it obeys the rule x `rem` y = x - y * (x `quot` y). +--- Thus, the value of 13 `rem` 5 is 3, +--- and the value of -15 `rem` 4 is -3. +rem :: Int -> Int -> Int +rem external + +--- Returns an integer (quotient,remainder) pair. +--- The value is the integer quotient of its arguments +--- and always truncated towards zero. +quotRem :: Int -> Int -> (Int, Int) +quotRem external + +--- Unary minus. Usually written as "- e". +negate :: Int -> Int +negate x = 0 - x + +--- Unary minus on Floats. Usually written as "-e". +negateFloat :: Float -> Float +negateFloat external + + +-- Constraints (included for backwar compatibility) +type Success = Bool + +--- The always satisfiable constraint. +success :: Success +success = True + +-- Maybe type + +data Maybe a = Nothing | Just a + +maybe :: b -> (a -> b) -> Maybe a -> b +maybe n _ Nothing = n +maybe _ f (Just x) = f x + + +-- Either type + +data Either a b = Left a | Right b + +either :: (a -> c) -> (b -> c) -> Either a b -> c +either f _ (Left x) = f x +either _ g (Right x) = g x + + +-- Monadic IO + +data IO _ -- conceptually: World -> (a,World) + +--- Sequential composition of actions. +--- @param a - An action +--- @param fa - A function from a value into an action +--- @return An action that first performs a (yielding result r) +--- and then performs (fa r) +(>>=) :: IO a -> (a -> IO b) -> IO b +(>>=) external + +--- The empty action that directly returns its argument. +return :: a -> IO a +return external + +--- Sequential composition of actions. +--- @param a1 - An action +--- @param a2 - An action +--- @return An action that first performs a1 and then a2 +(>>) :: IO _ -> IO b -> IO b +a >> b = a >>= (\_ -> b) + +--- The empty action that returns nothing. +done :: IO () +done = return () + +--- An action that puts its character argument on standard output. +putChar :: Char -> IO () +putChar c = prim_putChar $## c + +prim_putChar :: Char -> IO () +prim_putChar external + +--- An action that reads a character from standard output and returns it. +getChar :: IO Char +getChar external + +--- An action that (lazily) reads a file and returns its contents. +readFile :: String -> IO String +readFile f = prim_readFile $## f + +prim_readFile :: String -> IO String +prim_readFile external + +--- An action that writes a file. +--- @param filename - The name of the file to be written. +--- @param contents - The contents to be written to the file. +writeFile :: String -> String -> IO () +writeFile f s = (prim_writeFile $## f) $## s + +prim_writeFile :: String -> String -> IO () +prim_writeFile external + +--- An action that appends a string to a file. +--- It behaves like writeFile if the file does not exist. +--- @param filename - The name of the file to be written. +--- @param contents - The contents to be appended to the file. +appendFile :: String -> String -> IO () +appendFile f s = (prim_appendFile $## f) $## s + +prim_appendFile :: String -> String -> IO () +prim_appendFile external + +--- Action to print a string on stdout. +putStr :: String -> IO () +putStr [] = done +putStr (c:cs) = putChar c >> putStr cs + +--- Action to print a string with a newline on stdout. +putStrLn :: String -> IO () +putStrLn cs = putStr cs >> putChar '\n' + +--- Action to read a line from stdin. +getLine :: IO String +getLine = do c <- getChar + if c=='\n' then return [] + else do cs <- getLine + return (c:cs) + +---------------------------------------------------------------------------- +-- Error handling in the I/O monad: + +--- The (abstract) type of error values. +--- Currently, it distinguishes between general IO errors, +--- user-generated errors (see 'userError'), failures and non-determinism +--- errors during IO computations. These errors can be caught by 'catch' +--- and shown by 'showError'. +--- Each error contains a string shortly explaining the error. +--- This type might be extended in the future to distinguish +--- further error situations. +data IOError + = IOError String -- normal IO error + | UserError String -- user-specified error + | FailError String -- failing computation + | NondetError String -- non-deterministic computation + +--- A user error value is created by providing a description of the +--- error situation as a string. +userError :: String -> IOError +userError s = UserError s + +--- Raises an I/O exception with a given error value. +ioError :: IOError -> IO _ +ioError err = prim_ioError $## err + +prim_ioError :: IOError -> IO _ +prim_ioError external + +--- Shows an error values as a string. +showError :: IOError -> String +showError (IOError s) = "i/o error: " ++ s +showError (UserError s) = "user error: " ++ s +showError (FailError s) = "fail error: " ++ s +showError (NondetError s) = "nondet error: " ++ s + +--- Catches a possible error or failure during the execution of an +--- I/O action. `(catch act errfun)` executes the I/O action +--- `act`. If an exception or failure occurs +--- during this I/O action, the function `errfun` is applied +--- to the error value. +catch :: IO a -> (IOError -> IO a) -> IO a +catch external + +---------------------------------------------------------------------------- + +--- Converts an arbitrary term into an external string representation. +show :: _ -> String +show x = prim_show $## x + +prim_show :: _ -> String +prim_show external + +--- Converts a term into a string and prints it. +print :: _ -> IO () +print t = putStrLn (show t) + +--- Solves a constraint as an I/O action. +--- Note: the constraint should be always solvable in a deterministic way +doSolve :: Bool -> IO () +doSolve b | b = done + + +-- IO monad auxiliary functions: + +--- Executes a sequence of I/O actions and collects all results in a list. +sequenceIO :: [IO a] -> IO [a] +sequenceIO [] = return [] +sequenceIO (c:cs) = do x <- c + xs <- sequenceIO cs + return (x:xs) + +--- Executes a sequence of I/O actions and ignores the results. +sequenceIO_ :: [IO _] -> IO () +sequenceIO_ = foldr (>>) done + +--- Maps an I/O action function on a list of elements. +--- The results of all I/O actions are collected in a list. +mapIO :: (a -> IO b) -> [a] -> IO [b] +mapIO f = sequenceIO . map f + +--- Maps an I/O action function on a list of elements. +--- The results of all I/O actions are ignored. +mapIO_ :: (a -> IO _) -> [a] -> IO () +mapIO_ f = sequenceIO_ . map f + +--- Folds a list of elements using an binary I/O action and a value +--- for the empty list. +foldIO :: (a -> b -> IO a) -> a -> [b] -> IO a +foldIO _ a [] = return a +foldIO f a (x:xs) = f a x >>= \fax -> foldIO f fax xs + +--- Apply a pure function to the result of an I/O action. +liftIO :: (a -> b) -> IO a -> IO b +liftIO f m = m >>= return . f + +--- Like `mapIO`, but with flipped arguments. +--- +--- This can be useful if the definition of the function is longer +--- than those of the list, like in +--- +--- forIO [1..10] $ \n -> do +--- ... +forIO :: [a] -> (a -> IO b) -> IO [b] +forIO xs f = mapIO f xs + +--- Like `mapIO_`, but with flipped arguments. +--- +--- This can be useful if the definition of the function is longer +--- than those of the list, like in +--- +--- forIO_ [1..10] $ \n -> do +--- ... +forIO_ :: [a] -> (a -> IO b) -> IO () +forIO_ xs f = mapIO_ f xs + +--- Performs an `IO` action unless the condition is met. +unless :: Bool -> IO () -> IO () +unless p act = if p then done else act + +--- Performs an `IO` action when the condition is met. +when :: Bool -> IO () -> IO () +when p act = if p then act else done + +---------------------------------------------------------------- +-- Non-determinism and free variables: + +--- Non-deterministic choice _par excellence_. +--- The value of `x ? y` is either `x` or `y`. +--- @param x - The right argument. +--- @param y - The left argument. +--- @return either `x` or `y` non-deterministically. +(?) :: a -> a -> a +x ? _ = x +_ ? y = y + + +--- Evaluates to a fresh free variable. +unknown :: _ +unknown = let x free in x + +---------------------------------------------------------------- +--- Identity type synonym used to mark deterministic operations. +type DET a = a + +--- Identity function used by the partial evaluator +--- to mark expressions to be partially evaluated. +PEVAL :: a -> a +PEVAL x = x + +--- Evaluates the argument to normal form and returns it. +normalForm :: a -> a +normalForm x = id $!! x + +--- Evaluates the argument to ground normal form and returns it. +--- Suspends as long as the normal form of the argument is not ground. +groundNormalForm :: a -> a +groundNormalForm x = id $## x + +-- Only for internal use: +-- Representation of higher-order applications in FlatCurry. +apply :: (a -> b) -> a -> b +apply external + +-- Only for internal use: +-- Representation of conditional rules in FlatCurry. +cond :: Bool -> a -> a +cond external + +--- Non-strict equational constraint. Used to implement functional patterns. +(=:<=) :: a -> a -> Bool +(=:<=) external + +-- the end of the standard prelude diff --git a/test/Pretty.curry b/test/pass/Pretty.curry similarity index 100% rename from test/Pretty.curry rename to test/pass/Pretty.curry diff --git a/test/pass/RecordTest1.curry b/test/pass/RecordTest1.curry new file mode 100644 index 00000000..90781a22 --- /dev/null +++ b/test/pass/RecordTest1.curry @@ -0,0 +1,15 @@ +module RecordTest1 where + +data Person = Person { firstName :: String, lastName :: String } + | Agent { lastName :: String, trueIdentity :: Person } + +mike :: Person +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 } diff --git a/test/RecordTest2.curry b/test/pass/RecordTest2.curry similarity index 76% rename from test/RecordTest2.curry rename to test/pass/RecordTest2.curry index d5e08797..5f30a166 100644 --- a/test/RecordTest2.curry +++ b/test/pass/RecordTest2.curry @@ -1,6 +1,6 @@ module RecordTest2 where -import RecordTest +import RecordTest1 updLN = mike { lastName = "Doe" } diff --git a/test/pass/RecordTest3.curry b/test/pass/RecordTest3.curry new file mode 100644 index 00000000..8d7c4d36 --- /dev/null +++ b/test/pass/RecordTest3.curry @@ -0,0 +1,13 @@ +--- Internal error in record parsing +--- Redmine - curry-frontend - bug #9 + +module RecordTest3 where + +data Options = Opts { optHelp :: Bool } + +options :: [Options -> Options] +options = [] + +parseOpts :: Options +parseOpts = foldl (flip ($)) Opts { optHelp = False } opts + where opts = options diff --git a/test/pass/RecordsPolymorphism.curry b/test/pass/RecordsPolymorphism.curry new file mode 100644 index 00000000..ab44089a --- /dev/null +++ b/test/pass/RecordsPolymorphism.curry @@ -0,0 +1,21 @@ +--- Missing polymorphism of record labels +--- Redmine - curry-fronted - bug #445 + +--- 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 + +data Rec a = Rec { a :: a, b :: Bool } + +testRecSel1 = a Rec { a = 'c', b = True } + +testRecSel2 x y = a Rec { a = fun x, b = fun3 y y } + +--- 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. diff --git a/test/Main.curry b/test/pass/ReexportTest.curry similarity index 56% rename from test/Main.curry rename to test/pass/ReexportTest.curry index 0a0e9e45..43719660 100644 --- a/test/Main.curry +++ b/test/pass/ReexportTest.curry @@ -1,3 +1,5 @@ +--- importing a reexported module + import qualified Set final xs = Set.last xs diff --git a/test/SelfExport.curry b/test/pass/SelfExport.curry similarity index 100% rename from test/SelfExport.curry rename to test/pass/SelfExport.curry diff --git a/test/Set.curry b/test/pass/Set.curry similarity index 100% rename from test/Set.curry rename to test/pass/Set.curry diff --git a/test/SpaceLeak.curry b/test/pass/SpaceLeak.curry similarity index 100% rename from test/SpaceLeak.curry rename to test/pass/SpaceLeak.curry diff --git a/test/TyConsTest.curry b/test/pass/TyConsTest.curry similarity index 100% rename from test/TyConsTest.curry rename to test/pass/TyConsTest.curry diff --git a/test/TypedExpr.curry b/test/pass/TypedExpr.curry similarity index 100% rename from test/TypedExpr.curry rename to test/pass/TypedExpr.curry diff --git a/test/UntypedAcy.curry b/test/pass/UntypedAcy.curry similarity index 100% rename from test/UntypedAcy.curry rename to test/pass/UntypedAcy.curry diff --git a/test/Unzip.curry b/test/pass/Unzip.curry similarity index 100% rename from test/Unzip.curry rename to test/pass/Unzip.curry diff --git a/test/AliasClash.curry b/test/warning/AliasClash.curry similarity index 100% rename from test/AliasClash.curry rename to test/warning/AliasClash.curry diff --git a/test/Case.curry b/test/warning/Case1.curry similarity index 100% rename from test/Case.curry rename to test/warning/Case1.curry diff --git a/test/Case2.curry b/test/warning/Case2.curry similarity index 100% rename from test/Case2.curry rename to test/warning/Case2.curry diff --git a/test/CheckSignature.curry b/test/warning/CheckSignature.curry similarity index 100% rename from test/CheckSignature.curry rename to test/warning/CheckSignature.curry diff --git a/test/warning/List.curry b/test/warning/List.curry new file mode 100644 index 00000000..c61e76dc --- /dev/null +++ b/test/warning/List.curry @@ -0,0 +1,5 @@ +module List (first) where + +first :: [a] -> a +first [] = error "empty" +first (x:_) = x diff --git a/test/warning/Maybe.curry b/test/warning/Maybe.curry new file mode 100644 index 00000000..089c539d --- /dev/null +++ b/test/warning/Maybe.curry @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +--- Library with some useful functions on the Maybe datatype +--- +--- @author Frank Huch (source from the corresponding Hugs module) +--- Bernd Brassel (sequence, mapM) +--- @version April 2005 +------------------------------------------------------------------------------ + +module Maybe( + isJust, isNothing, + fromJust, fromMaybe, listToMaybe, maybeToList, + catMaybes, mapMaybe,(>>-), sequenceMaybe, mapMMaybe, + + -- ... and what the Prelude exports + Maybe(..), + maybe + ) where + +infixl 1 >>- + +isJust :: Maybe _ -> Bool +isJust (Just _) = True +isJust Nothing = False + +isNothing :: Maybe _ -> Bool +isNothing Nothing = True +isNothing (Just _) = False + +fromJust :: Maybe a -> a +fromJust (Just a) = a +fromJust Nothing = error "Maybe.fromJust: Nothing" + +fromMaybe :: a -> Maybe a -> a +fromMaybe d Nothing = d +fromMaybe _ (Just a) = a + +maybeToList :: Maybe a -> [a] +maybeToList Nothing = [] +maybeToList (Just a) = [a] + +listToMaybe :: [a] -> Maybe a +listToMaybe [] = Nothing +listToMaybe (a:_) = Just a + +catMaybes :: [Maybe a] -> [a] +catMaybes ms = [ m | (Just m) <- ms ] + +mapMaybe :: (a -> Maybe b) -> [a] -> [b] +mapMaybe f = catMaybes . map f + +--- Monadic bind for Maybe. +--- Maybe can be interpreted as a monad where Nothing is interpreted +--- as the error case by this monadic binding. +--- @param maybeValue - Nothing or Just x +--- @param f - function to be applied to x +--- @return Nothing if maybeValue is Nothing, +--- otherwise f is applied to x +(>>-) :: Maybe a -> (a -> Maybe b) -> Maybe b +Nothing >>- _ = Nothing +(Just x) >>- f = f x + +--- monadic sequence for maybe +sequenceMaybe :: [Maybe a] -> Maybe [a] +sequenceMaybe [] = Just [] +sequenceMaybe (c:cs) = c >>- \x -> sequenceMaybe cs >>- \xs -> Just (x:xs) + +--- monadic map for maybe +mapMMaybe :: (a -> Maybe b) -> [a] -> Maybe [b] +mapMMaybe f = sequenceMaybe . map f + + +----------------------------------------------------------------------------- diff --git a/test/NonExhaustivePattern.curry b/test/warning/NonExhaustivePattern.curry similarity index 69% rename from test/NonExhaustivePattern.curry rename to test/warning/NonExhaustivePattern.curry index 2b0b6c12..afc5245f 100644 --- a/test/NonExhaustivePattern.curry +++ b/test/warning/NonExhaustivePattern.curry @@ -1,4 +1,3 @@ -{-# LANGUAGE Records #-} test x = case x of Just 1 -> True Just 2 -> True @@ -20,6 +19,6 @@ f (_:_) = 1 g "a" = 0 -type Record = { list :: [Bool], int :: Int } +data Record = R { list :: [Bool], int :: Int } -rec { list = [] | _ } = 0 +rec R { list = [] } = 0 diff --git a/test/OverlappingPatterns.curry b/test/warning/OverlappingPatterns.curry similarity index 100% rename from test/OverlappingPatterns.curry rename to test/warning/OverlappingPatterns.curry diff --git a/test/warning/Prelude.curry b/test/warning/Prelude.curry new file mode 100644 index 00000000..75dce400 --- /dev/null +++ b/test/warning/Prelude.curry @@ -0,0 +1,861 @@ +---------------------------------------------------------------------------- +--- The standard prelude of Curry. +--- All top-level functions defined in this module +--- are always available in any Curry program. +--- +--- @category general +---------------------------------------------------------------------------- + +{-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-overlapping #-} + +module Prelude where + +-- Lines beginning with "--++" are part of the prelude +-- but cannot parsed by the compiler + +-- Infix operator declarations: + + +infixl 9 !! +infixr 9 . +infixl 7 *, `div`, `mod`, `quot`, `rem` +infixl 6 +, - +-- infixr 5 : -- declared together with list +infixr 5 ++ +infix 4 =:=, ==, /=, <, >, <=, >=, =:<= +infix 4 `elem`, `notElem` +infixr 3 && +infixr 2 || +infixl 1 >>, >>= +infixr 0 $, $!, $!!, $#, $##, `seq`, &, &>, ? + + +-- externally defined types for numbers and characters +data Int +data Float +data Char + + +type String = [Char] + +-- Some standard combinators: + +--- Function composition. +(.) :: (b -> c) -> (a -> b) -> (a -> c) +f . g = \x -> f (g x) + +--- Identity function. +id :: a -> a +id x = x + +--- Constant function. +const :: a -> _ -> a +const x _ = x + +--- Converts an uncurried function to a curried function. +curry :: ((a,b) -> c) -> a -> b -> c +curry f a b = f (a,b) + +--- Converts an curried function to a function on pairs. +uncurry :: (a -> b -> c) -> (a,b) -> c +uncurry f (a,b) = f a b + +--- (flip f) is identical to f but with the order of arguments reversed. +flip :: (a -> b -> c) -> b -> a -> c +flip f x y = f y x + +--- Repeats application of a function until a predicate holds. +until :: (a -> Bool) -> (a -> a) -> a -> a +until p f x = if p x then x else until p f (f x) + +--- Evaluates the first argument to head normal form (which could also +--- be a free variable) and returns the second argument. +seq :: _ -> a -> a +x `seq` y = const y $! x + +--- Evaluates the argument to head normal form and returns it. +--- Suspends until the result is bound to a non-variable term. +ensureNotFree :: a -> a +ensureNotFree external + +--- Evaluates the argument to spine form and returns it. +--- Suspends until the result is bound to a non-variable spine. +ensureSpine :: [a] -> [a] +ensureSpine l = ensureList (ensureNotFree l) + where ensureList [] = [] + ensureList (x:xs) = x : ensureSpine xs + +--- Right-associative application. +($) :: (a -> b) -> a -> b +f $ x = f x + +--- Right-associative application with strict evaluation of its argument +--- to head normal form. +($!) :: (a -> b) -> a -> b +($!) external + +--- Right-associative application with strict evaluation of its argument +--- to normal form. +($!!) :: (a -> b) -> a -> b +($!!) external + +--- Right-associative application with strict evaluation of its argument +--- to a non-variable term. +($#) :: (a -> b) -> a -> b +f $# x = f $! (ensureNotFree x) + +--- Right-associative application with strict evaluation of its argument +--- to ground normal form. +($##) :: (a -> b) -> a -> b +($##) external + +--- Aborts the execution with an error message. +error :: String -> _ +error x = prim_error $## x + +prim_error :: String -> _ +prim_error external + +--- A non-reducible polymorphic function. +--- It is useful to express a failure in a search branch of the execution. +--- It could be defined by: `failed = head []` +failed :: _ +failed external + + +-- Boolean values +-- already defined as builtin, since it is required for if-then-else +data Bool = False | True + +--- Sequential conjunction on Booleans. +(&&) :: Bool -> Bool -> Bool +True && x = x +False && _ = False + + +--- Sequential disjunction on Booleans. +(||) :: Bool -> Bool -> Bool +True || _ = True +False || x = x + + +--- Negation on Booleans. +not :: Bool -> Bool +not True = False +not False = True + +--- Useful name for the last condition in a sequence of conditional equations. +otherwise :: Bool +otherwise = True + + +--- The standard conditional. It suspends if the condition is a free variable. +if_then_else :: Bool -> a -> a -> a +if_then_else b t f = case b of True -> t + False -> f + +--- Enforce a Boolean condition to be true. +--- The computation fails if the argument evaluates to `False`. +solve :: Bool -> Bool +solve True = True + +--- Conditional expression. +--- An expression like `(c &> e)` is evaluated by evaluating the first +--- argument to `True` and then evaluating `e`. +--- The expression has no value if the condition does not evaluate to `True`. +(&>) :: Bool -> a -> a +True &> x = x + +--- Equality on finite ground data terms. +(==) :: a -> a -> Bool +(==) external + +--- Disequality. +(/=) :: a -> a -> Bool +x /= y = not (x==y) + +--- The equational constraint. +--- `(e1 =:= e2)` is satisfiable if both sides `e1` and `e2` can be +--- reduced to a unifiable data term (i.e., a term without defined +--- function symbols). +(=:=) :: a -> a -> Bool +(=:=) external + +--- Concurrent conjunction. +--- An expression like `(c1 & c2)` is evaluated by evaluating +--- the `c1` and `c2` in a concurrent manner. +(&) :: Bool -> Bool -> Bool +(&) external + + +--- Ordering type. Useful as a result of comparison functions. +data Ordering = LT | EQ | GT + +--- Comparison of arbitrary ground data terms. +--- Data constructors are compared in the order of their definition +--- in the datatype declarations and recursively in the arguments. +compare :: a -> a -> Ordering +compare x y | x == y = EQ + | x <= y = LT + | otherwise = GT + +--- Less-than on ground data terms. +(<) :: a -> a -> Bool +x < y = not (y <= x) + +--- Greater-than on ground data terms. +(>) :: a -> a -> Bool +x > y = not (x <= y) + +--- Less-or-equal on ground data terms. +(<=) :: a -> a -> Bool +(<=) external + +--- Greater-or-equal on ground data terms. +(>=) :: a -> a -> Bool +x >= y = not (x < y) + +--- Maximum of ground data terms. +max :: a -> a -> a +max x y = if x >= y then x else y + +--- Minimum of ground data terms. +min :: a -> a -> a +min x y = if x <= y then x else y + + +-- Pairs + +--++ data (a,b) = (a,b) + +--- Selects the first component of a pair. +fst :: (a,_) -> a +fst (x,_) = x + +--- Selects the second component of a pair. +snd :: (_,b) -> b +snd (_,y) = y + + +-- Unit type +--++ data () = () + + +-- Lists + +--++ data [a] = [] | a : [a] + +--- Computes the first element of a list. +head :: [a] -> a +head (x:_) = x + +--- Computes the remaining elements of a list. +tail :: [a] -> [a] +tail (_:xs) = xs + +--- Is a list empty? +null :: [_] -> Bool +null [] = True +null (_:_) = False + +--- Concatenates two lists. +--- Since it is flexible, it could be also used to split a list +--- into two sublists etc. +(++) :: [a] -> [a] -> [a] +[] ++ ys = ys +(x:xs) ++ ys = x : xs++ys + +--- Computes the length of a list. +length :: [_] -> Int +length xs = len xs 0 + where + len [] n = n + len (_:ys) n = let np1 = n + 1 in len ys $!! np1 +--length [] = 0 +--length (_:xs) = 1 + length xs + +--- List index (subscript) operator, head has index 0. +(!!) :: [a] -> Int -> a +(x:xs) !! n | n==0 = x + | n>0 = xs !! (n-1) + +--- Map a function on all elements of a list. +map :: (a->b) -> [a] -> [b] +map _ [] = [] +map f (x:xs) = f x : map f xs + +--- Accumulates all list elements by applying a binary operator from +--- left to right. Thus, +--- +--- foldl f z [x1,x2,...,xn] = (...((z `f` x1) `f` x2) ...) `f` xn +foldl :: (a -> b -> a) -> a -> [b] -> a +foldl _ z [] = z +foldl f z (x:xs) = foldl f (f z x) xs + +--- Accumulates a non-empty list from left to right. +foldl1 :: (a -> a -> a) -> [a] -> a +foldl1 f (x:xs) = foldl f x xs + +--- Accumulates all list elements by applying a binary operator from +--- right to left. Thus, +--- +--- foldr f z [x1,x2,...,xn] = (x1 `f` (x2 `f` ... (xn `f` z)...)) +foldr :: (a->b->b) -> b -> [a] -> b +foldr _ z [] = z +foldr f z (x:xs) = f x (foldr f z xs) + +--- Accumulates a non-empty list from right to left: +foldr1 :: (a -> a -> a) -> [a] -> a +foldr1 _ [x] = x +foldr1 f (x1:x2:xs) = f x1 (foldr1 f (x2:xs)) + +--- Filters all elements satisfying a given predicate in a list. +filter :: (a -> Bool) -> [a] -> [a] +filter _ [] = [] +filter p (x:xs) = if p x then x : filter p xs + else filter p xs + +--- Joins two lists into one list of pairs. If one input list is shorter than +--- the other, the additional elements of the longer list are discarded. +zip :: [a] -> [b] -> [(a,b)] +zip [] _ = [] +zip (_:_) [] = [] +zip (x:xs) (y:ys) = (x,y) : zip xs ys + +--- Joins three lists into one list of triples. If one input list is shorter +--- than the other, the additional elements of the longer lists are discarded. +zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] +zip3 [] _ _ = [] +zip3 (_:_) [] _ = [] +zip3 (_:_) (_:_) [] = [] +zip3 (x:xs) (y:ys) (z:zs) = (x,y,z) : zip3 xs ys zs + +--- Joins two lists into one list by applying a combination function to +--- corresponding pairs of elements. Thus `zip = zipWith (,)` +zipWith :: (a->b->c) -> [a] -> [b] -> [c] +zipWith _ [] _ = [] +zipWith _ (_:_) [] = [] +zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys + +--- Joins three lists into one list by applying a combination function to +--- corresponding triples of elements. Thus `zip3 = zipWith3 (,,)` +zipWith3 :: (a->b->c->d) -> [a] -> [b] -> [c] -> [d] +zipWith3 _ [] _ _ = [] +zipWith3 _ (_:_) [] _ = [] +zipWith3 _ (_:_) (_:_) [] = [] +zipWith3 f (x:xs) (y:ys) (z:zs) = f x y z : zipWith3 f xs ys zs + +--- Transforms a list of pairs into a pair of lists. +unzip :: [(a,b)] -> ([a],[b]) +unzip [] = ([],[]) +unzip ((x,y):ps) = (x:xs,y:ys) where (xs,ys) = unzip ps + +--- Transforms a list of triples into a triple of lists. +unzip3 :: [(a,b,c)] -> ([a],[b],[c]) +unzip3 [] = ([],[],[]) +unzip3 ((x,y,z):ts) = (x:xs,y:ys,z:zs) where (xs,ys,zs) = unzip3 ts + +--- Concatenates a list of lists into one list. +concat :: [[a]] -> [a] +concat l = foldr (++) [] l + +--- Maps a function from elements to lists and merges the result into one list. +concatMap :: (a -> [b]) -> [a] -> [b] +concatMap f = concat . map f + +--- Infinite list of repeated applications of a function f to an element x. +--- Thus, `iterate f x = [x, f x, f (f x),...]` +iterate :: (a -> a) -> a -> [a] +iterate f x = x : iterate f (f x) + +--- Infinite list where all elements have the same value. +--- Thus, `repeat x = [x, x, x,...]` +repeat :: a -> [a] +repeat x = x : repeat x + +--- List of length n where all elements have the same value. +replicate :: Int -> a -> [a] +replicate n x = take n (repeat x) + +--- Returns prefix of length n. +take :: Int -> [a] -> [a] +take n l = if n<=0 then [] else takep n l + where takep _ [] = [] + takep m (x:xs) = x : take (m-1) xs + +--- Returns suffix without first n elements. +drop :: Int -> [a] -> [a] +drop n l = if n<=0 then l else dropp n l + where dropp _ [] = [] + dropp m (_:xs) = drop (m-1) xs + +--- (splitAt n xs) is equivalent to (take n xs, drop n xs) +splitAt :: Int -> [a] -> ([a],[a]) +splitAt n l = if n<=0 then ([],l) else splitAtp n l + where splitAtp _ [] = ([],[]) + splitAtp m (x:xs) = let (ys,zs) = splitAt (m-1) xs in (x:ys,zs) + +--- Returns longest prefix with elements satisfying a predicate. +takeWhile :: (a -> Bool) -> [a] -> [a] +takeWhile _ [] = [] +takeWhile p (x:xs) = if p x then x : takeWhile p xs else [] + +--- Returns suffix without takeWhile prefix. +dropWhile :: (a -> Bool) -> [a] -> [a] +dropWhile _ [] = [] +dropWhile p (x:xs) = if p x then dropWhile p xs else x:xs + +--- (span p xs) is equivalent to (takeWhile p xs, dropWhile p xs) +span :: (a -> Bool) -> [a] -> ([a],[a]) +span _ [] = ([],[]) +span p (x:xs) + | p x = let (ys,zs) = span p xs in (x:ys, zs) + | otherwise = ([],x:xs) + +--- (break p xs) is equivalent to (takeWhile (not.p) xs, dropWhile (not.p) xs). +--- Thus, it breaks a list at the first occurrence of an element satisfying p. +break :: (a -> Bool) -> [a] -> ([a],[a]) +break p = span (not . p) + +--- Breaks a string into a list of lines where a line is terminated at a +--- newline character. The resulting lines do not contain newline characters. +lines :: String -> [String] +lines [] = [] +lines (x:xs) = let (l,xs_l) = splitline (x:xs) in l : lines xs_l + where splitline [] = ([],[]) + splitline (c:cs) = if c=='\n' + then ([],cs) + else let (ds,es) = splitline cs in (c:ds,es) + +--- Concatenates a list of strings with terminating newlines. +unlines :: [String] -> String +unlines ls = concatMap (++"\n") ls + +--- Breaks a string into a list of words where the words are delimited by +--- white spaces. +words :: String -> [String] +words s = let s1 = dropWhile isSpace s + in if s1=="" then [] + else let (w,s2) = break isSpace s1 + in w : words s2 + where + isSpace c = c == ' ' || c == '\t' || c == '\n' || c == '\r' + +--- Concatenates a list of strings with a blank between two strings. +unwords :: [String] -> String +unwords ws = if ws==[] then [] + else foldr1 (\w s -> w ++ ' ':s) ws + +--- Reverses the order of all elements in a list. +reverse :: [a] -> [a] +reverse = foldl (flip (:)) [] + +--- Computes the conjunction of a Boolean list. +and :: [Bool] -> Bool +and = foldr (&&) True + +--- Computes the disjunction of a Boolean list. +or :: [Bool] -> Bool +or = foldr (||) False + +--- Is there an element in a list satisfying a given predicate? +any :: (a -> Bool) -> [a] -> Bool +any p = or . map p + +--- Is a given predicate satisfied by all elements in a list? +all :: (a -> Bool) -> [a] -> Bool +all p = and . map p + +--- Element of a list? +elem :: a -> [a] -> Bool +elem x = any (x==) + +--- Not element of a list? +notElem :: a -> [a] -> Bool +notElem x = all (x/=) + +--- Looks up a key in an association list. +lookup :: a -> [(a,b)] -> Maybe b +lookup _ [] = Nothing +lookup k ((x,y):xys) + | k==x = Just y + | otherwise = lookup k xys + +--- Generates an infinite sequence of ascending integers. +enumFrom :: Int -> [Int] -- [n..] +enumFrom n = n : enumFrom (n+1) + +--- Generates an infinite sequence of integers with a particular in/decrement. +enumFromThen :: Int -> Int -> [Int] -- [n1,n2..] +enumFromThen n1 n2 = iterate ((n2-n1)+) n1 + +--- Generates a sequence of ascending integers. +enumFromTo :: Int -> Int -> [Int] -- [n..m] +enumFromTo n m = if n>m then [] else n : enumFromTo (n+1) m + +--- Generates a sequence of integers with a particular in/decrement. +enumFromThenTo :: Int -> Int -> Int -> [Int] -- [n1,n2..m] +enumFromThenTo n1 n2 m = takeWhile p (enumFromThen n1 n2) + where p x | n2 >= n1 = (x <= m) + | otherwise = (x >= m) + + +--- Converts a character into its ASCII value. +ord :: Char -> Int +ord c = prim_ord $# c + +prim_ord :: Char -> Int +prim_ord external + +--- Converts a Unicode value into a character, fails iff the value is out of bounds +chr :: Int -> Char +chr n | n >= 0 = prim_chr $# n +-- chr n | n < 0 || n > 1114111 = failed +-- | otherwise = prim_chr $# n + +prim_chr :: Int -> Char +prim_chr external + + +-- Types of primitive arithmetic functions and predicates + +--- Adds two integers. +(+) :: Int -> Int -> Int +(+) external + +--- Subtracts two integers. +(-) :: Int -> Int -> Int +(-) external + +--- Multiplies two integers. +(*) :: Int -> Int -> Int +(*) external + +--- Integer division. The value is the integer quotient of its arguments +--- and always truncated towards negative infinity. +--- Thus, the value of 13 `div` 5 is 2, +--- and the value of -15 `div` 4 is -4. +div :: Int -> Int -> Int +div external + +--- Integer remainder. The value is the remainder of the integer division and +--- it obeys the rule x `mod` y = x - y * (x `div` y). +--- Thus, the value of 13 `mod` 5 is 3, +--- and the value of -15 `mod` 4 is -3. +mod :: Int -> Int -> Int +mod external + +--- Returns an integer (quotient,remainder) pair. +--- The value is the integer quotient of its arguments +--- and always truncated towards negative infinity. +divMod :: Int -> Int -> (Int, Int) +divMod external + +--- Integer division. The value is the integer quotient of its arguments +--- and always truncated towards zero. +--- Thus, the value of 13 `quot` 5 is 2, +--- and the value of -15 `quot` 4 is -3. +quot :: Int -> Int -> Int +quot external + +--- Integer remainder. The value is the remainder of the integer division and +--- it obeys the rule x `rem` y = x - y * (x `quot` y). +--- Thus, the value of 13 `rem` 5 is 3, +--- and the value of -15 `rem` 4 is -3. +rem :: Int -> Int -> Int +rem external + +--- Returns an integer (quotient,remainder) pair. +--- The value is the integer quotient of its arguments +--- and always truncated towards zero. +quotRem :: Int -> Int -> (Int, Int) +quotRem external + +--- Unary minus. Usually written as "- e". +negate :: Int -> Int +negate x = 0 - x + +--- Unary minus on Floats. Usually written as "-e". +negateFloat :: Float -> Float +negateFloat external + + +-- Constraints (included for backwar compatibility) +type Success = Bool + +--- The always satisfiable constraint. +success :: Success +success = True + +-- Maybe type + +data Maybe a = Nothing | Just a + +maybe :: b -> (a -> b) -> Maybe a -> b +maybe n _ Nothing = n +maybe _ f (Just x) = f x + + +-- Either type + +data Either a b = Left a | Right b + +either :: (a -> c) -> (b -> c) -> Either a b -> c +either f _ (Left x) = f x +either _ g (Right x) = g x + + +-- Monadic IO + +data IO _ -- conceptually: World -> (a,World) + +--- Sequential composition of actions. +--- @param a - An action +--- @param fa - A function from a value into an action +--- @return An action that first performs a (yielding result r) +--- and then performs (fa r) +(>>=) :: IO a -> (a -> IO b) -> IO b +(>>=) external + +--- The empty action that directly returns its argument. +return :: a -> IO a +return external + +--- Sequential composition of actions. +--- @param a1 - An action +--- @param a2 - An action +--- @return An action that first performs a1 and then a2 +(>>) :: IO _ -> IO b -> IO b +a >> b = a >>= (\_ -> b) + +--- The empty action that returns nothing. +done :: IO () +done = return () + +--- An action that puts its character argument on standard output. +putChar :: Char -> IO () +putChar c = prim_putChar $## c + +prim_putChar :: Char -> IO () +prim_putChar external + +--- An action that reads a character from standard output and returns it. +getChar :: IO Char +getChar external + +--- An action that (lazily) reads a file and returns its contents. +readFile :: String -> IO String +readFile f = prim_readFile $## f + +prim_readFile :: String -> IO String +prim_readFile external + +--- An action that writes a file. +--- @param filename - The name of the file to be written. +--- @param contents - The contents to be written to the file. +writeFile :: String -> String -> IO () +writeFile f s = (prim_writeFile $## f) $## s + +prim_writeFile :: String -> String -> IO () +prim_writeFile external + +--- An action that appends a string to a file. +--- It behaves like writeFile if the file does not exist. +--- @param filename - The name of the file to be written. +--- @param contents - The contents to be appended to the file. +appendFile :: String -> String -> IO () +appendFile f s = (prim_appendFile $## f) $## s + +prim_appendFile :: String -> String -> IO () +prim_appendFile external + +--- Action to print a string on stdout. +putStr :: String -> IO () +putStr [] = done +putStr (c:cs) = putChar c >> putStr cs + +--- Action to print a string with a newline on stdout. +putStrLn :: String -> IO () +putStrLn cs = putStr cs >> putChar '\n' + +--- Action to read a line from stdin. +getLine :: IO String +getLine = do c <- getChar + if c=='\n' then return [] + else do cs <- getLine + return (c:cs) + +---------------------------------------------------------------------------- +-- Error handling in the I/O monad: + +--- The (abstract) type of error values. +--- Currently, it distinguishes between general IO errors, +--- user-generated errors (see 'userError'), failures and non-determinism +--- errors during IO computations. These errors can be caught by 'catch' +--- and shown by 'showError'. +--- Each error contains a string shortly explaining the error. +--- This type might be extended in the future to distinguish +--- further error situations. +data IOError + = IOError String -- normal IO error + | UserError String -- user-specified error + | FailError String -- failing computation + | NondetError String -- non-deterministic computation + +--- A user error value is created by providing a description of the +--- error situation as a string. +userError :: String -> IOError +userError s = UserError s + +--- Raises an I/O exception with a given error value. +ioError :: IOError -> IO _ +ioError err = prim_ioError $## err + +prim_ioError :: IOError -> IO _ +prim_ioError external + +--- Shows an error values as a string. +showError :: IOError -> String +showError (IOError s) = "i/o error: " ++ s +showError (UserError s) = "user error: " ++ s +showError (FailError s) = "fail error: " ++ s +showError (NondetError s) = "nondet error: " ++ s + +--- Catches a possible error or failure during the execution of an +--- I/O action. `(catch act errfun)` executes the I/O action +--- `act`. If an exception or failure occurs +--- during this I/O action, the function `errfun` is applied +--- to the error value. +catch :: IO a -> (IOError -> IO a) -> IO a +catch external + +---------------------------------------------------------------------------- + +--- Converts an arbitrary term into an external string representation. +show :: _ -> String +show x = prim_show $## x + +prim_show :: _ -> String +prim_show external + +--- Converts a term into a string and prints it. +print :: _ -> IO () +print t = putStrLn (show t) + +--- Solves a constraint as an I/O action. +--- Note: the constraint should be always solvable in a deterministic way +doSolve :: Bool -> IO () +doSolve b | b = done + + +-- IO monad auxiliary functions: + +--- Executes a sequence of I/O actions and collects all results in a list. +sequenceIO :: [IO a] -> IO [a] +sequenceIO [] = return [] +sequenceIO (c:cs) = do x <- c + xs <- sequenceIO cs + return (x:xs) + +--- Executes a sequence of I/O actions and ignores the results. +sequenceIO_ :: [IO _] -> IO () +sequenceIO_ = foldr (>>) done + +--- Maps an I/O action function on a list of elements. +--- The results of all I/O actions are collected in a list. +mapIO :: (a -> IO b) -> [a] -> IO [b] +mapIO f = sequenceIO . map f + +--- Maps an I/O action function on a list of elements. +--- The results of all I/O actions are ignored. +mapIO_ :: (a -> IO _) -> [a] -> IO () +mapIO_ f = sequenceIO_ . map f + +--- Folds a list of elements using an binary I/O action and a value +--- for the empty list. +foldIO :: (a -> b -> IO a) -> a -> [b] -> IO a +foldIO _ a [] = return a +foldIO f a (x:xs) = f a x >>= \fax -> foldIO f fax xs + +--- Apply a pure function to the result of an I/O action. +liftIO :: (a -> b) -> IO a -> IO b +liftIO f m = m >>= return . f + +--- Like `mapIO`, but with flipped arguments. +--- +--- This can be useful if the definition of the function is longer +--- than those of the list, like in +--- +--- forIO [1..10] $ \n -> do +--- ... +forIO :: [a] -> (a -> IO b) -> IO [b] +forIO xs f = mapIO f xs + +--- Like `mapIO_`, but with flipped arguments. +--- +--- This can be useful if the definition of the function is longer +--- than those of the list, like in +--- +--- forIO_ [1..10] $ \n -> do +--- ... +forIO_ :: [a] -> (a -> IO b) -> IO () +forIO_ xs f = mapIO_ f xs + +--- Performs an `IO` action unless the condition is met. +unless :: Bool -> IO () -> IO () +unless p act = if p then done else act + +--- Performs an `IO` action when the condition is met. +when :: Bool -> IO () -> IO () +when p act = if p then act else done + +---------------------------------------------------------------- +-- Non-determinism and free variables: + +--- Non-deterministic choice _par excellence_. +--- The value of `x ? y` is either `x` or `y`. +--- @param x - The right argument. +--- @param y - The left argument. +--- @return either `x` or `y` non-deterministically. +(?) :: a -> a -> a +x ? _ = x +_ ? y = y + + +--- Evaluates to a fresh free variable. +unknown :: _ +unknown = let x free in x + +---------------------------------------------------------------- +--- Identity type synonym used to mark deterministic operations. +type DET a = a + +--- Identity function used by the partial evaluator +--- to mark expressions to be partially evaluated. +PEVAL :: a -> a +PEVAL x = x + +--- Evaluates the argument to normal form and returns it. +normalForm :: a -> a +normalForm x = id $!! x + +--- Evaluates the argument to ground normal form and returns it. +--- Suspends as long as the normal form of the argument is not ground. +groundNormalForm :: a -> a +groundNormalForm x = id $## x + +-- Only for internal use: +-- Representation of higher-order applications in FlatCurry. +apply :: (a -> b) -> a -> b +apply external + +-- Only for internal use: +-- Representation of conditional rules in FlatCurry. +cond :: Bool -> a -> a +cond external + +--- Non-strict equational constraint. Used to implement functional patterns. +(=:<=) :: a -> a -> Bool +(=:<=) external + +-- the end of the standard prelude diff --git a/test/Shadow.curry b/test/warning/ShadowingSymbols.curry similarity index 67% rename from test/Shadow.curry rename to test/warning/ShadowingSymbols.curry index 432957d3..13db4a7c 100644 --- a/test/Shadow.curry +++ b/test/warning/ShadowingSymbols.curry @@ -1,4 +1,4 @@ -module Shadow where +module ShadowingSymbols where main = do x <- return True @@ -12,4 +12,4 @@ main2 = do f x = g 1 where g x = x -lc = [x | x <- [1..10], x <- [1..10]] \ No newline at end of file +lc = [x | x <- [1..10], x <- [1..10]] -- GitLab