@@ -1,19 +1,21 @@
11module Parse.Helpers where
22
33import Prelude hiding (until)
4−import Control.Applicative ((<$>),(<*>))
4+import Control.Applicative ((<$>),(<*>), (<$), pure)
55import Control.Monad
66import Control.Monad.State
77import Data.Char (isUpper)
88import qualified Data.Set as Set
99import qualified Data.Map as Map
10+import Text.Parsec hiding (newline,spaces,State)
11+import Text.Parsec.Indent
12+import qualified Text.Parsec.Token as P
13+
1014import SourceSyntax.Helpers as Help
1115import SourceSyntax.Location as Location
1216import SourceSyntax.Expression
1317import SourceSyntax.PrettyPrint
1418import SourceSyntax.Declaration (Assoc)
15−import Text.Parsec hiding (newline,spaces,State)
16−import Text.Parsec.Indent
1719
1820reserveds = [ "if", "then", "else"
1921 , "case", "of"
@@ -45,7 +47,8 @@ jsReserveds = Set.fromList
4547expecting = flip (<?>)
4648
4749type OpTable = Map.Map String (Int, Assoc)
48−type IParser a = ParsecT String OpTable (State SourcePos) a
50+type SourceM = State SourcePos
51+type IParser a = ParsecT String OpTable SourceM a
4952
5053iParse :: IParser a -> String -> Either ParseError a
5154iParse = iParseWithTable "" Map.empty
@@ -54,23 +57,6 @@ iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseE
5457iParseWithTable sourceName table aParser input =
5558 runIndent sourceName $ runParserT aParser table sourceName input
5659
57−readMaybe :: Read a => String -> Maybe a
58−readMaybe s =
59− case [ x | (x,t) <- reads s, ("","") <- lex t ] of
60− [x] -> Just x
61− _ -> Nothing
62−
63−backslashed :: IParser Char
64−backslashed = do
65− char '\\'
66− c <- anyChar
67− case readMaybe ['\'','\\',c,'\''] of
68− Just chr -> return chr
69− Nothing ->
70− fail $ "Did not recognize character '\\" ++ [c] ++
71− "'. If the backslash is meant to be a character of its own, " ++
72− "it should be escaped like this: \"\\\\" ++ [c] ++ "\""
73−
7460var :: IParser String
7561var = makeVar (letter <|> char '_' <?> "variable")
7662
@@ -326,23 +312,69 @@ markdown interpolation = try (string "[markdown|") >> closeMarkdown "" []
326312 ]
327313
328314str :: IParser String
329−str = choice [ quote >> dewindows <$> manyTill (backslashed <|> anyChar) quote
330− , liftM dewindows . expecting "string" . betwixt '"' '"' . many $
331− backslashed <|> satisfy (/='"')
332− ]
333− where
334− quote = try (string "\"\"\"")
335−
336− -- Remove \r from strings to fix generated JavaScript
337− dewindows [] = []
338− dewindows cs =
339− let (pre, suf) = break (`elem` ['\r','\n']) cs
340− in pre ++ case suf of
341− ('\r':'\n':rest) -> '\n' : dewindows rest
342− ('\n':rest) -> '\n' : dewindows rest
343− ('\r':rest) -> '\n' : dewindows rest
344− _ -> []
315+str = expecting "String" $
316+ choice [ quote >> manyTill multilineStringChar quote
317+ , char '"' >> manyTill stringChar (char '"')
318+ ]
319+ >>= parseStringLiteral . wrapQuotes '\"' . join
320+ where quote = try (string "\"\"\"")
321+
322+wrapQuotes :: Char -> String -> String
323+wrapQuotes delim s = (delim:s ++ [delim])
324+
325+stringChar :: IParser String
326+stringChar = newlineChar <|> escaped '\"' <|> (pure <$> satisfy (/= '\"'))
327+
328+multilineStringChar :: IParser String
329+multilineStringChar = noEnd
330+ >> (newlineChar <|> escaped '\"' <|> expandQuote <$> anyChar)
331+ where noEnd = notFollowedBy (string "\"\"\"")
332+ expandQuote c = if c == '\"'
333+ then "\\\""
334+ else [c]
335+
336+newlineChar :: IParser String
337+newlineChar = ['\\', 'n'] <$ char '\n'
338+ <|> ['\\', 'r'] <$ char '\r'
339+
340+escaped :: Char -> IParser String
341+escaped delim = try $ do
342+ char '\\'
343+ c <- char '\\' <|> char delim
344+ return ['\\', c]
345345
346346chr :: IParser Char
347−chr = betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
348− <?> "character"
347+chr = (betwixt '\'' '\''
348+ (many1 (escaped '\'' <|> (pure <$> satisfy (/='\''))))
349+ >>= parseCharLiteral . wrapQuotes '\'' . join
350+ )
351+ <?> "character"
352+
353+calloutParser :: String -> IParser a -> IParser a
354+calloutParser inp p = case iParse p inp of
355+ Left err -> fail . show $ err
356+ Right s -> return s
357+
358+parseStringLiteral :: String -> IParser String
359+parseStringLiteral s = calloutParser s . P.stringLiteral $ lexer
360+
361+parseCharLiteral :: String -> IParser Char
362+parseCharLiteral s = calloutParser s . P.charLiteral $ lexer
363+
364+lexer = P.makeTokenParser elmDef
365+
366+-- I don't know how many of these are necessary for charLiteral/stringLiteral
367+elmDef :: P.GenLanguageDef String u SourceM
368+elmDef = P.LanguageDef {
369+ P.commentStart = "{-"
370+ , P.commentEnd = "-}"
371+ , P.commentLine = "--"
372+ , P.nestedComments = True
373+ , P.identStart = undefined
374+ , P.identLetter = undefined
375+ , P.opStart = undefined
376+ , P.opLetter = undefined
377+ , P.reservedNames = reserveds
378+ , P.reservedOpNames = [":", "->", "<-", "|"]
379+ , P.caseSensitive = True
380+ }