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
|
||||
|
||||
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,69 @@ 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 = expecting "String" $
|
||||
choice [ quote >> manyTill multilineStringChar quote
|
||||
, char '"' >> manyTill stringChar (char '"')
|
||||
]
|
||||
>>= 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 = newlineChar <|> escaped '\"' <|> (pure <$> satisfy (/= '\"'))
|
||||
|
||||
multilineStringChar :: IParser String
|
||||
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 = betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
|
||||
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
|
||||
}
|
||||
|
|
|
@ -16,6 +16,6 @@ instance Pretty Literal where
|
|||
case literal of
|
||||
IntNum n -> PP.int n
|
||||
FloatNum n -> PP.double n
|
||||
Chr c -> PP.quotes (PP.char c)
|
||||
Str s -> PP.text (show s)
|
||||
Chr c -> PP.text . show $ c
|
||||
Str s -> PP.text . show $ s
|
||||
Boolean bool -> PP.text (show bool)
|
||||
|
|
|
@ -7,14 +7,15 @@ import System.FilePath ((</>))
|
|||
import System.FilePath.Find (find, (==?), extension)
|
||||
import Test.Framework
|
||||
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
|
||||
|
||||
compilerTests :: Test
|
||||
compilerTests = buildTest $ do
|
||||
goods <- mkTests True =<< getElms "good"
|
||||
bads <- mkTests False =<< getElms "bad"
|
||||
goods <- mkTests goodCompile =<< getElms "good"
|
||||
bads <- mkTests badCompile =<< getElms "bad"
|
||||
return $ testGroup "Compile Tests"
|
||||
[
|
||||
testGroup "Good Tests" goods
|
||||
|
@ -24,15 +25,21 @@ compilerTests = buildTest $ do
|
|||
where getElms :: FilePath -> IO [FilePath]
|
||||
getElms fname = find (return True) (extension ==? ".elm") (testsDir </> fname)
|
||||
|
||||
mkTests :: Bool -> [FilePath] -> IO [Test]
|
||||
mkTests b = traverse setupTest
|
||||
where setupTest f = testCase f . mkCompileTest b <$> readFile f
|
||||
mkTests :: (Either String String -> Assertion) -> [FilePath] -> IO [Test]
|
||||
mkTests h = traverse setupTest
|
||||
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
|
||||
-> Assertion
|
||||
mkCompileTest succ modul = noCompileErr @=? succ
|
||||
where noCompileErr = either (const False) (const True) . Elm.compile $ modul
|
||||
expectation = "Compile " ++ if succ then "Success" else "Error"
|
||||
mkCompileTest handle = handle . Elm.compile
|
||||
|
|
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