aba241b · elk · git.iko.soy

compiler/Parse/Helpers.hs+71−39

compare with master

unifiedsplit

@@ -1,19 +1,21 @@

1module Parse.Helpers where

2

3import Prelude hiding (until)

4−import Control.Applicative ((<$>),(<*>))

4+import Control.Applicative ((<$>),(<*>), (<$), pure)

5import Control.Monad

6import Control.Monad.State

7import Data.Char (isUpper)

8import qualified Data.Set as Set

9import qualified Data.Map as Map

10+import Text.Parsec hiding (newline,spaces,State)

11+import Text.Parsec.Indent

12+import qualified Text.Parsec.Token as P

13+

10import SourceSyntax.Helpers as Help

14import SourceSyntax.Helpers as Help

11import SourceSyntax.Location as Location

15import SourceSyntax.Location as Location

12import SourceSyntax.Expression

16import SourceSyntax.Expression

13import SourceSyntax.PrettyPrint

17import SourceSyntax.PrettyPrint

14import SourceSyntax.Declaration (Assoc)

18import SourceSyntax.Declaration (Assoc)

15−import Text.Parsec hiding (newline,spaces,State)

16−import Text.Parsec.Indent

17

19

18reserveds = [ "if", "then", "else"

20reserveds = [ "if", "then", "else"

19 , "case", "of"

21 , "case", "of"

@@ -45,7 +47,8 @@ jsReserveds = Set.fromList

45expecting = flip (<?>)

47expecting = flip (<?>)

46

48

47type OpTable = Map.Map String (Int, Assoc)

49type OpTable = Map.Map String (Int, Assoc)

50+type SourceM = State SourcePos

48−type IParser a = ParsecT String OpTable (State SourcePos) a

51+type IParser a = ParsecT String OpTable SourceM a

49

52

50iParse :: IParser a -> String -> Either ParseError a

53iParse :: IParser a -> String -> Either ParseError a

51iParse = iParseWithTable "" Map.empty

54iParse = iParseWithTable "" Map.empty

@@ -54,23 +57,6 @@ iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseE

54iParseWithTable sourceName table aParser input =

57iParseWithTable sourceName table aParser input =

55 runIndent sourceName $ runParserT aParser table sourceName input

58 runIndent sourceName $ runParserT aParser table sourceName input

56

59

57−readMaybe :: Read a => String -> Maybe a

58−readMaybe s =

59− case [ x | (x,t) <- reads s, ("","") <- lex t ] of

60− [x] -> Just x

61− _ -> Nothing

62−

63−backslashed :: IParser Char

64−backslashed = do

65− char '\\'

66− c <- anyChar

67− case readMaybe ['\'','\\',c,'\''] of

68− Just chr -> return chr

69− Nothing ->

70− fail $ "Did not recognize character '\\" ++ [c] ++

71− "'. If the backslash is meant to be a character of its own, " ++

72− "it should be escaped like this: \"\\\\" ++ [c] ++ "\""

73−

74var :: IParser String

60var :: IParser String

75var = makeVar (letter <|> char '_' <?> "variable")

61var = makeVar (letter <|> char '_' <?> "variable")

76

62

@@ -326,23 +312,69 @@ markdown interpolation = try (string "[markdown|") >> closeMarkdown "" []

326 ]

312 ]

327

313

328str :: IParser String

314str :: IParser String

329−str = choice [ quote >> dewindows <$> manyTill (backslashed <|> anyChar) quote

315+str = expecting "String" $

330− , liftM dewindows . expecting "string" . betwixt '"' '"' . many $

316+ choice [ quote >> manyTill multilineStringChar quote

331− backslashed <|> satisfy (/='"')

317+ , char '"' >> manyTill stringChar (char '"')

332− ]

318+ ]

333− where

319+ >>= parseStringLiteral . wrapQuotes '\"' . join

334− quote = try (string "\"\"\"")

320+ where quote = try (string "\"\"\"")

335−

321+

336− -- Remove \r from strings to fix generated JavaScript

322+wrapQuotes :: Char -> String -> String

337− dewindows [] = []

323+wrapQuotes delim s = (delim:s ++ [delim])

338− dewindows cs =

324+

339− let (pre, suf) = break (`elem` ['\r','\n']) cs

325+stringChar :: IParser String

340− in pre ++ case suf of

326+stringChar = newlineChar <|> escaped '\"' <|> (pure <$> satisfy (/= '\"'))

341− ('\r':'\n':rest) -> '\n' : dewindows rest

327+

342− ('\n':rest) -> '\n' : dewindows rest

328+multilineStringChar :: IParser String

343− ('\r':rest) -> '\n' : dewindows rest

329+multilineStringChar = noEnd

344− _ -> []

330+ >> (newlineChar <|> escaped '\"' <|> expandQuote <$> anyChar)

331+ where noEnd = notFollowedBy (string "\"\"\"")

332+ expandQuote c = if c == '\"'

333+ then "\\\""

334+ else [c]

335+

336+newlineChar :: IParser String

337+newlineChar = ['\\', 'n'] <$ char '\n'

338+ <|> ['\\', 'r'] <$ char '\r'

339+

340+escaped :: Char -> IParser String

341+escaped delim = try $ do

342+ char '\\'

343+ c <- char '\\' <|> char delim

344+ return ['\\', c]

345

346chr :: IParser Char

347−chr = betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))

347+chr = (betwixt '\'' '\''

348+ (many1 (escaped '\'' <|> (pure <$> satisfy (/='\''))))

349+ >>= parseCharLiteral . wrapQuotes '\'' . join

350+ )

348− <?> "character"

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+ }

compiler/SourceSyntax/Literal.hs+2−2

@@ -16,6 +16,6 @@ instance Pretty Literal where

16 case literal of

