From 9c3c0add2e39b791c66c72b0d3eb72c16f40e30f Mon Sep 17 00:00:00 2001 From: Decio Ferreira Date: Thu, 19 Sep 2024 00:20:27 +0100 Subject: [PATCH] Work on Language.GLSL.Parser and improvement on tests --- compiler/src/Parse/Shader.elm | 55 +- src/Language/GLSL/Parser.elm | 1487 ++++++++++++++++--------- tests/backwards-compatibility.test.js | 65 +- 3 files changed, 991 insertions(+), 616 deletions(-) diff --git a/compiler/src/Parse/Shader.elm b/compiler/src/Parse/Shader.elm index 83b4b71b7..555c23d2a 100644 --- a/compiler/src/Parse/Shader.elm +++ b/compiler/src/Parse/Shader.elm @@ -1,11 +1,9 @@ module Parse.Shader exposing (shader) --- import Language.GLSL.Parser as GLP - import AST.Source as Src import AST.Utils.Shader as Shader import Data.Map as Dict -import Data.Name as Name +import Language.GLSL.Parser as GLP import Language.GLSL.Syntax as GLS import Parse.Primitives as P exposing (Col, Parser, Row) import Reporting.Annotation as A @@ -118,31 +116,32 @@ eatShader src pos end row col = parseGlsl : Row -> Col -> String -> Parser E.Expr Shader.Types parseGlsl startRow startCol src = - -- case GLP.parse src of - -- Ok (GLS.TranslationUnit decls) -> - -- P.succeed (List.foldr addInput emptyTypes (List.concatMap extractInputs decls)) - -- Err err -> - -- let - -- pos = - -- Parsec.errorPos err - -- row = - -- fromIntegral (Parsec.sourceLine pos) - -- col = - -- fromIntegral (Parsec.sourceColumn pos) - -- msg = - -- Parsec.showErrorMessages - -- "or" - -- "unknown parse error" - -- "expecting" - -- "unexpected" - -- "end of input" - -- (Parsec.errorMessages err) - -- in - -- if row == 1 then - -- failure startRow (startCol + 6 + col) msg - -- else - -- failure (startRow + row - 1) col msg - Debug.todo "parseGlsl" + case GLP.parse src of + Ok (GLS.TranslationUnit decls) -> + P.pure (List.foldr addInput emptyTypes (List.concatMap extractInputs decls)) + + Err err -> + -- let + -- pos = + -- Parsec.errorPos err + -- row = + -- fromIntegral (Parsec.sourceLine pos) + -- col = + -- fromIntegral (Parsec.sourceColumn pos) + -- msg = + -- Parsec.showErrorMessages + -- "or" + -- "unknown parse error" + -- "expecting" + -- "unexpected" + -- "end of input" + -- (Parsec.errorMessages err) + -- in + -- if row == 1 then + -- failure startRow (startCol + 6 + col) msg + -- else + -- failure (startRow + row - 1) col msg + Debug.todo "parseGlsl" failure : Row -> Col -> String -> Parser E.Expr a diff --git a/src/Language/GLSL/Parser.elm b/src/Language/GLSL/Parser.elm index 8fa31dc0c..70f446536 100644 --- a/src/Language/GLSL/Parser.elm +++ b/src/Language/GLSL/Parser.elm @@ -1,9 +1,138 @@ -module Language.GLSL.Parser exposing (..) - --- import Text.ParserCombinators.Parsec --- import Text.ParserCombinators.Parsec.Expr +module Language.GLSL.Parser exposing (parse) import Language.GLSL.Syntax exposing (..) +import Parser exposing ((|.), (|=), Parser) +import Utils.Main as Utils + + +char : Char -> Parser Char +char c = + Parser.getChompedString <| + Parser.symbol (String.fromChar c) + + +try : Parser a -> Parser a +try = + Parser.backtrackable + + +choice : List (Parser a) -> Parser a +choice = + Parser.oneOf + + +optionMaybe : Parser a -> Parser (Maybe a) +optionMaybe p = + Parser.oneOf + [ Parser.map Just p + , Parser.succeed Nothing + ] + + +between : Parser () -> Parser () -> Parser a -> Parser a +between open close p = + Parser.succeed identity + |. open + |= p + |. close + + +many : Parser a -> Parser (List a) +many p = + Parser.loop [] (manyHelp p) + + +manyHelp : Parser a -> List a -> Parser (Parser.Step (List a) (List a)) +manyHelp p revStmts = + Parser.oneOf + [ Parser.succeed (\stmt -> Parser.Loop (stmt :: revStmts)) + |= p + , Parser.succeed () + |> Parser.map (\_ -> Parser.Done (List.reverse revStmts)) + ] + + +many1 : Parser a -> Parser (List a) +many1 p = + Parser.succeed (::) + |= p + |= many p + + +string : String -> P String +string = + Parser.getChompedString << Parser.keyword + + +notFollowedBy : P a -> P () +notFollowedBy p = + try + (Parser.oneOf + [ try p + , Parser.succeed () + ] + ) + + +hexDigit : P Char +hexDigit = + Parser.chompIf Char.isHexDigit + + +oneOf : String -> P Char +oneOf cs = + Parser.chompIf (\c -> String.contains c cs) + + +letter : P Char +letter = + Parser.chompIf Char.isAlpha + + +octDigit : P Char +octDigit = + Parser.chompIf Char.isOctDigit + + +alphaNum : P Char +alphaNum = + Parser.chompIf Char.isAlphaNum + + +digit : P Char +digit = + Parser.chompIf Char.isDigit + + +sepBy : P a -> P sep -> P (List a) +sepBy p sep = + Parser.oneOf + [ sepBy1 p sep + , Parser.succeed [] + ] + + +sepBy1 : P a -> P sep -> P (List a) +sepBy1 p sep = + Parser.succeed (::) + |= p + |= many + (Parser.succeed identity + |. sep + |= p + ) + + +type Assoc + = AssocNone + | AssocLeft + | AssocRight + + +type Operator tok st a + = Infix (GenParser tok st (a -> a -> a)) Assoc + | Prefix (GenParser tok st (a -> a)) + | Postfix (GenParser tok st (a -> a)) @@ -16,8 +145,8 @@ type S = S -type P a - = GenParser Char S a +type alias P a = + Parser a @@ -103,22 +232,18 @@ reservedWords = comment : P () comment = - -- do - -- _ <- char '/' - -- _ <- choice - -- [ do _ <- char '*' - -- manyTill anyChar (try $ string "*/") - -- , do _ <- char '/' - -- manyTill anyChar ((newline >> return ()) <|> eof) - -- ] - -- return () - Debug.todo "comment" + Parser.oneOf + [ Parser.lineComment "//" + , Parser.multiComment "/*" "*/" Parser.NotNestable + ] blank : P () blank = - -- try comment <|> (space >> return ()) - Debug.todo "blank" + Parser.oneOf + [ try comment + , Parser.spaces + ] @@ -127,18 +252,19 @@ blank = lexeme : P a -> P a lexeme p = - -- do - -- x <- p - -- skipMany blank - -- return x - Debug.todo "lexeme" + Parser.succeed identity + |= p + |. Parser.spaces -parse : String -> Result ParseError TranslationUnit +parse : String -> Result Parser.Problem TranslationUnit parse = - -- runParser (do {skipMany blank ; r <- translationUnit ; eof ; return r}) - -- S "GLSL" - Debug.todo "parse" + Parser.run + (Parser.succeed identity + |. Parser.spaces + |= translationUnit + |. Parser.end + ) @@ -149,56 +275,47 @@ parse = semicolon : P () semicolon = - -- lexeme $ char ';' >> return () - Debug.todo "semicolon" + lexeme <| char ';' comma : P () comma = - -- lexeme $ char ',' >> return () - Debug.todo "comma" + lexeme <| char ',' colon : P () colon = - -- lexeme $ char ':' >> return () - Debug.todo "colon" + lexeme <| char ':' lbrace : P () lbrace = - -- lexeme $ char '{' >> return () - Debug.todo "lbrace" + lexeme <| char '{' rbrace : P () rbrace = - -- lexeme $ char '}' >> return () - Debug.todo "rbrace" + lexeme <| char '}' lbracket : P () lbracket = - -- lexeme $ char '[' >> return () - Debug.todo "lbracket" + lexeme <| char '[' rbracket : P () rbracket = - -- lexeme $ char ']' >> return () - Debug.todo "rbracket" + lexeme <| char ']' lparen : P () lparen = - -- lexeme $ char '(' >> return () - Debug.todo "lparen" + lexeme <| char '(' rparen : P () rparen = - -- lexeme $ char ')' >> return () - Debug.todo "rparen" + lexeme <| char ')' @@ -208,8 +325,12 @@ rparen = keyword : String -> P () keyword w = - -- lexeme $ try (string w >> notFollowedBy identifierTail) - Debug.todo "keyword" + lexeme <| + try + (Parser.succeed () + |. string w + |. notFollowedBy identifierTail + ) @@ -220,20 +341,36 @@ keyword w = identifier : P String identifier = - -- lexeme $ do - -- h <- identifierHead - -- t <- many identifierTail - -- check (h:t) - -- where check i | i `elem` reservedWords = fail $ - -- i ++ " is reserved" - -- | i `elem` keywords = fail $ - -- i ++ " is a keyword" - -- | otherwise = checkUnderscore i i - -- checkUnderscore i ('_':'_':_) = fail $ - -- i ++ " is reserved (two consecutive underscores)" - -- checkUnderscore i (_:cs) = checkUnderscore i cs - -- checkUnderscore i [] = return i - Debug.todo "identifier" + let + check : String -> P String + check i = + if List.member i reservedWords then + Parser.problem (i ++ " is reserved") + + else if List.member i keywords then + Parser.problem (i ++ " is a keyword") + + else + checkUnderscore i (String.toList i) + + checkUnderscore : String -> List Char -> P String + checkUnderscore i i2 = + case i2 of + '_' :: '_' :: _ -> + Parser.problem (i ++ " is reserved (two consecutive underscores)") + + _ :: cs -> + checkUnderscore i cs + + [] -> + Parser.succeed i + in + lexeme + (Parser.succeed (\h t -> String.fromList (h :: t)) + |= identifierHead + |= many identifierTail + |> Parser.andThen check + ) @@ -245,7 +382,7 @@ intConstant = choice [ hexadecimal , octal - , badOctal >> fail "Invalid octal number" + , badOctal |> Parser.andThen (\_ -> Parser.problem "Invalid octal number") , decimal ] @@ -266,8 +403,7 @@ floatingConstant = operator : String -> P String operator = - -- lexeme . try . string - Debug.todo "operator" + lexeme << try << string @@ -278,95 +414,129 @@ operator = identifierHead : P Char identifierHead = - -- letter <|> char '_' - Debug.todo "identifierHead" + Parser.oneOf + [ letter + , char '_' + ] identifierTail : P Char identifierTail = - -- alphaNum <|> char '_' - Debug.todo "identifierTail" + Parser.oneOf + [ alphaNum + , char '_' + ] hexadecimal : P Expr hexadecimal = - -- lexeme $ try $ do - -- _ <- char '0' - -- _ <- oneOf "Xx" - -- d <- many1 hexDigit - -- m <- optionMaybe $ oneOf "Uu" -- TODO - -- return $ IntConstant Hexadecimal $ read ("0x" ++ d) - Debug.todo "hexadecimal" + lexeme <| + try <| + Parser.succeed (\d -> IntConstant Hexadecimal ("0x" ++ d)) + |. Parser.keyword "0" + |. oneOf "Xx" + |= Parser.chompWhile Char.isHexDigit + -- TODO + |. optionMaybe (oneOf "Uu") octal : P Expr octal = - -- lexeme $ try $ do - -- _ <- char '0' - -- d <- many1 octDigit - -- m <- optionMaybe $ oneOf "Uu" -- TODO - -- return $ IntConstant Octal $ read ("0o" ++ d) - Debug.todo "octal" + lexeme <| + try <| + Parser.succeed (\d -> IntConstant Octal ("0o" ++ d)) + |. char '0' + |= many1 octDigit + -- TODO + |. optionMaybe (oneOf "Uu") badOctal : P () badOctal = - -- lexeme $ try $ char '0' >> many1 hexDigit >> return () - Debug.todo "badOctal" + lexeme <| + try <| + Parser.succeed () + |. char '0' + |. many1 hexDigit decimal : P Expr decimal = - -- lexeme $ try $ do - -- d <- many1 digit - -- notFollowedBy (char '.' <|> (exponent >> return ' ')) - -- m <- optionMaybe $ oneOf "Uu" -- TODO - -- return $ IntConstant Decimal $ read d - Debug.todo "decimal" + lexeme <| + try <| + Parser.succeed (\d -> IntConstant Decimal (String.fromList d)) + |= many1 digit + |. notFollowedBy + (Parser.oneOf + [ char '.' + , Parser.succeed ' ' + |. exponent + ] + ) + -- TODO + |. optionMaybe (oneOf "Uu") floatExponent : P Expr floatExponent = - -- lexeme $ try $ do - -- d <- many1 digit - -- e <- exponent - -- m <- optionMaybe $ oneOf "Ff" -- TODO - -- return $ FloatConstant $ read $ d ++ e - Debug.todo "floatExponent" + lexeme <| + try <| + Parser.succeed (\d e -> FloatConstant (String.fromList d ++ e)) + |= many1 digit + |= exponent + -- TODO + |. optionMaybe (oneOf "Ff") floatPoint : P Expr floatPoint = - -- lexeme $ try $ do - -- d <- many1 digit - -- _ <- char '.' - -- d' <- many digit - -- let d'' = if null d' then "0" else d' - -- e <- optionMaybe exponent - -- m <- optionMaybe $ oneOf "Ff" -- TODO - -- return $ FloatConstant $ read $ d ++ "." ++ d'' ++ maybe "" id e - Debug.todo "floatPoint" + lexeme <| + try <| + Parser.succeed + (\d d_ e -> + let + d__ = + if List.isEmpty d_ then + "0" + + else + String.fromList d_ + in + FloatConstant + (String.fromList d + ++ "." + ++ d__ + ++ Maybe.withDefault "" e + ) + ) + |= many1 digit + |. char '.' + |= many digit + |= optionMaybe exponent + -- TODO + |. optionMaybe (oneOf "Ff") pointFloat : P Expr pointFloat = - -- lexeme $ try $ do - -- _ <- char '.' - -- d <- many1 digit - -- e <- optionMaybe exponent - -- m <- optionMaybe $ oneOf "Ff" - -- return $ FloatConstant $ read $ "0." ++ d ++ maybe "" id e - Debug.todo "pointFloat" + lexeme <| + try <| + Parser.succeed (\d e -> FloatConstant ("0." ++ String.fromList d ++ Maybe.withDefault "" e)) + |. char '.' + |= many1 digit + |= optionMaybe exponent + -- TODO + |. optionMaybe (oneOf "Ff") exponent : P String exponent = - -- lexeme $ try $ do - -- _ <- oneOf "Ee" - -- s <- optionMaybe (oneOf "+-") - -- d <- many1 digit - -- return $ "e" ++ maybe "" (:[]) s ++ d - Debug.todo "exponent" + lexeme <| + try <| + Parser.succeed (\s d -> "e" ++ Maybe.withDefault "" s ++ d) + |. Parser.oneOf [ Parser.keyword "U", Parser.keyword "u" ] + |= optionMaybe (Parser.getChompedString (Parser.oneOf [ Parser.keyword "+", Parser.keyword "-" ])) + |= Parser.chompWhile Char.isDigit @@ -377,26 +547,46 @@ exponent = infixLeft : String -> (a -> a -> a) -> Operator Char S a infixLeft s r = - -- Infix (lexeme (try $ string s) >> return r) AssocLeft - Debug.todo "infixLeft" + Infix + (Parser.succeed r + |. lexeme (try (string s)) + ) + AssocLeft infixLeft_ : String -> (a -> a -> a) -> Operator Char S a infixLeft_ s r = - -- Infix (lexeme (try $ string s >> notFollowedBy (char '=')) >> return r) AssocLeft - Debug.todo "infixLeft_" + Infix + (Parser.succeed r + |. lexeme + (Parser.succeed () + |. try (string s) + |. notFollowedBy (char '=') + ) + ) + AssocLeft infixLeft__ : Char -> (a -> a -> a) -> Operator Char S a infixLeft__ c r = - -- Infix (lexeme (try $ char c >> notFollowedBy (oneOf (c:"="))) >> return r) AssocLeft - Debug.todo "infixLeft__" + Infix + (Parser.succeed r + |. lexeme + (Parser.succeed () + |. try (char c) + |. notFollowedBy (oneOf (String.cons c "=")) + ) + ) + AssocLeft infixRight : String -> (a -> a -> a) -> Operator Char S a infixRight s r = - -- Infix (lexeme (try $ string s) >> return r) AssocRight - Debug.todo "infixRight" + Infix + (Parser.succeed r + |. lexeme (try (string s)) + ) + AssocRight conditionalTable : List (List (Operator Char S Expr)) @@ -449,7 +639,7 @@ expressionTable = primaryExpression : P Expr primaryExpression = choice - [ fmap Variable (try identifier) + [ Parser.map Variable (try identifier) -- int constant , intConstant @@ -459,8 +649,10 @@ primaryExpression = , floatingConstant -- bool constant - , keyword "true" >> return (BoolConstant True) - , keyword "false" >> return (BoolConstant False) + , Parser.succeed (BoolConstant True) + |. keyword "true" + , Parser.succeed (BoolConstant False) + |. keyword "false" -- expression within parentheses , between lparen rparen expression @@ -469,30 +661,46 @@ primaryExpression = postfixExpression : P Expr postfixExpression = - -- do - -- e <- try (functionCallGeneric >>= \(i,p) -> return (FunctionCall i p)) - -- <|> primaryExpression - -- p <- many <| choice - -- [ between lbracket rbracket integerExpression >>= return . flip Bracket - -- , dotFunctionCallGeneric - -- , dotFieldSelection - -- , operator "++" >> return PostInc - -- , operator "--" >> return PostDec - -- ] - -- return $ foldl (flip ($)) e p - Debug.todo "postfixExpression" + Parser.succeed (List.foldl (|>)) + |= try + (Parser.oneOf + [ Parser.succeed (\( i, p ) -> FunctionCall i p) + |= functionCallGeneric + , primaryExpression + ] + ) + |= many + (choice + [ Parser.succeed (Utils.flip Bracket) + |= between lbracket rbracket integerExpression + , dotFunctionCallGeneric + , dotFieldSelection + , Parser.succeed PostInc + |. operator "++" + , Parser.succeed PostDec + |. operator "--" + ] + ) dotFunctionCallGeneric : P (Expr -> Expr) dotFunctionCallGeneric = - -- lexeme (try $ string "." >> functionCallGeneric) >>= \(i,p) -> return (\e -> MethodCall e i p) - Debug.todo "dotFunctionCallGeneric" + Parser.succeed (\( i, p ) e -> MethodCall e i p) + |= lexeme + (Parser.succeed identity + |. try (string ".") + |= functionCallGeneric + ) dotFieldSelection : P (Expr -> Expr) dotFieldSelection = - -- lexeme (try $ string "." >> identifier) >>= return . flip FieldSelection - Debug.todo "dotFieldSelection" + Parser.succeed (Utils.flip FieldSelection) + |= lexeme + (Parser.succeed identity + |. try (string ".") + |= identifier + ) integerExpression : P Expr @@ -508,15 +716,15 @@ integerExpression = functionCallGeneric : P ( FunctionIdentifier, Parameters ) functionCallGeneric = - -- do - -- i <- functionCallHeader - -- p <- choice - -- [ keyword "void" >> return ParamVoid - -- , sepBy assignmentExpression comma >>= return . Params - -- ] - -- rparen - -- return (i, p) - Debug.todo "functionCallGeneric" + Parser.succeed Tuple.pair + |= functionCallHeader + |= choice + [ Parser.succeed ParamVoid + |. keyword "void" + , Parser.succeed Params + |= sepBy assignmentExpression comma + ] + |. rparen @@ -527,37 +735,45 @@ functionCallGeneric = functionCallHeader : P FunctionIdentifier functionCallHeader = - -- do - -- i <- functionIdentifier - -- lparen - -- return i - Debug.todo "functionCallHeader" + Parser.succeed identity + |= functionIdentifier + |. lparen functionIdentifier : P FunctionIdentifier functionIdentifier = - -- choice - -- [ try identifier >>= return . FuncId - -- , typeSpecifier >>= return . FuncIdTypeSpec -- TODO if the 'identifier' is declared as a type, should be this case - -- -- no need for fieldSelection - -- ] - Debug.todo "functionIdentifier" + choice + [ Parser.succeed FuncId + |= try identifier + + -- TODO if the 'identifier' is declared as a type, should be this case + , Parser.succeed FuncIdTypeSpec + |= typeSpecifier + + -- no need for fieldSelection + ] unaryExpression : P Expr unaryExpression = - -- do - -- p <- many $ choice - -- [ operator "++" >> return PreInc - -- , operator "--" >> return PreDec - -- , operator "+" >> return UnaryPlus - -- , operator "-" >> return UnaryNegate - -- , operator "!" >> return UnaryNot - -- , operator "~" >> return UnaryOneComplement - -- ] - -- e <- postfixExpression - -- return $ foldr ($) e p - Debug.todo "unaryExpression" + Parser.succeed (\p e -> List.foldr (<|) e p) + |= many + (choice + [ Parser.succeed PreInc + |. operator "++" + , Parser.succeed PreDec + |. operator "--" + , Parser.succeed UnaryPlus + |. operator "+" + , Parser.succeed UnaryNegate + |. operator "-" + , Parser.succeed UnaryNot + |. operator "!" + , Parser.succeed UnaryOneComplement + |. operator "~" + ] + ) + |= postfixExpression @@ -579,18 +795,24 @@ unaryExpression = conditionalExpression : P Expr conditionalExpression = - -- do - -- loe <- buildExpressionParser conditionalTable unaryExpression - -- ter <- optionMaybe $ do - -- _ <- lexeme (string "?") - -- e <- expression - -- _ <- lexeme (string ":") - -- a <- assignmentExpression - -- return (e, a) - -- case ter of - -- Nothing -> return loe - -- Just (e, a) -> return $ Selection loe e a - Debug.todo "conditionalExpression" + Parser.succeed Tuple.pair + |= buildExpressionParser conditionalTable unaryExpression + |= optionMaybe + (Parser.succeed Tuple.pair + |. lexeme (string "?") + |= expression + |. lexeme (string ":") + |= assignmentExpression + ) + |> Parser.map + (\( loe, ter ) -> + case ter of + Nothing -> + loe + + Just ( e, a ) -> + Selection loe e a + ) assignmentExpression : P Expr @@ -616,62 +838,102 @@ constantExpression = declaration : P Declaration declaration = + -- choice + -- [ try $ do + -- t <- fullySpecifiedType + -- l <- idecl `sepBy` comma + -- semicolon + -- return $ InitDeclaration (TypeDeclarator t) l + -- , do keyword "invariant" + -- i <- idecl `sepBy` comma + -- semicolon + -- return $ InitDeclaration InvariantDeclarator i + -- , do keyword "precision" + -- q <- precisionQualifier + -- s <- typeSpecifierNoPrecision + -- semicolon + -- return $ Precision q s + -- , do q <- typeQualifier + -- choice + -- [ semicolon >> return (TQ q) + -- , do i <- identifier + -- lbrace + -- s <- structDeclarationList + -- rbrace + -- m <- optionMaybe $ do + -- j <- identifier + -- n <- optionMaybe $ between lbracket rbracket $ optionMaybe constantExpression + -- return (j,n) + -- semicolon + -- return $ Block q i s m + -- ] + -- ] + -- where idecl = do + -- i <- identifier + -- m <- optionMaybe $ between lbracket rbracket $ + -- optionMaybe constantExpression + -- j <- optionMaybe $ lexeme (string "=") >> initializer + -- return $ InitDecl i m j + let + idecl = + Parser.succeed InitDecl + |= identifier + |= optionMaybe (between lbracket rbracket (optionMaybe constantExpression)) + |= optionMaybe (Parser.succeed identity |. lexeme (string "=") |= initializer) + in choice - -- [ try $ do - -- t <- fullySpecifiedType - -- l <- idecl `sepBy` comma - -- semicolon - -- return $ InitDeclaration (TypeDeclarator t) l - -- , do keyword "invariant" - -- i <- idecl `sepBy` comma - -- semicolon - -- return $ InitDeclaration InvariantDeclarator i - -- , do keyword "precision" - -- q <- precisionQualifier - -- s <- typeSpecifierNoPrecision - -- semicolon - -- return $ Precision q s - -- , do q <- typeQualifier - -- choice - -- [ semicolon >> return (TQ q) - -- , do i <- identifier - -- lbrace - -- s <- structDeclarationList - -- rbrace - -- m <- optionMaybe $ do - -- j <- identifier - -- n <- optionMaybe $ between lbracket rbracket $ optionMaybe constantExpression - -- return (j,n) - -- semicolon - -- return $ Block q i s m - -- ] - -- ] - -- where idecl = do - -- i <- identifier - -- m <- optionMaybe $ between lbracket rbracket $ - -- optionMaybe constantExpression - -- j <- optionMaybe $ lexeme (string "=") >> initializer - -- return $ InitDecl i m j - Debug.todo - "declaration" + [ try <| + Parser.succeed (\t l -> InitDeclaration (TypeDeclarator t) l) + |= fullySpecifiedType + |= sepBy idecl comma + |. semicolon + , Parser.succeed (InitDeclaration InvariantDeclarator) + |. keyword "invariant" + |= sepBy idecl comma + |. semicolon + , Parser.succeed Precision + |. keyword "precision" + |= precisionQualifier + |= typeSpecifierNoPrecision + |. semicolon + , typeQualifier + |> Parser.andThen + (\q -> + choice + [ Parser.succeed (TQ q) + |. semicolon + , Parser.succeed (Block q) + |= identifier + |. lbrace + |= structDeclarationList + |. rbrace + |= optionMaybe + (Parser.succeed Tuple.pair + |= identifier + |= optionMaybe + (between lbracket + rbracket + (optionMaybe constantExpression) + ) + ) + |. semicolon + ] + ) + ] functionPrototype : P FunctionPrototype functionPrototype = - -- do - -- (t, i, p) <- functionDeclarator - -- rparen - -- return $ FuncProt t i p - Debug.todo "functionPrototype" + Parser.succeed (\( t, i, p ) -> FuncProt t i p) + |= functionDeclarator + |. rparen functionDeclarator : P ( FullType, String, List ParameterDeclaration ) functionDeclarator = - -- do - -- (t, i) <- functionHeader - -- p <- parameterDeclaration `sepBy` comma - -- return (t, i, p) - Debug.todo "functionDeclarator" + Parser.succeed (\( t, i ) p -> ( t, i, p )) + |= functionHeader + |= sepBy parameterDeclaration comma @@ -681,12 +943,10 @@ functionDeclarator = functionHeader : P ( FullType, String ) functionHeader = - -- do - -- t <- fullySpecifiedType - -- i <- identifier - -- lparen - -- return (t, i) - Debug.todo "functionHeader" + Parser.succeed (\t i -> ( t, i )) + |= fullySpecifiedType + |= identifier + |. lparen @@ -704,27 +964,26 @@ functionHeader = parameterDeclaration : P ParameterDeclaration parameterDeclaration = - -- do - -- tq <- optionMaybe parameterTypeQualifier - -- q <- optionMaybe parameterQualifier - -- s <- typeSpecifier - -- m <- optionMaybe $ do - -- i <- identifier - -- b <- optionMaybe $ between lbracket rbracket constantExpression -- FIXME can't the bracket be empty, i.e. a[] ? - -- return (i,b) - -- return $ ParameterDeclaration tq q s m - Debug.todo "parameterDeclaration" + Parser.succeed ParameterDeclaration + |= optionMaybe parameterTypeQualifier + |= optionMaybe parameterQualifier + |= typeSpecifier + |= optionMaybe + (Parser.succeed Tuple.pair + |= identifier + -- FIXME can't the bracket be empty, i.e. a[] ? + |= optionMaybe (between lbracket rbracket constantExpression) + ) parameterQualifier : P ParameterQualifier parameterQualifier = - -- choice - -- -- "empty" case handled in the caller - -- [ (try . lexeme . string) "inout" >> return InOutParameter - -- , (try . lexeme . string) "in" >> return InParameter - -- , (try . lexeme . string) "out" >> return OutParameter - -- ] - Debug.todo "parameterQualifier" + choice + -- "empty" case handled in the caller + [ Parser.succeed InOutParameter ((try << lexeme << string) "inout") + , Parser.succeed InParameter ((try << lexeme << string) "in") + , Parser.succeed OutParameter ((try << lexeme << string) "out") + ] @@ -745,40 +1004,40 @@ parameterQualifier = fullySpecifiedType : P FullType fullySpecifiedType = - -- choice - -- [ try typeSpecifier >>= return . FullType Nothing - -- , do q <- typeQualifier - -- s <- typeSpecifier - -- return $ FullType (Just q) s - -- ] - Debug.todo "fullySpecifiedType" + choice + [ Parser.succeed (FullType Nothing) + |= try typeSpecifier + , Parser.succeed (\q s -> FullType (Just q) s) + |= typeQualifier + |= typeSpecifier + ] invariantQualifier : P InvariantQualifier invariantQualifier = - -- keyword "invariant" >> return Invariant - Debug.todo "invariantQualifier" + Parser.succeed Invariant + |. keyword "invariant" interpolationQualifier : P InterpolationQualifier interpolationQualifier = - -- choice - -- [ keyword "smooth" >> return Smooth - -- , keyword "flat" >> return Flat - -- , keyword "noperspective" >> return NoPerspective - -- ] - Debug.todo "interpolationQualifier" + choice + [ Parser.succeed Smooth + |. keyword "smooth" + , Parser.succeed Flat + |. keyword "flat" + , Parser.succeed NoPerspective + |. keyword "noperspective" + ] layoutQualifier : P LayoutQualifier layoutQualifier = - -- do - -- keyword "layout" - -- lparen - -- q <- layoutQualifierId `sepBy` comma - -- rparen - -- return $ Layout q - Debug.todo "layoutQualifier" + Parser.succeed Layout + |. keyword "layout" + |. lparen + |= sepBy layoutQualifierId comma + |. rparen @@ -788,17 +1047,19 @@ layoutQualifier = layoutQualifierId : P LayoutQualifierId layoutQualifierId = - -- do - -- i <- identifier - -- c <- optionMaybe $ lexeme (string "=") >> intConstant - -- return $ LayoutQualId i c - Debug.todo "layoutQualifierId" + Parser.succeed LayoutQualId + |= identifier + |= optionMaybe + (Parser.succeed identity + |. lexeme (string "=") + |= intConstant + ) parameterTypeQualifier : P ParameterTypeQualifier parameterTypeQualifier = - -- keyword "const" >> return ConstParameter - Debug.todo "parameterTypeQualifier" + Parser.succeed ConstParameter + |. keyword "const" @@ -811,25 +1072,27 @@ parameterTypeQualifier = typeQualifier : P TypeQualifier typeQualifier = - -- choice - -- [ do s <- storageQualifier - -- return $ TypeQualSto s - -- , do l <- layoutQualifier - -- s <- optionMaybe storageQualifier - -- return $ TypeQualLay l s - -- , do i <- interpolationQualifier - -- s <- optionMaybe storageQualifier - -- return $ TypeQualInt i s - -- , do i <- invariantQualifier - -- choice - -- [ do j <- interpolationQualifier - -- s <- storageQualifier - -- return $ TypeQualInv3 i j s - -- , do s <- optionMaybe storageQualifier - -- return $ TypeQualInv i s - -- ] - -- ] - Debug.todo "typeQualifier" + choice + [ Parser.succeed TypeQualSto + |= storageQualifier + , Parser.succeed TypeQualLay + |= layoutQualifier + |= optionMaybe storageQualifier + , Parser.succeed TypeQualInt + |= interpolationQualifier + |= optionMaybe storageQualifier + , invariantQualifier + |> Parser.andThen + (\i -> + choice + [ Parser.succeed (TypeQualInv3 i) + |= interpolationQualifier + |= storageQualifier + , Parser.succeed (TypeQualInv i) + |= optionMaybe storageQualifier + ] + ) + ] @@ -838,43 +1101,63 @@ typeQualifier = storageQualifier : P StorageQualifier storageQualifier = - -- choice - -- [ keyword "const" >> return Const - -- , keyword "attribute" >> return Attribute -- TODO vertex only, is deprecated - -- , keyword "varying" >> return Varying -- deprecated - -- , keyword "in" >> return In - -- , keyword "out" >> return Out - -- , keyword "centroid" >> (choice - -- [ keyword "varying" >> return CentroidVarying -- deprecated - -- , keyword "in" >> return CentroidIn - -- , keyword "out" >> return CentroidOut - -- ]) - -- , keyword "uniform" >> return Uniform - -- ] - Debug.todo "storageQualifier" + choice + [ Parser.succeed Const + |. keyword "const" + + -- TODO vertex only, is deprecated + , Parser.succeed Attribute + |. keyword "attribute" + + -- deprecated + , Parser.succeed Varying + |. keyword "varying" + , Parser.succeed In + |. keyword "in" + , Parser.succeed Out + |. keyword "out" + , Parser.succeed identity + |. keyword "centroid" + |= choice + [ -- deprecated + Parser.succeed CentroidVarying + |. keyword "varying" + , Parser.succeed CentroidIn + |. keyword "in" + , Parser.succeed CentroidOut + |. keyword "out" + ] + , Parser.succeed Uniform + |. keyword "uniform" + ] typeSpecifier : P TypeSpecifier typeSpecifier = - -- choice - -- [ do q <- try precisionQualifier - -- s <- typeSpecifierNoPrecision - -- return $ TypeSpec (Just q) s - -- , typeSpecifierNoPrecision >>= return . TypeSpec Nothing - -- ] - Debug.todo "typeSpecifier" + choice + [ Parser.succeed (\q s -> TypeSpec (Just q) s) + |= try precisionQualifier + |= typeSpecifierNoPrecision + , Parser.succeed (TypeSpec Nothing) + |= typeSpecifierNoPrecision + ] typeSpecifierNoPrecision : P TypeSpecifierNoPrecision typeSpecifierNoPrecision = - -- do - -- s <- typeSpecifierNonArray - -- choice - -- [ try (lbracket >> rbracket) >> return (TypeSpecNoPrecision s (Just Nothing)) - -- , lbracket >> constantExpression >>= \c -> rbracket >> return (TypeSpecNoPrecision s (Just $ Just c)) - -- , return $ TypeSpecNoPrecision s Nothing - -- ] - Debug.todo "typeSpecifierNoPrecision" + typeSpecifierNonArray + |> Parser.andThen + (\s -> + choice + [ Parser.succeed (TypeSpecNoPrecision s (Just Nothing)) + |. try (Parser.succeed () |. lbracket |. rbracket) + , Parser.succeed (TypeSpecNoPrecision << Just << Just) + |. lbracket + |= constantExpression + |. rbracket + , Parser.succeed (TypeSpecNoPrecision s Nothing) + ] + ) @@ -883,135 +1166,199 @@ typeSpecifierNoPrecision = typeSpecifierNonArray : P TypeSpecifierNonArray typeSpecifierNonArray = - -- choice - -- [ keyword "void" >> return Void - -- , keyword "float" >> return Float - -- , keyword "int" >> return Int - -- , keyword "uint" >> return UInt - -- , keyword "bool" >> return Bool - -- , keyword "vec2" >> return Vec2 - -- , keyword "vec3" >> return Vec3 - -- , keyword "vec4" >> return Vec4 - -- , keyword "bvec2" >> return BVec2 - -- , keyword "bvec3" >> return BVec3 - -- , keyword "bvec4" >> return BVec4 - -- , keyword "ivec2" >> return IVec2 - -- , keyword "ivec3" >> return IVec3 - -- , keyword "ivec4" >> return IVec4 - -- , keyword "uvec2" >> return UVec2 - -- , keyword "uvec3" >> return UVec3 - -- , keyword "uvec4" >> return UVec4 - -- , keyword "mat2" >> return Mat2 - -- , keyword "mat3" >> return Mat3 - -- , keyword "mat4" >> return Mat4 - -- , keyword "mat2x2" >> return Mat2x2 - -- , keyword "mat2x3" >> return Mat2x3 - -- , keyword "mat2x4" >> return Mat2x4 - -- , keyword "mat3x2" >> return Mat3x2 - -- , keyword "mat3x3" >> return Mat3x3 - -- , keyword "mat3x4" >> return Mat3x4 - -- , keyword "mat4x2" >> return Mat4x2 - -- , keyword "mat4x3" >> return Mat4x3 - -- , keyword "mat4x4" >> return Mat4x4 - -- , keyword "sampler1D" >> return Sampler1D - -- , keyword "sampler2D" >> return Sampler2D - -- , keyword "sampler3D" >> return Sampler3D - -- , keyword "samplerCube" >> return SamplerCube - -- , keyword "sampler1DShadow" >> return Sampler1DShadow - -- , keyword "sampler2DShadow" >> return Sampler2DShadow - -- , keyword "samplerCubeShadow" >> return SamplerCubeShadow - -- , keyword "sampler1DArray" >> return Sampler1DArray - -- , keyword "sampler2DArray" >> return Sampler2DArray - -- , keyword "sampler1DArrayShadow" >> return Sampler1DArrayShadow - -- , keyword "sampler2DArrayShadow" >> return Sampler2DArrayShadow - -- , keyword "isampler1D" >> return ISampler1D - -- , keyword "isampler2D" >> return ISampler2D - -- , keyword "isampler3D" >> return ISampler3D - -- , keyword "isamplerCube" >> return ISamplerCube - -- , keyword "isampler1DArray" >> return ISampler1DArray - -- , keyword "isampler2DArray" >> return ISampler2DArray - -- , keyword "usampler1D" >> return USampler1D - -- , keyword "usampler2D" >> return USampler2D - -- , keyword "usampler3D" >> return USampler3D - -- , keyword "usamplerCube" >> return USamplerCube - -- , keyword "usampler1DArray" >> return USampler1DArray - -- , keyword "usampler2DArray" >> return USampler2DArray - -- , keyword "sampler2DRect" >> return Sampler2DRect - -- , keyword "sampler2DRectShadow" >> return Sampler2DRectShadow - -- , keyword "isampler2DRect" >> return ISampler2DRect - -- , keyword "usampler2DRect" >> return USampler2DRect - -- , keyword "samplerBuffer" >> return SamplerBuffer - -- , keyword "isamplerBuffer" >> return ISamplerBuffer - -- , keyword "usamplerBuffer" >> return USamplerBuffer - -- , keyword "sampler2DMS" >> return Sampler2DMS - -- , keyword "isampler2DMS" >> return ISampler2DMS - -- , keyword "usampler2DMS" >> return USampler2DMS - -- , keyword "sampler2DMSArray" >> return Sampler2DMSArray - -- , keyword "isampler2DMSArray" >> return ISampler2DMSArray - -- , keyword "usampler2DMSArray" >> return USampler2DMSArray - -- , structSpecifier - -- , identifier >>= return . TypeName -- verify if it is declared - -- ] - Debug.todo "typeSpecifierNonArray" + choice + [ Parser.succeed Void + |. keyword "void" + , Parser.succeed Float + |. keyword "float" + , Parser.succeed Int + |. keyword "int" + , Parser.succeed UInt + |. keyword "uint" + , Parser.succeed Bool + |. keyword "bool" + , Parser.succeed Vec2 + |. keyword "vec2" + , Parser.succeed Vec3 + |. keyword "vec3" + , Parser.succeed Vec4 + |. keyword "vec4" + , Parser.succeed BVec2 + |. keyword "bvec2" + , Parser.succeed BVec3 + |. keyword "bvec3" + , Parser.succeed BVec4 + |. keyword "bvec4" + , Parser.succeed IVec2 + |. keyword "ivec2" + , Parser.succeed IVec3 + |. keyword "ivec3" + , Parser.succeed IVec4 + |. keyword "ivec4" + , Parser.succeed UVec2 + |. keyword "uvec2" + , Parser.succeed UVec3 + |. keyword "uvec3" + , Parser.succeed UVec4 + |. keyword "uvec4" + , Parser.succeed Mat2 + |. keyword "mat2" + , Parser.succeed Mat3 + |. keyword "mat3" + , Parser.succeed Mat4 + |. keyword "mat4" + , Parser.succeed Mat2x2 + |. keyword "mat2x2" + , Parser.succeed Mat2x3 + |. keyword "mat2x3" + , Parser.succeed Mat2x4 + |. keyword "mat2x4" + , Parser.succeed Mat3x2 + |. keyword "mat3x2" + , Parser.succeed Mat3x3 + |. keyword "mat3x3" + , Parser.succeed Mat3x4 + |. keyword "mat3x4" + , Parser.succeed Mat4x2 + |. keyword "mat4x2" + , Parser.succeed Mat4x3 + |. keyword "mat4x3" + , Parser.succeed Mat4x4 + |. keyword "mat4x4" + , Parser.succeed Sampler1D + |. keyword "sampler1D" + , Parser.succeed Sampler2D + |. keyword "sampler2D" + , Parser.succeed Sampler3D + |. keyword "sampler3D" + , Parser.succeed SamplerCube + |. keyword "samplerCube" + , Parser.succeed Sampler1DShadow + |. keyword "sampler1DShadow" + , Parser.succeed Sampler2DShadow + |. keyword "sampler2DShadow" + , Parser.succeed SamplerCubeShadow + |. keyword "samplerCubeShadow" + , Parser.succeed Sampler1DArray + |. keyword "sampler1DArray" + , Parser.succeed Sampler2DArray + |. keyword "sampler2DArray" + , Parser.succeed Sampler1DArrayShadow + |. keyword "sampler1DArrayShadow" + , Parser.succeed Sampler2DArrayShadow + |. keyword "sampler2DArrayShadow" + , Parser.succeed ISampler1D + |. keyword "isampler1D" + , Parser.succeed ISampler2D + |. keyword "isampler2D" + , Parser.succeed ISampler3D + |. keyword "isampler3D" + , Parser.succeed ISamplerCube + |. keyword "isamplerCube" + , Parser.succeed ISampler1DArray + |. keyword "isampler1DArray" + , Parser.succeed ISampler2DArray + |. keyword "isampler2DArray" + , Parser.succeed USampler1D + |. keyword "usampler1D" + , Parser.succeed USampler2D + |. keyword "usampler2D" + , Parser.succeed USampler3D + |. keyword "usampler3D" + , Parser.succeed USamplerCube + |. keyword "usamplerCube" + , Parser.succeed USampler1DArray + |. keyword "usampler1DArray" + , Parser.succeed USampler2DArray + |. keyword "usampler2DArray" + , Parser.succeed Sampler2DRect + |. keyword "sampler2DRect" + , Parser.succeed Sampler2DRectShadow + |. keyword "sampler2DRectShadow" + , Parser.succeed ISampler2DRect + |. keyword "isampler2DRect" + , Parser.succeed USampler2DRect + |. keyword "usampler2DRect" + , Parser.succeed SamplerBuffer + |. keyword "samplerBuffer" + , Parser.succeed ISamplerBuffer + |. keyword "isamplerBuffer" + , Parser.succeed USamplerBuffer + |. keyword "usamplerBuffer" + , Parser.succeed Sampler2DMS + |. keyword "sampler2DMS" + , Parser.succeed ISampler2DMS + |. keyword "isampler2DMS" + , Parser.succeed USampler2DMS + |. keyword "usampler2DMS" + , Parser.succeed Sampler2DMSArray + |. keyword "sampler2DMSArray" + , Parser.succeed ISampler2DMSArray + |. keyword "isampler2DMSArray" + , Parser.succeed USampler2DMSArray + |. keyword "usampler2DMSArray" + , structSpecifier + + -- verify if it is declared + , Parser.succeed TypeName + |= identifier + ] precisionQualifier : P PrecisionQualifier precisionQualifier = - -- choice - -- [ keyword "highp" >> return HighP - -- , keyword "mediump" >> return MediumP - -- , keyword "lowp" >> return LowP - -- ] - Debug.todo "precisionQualifier" + choice + [ Parser.succeed HighP + |. keyword "highp" + , Parser.succeed MediumP + |. keyword "mediump" + , Parser.succeed LowP + |. keyword "lowp" + ] structSpecifier : P TypeSpecifierNonArray structSpecifier = - -- do - -- keyword "struct" - -- i <- optionMaybe identifier - -- lbrace - -- d <- structDeclarationList - -- rbrace - -- return $ StructSpecifier i d - Debug.todo "structSpecifier" + Parser.succeed StructSpecifier + |. keyword "struct" + |= optionMaybe identifier + |. lbrace + |= structDeclarationList + |. rbrace structDeclarationList : P (List Field) structDeclarationList = - -- many1 structDeclaration - Debug.todo "structDeclarationList" + many1 structDeclaration structDeclaration : P Field structDeclaration = - -- do - -- q <- optionMaybe typeQualifier - -- s <- typeSpecifier - -- l <- structDeclaratorList - -- semicolon - -- return $ Field q s l - Debug.todo "structDeclaration" + Parser.succeed Field + |= optionMaybe typeQualifier + |= typeSpecifier + |= structDeclaratorList + |. semicolon structDeclaratorList : P (List StructDeclarator) structDeclaratorList = - -- sepBy structDeclarator comma - Debug.todo "structDeclaratorList" + sepBy structDeclarator comma structDeclarator : P StructDeclarator structDeclarator = - -- do - -- i <- identifier - -- choice - -- [ do lbracket - -- e <- optionMaybe constantExpression - -- rbracket - -- return $ StructDeclarator i (Just e) - -- , return $ StructDeclarator i Nothing - -- ] - Debug.todo "structDeclarator" + identifier + |> Parser.andThen + (\i -> + choice + [ Parser.succeed (\e -> StructDeclarator i (Just e)) + |. lbracket + |= optionMaybe constantExpression + |. rbracket + , Parser.succeed (StructDeclarator i Nothing) + ] + ) initializer : P Expr @@ -1026,39 +1373,48 @@ declarationStatement = statement : P Statement statement = - -- CompoundStatement `fmap` compoundStatement - -- <|> simpleStatement - Debug.todo "statement" + Parser.oneOf + [ Parser.map CompoundStatement compoundStatement + , simpleStatement + ] simpleStatement : P Statement simpleStatement = - -- choice - -- [ declarationStatement >>= return . DeclarationStatement - -- , expressionStatement >>= return . ExpressionStatement - -- , selectionStatement - -- , switchStatement - -- , caseLabel >>= return . CaseLabel - -- , iterationStatement - -- , jumpStatement - -- ] - Debug.todo "simpleStatement" + choice + [ Parser.succeed DeclarationStatement + |= declarationStatement + , Parser.succeed ExpressionStatement + |= expressionStatement + , selectionStatement + , switchStatement + , Parser.succeed CaseLabel + |= caseLabel + , iterationStatement + , jumpStatement + ] compoundStatement : P Compound compoundStatement = - -- choice - -- [ try (lbrace >> rbrace) >> return (Compound []) - -- , between lbrace rbrace statementList >>= return . Compound - -- ] - Debug.todo "compoundStatement" + choice + [ Parser.succeed (Compound []) + |. try + (Parser.succeed () + |. lbrace + |. rbrace + ) + , Parser.succeed Compound + |= between lbrace rbrace statementList + ] statementNoNewScope : P Statement statementNoNewScope = - -- CompoundStatement `fmap` compoundStatementNoNewScope - -- <|> simpleStatement - Debug.todo "statementNoNewScope" + Parser.oneOf + [ Parser.map CompoundStatement compoundStatementNoNewScope + , simpleStatement + ] compoundStatementNoNewScope : P Compound @@ -1073,24 +1429,26 @@ statementList = expressionStatement : P (Maybe Expr) expressionStatement = - -- choice - -- [ semicolon >> return Nothing - -- , expression >>= \e -> semicolon >> return (Just e) - -- ] - Debug.todo "expressionStatement" + choice + [ Parser.succeed Nothing |. semicolon + , expression + |> Parser.andThen (\e -> Parser.succeed (Just e) |. semicolon) + ] selectionStatement : P Statement selectionStatement = - -- do - -- keyword "if" - -- lparen - -- c <- expression - -- rparen - -- t <- statement - -- f <- optionMaybe (keyword "else" >> statement) - -- return $ SelectionStatement c t f - Debug.todo "selectionStatement" + Parser.succeed SelectionStatement + |. keyword "if" + |. lparen + |= expression + |. rparen + |= statement + |= optionMaybe + (Parser.succeed identity + |. keyword "else" + |= statement + ) @@ -1100,29 +1458,27 @@ selectionStatement = condition : P Condition condition = - -- choice - -- [ expression >>= return . Condition - -- , do t <- fullySpecifiedType - -- i <- identifier - -- _ <- lexeme (string "=") - -- j <- initializer - -- return $ InitializedCondition t i j - -- ] - Debug.todo "condition" + choice + [ Parser.succeed Condition + |= expression + , Parser.succeed InitializedCondition + |= fullySpecifiedType + |= identifier + |. lexeme (string "=") + |= initializer + ] switchStatement : P Statement switchStatement = - -- do - -- keyword "switch" - -- lparen - -- e <- expression - -- rparen - -- lbrace - -- l <- switchStatementList - -- rbrace - -- return $ SwitchStatement e l - Debug.todo "switchStatement" + Parser.succeed SwitchStatement + |. keyword "switch" + |. lparen + |= expression + |. rparen + |. lbrace + |= switchStatementList + |. rbrace switchStatementList : P (List Statement) @@ -1132,48 +1488,58 @@ switchStatementList = caseLabel : P CaseLabel caseLabel = - -- choice - -- [ keyword "case" >> expression >>= \e -> colon >> return (Case e) - -- , keyword "default" >> colon >> return Default - -- ] - Debug.todo "caseLabel" + choice + [ Parser.succeed identity + |. keyword "case" + |= expression + |> Parser.andThen + (\e -> + Parser.succeed (Case e) + |. colon + ) + , Parser.succeed Default + |. keyword "default" + |. colon + ] iterationStatement : P Statement iterationStatement = - -- choice - -- [ do keyword "while" - -- lparen - -- c <- condition - -- rparen - -- s <- statementNoNewScope - -- return $ While c s - -- , do keyword "do" - -- s <- statement - -- keyword "while" - -- lparen - -- e <- expression - -- rparen - -- semicolon - -- return $ DoWhile s e - -- , do keyword "for" - -- lparen - -- i <- forInitStatement - -- c <- optionMaybe condition - -- semicolon - -- e <- optionMaybe expression - -- rparen - -- s <- statementNoNewScope - -- return $ For i c e s - -- ] - Debug.todo "iterationStatement" + choice + [ Parser.succeed While + |. keyword "while" + |. lparen + |= condition + |. rparen + |= statementNoNewScope + , Parser.succeed DoWhile + |. keyword "do" + |= statement + |. keyword "while" + |. lparen + |= expression + |. rparen + |. semicolon + , Parser.succeed For + |. keyword "for" + |. lparen + |= forInitStatement + |= optionMaybe condition + |. semicolon + |= optionMaybe expression + |. rparen + |= statementNoNewScope + ] forInitStatement : P (Result (Maybe Expr) Declaration) forInitStatement = - -- (expressionStatement >>= return . Left) - -- <|> (declarationStatement >>= return . Right) - Debug.todo "forInitStatement" + Parser.oneOf + [ Parser.succeed Err + |= expressionStatement + , Parser.succeed Ok + |= declarationStatement + ] @@ -1185,32 +1551,53 @@ forInitStatement = jumpStatement : P Statement jumpStatement = - -- choice - -- [ keyword "continue" >> semicolon >> return Continue - -- , keyword "break" >> semicolon >> return Break - -- , try (keyword "return" >> semicolon) >> return (Return Nothing) - -- , keyword "return" >> expression >>= \e -> semicolon >> return (Return $ Just e) - -- , keyword "discard" >> semicolon >> return Discard - -- ] - Debug.todo "jumpStatement" + choice + [ Parser.succeed Continue + |. keyword "continue" + |. semicolon + , Parser.succeed Break + |. keyword "break" + |. semicolon + , Parser.succeed (Return Nothing) + |. try + (Parser.succeed () + |. keyword "return" + |. semicolon + ) + , Parser.succeed identity + |. keyword "return" + |= expression + |> Parser.andThen + (\e -> + Parser.succeed (Return <| Just e) + |. semicolon + ) + , Parser.succeed Discard + |. keyword "discard" + |. semicolon + ] translationUnit : P TranslationUnit translationUnit = - fmap TranslationUnit (many1 externalDeclaration) + Parser.map TranslationUnit (many1 externalDeclaration) externalDeclaration : P ExternalDeclaration externalDeclaration = - -- choice - -- [ do p <- try functionPrototype - -- choice - -- [ semicolon >> return (FunctionDeclaration p) - -- , compoundStatementNoNewScope >>= return . FunctionDefinition p - -- ] - -- , fmap Declaration declaration - -- ] - Debug.todo "externalDeclaration" + choice + [ try functionPrototype + |> Parser.andThen + (\p -> + choice + [ Parser.succeed (FunctionDeclaration p) + |. semicolon + , Parser.succeed (FunctionDefinition p) + |= compoundStatementNoNewScope + ] + ) + , Parser.map Declaration declaration + ] @@ -1219,8 +1606,6 @@ externalDeclaration = functionDefinition : P ExternalDeclaration functionDefinition = - -- do - -- fp <- functionPrototype - -- cs <- compoundStatementNoNewScope - -- return $ FunctionDefinition fp cs - Debug.todo "functionDefinition" + Parser.succeed FunctionDefinition + |= functionPrototype + |= compoundStatementNoNewScope diff --git a/tests/backwards-compatibility.test.js b/tests/backwards-compatibility.test.js index dc1804f6a..fd477def2 100644 --- a/tests/backwards-compatibility.test.js +++ b/tests/backwards-compatibility.test.js @@ -4,46 +4,46 @@ const childProcess = require("child_process"); const os = require("os"); const tmpDir = os.tmpdir(); +const defaultFlags = ["no-flags", "debug", "optimize"]; + const examples = [ // HTML - "Hello", - "Groceries", - "Shapes", + ["Hello", defaultFlags], + ["Groceries", defaultFlags], + ["Shapes", defaultFlags], // User Input - "Buttons", - "TextFields", - "Forms", + ["Buttons", defaultFlags], + ["TextFields", defaultFlags], + ["Forms", defaultFlags], // Random - "Numbers", - "Cards", - "Positions", + ["Numbers", defaultFlags], + ["Cards", defaultFlags], + ["Positions", defaultFlags], // HTTP - "Book", - "Quotes", + ["Book", defaultFlags], + ["Quotes", defaultFlags], // Time - "CurrentTime", - "Clock", + ["CurrentTime", defaultFlags], + ["Clock", defaultFlags], // Files ["Upload", ["no-flags", "debug"]], ["DragAndDrop", ["no-flags", "debug"]], - "ImagePreviews", + ["ImagePreviews", defaultFlags], // WebGL - "Triangle", - "Cube", - "Crate", - "Thwomp", - "FirstPerson", + ["Triangle", defaultFlags], + ["Cube", defaultFlags], + ["Crate", defaultFlags], + ["Thwomp", defaultFlags], + ["FirstPerson", defaultFlags], // Playground - "Picture", - "Animation", - "Mouse", - "Keyboard", - "Turtle", - "Mario", + ["Picture", defaultFlags], + ["Animation", defaultFlags], + ["Mouse", defaultFlags], + ["Keyboard", defaultFlags], + ["Turtle", defaultFlags], + ["Mario", defaultFlags], ]; -const defaultFlags = ["no-flags", "debug", "optimize"]; - const generateCommandFlags = function (flag) { if (flag === "no-flags") { return ""; @@ -55,16 +55,7 @@ const generateCommandFlags = function (flag) { describe("backwards compatibility", () => { describe.each(examples)( "produces the same code as elm for the %s example", - (examplePlusFlags) => { - let example, currentFlags; - - if (Array.isArray(examplePlusFlags)) { - [example, currentFlags] = examplePlusFlags; - } else { - example = examplePlusFlags; - currentFlags = defaultFlags; - } - + (example, currentFlags) => { test.each(currentFlags)("%s", (flag) => { const elmOutput = `${tmpDir}/guida-test-elm-${example}-${flag}-${process.pid}.js`; const guidaOutput = `${tmpDir}/guida-test-guida-${example}-${flag}-${process.pid}.js`;