Call out to stringLiteral/charLiteral for string/char literal parsing

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"
+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
+  }