From 5ea3ec7f80a0e1a5ea8b9932536fdaecb7c3dc02 Mon Sep 17 00:00:00 2001 From: Max New Date: Tue, 7 Jan 2014 15:44:12 -0600 Subject: [PATCH 1/3] Call out to stringLiteral/charLiteral for string/char literal parsing --- compiler/Parse/Helpers.hs | 97 ++++++++++++++++++++++++--------------- 1 file changed, 59 insertions(+), 38 deletions(-) diff --git a/compiler/Parse/Helpers.hs b/compiler/Parse/Helpers.hs index 6ec68a6..e9c12de 100644 --- a/compiler/Parse/Helpers.hs +++ b/compiler/Parse/Helpers.hs @@ -1,19 +1,21 @@ module Parse.Helpers where import Prelude hiding (until) -import Control.Applicative ((<$>),(<*>)) +import Control.Applicative ((<$>),(<*>), (<$), pure) import Control.Monad import Control.Monad.State import Data.Char (isUpper) import qualified Data.Set as Set import qualified Data.Map as Map +import Text.Parsec hiding (newline,spaces,State) +import Text.Parsec.Indent +import qualified Text.Parsec.Token as P + import SourceSyntax.Helpers as Help import SourceSyntax.Location as Location import SourceSyntax.Expression import SourceSyntax.PrettyPrint import SourceSyntax.Declaration (Assoc) -import Text.Parsec hiding (newline,spaces,State) -import Text.Parsec.Indent reserveds = [ "if", "then", "else" , "case", "of" @@ -45,7 +47,8 @@ jsReserveds = Set.fromList expecting = flip () type OpTable = Map.Map String (Int, Assoc) -type IParser a = ParsecT String OpTable (State SourcePos) a +type SourceM = State SourcePos +type IParser a = ParsecT String OpTable SourceM a iParse :: IParser a -> String -> Either ParseError a iParse = iParseWithTable "" Map.empty @@ -54,23 +57,6 @@ iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseE iParseWithTable sourceName table aParser input = runIndent sourceName $ runParserT aParser table sourceName input -readMaybe :: Read a => String -> Maybe a -readMaybe s = - case [ x | (x,t) <- reads s, ("","") <- lex t ] of - [x] -> Just x - _ -> Nothing - -backslashed :: IParser Char -backslashed = do - char '\\' - c <- anyChar - case readMaybe ['\'','\\',c,'\''] of - Just chr -> return chr - Nothing -> - fail $ "Did not recognize character '\\" ++ [c] ++ - "'. If the backslash is meant to be a character of its own, " ++ - "it should be escaped like this: \"\\\\" ++ [c] ++ "\"" - var :: IParser String var = makeVar (letter <|> char '_' "variable") @@ -326,23 +312,58 @@ markdown interpolation = try (string "[markdown|") >> closeMarkdown "" [] ] str :: IParser String -str = choice [ quote >> dewindows <$> manyTill (backslashed <|> anyChar) quote - , liftM dewindows . expecting "string" . betwixt '"' '"' . many $ - backslashed <|> satisfy (/='"') - ] - where - quote = try (string "\"\"\"") +str = + choice [ quote >> manyTill stringChar quote + , expecting "string" . betwixt '"' '"' . many $ stringChar + ] + >>= parseStringLiteral . wrapQuotes '\"' . join + where quote = try (string "\"\"\"") - -- Remove \r from strings to fix generated JavaScript - dewindows [] = [] - dewindows cs = - let (pre, suf) = break (`elem` ['\r','\n']) cs - in pre ++ case suf of - ('\r':'\n':rest) -> '\n' : dewindows rest - ('\n':rest) -> '\n' : dewindows rest - ('\r':rest) -> '\n' : dewindows rest - _ -> [] +wrapQuotes :: Char -> String -> String +wrapQuotes delim s = (delim:s ++ [delim]) + +stringChar :: IParser String +stringChar = newline <|> escaped '\"' <|> (pure <$> satisfy (/= '\"')) + where newline = ['\\', 'n'] <$ char '\n' + <|> ['\\', 'r'] <$ char '\r' + +escaped :: Char -> IParser String +escaped delim = try $ do + char '\\' + c <- char '\\' <|> char delim + return ['\\', c] chr :: IParser Char -chr = betwixt '\'' '\'' (backslashed <|> satisfy (/='\'')) - "character" \ No newline at end of file +chr = (betwixt '\'' '\'' (many1 (escaped '\'' <|> (pure <$> satisfy (/='\'')))) + >>= parseCharLiteral . wrapQuotes '\'' . join + ) + "character" + +calloutParser :: String -> IParser a -> IParser a +calloutParser inp p = case iParse p inp of + Left err -> fail . show $ err + Right s -> return s + +parseStringLiteral :: String -> IParser String +parseStringLiteral s = calloutParser s . P.stringLiteral $ lexer + +parseCharLiteral :: String -> IParser Char +parseCharLiteral s = calloutParser s . P.charLiteral $ lexer + +lexer = P.makeTokenParser elmDef + +-- I don't know how many of these are necessary for charLiteral/stringLiteral +elmDef :: P.GenLanguageDef String u SourceM +elmDef = P.LanguageDef { + P.commentStart = "{-" + , P.commentEnd = "-}" + , P.commentLine = "--" + , P.nestedComments = True + , P.identStart = undefined + , P.identLetter = undefined + , P.opStart = undefined + , P.opLetter = undefined + , P.reservedNames = reserveds + , P.reservedOpNames = [":", "->", "<-", "|"] + , P.caseSensitive = True + } From cca69cf8e72c494ab32b09aae1a08ad58d8ef9f6 Mon Sep 17 00:00:00 2001 From: Max New Date: Tue, 7 Jan 2014 15:52:19 -0600 Subject: [PATCH 2/3] Fix Char literal printing bug. --- compiler/SourceSyntax/Literal.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/compiler/SourceSyntax/Literal.hs b/compiler/SourceSyntax/Literal.hs index 3bf4207..818f610 100644 --- a/compiler/SourceSyntax/Literal.hs +++ b/compiler/SourceSyntax/Literal.hs @@ -16,6 +16,6 @@ instance Pretty Literal where case literal of IntNum n -> PP.int n FloatNum n -> PP.double n - Chr c -> PP.quotes (PP.char c) - Str s -> PP.text (show s) + Chr c -> PP.text . show $ c + Str s -> PP.text . show $ s Boolean bool -> PP.text (show bool) From 6b255fed5989f52c94c66241944b69bc66345fb0 Mon Sep 17 00:00:00 2001 From: Max New Date: Tue, 7 Jan 2014 16:57:47 -0600 Subject: [PATCH 3/3] Fix multiline string handling and add more tests. --- compiler/Parse/Helpers.hs | 25 +++++++++++----- tests/Tests/Compiler.hs | 29 ++++++++++++------- tests/{data => test-files}/bad/BBTArgs | 0 .../{data => test-files}/bad/InfiniteType.elm | 0 .../bad/NonElementMain.elm | 0 tests/test-files/bad/Strings/ExtraClose.elm | 4 +++ .../good/AliasSubstitution.elm | 0 .../good/NoExpressions.elm | 0 tests/{data => test-files}/good/Otherwise.elm | 0 .../good/QuotesAndComments.elm | 0 .../good/Soundness/Apply.elm | 0 .../good/Soundness/ApplyAnnotated.elm | 0 .../good/Soundness/Id.elm | 0 .../good/Soundness/IdAnnotated.elm | 0 .../good/Soundness/TrickyId.elm | 0 .../good/Soundness/TrickyIdAnnotated.elm | 0 tests/test-files/good/Strings/Multiline.elm | 6 ++++ .../good/Strings/MultilineNormal.elm | 6 ++++ .../good/Unify/LockedVars.elm | 0 .../good/Unify/NonHomogeneousRecords.elm | 0 20 files changed, 52 insertions(+), 18 deletions(-) rename tests/{data => test-files}/bad/BBTArgs (100%) rename tests/{data => test-files}/bad/InfiniteType.elm (100%) rename tests/{data => test-files}/bad/NonElementMain.elm (100%) create mode 100644 tests/test-files/bad/Strings/ExtraClose.elm rename tests/{data => test-files}/good/AliasSubstitution.elm (100%) rename tests/{data => test-files}/good/NoExpressions.elm (100%) rename tests/{data => test-files}/good/Otherwise.elm (100%) rename tests/{data => test-files}/good/QuotesAndComments.elm (100%) rename tests/{data => test-files}/good/Soundness/Apply.elm (100%) rename tests/{data => test-files}/good/Soundness/ApplyAnnotated.elm (100%) rename tests/{data => test-files}/good/Soundness/Id.elm (100%) rename tests/{data => test-files}/good/Soundness/IdAnnotated.elm (100%) rename tests/{data => test-files}/good/Soundness/TrickyId.elm (100%) rename tests/{data => test-files}/good/Soundness/TrickyIdAnnotated.elm (100%) create mode 100644 tests/test-files/good/Strings/Multiline.elm create mode 100644 tests/test-files/good/Strings/MultilineNormal.elm rename tests/{data => test-files}/good/Unify/LockedVars.elm (100%) rename tests/{data => test-files}/good/Unify/NonHomogeneousRecords.elm (100%) diff --git a/compiler/Parse/Helpers.hs b/compiler/Parse/Helpers.hs index e9c12de..fe2318d 100644 --- a/compiler/Parse/Helpers.hs +++ b/compiler/Parse/Helpers.hs @@ -312,9 +312,9 @@ markdown interpolation = try (string "[markdown|") >> closeMarkdown "" [] ] str :: IParser String -str = - choice [ quote >> manyTill stringChar quote - , expecting "string" . betwixt '"' '"' . many $ stringChar +str = expecting "String" $ + choice [ quote >> manyTill multilineStringChar quote + , char '"' >> manyTill stringChar (char '"') ] >>= parseStringLiteral . wrapQuotes '\"' . join where quote = try (string "\"\"\"") @@ -323,9 +323,19 @@ wrapQuotes :: Char -> String -> String wrapQuotes delim s = (delim:s ++ [delim]) stringChar :: IParser String -stringChar = newline <|> escaped '\"' <|> (pure <$> satisfy (/= '\"')) - where newline = ['\\', 'n'] <$ char '\n' - <|> ['\\', 'r'] <$ char '\r' +stringChar = newlineChar <|> escaped '\"' <|> (pure <$> satisfy (/= '\"')) + +multilineStringChar :: IParser String +multilineStringChar = noEnd + >> (newlineChar <|> escaped '\"' <|> expandQuote <$> anyChar) + where noEnd = notFollowedBy (string "\"\"\"") + expandQuote c = if c == '\"' + then "\\\"" + else [c] + +newlineChar :: IParser String +newlineChar = ['\\', 'n'] <$ char '\n' + <|> ['\\', 'r'] <$ char '\r' escaped :: Char -> IParser String escaped delim = try $ do @@ -334,7 +344,8 @@ escaped delim = try $ do return ['\\', c] chr :: IParser Char -chr = (betwixt '\'' '\'' (many1 (escaped '\'' <|> (pure <$> satisfy (/='\'')))) +chr = (betwixt '\'' '\'' + (many1 (escaped '\'' <|> (pure <$> satisfy (/='\'')))) >>= parseCharLiteral . wrapQuotes '\'' . join ) "character" diff --git a/tests/Tests/Compiler.hs b/tests/Tests/Compiler.hs index 1bd2e85..64b7bc9 100644 --- a/tests/Tests/Compiler.hs +++ b/tests/Tests/Compiler.hs @@ -7,14 +7,15 @@ import System.FilePath (()) import System.FilePath.Find (find, (==?), extension) import Test.Framework import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?), Assertion) +import Test.HUnit (Assertion, assertFailure, assertBool) +import Text.Parsec (ParseError) import Elm.Internal.Utils as Elm compilerTests :: Test compilerTests = buildTest $ do - goods <- mkTests True =<< getElms "good" - bads <- mkTests False =<< getElms "bad" + goods <- mkTests goodCompile =<< getElms "good" + bads <- mkTests badCompile =<< getElms "bad" return $ testGroup "Compile Tests" [ testGroup "Good Tests" goods @@ -24,15 +25,21 @@ compilerTests = buildTest $ do where getElms :: FilePath -> IO [FilePath] getElms fname = find (return True) (extension ==? ".elm") (testsDir fname) - mkTests :: Bool -> [FilePath] -> IO [Test] - mkTests b = traverse setupTest - where setupTest f = testCase f . mkCompileTest b <$> readFile f + mkTests :: (Either String String -> Assertion) -> [FilePath] -> IO [Test] + mkTests h = traverse setupTest + where setupTest f = testCase f . mkCompileTest h <$> readFile f - testsDir = "tests" "data" + testsDir = "tests" "test-files" -mkCompileTest :: Bool -- ^ Expect success? +goodCompile :: Either String String -> Assertion +goodCompile (Left err) = assertFailure err +goodCompile (Right _) = assertBool "" True + +badCompile :: Either String String -> Assertion +badCompile (Left _) = assertBool "" True +badCompile (Right _) = assertFailure "Compilation succeeded but should have failed" + +mkCompileTest :: ((Either String String) -> Assertion) -- ^ Handler -> String -- ^ File Contents -> Assertion -mkCompileTest succ modul = noCompileErr @=? succ - where noCompileErr = either (const False) (const True) . Elm.compile $ modul - expectation = "Compile " ++ if succ then "Success" else "Error" +mkCompileTest handle = handle . Elm.compile diff --git a/tests/data/bad/BBTArgs b/tests/test-files/bad/BBTArgs similarity index 100% rename from tests/data/bad/BBTArgs rename to tests/test-files/bad/BBTArgs diff --git a/tests/data/bad/InfiniteType.elm b/tests/test-files/bad/InfiniteType.elm similarity index 100% rename from tests/data/bad/InfiniteType.elm rename to tests/test-files/bad/InfiniteType.elm diff --git a/tests/data/bad/NonElementMain.elm b/tests/test-files/bad/NonElementMain.elm similarity index 100% rename from tests/data/bad/NonElementMain.elm rename to tests/test-files/bad/NonElementMain.elm diff --git a/tests/test-files/bad/Strings/ExtraClose.elm b/tests/test-files/bad/Strings/ExtraClose.elm new file mode 100644 index 0000000..f00a493 --- /dev/null +++ b/tests/test-files/bad/Strings/ExtraClose.elm @@ -0,0 +1,4 @@ + +s = " " " + +main = plainText s diff --git a/tests/data/good/AliasSubstitution.elm b/tests/test-files/good/AliasSubstitution.elm similarity index 100% rename from tests/data/good/AliasSubstitution.elm rename to tests/test-files/good/AliasSubstitution.elm diff --git a/tests/data/good/NoExpressions.elm b/tests/test-files/good/NoExpressions.elm similarity index 100% rename from tests/data/good/NoExpressions.elm rename to tests/test-files/good/NoExpressions.elm diff --git a/tests/data/good/Otherwise.elm b/tests/test-files/good/Otherwise.elm similarity index 100% rename from tests/data/good/Otherwise.elm rename to tests/test-files/good/Otherwise.elm diff --git a/tests/data/good/QuotesAndComments.elm b/tests/test-files/good/QuotesAndComments.elm similarity index 100% rename from tests/data/good/QuotesAndComments.elm rename to tests/test-files/good/QuotesAndComments.elm diff --git a/tests/data/good/Soundness/Apply.elm b/tests/test-files/good/Soundness/Apply.elm similarity index 100% rename from tests/data/good/Soundness/Apply.elm rename to tests/test-files/good/Soundness/Apply.elm diff --git a/tests/data/good/Soundness/ApplyAnnotated.elm b/tests/test-files/good/Soundness/ApplyAnnotated.elm similarity index 100% rename from tests/data/good/Soundness/ApplyAnnotated.elm rename to tests/test-files/good/Soundness/ApplyAnnotated.elm diff --git a/tests/data/good/Soundness/Id.elm b/tests/test-files/good/Soundness/Id.elm similarity index 100% rename from tests/data/good/Soundness/Id.elm rename to tests/test-files/good/Soundness/Id.elm diff --git a/tests/data/good/Soundness/IdAnnotated.elm b/tests/test-files/good/Soundness/IdAnnotated.elm similarity index 100% rename from tests/data/good/Soundness/IdAnnotated.elm rename to tests/test-files/good/Soundness/IdAnnotated.elm diff --git a/tests/data/good/Soundness/TrickyId.elm b/tests/test-files/good/Soundness/TrickyId.elm similarity index 100% rename from tests/data/good/Soundness/TrickyId.elm rename to tests/test-files/good/Soundness/TrickyId.elm diff --git a/tests/data/good/Soundness/TrickyIdAnnotated.elm b/tests/test-files/good/Soundness/TrickyIdAnnotated.elm similarity index 100% rename from tests/data/good/Soundness/TrickyIdAnnotated.elm rename to tests/test-files/good/Soundness/TrickyIdAnnotated.elm diff --git a/tests/test-files/good/Strings/Multiline.elm b/tests/test-files/good/Strings/Multiline.elm new file mode 100644 index 0000000..018b76e --- /dev/null +++ b/tests/test-files/good/Strings/Multiline.elm @@ -0,0 +1,6 @@ +s = """ +here's a quote: " + +""" + +main = plainText s diff --git a/tests/test-files/good/Strings/MultilineNormal.elm b/tests/test-files/good/Strings/MultilineNormal.elm new file mode 100644 index 0000000..b6a2b15 --- /dev/null +++ b/tests/test-files/good/Strings/MultilineNormal.elm @@ -0,0 +1,6 @@ +s = " +here's a quote: \" + +" + +main = plainText s diff --git a/tests/data/good/Unify/LockedVars.elm b/tests/test-files/good/Unify/LockedVars.elm similarity index 100% rename from tests/data/good/Unify/LockedVars.elm rename to tests/test-files/good/Unify/LockedVars.elm diff --git a/tests/data/good/Unify/NonHomogeneousRecords.elm b/tests/test-files/good/Unify/NonHomogeneousRecords.elm similarity index 100% rename from tests/data/good/Unify/NonHomogeneousRecords.elm rename to tests/test-files/good/Unify/NonHomogeneousRecords.elm