17 IntNum n -> PP.int n

18 FloatNum n -> PP.double n

19− Chr c -> PP.quotes (PP.char c)

19+ Chr c -> PP.text . show $ c

20− Str s -> PP.text (show s)

20+ Str s -> PP.text . show $ s

21 Boolean bool -> PP.text (show bool)

tests/Tests/Compiler.hs+18−11

@@ -7,14 +7,15 @@ import System.FilePath ((</>))

7import System.FilePath.Find (find, (==?), extension)

8import Test.Framework

9import Test.Framework.Providers.HUnit (testCase)

10−import Test.HUnit ((@=?), Assertion)

10+import Test.HUnit (Assertion, assertFailure, assertBool)

11+import Text.Parsec (ParseError)

11

12

12import Elm.Internal.Utils as Elm

13import Elm.Internal.Utils as Elm

13

14

14compilerTests :: Test

15compilerTests :: Test

15compilerTests = buildTest $ do

16compilerTests = buildTest $ do

16− goods <- mkTests True =<< getElms "good"

17+ goods <- mkTests goodCompile =<< getElms "good"

17− bads <- mkTests False =<< getElms "bad"

18+ bads <- mkTests badCompile =<< getElms "bad"

18 return $ testGroup "Compile Tests"

19 return $ testGroup "Compile Tests"

19 [

20 [

20 testGroup "Good Tests" goods

21 testGroup "Good Tests" goods

@@ -24,15 +25,21 @@ compilerTests = buildTest $ do

24 where getElms :: FilePath -> IO [FilePath]

25 where getElms :: FilePath -> IO [FilePath]

25 getElms fname = find (return True) (extension ==? ".elm") (testsDir </> fname)

26 getElms fname = find (return True) (extension ==? ".elm") (testsDir </> fname)

26

27

27− mkTests :: Bool -> [FilePath] -> IO [Test]

28+ mkTests :: (Either String String -> Assertion) -> [FilePath] -> IO [Test]

28− mkTests b = traverse setupTest

29+ mkTests h = traverse setupTest

29− where setupTest f = testCase f . mkCompileTest b <$> readFile f

30+ where setupTest f = testCase f . mkCompileTest h <$> readFile f

30

31

31− testsDir = "tests" </> "data"

32+ testsDir = "tests" </> "test-files"

32

33

33−mkCompileTest :: Bool -- ^ Expect success?

34+goodCompile :: Either String String -> Assertion

35+goodCompile (Left err) = assertFailure err

36+goodCompile (Right _) = assertBool "" True

37+

38+badCompile :: Either String String -> Assertion

39+badCompile (Left _) = assertBool "" True

40+badCompile (Right _) = assertFailure "Compilation succeeded but should have failed"

41+

42+mkCompileTest :: ((Either String String) -> Assertion) -- ^ Handler

34 -> String -- ^ File Contents

43 -> String -- ^ File Contents

35 -> Assertion

44 -> Assertion

36−mkCompileTest succ modul = noCompileErr @=? succ

45+mkCompileTest handle = handle . Elm.compile

37− where noCompileErr = either (const False) (const True) . Elm.compile $ modul

38− expectation = "Compile " ++ if succ then "Success" else "Error"

tests/data/bad/BBTArgs → tests/test-files/bad/BBTArgsrenamed

The content is the same.

tests/data/bad/InfiniteType.elm → tests/test-files/bad/InfiniteType.elmrenamed

The content is the same.

tests/data/bad/NonElementMain.elm → tests/test-files/bad/NonElementMain.elmrenamed

The content is the same.

tests/test-files/bad/Strings/ExtraClose.elmnew file+4

@@ -0,0 +1,4 @@

1+

2+s = " " "

3+

4+main = plainText s

tests/data/good/AliasSubstitution.elm → tests/test-files/good/AliasSubstitution.elmrenamed

The content is the same.

tests/data/good/NoExpressions.elm → tests/test-files/good/NoExpressions.elmrenamed

The content is the same.

tests/data/good/Otherwise.elm → tests/test-files/good/Otherwise.elmrenamed

The content is the same.

tests/data/good/QuotesAndComments.elm → tests/test-files/good/QuotesAndComments.elmrenamed

The content is the same.

tests/data/good/Soundness/Apply.elm → tests/test-files/good/Soundness/Apply.elmrenamed

The content is the same.

tests/data/good/Soundness/ApplyAnnotated.elm → tests/test-files/good/Soundness/ApplyAnnotated.elmrenamed

The content is the same.

tests/data/good/Soundness/Id.elm → tests/test-files/good/Soundness/Id.elmrenamed

The content is the same.

tests/data/good/Soundness/IdAnnotated.elm → tests/test-files/good/Soundness/IdAnnotated.elmrenamed

The content is the same.

tests/data/good/Soundness/TrickyId.elm → tests/test-files/good/Soundness/TrickyId.elmrenamed

The content is the same.

tests/data/good/Soundness/TrickyIdAnnotated.elm → tests/test-files/good/Soundness/TrickyIdAnnotated.elmrenamed

The content is the same.

tests/test-files/good/Strings/Multiline.elmnew file+6

@@ -0,0 +1,6 @@

1+s = """

2+here's a quote: "

3+

4+"""

5+

6+main = plainText s

tests/test-files/good/Strings/MultilineNormal.elmnew file+6

@@ -0,0 +1,6 @@

1+s = "

2+here's a quote: \"

3+

4+"

5+

6+main = plainText s

tests/data/good/Unify/LockedVars.elm → tests/test-files/good/Unify/LockedVars.elmrenamed

The content is the same.

tests/data/good/Unify/NonHomogeneousRecords.elm → tests/test-files/good/Unify/NonHomogeneousRecords.elmrenamed

The content is the same.