Merge pull request #443 from maxsnew/strchr

Fix String/Char Parse/Print Bugs

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,69 @@ markdown interpolation = try (string "[markdown|") >> closeMarkdown "" []
                  ]
 
 str :: IParser String
-str = choice [ quote >> dewindows <$> manyTill (backslashed <|> anyChar) quote
+str = expecting "String" $
-             , liftM dewindows . expecting "string" . betwixt '"' '"' . many $
+  choice [ quote >> manyTill multilineStringChar quote
-               backslashed <|> satisfy (/='"')
+         , char '"' >> manyTill stringChar (char '"')
-             ]
+         ]
-    where
+  >>= parseStringLiteral . wrapQuotes '\"' . join
-      quote = try (string "\"\"\"")
+  where quote = try (string "\"\"\"")
 
-      -- Remove \r from strings to fix generated JavaScript
+wrapQuotes :: Char -> String -> String
-      dewindows [] = []
+wrapQuotes delim s = (delim:s ++ [delim])
-      dewindows cs =
+
-          let (pre, suf) = break (`elem` ['\r','\n']) cs
+stringChar :: IParser String
-          in  pre ++ case suf of 
+stringChar = newlineChar <|> escaped '\"' <|> (pure <$> satisfy (/= '\"'))
-                       ('\r':'\n':rest) -> '\n' : dewindows rest
+
-                       ('\n':rest)      -> '\n' : dewindows rest
+multilineStringChar :: IParser String
-                       ('\r':rest)      -> '\n' : dewindows rest
+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
+  char '\\'
+  c <- char '\\' <|> char delim
+  return ['\\', c]
 
 chr :: IParser Char
-chr = betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
+chr = (betwixt '\'' '\''
-      <?> "character"
+       (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
+  }

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)
+      Chr c -> PP.text . show $ c
-      Str s -> PP.text (show s)
+      Str s -> PP.text . show $ s
       Boolean bool -> PP.text (show bool)

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"
+  goods <- mkTests goodCompile  =<< getElms "good"
-  bads  <- mkTests False =<< getElms "bad"
+  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 :: (Either String String -> Assertion) -> [FilePath] -> IO [Test]
-        mkTests b = traverse setupTest
+        mkTests h = traverse setupTest
-          where setupTest f = testCase f . mkCompileTest b <$> readFile f
+          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
+mkCompileTest handle = handle . Elm.compile
-  where noCompileErr = either (const False) (const True) . Elm.compile $ modul
-        expectation = "Compile " ++ if succ then "Success" else "Error"

tests/test-files/bad/Strings/ExtraClose.elm

@@ -0,0 +1,4 @@
+
+s = " " "
+
+main = plainText s

tests/test-files/good/Strings/Multiline.elm

@@ -0,0 +1,6 @@
+s = """
+here's a quote: "
+
+"""
+
+main = plainText s

tests/test-files/good/Strings/MultilineNormal.elm

@@ -0,0 +1,6 @@
+s = "
+here's a quote: \"
+
+"
+
+main = plainText s