@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -W #-}
12module Parse.Helpers where
23
34import Prelude hiding (until)
@@ -10,14 +11,16 @@ import Data.Map (Map)
1011import qualified Data.Map as Map
1112import qualified Language.GLSL.Parser as GLP
1213import Language.GLSL.Syntax
14+import Text.Parsec hiding (newline,spaces,State)
15+import Text.Parsec.Indent
16+import qualified Text.Parsec.Token as T
17+
1318import SourceSyntax.Helpers as Help
1419import SourceSyntax.Literal as Literal
1520import SourceSyntax.Location as Location
1621import SourceSyntax.Expression
1722import SourceSyntax.PrettyPrint
1823import SourceSyntax.Declaration (Assoc)
19−import Text.Parsec hiding (newline,spaces,State)
20−import Text.Parsec.Indent
2124
2225reserveds = [ "if", "then", "else"
2326 , "case", "of"
@@ -49,7 +52,8 @@ jsReserveds = Set.fromList
4952expecting = flip (<?>)
5053
5154type OpTable = Map.Map String (Int, Assoc)
52−type IParser a = ParsecT String OpTable (State SourcePos) a
55+type SourceM = State SourcePos
56+type IParser a = ParsecT String OpTable SourceM a
5357
5458iParse :: IParser a -> String -> Either ParseError a
5559iParse = iParseWithTable "" Map.empty
@@ -58,23 +62,6 @@ iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseE
5862iParseWithTable sourceName table aParser input =
5963 runIndent sourceName $ runParserT aParser table sourceName input
6064
61−readMaybe :: Read a => String -> Maybe a
62−readMaybe s =
63− case [ x | (x,t) <- reads s, ("","") <- lex t ] of
64− [x] -> Just x
65− _ -> Nothing
66−
67−backslashed :: IParser Char
68−backslashed = do
69− char '\\'
70− c <- anyChar
71− case readMaybe ['\'','\\',c,'\''] of
72− Just chr -> return chr
73− Nothing ->
74− fail $ "Did not recognize character '\\" ++ [c] ++
75− "'. If the backslash is meant to be a character of its own, " ++
76− "it should be escaped like this: \"\\\\" ++ [c] ++ "\""
77−
7865var :: IParser String
7966var = makeVar (letter <|> char '_' <?> "variable")
8067
@@ -369,24 +356,73 @@ glSource src =
369356 else []
370357 _ -> []
371358
372−str :: IParser String
373−str = choice [ quote >> dewindows <$> manyTill (backslashed <|> anyChar) quote
374− , liftM dewindows . expecting "string" . betwixt '"' '"' . many $
375− backslashed <|> satisfy (/='"')
376− ]
377− where
378− quote = try (string "\"\"\"")
379−
380− -- Remove \r from strings to fix generated JavaScript
381− dewindows [] = []
382− dewindows cs =
383− let (pre, suf) = break (`elem` ['\r','\n']) cs
384− in pre ++ case suf of
385− ('\r':'\n':rest) -> '\n' : dewindows rest
386− ('\n':rest) -> '\n' : dewindows rest
387− ('\r':rest) -> '\n' : dewindows rest
388− _ -> []
359+--str :: IParser String
360+str = expecting "String" $ do
361+ s <- choice [ multiStr, singleStr ]
362+ processAs T.stringLiteral . sandwich '\"' $ concat s
363+ where
364+ rawString quote insides =
365+ quote >> manyTill insides quote
366+
367+ multiStr = rawString (try (string "\"\"\"")) multilineStringChar
368+ singleStr = rawString (char '"') stringChar
369+
370+ stringChar :: IParser String
371+ stringChar = choice [ newlineChar, escaped '\"', (:[]) <$> satisfy (/= '\"') ]
372+
373+ multilineStringChar :: IParser String
374+ multilineStringChar =
375+ do noEnd
376+ choice [ newlineChar, escaped '\"', expandQuote <$> anyChar ]
377+ where
378+ noEnd = notFollowedBy (string "\"\"\"")
379+ expandQuote c = if c == '\"' then "\\\"" else [c]
380+
381+ newlineChar :: IParser String
382+ newlineChar =
383+ choice [ char '\n' >> return "\\n"
384+ , char '\r' >> return "\\r" ]
385+
386+sandwich :: Char -> String -> String
387+sandwich delim s = delim : s ++ [delim]
388+
389+escaped :: Char -> IParser String
390+escaped delim = try $ do
391+ char '\\'
392+ c <- char '\\' <|> char delim
393+ return ['\\', c]
389394
390395chr :: IParser Char
391−chr = betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
392− <?> "character"
396+chr = betwixt '\'' '\'' character <?> "character"
397+ where
398+ nonQuote = satisfy (/='\'')
399+ character = do
400+ c <- choice [ escaped '\''
401+ , (:) <$> char '\\' <*> many1 nonQuote
402+ , (:[]) <$> nonQuote ]
403+ processAs T.charLiteral $ sandwich '\'' c
404+
405+processAs :: (T.GenTokenParser String u SourceM -> IParser a) -> String -> IParser a
406+processAs processor s = calloutParser s (processor lexer)
407+ where
408+ calloutParser :: String -> IParser a -> IParser a
409+ calloutParser inp p = either (fail . show) return (iParse p inp)
410+
411+ lexer :: T.GenTokenParser String u SourceM
412+ lexer = T.makeTokenParser elmDef
413+
414+ -- I don't know how many of these are necessary for charLiteral/stringLiteral
415+ elmDef :: T.GenLanguageDef String u SourceM
416+ elmDef = T.LanguageDef
417+ { T.commentStart = "{-"
418+ , T.commentEnd = "-}"
419+ , T.commentLine = "--"
420+ , T.nestedComments = True
421+ , T.identStart = undefined
422+ , T.identLetter = undefined
423+ , T.opStart = undefined
424+ , T.opLetter = undefined
425+ , T.reservedNames = reserveds
426+ , T.reservedOpNames = [":", "->", "<-", "|"]
427+ , T.caseSensitive = True
428+ }