17f2fdd · elk · git.iko.soy

compiler/Parse/Helpers.hs+75−39

compare with master

unifiedsplit

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -W #-}

1module Parse.Helpers where

2module Parse.Helpers where

2

3

3import Prelude hiding (until)

4import Prelude hiding (until)

@@ -10,14 +11,16 @@ import Data.Map (Map)

10import qualified Data.Map as Map

11import qualified Data.Map as Map

11import qualified Language.GLSL.Parser as GLP

12import qualified Language.GLSL.Parser as GLP

12import Language.GLSL.Syntax

13import Language.GLSL.Syntax

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

15+import Text.Parsec.Indent

16+import qualified Text.Parsec.Token as T

17+

13import SourceSyntax.Helpers as Help

18import SourceSyntax.Helpers as Help

14import SourceSyntax.Literal as Literal

19import SourceSyntax.Literal as Literal

15import SourceSyntax.Location as Location

20import SourceSyntax.Location as Location

16import SourceSyntax.Expression

21import SourceSyntax.Expression

17import SourceSyntax.PrettyPrint

22import SourceSyntax.PrettyPrint

18import SourceSyntax.Declaration (Assoc)

23import SourceSyntax.Declaration (Assoc)

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

20−import Text.Parsec.Indent

21

24

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

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

23 , "case", "of"

26 , "case", "of"

@@ -49,7 +52,8 @@ jsReserveds = Set.fromList

49expecting = flip (<?>)

52expecting = flip (<?>)

50

53

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

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

55+type SourceM = State SourcePos

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

56+type IParser a = ParsecT String OpTable SourceM a

53

57

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

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

55iParse = iParseWithTable "" Map.empty

59iParse = iParseWithTable "" Map.empty

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

58iParseWithTable sourceName table aParser input =

62iParseWithTable sourceName table aParser input =

59 runIndent sourceName $ runParserT aParser table sourceName input

63 runIndent sourceName $ runParserT aParser table sourceName input

60

64

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

62−readMaybe s =

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

64− [x] -> Just x

65− _ -> Nothing

66−

67−backslashed :: IParser Char

68−backslashed = do

69− char '\\'

70− c <- anyChar

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

72− Just chr -> return chr

73− Nothing ->

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

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

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

77−

78var :: IParser String

65var :: IParser String

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

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

80

67

@@ -369,24 +356,73 @@ glSource src =

369 else []

356 else []

370 _ -> []

357 _ -> []

371

358

372−str :: IParser String

359+--str :: IParser String

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

360+str = expecting "String" $ do

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

361+ s <- choice [ multiStr, singleStr ]

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

362+ processAs T.stringLiteral . sandwich '\"' $ concat s

376− ]

363+ where

377− where

364+ rawString quote insides =

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

365+ quote >> manyTill insides quote

379−

366+

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

367+ multiStr = rawString (try (string "\"\"\"")) multilineStringChar

381− dewindows [] = []

368+ singleStr = rawString (char '"') stringChar

382− dewindows cs =

369+

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

370+ stringChar :: IParser String

384− in pre ++ case suf of

371+ stringChar = choice [ newlineChar, escaped '\"', (:[]) <$> satisfy (/= '\"') ]

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

372+

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

373+ multilineStringChar :: IParser String

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

374+ multilineStringChar =

388− _ -> []

375+ do noEnd

376+ choice [ newlineChar, escaped '\"', expandQuote <$> anyChar ]

377+ where

378+ noEnd = notFollowedBy (string "\"\"\"")

379+ expandQuote c = if c == '\"' then "\\\"" else [c]

380+

381+ newlineChar :: IParser String

382+ newlineChar =

383+ choice [ char '\n' >> return "\\n"

384+ , char '\r' >> return "\\r" ]

385+

386+sandwich :: Char -> String -> String

387+sandwich delim s = delim : s ++ [delim]

388+

389+escaped :: Char -> IParser String

390+escaped delim = try $ do

391+ char '\\'

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

393+ return ['\\', c]

389

394

390chr :: IParser Char

395chr :: IParser Char

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

396+chr = betwixt '\'' '\'' character <?> "character"

392− <?> "character"

397+ where

398+ nonQuote = satisfy (/='\'')

399+ character = do

400+ c <- choice [ escaped '\''

401+ , (:) <$> char '\\' <*> many1 nonQuote

402+ , (:[]) <$> nonQuote ]

403+ processAs T.charLiteral $ sandwich '\'' c

404+

405+processAs :: (T.GenTokenParser String u SourceM -> IParser a) -> String -> IParser a

406+processAs processor s = calloutParser s (processor lexer)

407+ where

408+ calloutParser :: String -> IParser a -> IParser a

409+ calloutParser inp p = either (fail . show) return (iParse p inp)

410+

411+ lexer :: T.GenTokenParser String u SourceM

412+ lexer = T.makeTokenParser elmDef

413+

414+ -- I don't know how many of these are necessary for charLiteral/stringLiteral

415+ elmDef :: T.GenLanguageDef String u SourceM

416+ elmDef = T.LanguageDef

417+ { T.commentStart = "{-"

418+ , T.commentEnd = "-}"

419+ , T.commentLine = "--"

420+ , T.nestedComments = True

421+ , T.identStart = undefined

422+ , T.identLetter = undefined

423+ , T.opStart = undefined

424+ , T.opLetter = undefined

425+ , T.reservedNames = reserveds

426+ , T.reservedOpNames = [":", "->", "<-", "|"]

427+ , T.caseSensitive = True

428+ }

compiler/SourceSyntax/Literal.hs+2−2

@@ -17,8 +17,8 @@ instance Pretty Literal where

17 case literal of

18 IntNum n -> PP.int n

19 FloatNum n -> PP.double n

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

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

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

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

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

23

24data GLTipe = V3 | M4

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.