Merge pull request #443 from maxsnew/strchr
Fix String/Char Parse/Print Bugs
This commit is contained in:
commit
aba241bf5b
21 changed files with 106 additions and 51 deletions
|
@ -1,19 +1,21 @@
|
||||||
module Parse.Helpers where
|
module Parse.Helpers where
|
||||||
|
|
||||||
import Prelude hiding (until)
|
import Prelude hiding (until)
|
||||||
import Control.Applicative ((<$>),(<*>))
|
import Control.Applicative ((<$>),(<*>), (<$), pure)
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import Data.Char (isUpper)
|
import Data.Char (isUpper)
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import qualified Data.Map as Map
|
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.Helpers as Help
|
||||||
import SourceSyntax.Location as Location
|
import SourceSyntax.Location as Location
|
||||||
import SourceSyntax.Expression
|
import SourceSyntax.Expression
|
||||||
import SourceSyntax.PrettyPrint
|
import SourceSyntax.PrettyPrint
|
||||||
import SourceSyntax.Declaration (Assoc)
|
import SourceSyntax.Declaration (Assoc)
|
||||||
import Text.Parsec hiding (newline,spaces,State)
|
|
||||||
import Text.Parsec.Indent
|
|
||||||
|
|
||||||
reserveds = [ "if", "then", "else"
|
reserveds = [ "if", "then", "else"
|
||||||
, "case", "of"
|
, "case", "of"
|
||||||
|
@ -45,7 +47,8 @@ jsReserveds = Set.fromList
|
||||||
expecting = flip (<?>)
|
expecting = flip (<?>)
|
||||||
|
|
||||||
type OpTable = Map.Map String (Int, Assoc)
|
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 :: IParser a -> String -> Either ParseError a
|
||||||
iParse = iParseWithTable "" Map.empty
|
iParse = iParseWithTable "" Map.empty
|
||||||
|
@ -54,23 +57,6 @@ iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseE
|
||||||
iParseWithTable sourceName table aParser input =
|
iParseWithTable sourceName table aParser input =
|
||||||
runIndent sourceName $ runParserT aParser table sourceName 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 :: IParser String
|
||||||
var = makeVar (letter <|> char '_' <?> "variable")
|
var = makeVar (letter <|> char '_' <?> "variable")
|
||||||
|
|
||||||
|
@ -326,23 +312,69 @@ markdown interpolation = try (string "[markdown|") >> closeMarkdown "" []
|
||||||
]
|
]
|
||||||
|
|
||||||
str :: IParser String
|
str :: IParser String
|
||||||
str = choice [ quote >> dewindows <$> manyTill (backslashed <|> anyChar) quote
|
str = expecting "String" $
|
||||||
, liftM dewindows . expecting "string" . betwixt '"' '"' . many $
|
choice [ quote >> manyTill multilineStringChar quote
|
||||||
backslashed <|> satisfy (/='"')
|
, char '"' >> manyTill stringChar (char '"')
|
||||||
]
|
]
|
||||||
where
|
>>= parseStringLiteral . wrapQuotes '\"' . join
|
||||||
quote = try (string "\"\"\"")
|
where quote = try (string "\"\"\"")
|
||||||
|
|
||||||
-- Remove \r from strings to fix generated JavaScript
|
wrapQuotes :: Char -> String -> String
|
||||||
dewindows [] = []
|
wrapQuotes delim s = (delim:s ++ [delim])
|
||||||
dewindows cs =
|
|
||||||
let (pre, suf) = break (`elem` ['\r','\n']) cs
|
stringChar :: IParser String
|
||||||
in pre ++ case suf of
|
stringChar = newlineChar <|> escaped '\"' <|> (pure <$> satisfy (/= '\"'))
|
||||||
('\r':'\n':rest) -> '\n' : dewindows rest
|
|
||||||
('\n':rest) -> '\n' : dewindows rest
|
multilineStringChar :: IParser String
|
||||||
('\r':rest) -> '\n' : dewindows rest
|
multilineStringChar = noEnd
|
||||||
_ -> []
|
>> (newlineChar <|> escaped '\"' <|> expandQuote <$> anyChar)
|
||||||
|
where noEnd = notFollowedBy (string "\"\"\"")
|
||||||
|
expandQuote c = if c == '\"'
|
||||||
|
then "\\\""
|
||||||
|
else [c]
|
||||||
|
|
||||||
|
newlineChar :: IParser String
|
||||||
|
newlineChar = ['\\', '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 :: IParser Char
|
||||||
chr = betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
|
chr = (betwixt '\'' '\''
|
||||||
|
(many1 (escaped '\'' <|> (pure <$> satisfy (/='\''))))
|
||||||
|
>>= parseCharLiteral . wrapQuotes '\'' . join
|
||||||
|
)
|
||||||
<?> "character"
|
<?> "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
|
||||||
|
}
|
||||||
|
|
|
@ -16,6 +16,6 @@ instance Pretty Literal where
|
||||||
case literal of
|
case literal of
|
||||||
IntNum n -> PP.int n
|
IntNum n -> PP.int n
|
||||||
FloatNum n -> PP.double n
|
FloatNum n -> PP.double n
|
||||||
Chr c -> PP.quotes (PP.char c)
|
Chr c -> PP.text . show $ c
|
||||||
Str s -> PP.text (show s)
|
Str s -> PP.text . show $ s
|
||||||
Boolean bool -> PP.text (show bool)
|
Boolean bool -> PP.text (show bool)
|
||||||
|
|
|
@ -7,14 +7,15 @@ import System.FilePath ((</>))
|
||||||
import System.FilePath.Find (find, (==?), extension)
|
import System.FilePath.Find (find, (==?), extension)
|
||||||
import Test.Framework
|
import Test.Framework
|
||||||
import Test.Framework.Providers.HUnit (testCase)
|
import Test.Framework.Providers.HUnit (testCase)
|
||||||
import Test.HUnit ((@=?), Assertion)
|
import Test.HUnit (Assertion, assertFailure, assertBool)
|
||||||
|
import Text.Parsec (ParseError)
|
||||||
|
|
||||||
import Elm.Internal.Utils as Elm
|
import Elm.Internal.Utils as Elm
|
||||||
|
|
||||||
compilerTests :: Test
|
compilerTests :: Test
|
||||||
compilerTests = buildTest $ do
|
compilerTests = buildTest $ do
|
||||||
goods <- mkTests True =<< getElms "good"
|
goods <- mkTests goodCompile =<< getElms "good"
|
||||||
bads <- mkTests False =<< getElms "bad"
|
bads <- mkTests badCompile =<< getElms "bad"
|
||||||
return $ testGroup "Compile Tests"
|
return $ testGroup "Compile Tests"
|
||||||
[
|
[
|
||||||
testGroup "Good Tests" goods
|
testGroup "Good Tests" goods
|
||||||
|
@ -24,15 +25,21 @@ compilerTests = buildTest $ do
|
||||||
where getElms :: FilePath -> IO [FilePath]
|
where getElms :: FilePath -> IO [FilePath]
|
||||||
getElms fname = find (return True) (extension ==? ".elm") (testsDir </> fname)
|
getElms fname = find (return True) (extension ==? ".elm") (testsDir </> fname)
|
||||||
|
|
||||||
mkTests :: Bool -> [FilePath] -> IO [Test]
|
mkTests :: (Either String String -> Assertion) -> [FilePath] -> IO [Test]
|
||||||
mkTests b = traverse setupTest
|
mkTests h = traverse setupTest
|
||||||
where setupTest f = testCase f . mkCompileTest b <$> readFile f
|
where setupTest f = testCase f . mkCompileTest h <$> readFile f
|
||||||
|
|
||||||
testsDir = "tests" </> "data"
|
testsDir = "tests" </> "test-files"
|
||||||
|
|
||||||
mkCompileTest :: Bool -- ^ Expect success?
|
goodCompile :: Either String String -> Assertion
|
||||||
|
goodCompile (Left err) = assertFailure err
|
||||||
|
goodCompile (Right _) = assertBool "" True
|
||||||
|
|
||||||
|
badCompile :: Either String String -> Assertion
|
||||||
|
badCompile (Left _) = assertBool "" True
|
||||||
|
badCompile (Right _) = assertFailure "Compilation succeeded but should have failed"
|
||||||
|
|
||||||
|
mkCompileTest :: ((Either String String) -> Assertion) -- ^ Handler
|
||||||
-> String -- ^ File Contents
|
-> String -- ^ File Contents
|
||||||
-> Assertion
|
-> Assertion
|
||||||
mkCompileTest succ modul = noCompileErr @=? succ
|
mkCompileTest handle = handle . Elm.compile
|
||||||
where noCompileErr = either (const False) (const True) . Elm.compile $ modul
|
|
||||||
expectation = "Compile " ++ if succ then "Success" else "Error"
|
|
||||||
|
|
4
tests/test-files/bad/Strings/ExtraClose.elm
Normal file
4
tests/test-files/bad/Strings/ExtraClose.elm
Normal file
|
@ -0,0 +1,4 @@
|
||||||
|
|
||||||
|
s = " " "
|
||||||
|
|
||||||
|
main = plainText s
|
6
tests/test-files/good/Strings/Multiline.elm
Normal file
6
tests/test-files/good/Strings/Multiline.elm
Normal file
|
@ -0,0 +1,6 @@
|
||||||
|
s = """
|
||||||
|
here's a quote: "
|
||||||
|
|
||||||
|
"""
|
||||||
|
|
||||||
|
main = plainText s
|
6
tests/test-files/good/Strings/MultilineNormal.elm
Normal file
6
tests/test-files/good/Strings/MultilineNormal.elm
Normal file
|
@ -0,0 +1,6 @@
|
||||||
|
s = "
|
||||||
|
here's a quote: \"
|
||||||
|
|
||||||
|
"
|
||||||
|
|
||||||
|
main = plainText s
|
Loading…
Reference in a new issue