@@ -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,58 @@ 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 =
316+ choice [ quote >> manyTill stringChar quote
317+ , expecting "string" . betwixt '"' '"' . many $ stringChar
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 = newline <|> escaped '\"' <|> (pure <$> satisfy (/= '\"'))
327+ where newline = ['\\', 'n'] <$ char '\n'
328+ <|> ['\\', 'r'] <$ char '\r'
329+
330+escaped :: Char -> IParser String
331+escaped delim = try $ do
332+ char '\\'
333+ c <- char '\\' <|> char delim
334+ return ['\\', c]
345335
346336chr :: IParser Char
347−chr = betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
348− <?> "character"
337+chr = (betwixt '\'' '\'' (many1 (escaped '\'' <|> (pure <$> satisfy (/='\''))))
338+ >>= parseCharLiteral . wrapQuotes '\'' . join
339+ )
340+ <?> "character"
341+
342+calloutParser :: String -> IParser a -> IParser a
343+calloutParser inp p = case iParse p inp of
344+ Left err -> fail . show $ err
345+ Right s -> return s
346+
347+parseStringLiteral :: String -> IParser String
348+parseStringLiteral s = calloutParser s . P.stringLiteral $ lexer
349+
350+parseCharLiteral :: String -> IParser Char
351+parseCharLiteral s = calloutParser s . P.charLiteral $ lexer
352+
353+lexer = P.makeTokenParser elmDef
354+
355+-- I don't know how many of these are necessary for charLiteral/stringLiteral
356+elmDef :: P.GenLanguageDef String u SourceM
357+elmDef = P.LanguageDef {
358+ P.commentStart = "{-"
359+ , P.commentEnd = "-}"
360+ , P.commentLine = "--"
361+ , P.nestedComments = True
362+ , P.identStart = undefined
363+ , P.identLetter = undefined
364+ , P.opStart = undefined
365+ , P.opLetter = undefined
366+ , P.reservedNames = reserveds
367+ , P.reservedOpNames = [":", "->", "<-", "|"]
368+ , P.caseSensitive = True
369+ }