Call out to stringLiteral/charLiteral for string/char literal parsing
This commit is contained in:
parent
ae3437196e
commit
5ea3ec7f80
1 changed files with 59 additions and 38 deletions
|
@ -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
|
||||
}
|
||||
|
|
Loading…
Reference in a new issue