@@ -1,7 +1,8 @@
1+{-# OPTIONS_GHC -W #-}
12module Parse.Helpers where
23
34import Prelude hiding (until)
4−import Control.Applicative ((<$>),(<*>), (<$), pure)
5+import Control.Applicative ((<$>),(<*>))
56import Control.Monad
67import Control.Monad.State
78import Data.Char (isUpper)
@@ -9,7 +10,7 @@ import qualified Data.Set as Set
910import qualified Data.Map as Map
1011import Text.Parsec hiding (newline,spaces,State)
1112import Text.Parsec.Indent
12−import qualified Text.Parsec.Token as P
13+import qualified Text.Parsec.Token as T
1314
1415import SourceSyntax.Helpers as Help
1516import SourceSyntax.Location as Location
@@ -311,31 +312,35 @@ markdown interpolation = try (string "[markdown|") >> closeMarkdown "" []
311312 closeMarkdown (md ++ [c]) stuff
312313 ]
313314
314−str :: IParser String
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 "\"\"\"")
315+--str :: IParser String
316+str = expecting "String" $ do
317+ s <- choice [ multiStr, singleStr ]
318+ processAs T.stringLiteral . sandwich '\"' $ concat s
319+ where
320+ rawString quote insides =
321+ quote >> manyTill insides quote
321322
322−wrapQuotes :: Char -> String -> String
323−wrapQuotes delim s = (delim:s ++ [delim])
323+ multiStr = rawString (try (string "\"\"\"")) multilineStringChar
324+ singleStr = rawString (char '"') stringChar
324325
325−stringChar :: IParser String
326−stringChar = newlineChar <|> escaped '\"' <|> (pure <$> satisfy (/= '\"'))
326+ stringChar :: IParser String
327+ stringChar = choice [ newlineChar, escaped '\"', (:[]) <$> satisfy (/= '\"') ]
327328
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]
329+ multilineStringChar :: IParser String
330+ multilineStringChar =
331+ do noEnd
332+ choice [ newlineChar, escaped '\"', expandQuote <$> anyChar ]
333+ where
334+ noEnd = notFollowedBy (string "\"\"\"")
335+ expandQuote c = if c == '\"' then "\\\"" else [c]
335336
336−newlineChar :: IParser String
337−newlineChar = ['\\', 'n'] <$ char '\n'
338− <|> ['\\', 'r'] <$ char '\r'
337+ newlineChar :: IParser String
338+ newlineChar =
339+ choice [ char '\n' >> return "\\n"
340+ , char '\r' >> return "\\r" ]
341+
342+sandwich :: Char -> String -> String
343+sandwich delim s = delim : s ++ [delim]
339344
340345escaped :: Char -> IParser String
341346escaped delim = try $ do
@@ -344,37 +349,33 @@ escaped delim = try $ do
344349 return ['\\', c]
345350
346351chr :: IParser Char
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− }
352+chr = betwixt '\'' '\'' character <?> "character"
353+ where
354+ character = do
355+ c <- many1 $ choice [ escaped '\'', (:[]) <$> satisfy (/='\'') ]
356+ processAs T.charLiteral . sandwich '\'' $ concat c
357+
358+processAs :: (T.GenTokenParser String u SourceM -> IParser a) -> String -> IParser a
359+processAs processor s = calloutParser s (processor lexer)
360+ where
361+ calloutParser :: String -> IParser a -> IParser a
362+ calloutParser inp p = either (fail . show) return (iParse p inp)
363+
364+ lexer :: T.GenTokenParser String u SourceM
365+ lexer = T.makeTokenParser elmDef
366+
367+ -- I don't know how many of these are necessary for charLiteral/stringLiteral
368+ elmDef :: T.GenLanguageDef String u SourceM
369+ elmDef = T.LanguageDef
370+ { T.commentStart = "{-"
371+ , T.commentEnd = "-}"
372+ , T.commentLine = "--"
373+ , T.nestedComments = True
374+ , T.identStart = undefined
375+ , T.identLetter = undefined
376+ , T.opStart = undefined
377+ , T.opLetter = undefined
378+ , T.reservedNames = reserveds
379+ , T.reservedOpNames = [":", "->", "<-", "|"]
380+ , T.caseSensitive = True
381+ }