language-glsl-0.3.0/0000755000000000000000000000000013342743400012422 5ustar0000000000000000language-glsl-0.3.0/language-glsl.cabal0000644000000000000000000000302613342743400016131 0ustar0000000000000000name: language-glsl version: 0.3.0 Cabal-Version: >= 1.8 synopsis: GLSL abstract syntax tree, parser, and pretty-printer description: The package language-glsl is a Haskell library for the representation, the parsing, and the pretty-printing of GLSL 1.50 code. category: Language, Graphics license: BSD3 license-file: LICENSE author: Vo Minh Thu maintainer: noteed@gmail.com build-type: Simple extra-source-files: glsl/sample-01.glsl source-repository head type: git location: https://github.com/noteed/language-glsl library build-depends: base < 5, parsec, prettyclass ghc-options: -Wall exposed-modules: Language.GLSL, Language.GLSL.Parser, Language.GLSL.Pretty, Language.GLSL.Syntax executable glsl-pprint main-is: glsl-pprint.hs hs-source-dirs: bin/ build-depends: base < 5, language-glsl, parsec, prettyclass ghc-options: -Wall Test-Suite tests Type: exitcode-stdio-1.0 build-depends: base < 5, HUnit, language-glsl, parsec, prettyclass, test-framework, test-framework-hunit ghc-options: -Wall Hs-Source-Dirs: tests main-is: Tests.hs language-glsl-0.3.0/LICENSE0000644000000000000000000000266413342743400013437 0ustar0000000000000000Copyright: (c) Vo Minh Thu, 2010. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. language-glsl-0.3.0/Setup.lhs0000644000000000000000000000011413342743400014226 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain language-glsl-0.3.0/Language/0000755000000000000000000000000013342743400014145 5ustar0000000000000000language-glsl-0.3.0/Language/GLSL.hs0000644000000000000000000000032313342743400015240 0ustar0000000000000000module Language.GLSL ( module Language.GLSL.Syntax, module Language.GLSL.Parser, module Language.GLSL.Pretty ) where import Language.GLSL.Syntax import Language.GLSL.Parser import Language.GLSL.Pretty language-glsl-0.3.0/Language/GLSL/0000755000000000000000000000000013342743400014706 5ustar0000000000000000language-glsl-0.3.0/Language/GLSL/Parser.hs0000644000000000000000000006477113342743400016515 0ustar0000000000000000module Language.GLSL.Parser where import Prelude hiding (break, exponent) import Text.ParserCombinators.Parsec hiding (State, parse) import Text.ParserCombinators.Parsec.Expr import Language.GLSL.Syntax ---------------------------------------------------------------------- -- Parser state, hold a symbol table. ---------------------------------------------------------------------- data S = S type P a = GenParser Char S a ---------------------------------------------------------------------- -- Reserved words ---------------------------------------------------------------------- -- List of keywords. keywords :: [String] keywords = concat $ map words $ [ "attribute const uniform varying" , "layout" , "centroid flat smooth noperspective" , "break continue do for while switch case default" , "if else" , "in out inout" , "float int void bool true false" , "invariant" , "discard return" , "mat2 mat3 mat4" , "mat2x2 mat2x3 mat2x4" , "mat3x2 mat3x3 mat3x4" , "mat4x2 mat4x3 mat4x4" , "vec2 vec3 vec4 ivec2 ivec3 ivec4 bvec2 bvec3 bvec4" , "uint uvec2 uvec3 uvec4" , "lowp mediump highp precision" , "sampler1D sampler2D sampler3D samplerCube" , "sampler1DShadow sampler2DShadow samplerCubeShadow" , "sampler1DArray sampler2DArray" , "sampler1DArrayShadow sampler2DArrayShadow" , "isampler1D isampler2D isampler3D isamplerCube" , "isampler1DArray isampler2DArray" , "usampler1D usampler2D usampler3D usamplerCube" , "usampler1DArray usampler2DArray" , "sampler2DRect sampler2DRectShadow isampler2DRect usampler2DRect" , "samplerBuffer isamplerBuffer usamplerBuffer" , "sampler2DMS isampler2DMS usampler2DMS" , "sampler2DMSArray isampler2DMSArray usampler2DMSArray" , "struct" ] -- List of keywords reserved for future use. reservedWords :: [String] reservedWords = concat $ map words $ [ "common partition active" , "asm" , "class union enum typedef template this packed" , "goto" , "inline noinline volatile public static extern external interface" , "long short double half fixed unsigned superp" , "input output" , "hvec2 hvec3 hvec4 dvec2 dvec3 dvec4 fvec2 fvec3 fvec4" , "sampler3DRect" , "filter" , "image1D image2D image3D imageCube" , "iimage1D iimage2D iimage3D iimageCube" , "uimage1D uimage2D uimage3D uimageCube" , "image1DArray image2DArray" , "iimage1DArray iimage2DArray uimage1DArray uimage2DArray" , "image1DShadow image2DShadow" , "image1DArrayShadow image2DArrayShadow" , "imageBuffer iimageBuffer uimageBuffer" , "sizeof cast" , "namespace using" , "row_major" ] ---------------------------------------------------------------------- -- Convenience parsers ---------------------------------------------------------------------- comment :: P () comment = do _ <- char '/' _ <- choice [ do _ <- char '*' manyTill anyChar (try $ string "*/") , do _ <- char '/' manyTill anyChar ((newline >> return ()) <|> eof) ] return () blank :: P () blank = try comment <|> (space >> return ()) -- Acts like p and discards any following space character. lexeme :: P a -> P a lexeme p = do x <- p skipMany blank return x parse :: [Char] -> Either ParseError TranslationUnit parse = runParser (do {skipMany blank ; r <- translationUnit ; eof ; return r}) S "GLSL" ---------------------------------------------------------------------- -- Lexical elements (tokens) ---------------------------------------------------------------------- semicolon :: P () semicolon = lexeme $ char ';' >> return () comma :: P () comma = lexeme $ char ',' >> return () colon :: P () colon = lexeme $ char ':' >> return () lbrace :: P () lbrace = lexeme $ char '{' >> return () rbrace :: P () rbrace = lexeme $ char '}' >> return () lbracket :: P () lbracket = lexeme $ char '[' >> return () rbracket :: P () rbracket = lexeme $ char ']' >> return () lparen :: P () lparen = lexeme $ char '(' >> return () rparen :: P () rparen = lexeme $ char ')' >> return () -- Try to parse a given string, making sure it is not a -- prefix of an identifier. keyword :: String -> P () keyword w = lexeme $ try (string w >> notFollowedBy identifierTail) -- Parses and returns an identifier. -- TODO an identifier can't start with "gl_" unless -- it is to redeclare a predeclared "gl_" identifier. 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 -- TODO the size of the int should fit its type. intConstant :: P Expr intConstant = choice [ hexadecimal , octal , badOctal >> fail "Invalid octal number" , decimal ] floatingConstant :: P Expr floatingConstant = choice [ floatExponent , floatPoint , pointFloat ] -- Try to parse a given string, and allow identifier characters -- (or anything else) to directly follow. operator :: String -> P String operator = lexeme . try . string ---------------------------------------------------------------------- -- Lexical elements helpers ---------------------------------------------------------------------- identifierHead :: P Char identifierHead = letter <|> char '_' identifierTail :: P Char identifierTail = 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) octal :: P Expr octal = lexeme $ try $ do _ <- char '0' d <- many1 octDigit m <- optionMaybe $ oneOf "Uu" -- TODO return $ IntConstant Octal $ read ("0o" ++ d) badOctal :: P () badOctal = lexeme $ try $ char '0' >> many1 hexDigit >> return () decimal :: P Expr decimal = lexeme $ try $ do d <- many1 digit notFollowedBy (char '.' <|> (exponent >> return ' ')) m <- optionMaybe $ oneOf "Uu" -- TODO return $ IntConstant Decimal $ read d floatExponent :: P Expr floatExponent = lexeme $ try $ do d <- many1 digit e <- exponent m <- optionMaybe $ oneOf "Ff" -- TODO return $ FloatConstant $ read $ d ++ e 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 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 exponent :: P String exponent = lexeme $ try $ do _ <- oneOf "Ee" s <- optionMaybe (oneOf "+-") d <- many1 digit return $ "e" ++ maybe "" (:[]) s ++ d ---------------------------------------------------------------------- -- Tables for buildExpressionParser ---------------------------------------------------------------------- infixLeft :: String -> (a -> a -> a) -> Operator Char S a infixLeft s r = Infix (lexeme (try $ string s) >> return r) AssocLeft infixLeft' :: String -> (a -> a -> a) -> Operator Char S a infixLeft' s r = Infix (lexeme (try $ string s >> notFollowedBy (char '=')) >> return r) AssocLeft infixLeft'' :: Char -> (a -> a -> a) -> Operator Char S a infixLeft'' c r = Infix (lexeme (try $ char c >> notFollowedBy (oneOf (c:"="))) >> return r) AssocLeft infixRight :: String -> (a -> a -> a) -> Operator Char S a infixRight s r = Infix (lexeme (try $ string s) >> return r) AssocRight conditionalTable :: [[Operator Char S Expr]] conditionalTable = [ [infixLeft' "*" Mul, infixLeft' "/" Div, infixLeft' "%" Mod] , [infixLeft' "+" Add, infixLeft' "-" Sub] , [infixLeft' "<<" LeftShift, infixLeft' ">>" RightShift] , [infixLeft' "<" Lt, infixLeft' ">" Gt ,infixLeft "<=" Lte, infixLeft ">=" Gte] , [infixLeft "==" Equ, infixLeft "!=" Neq] , [infixLeft'' '&' BitAnd] , [infixLeft' "^" BitXor] , [infixLeft'' '|' BitOr] , [infixLeft "&&" And] , [infixLeft "||" Or] ] assignmentTable :: [[Operator Char S Expr]] assignmentTable = [ [infixRight "=" Equal] , [infixRight "+=" AddAssign] , [infixRight "-=" SubAssign] , [infixRight "*=" MulAssign] , [infixRight "/=" DivAssign] , [infixRight "%=" ModAssign] , [infixRight "<<=" LeftAssign] , [infixRight ">>=" RightAssign] , [infixRight "&=" AndAssign] , [infixRight "^=" XorAssign] , [infixRight "|=" OrAssign] ] expressionTable :: [[Operator Char S Expr]] expressionTable = [ [infixLeft "," Sequence] ] ---------------------------------------------------------------------- -- Grammar ---------------------------------------------------------------------- primaryExpression :: P Expr primaryExpression = choice [ Variable `fmap` try identifier -- int constant , intConstant -- uint constant -- float constant , floatingConstant -- bool constant , keyword "true" >> return (BoolConstant True) , keyword "false" >> return (BoolConstant False) -- expression within parentheses , between lparen rparen expression ] 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 dotFunctionCallGeneric :: P (Expr -> Expr) dotFunctionCallGeneric = lexeme (try $ string "." >> functionCallGeneric) >>= \(i,p) -> return (\e -> MethodCall e i p) dotFieldSelection :: P (Expr -> Expr) dotFieldSelection = lexeme (try $ string "." >> identifier) >>= return . flip FieldSelection integerExpression :: P Expr integerExpression = expression -- Those productions are pushed inside postfixExpression. -- functionCall = functionCallOrMethod -- functionCallOrMethod = functionCallGeneric <|> postfixExpression DOT functionCallGeneric functionCallGeneric :: P (FunctionIdentifier, Parameters) functionCallGeneric = do i <- functionCallHeader p <- choice [ keyword "void" >> return ParamVoid , assignmentExpression `sepBy` comma >>= return . Params ] rparen return (i, p) -- Those productions are pushed inside functionCallGeneric. -- functionCallHeaderNoParameters = undefined -- functionCallHeaderWithParameters = undefined functionCallHeader :: P FunctionIdentifier functionCallHeader = do i <- functionIdentifier lparen return i 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 ] 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 -- inside unaryExpression -- unaryOperator = choice -- implemented throught buildExpressionParser -- multiplicativeExpression = undefined -- additiveExpression = undefined -- shiftExpression = undefined -- relationalExpression = undefined -- equalityExpression = undefined -- andExpression = undefined -- exclusiveOrExpression = undefined -- inclusiveOrExpression = undefined -- logicalAndExpression = undefined -- logicalXorExpression = undefined -- logicalOrExpression = undefined 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 assignmentExpression :: P Expr assignmentExpression = buildExpressionParser assignmentTable conditionalExpression expression :: P Expr expression = buildExpressionParser expressionTable assignmentExpression constantExpression :: P Expr constantExpression = conditionalExpression -- The GLSL grammar include here function definition but we don't -- do this here because they should occur only at top level (page 28). -- Function definitions are handled in externalDefinition instead. 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 functionPrototype :: P FunctionPrototype functionPrototype = do (t, i, p) <- functionDeclarator rparen return $ FuncProt t i p functionDeclarator :: P (FullType, String, [ParameterDeclaration]) functionDeclarator = do (t, i) <- functionHeader p <- parameterDeclaration `sepBy` comma return (t, i, p) -- inside functionDeclarator -- functionHeaderWithParameters = undefined functionHeader :: P (FullType, String) functionHeader = do t <- fullySpecifiedType i <- identifier lparen return (t, i) -- inside parameterDeclaration -- parameterDeclarator = undefined -- expanding parameterDeclarator and parameterTypeSpecifier, the rule is: -- parameterDeclaration: -- parameterTypeQualifier [parameterQualifier] typeSpecifier identifier[[e]] -- [parameterQualifier] typeSpecifier identifier[[e]] -- parameterTypeQualifier [parameterQualifier] typeSpecifier -- [parameterQualifier] typeSpecifier -- which is simply -- [parameterTypeQualifier] [parameterQualifier] typeSpecifier [identifier[[e]]] 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 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 ] -- inside parameterDeclaration -- parameterTypeSpecifier = typeSpecifier -- FIXME not correct w.r.t. the specs. -- The specs allow -- int -- int, foo -- invariant foo, bar[] -- and disallow -- invariant bar[] -- It is not used, it is inside declaration. -- initDeclaratorList = undefined -- inside initDeclaratorList -- singleDeclaration = undefined fullySpecifiedType :: P FullType fullySpecifiedType = choice [ try typeSpecifier >>= return . FullType Nothing , do q <- typeQualifier s <- typeSpecifier return $ FullType (Just q) s ] invariantQualifier :: P InvariantQualifier invariantQualifier = keyword "invariant" >> return Invariant interpolationQualifier :: P InterpolationQualifier interpolationQualifier = choice [ keyword "smooth" >> return Smooth , keyword "flat" >> return Flat , keyword "noperspective" >> return NoPerspective ] layoutQualifier :: P LayoutQualifier layoutQualifier = do keyword "layout" lparen q <- layoutQualifierId `sepBy` comma rparen return $ Layout q -- implemented directly in layoutQualifier -- layoutQualifierIdList = undefined layoutQualifierId :: P LayoutQualifierId layoutQualifierId = do i <- identifier c <- optionMaybe $ lexeme (string "=") >> intConstant return $ LayoutQualId i c parameterTypeQualifier :: P ParameterTypeQualifier parameterTypeQualifier = keyword "const" >> return ConstParameter -- sto -- lay [sto] -- int [sto] -- inv [sto] -- inv int sto 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 ] ] -- TODO see 4.3 for restrictions 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 ] typeSpecifier :: P TypeSpecifier typeSpecifier = choice [ do q <- try precisionQualifier s <- typeSpecifierNoPrecision return $ TypeSpec (Just q) s , typeSpecifierNoPrecision >>= return . TypeSpec Nothing ] 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 ] -- Basic types, structs, and user-defined types. 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 ] precisionQualifier :: P PrecisionQualifier precisionQualifier = choice [ keyword "highp" >> return HighP , keyword "mediump" >> return MediumP , keyword "lowp" >> return LowP ] structSpecifier :: P TypeSpecifierNonArray structSpecifier = do keyword "struct" i <- optionMaybe identifier lbrace d <- structDeclarationList rbrace return $ StructSpecifier i d structDeclarationList :: P [Field] structDeclarationList = many1 structDeclaration structDeclaration :: P Field structDeclaration = do q <- optionMaybe typeQualifier s <- typeSpecifier l <- structDeclaratorList semicolon return $ Field q s l structDeclaratorList :: P [StructDeclarator] structDeclaratorList = structDeclarator `sepBy` comma structDeclarator :: P StructDeclarator structDeclarator = do i <- identifier choice [ do lbracket e <- optionMaybe constantExpression rbracket return $ StructDeclarator i (Just e) , return $ StructDeclarator i Nothing ] initializer :: P Expr initializer = assignmentExpression declarationStatement :: P Declaration declarationStatement = declaration statement :: P Statement statement = CompoundStatement `fmap` compoundStatement <|> simpleStatement simpleStatement :: P Statement simpleStatement = choice [ declarationStatement >>= return . DeclarationStatement , expressionStatement >>= return . ExpressionStatement , selectionStatement , switchStatement , caseLabel >>= return . CaseLabel , iterationStatement , jumpStatement ] compoundStatement :: P Compound compoundStatement = choice [ try (lbrace >> rbrace) >> return (Compound []) , between lbrace rbrace statementList >>= return . Compound ] statementNoNewScope :: P Statement statementNoNewScope = CompoundStatement `fmap` compoundStatementNoNewScope <|> simpleStatement compoundStatementNoNewScope :: P Compound compoundStatementNoNewScope = compoundStatement statementList :: P [Statement] statementList = many1 statement expressionStatement :: P (Maybe Expr) expressionStatement = choice [ semicolon >> return Nothing , expression >>= \e -> semicolon >> return (Just e) ] selectionStatement :: P Statement selectionStatement = do keyword "if" lparen c <- expression rparen t <- statement f <- optionMaybe (keyword "else" >> statement) return $ SelectionStatement c t f -- inside selectionStatement -- selectionRestStatement = undefined condition :: P Condition condition = choice [ expression >>= return . Condition , do t <- fullySpecifiedType i <- identifier _ <- lexeme (string "=") j <- initializer return $ InitializedCondition t i j ] switchStatement :: P Statement switchStatement = do keyword "switch" lparen e <- expression rparen lbrace l <- switchStatementList rbrace return $ SwitchStatement e l switchStatementList :: P [Statement] switchStatementList = many statement caseLabel :: P CaseLabel caseLabel = choice [ keyword "case" >> expression >>= \e -> colon >> return (Case e) , keyword "default" >> colon >> return Default ] 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 ] forInitStatement :: P (Either (Maybe Expr) Declaration) forInitStatement = (expressionStatement >>= return . Left) <|> (declarationStatement >>= return . Right) -- inside iterationStatement -- conditionOp = undefined -- inside iterationStatement -- forRestStatement = undefined 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 ] translationUnit :: P TranslationUnit translationUnit = TranslationUnit `fmap` many1 externalDeclaration externalDeclaration :: P ExternalDeclaration externalDeclaration = choice [ do p <- try functionPrototype choice [ semicolon >> return (FunctionDeclaration p) , compoundStatementNoNewScope >>= return . FunctionDefinition p ] , Declaration `fmap` declaration ] -- inside externalDeclaration, used only in tests functionDefinition :: P ExternalDeclaration functionDefinition = do fp <- functionPrototype cs <- compoundStatementNoNewScope return $ FunctionDefinition fp cs language-glsl-0.3.0/Language/GLSL/Syntax.hs0000644000000000000000000001772013342743400016537 0ustar0000000000000000module Language.GLSL.Syntax where -- TODO: -- - add support for 'array of strings' ? -- - add support for macro preprocessing -- - add support for optional macro #include -- - applicative style (see http://github.com/markusle/husky)? -- - type checking -- - check for constant expression where expected -- - error reporting -- - pretty-printing -- - basic queries (inputs and outputs of the shader) -- - support GLSL 1.40? -- - proper testing (HUnit and QuickCheck) -- - use hpc with the tests -- - scoping -- - clean module import/export -- - order of Syntax data types and Pretty instances should be the same -- - build with no warning -- - use hlint -- - push to github -- - push to hackage -- - use parsec 3 -- - handle all possible newlines (\n, \r, \r\n, \n\r) -- - 80-columns clean -- - lot of restriction of Samplers use (section 4.1.7), -- well in fact, for plenty of things. ---------------------------------------------------------------------- -- Abstract syntax tree ---------------------------------------------------------------------- data TranslationUnit = TranslationUnit [ExternalDeclaration] -- at least one deriving (Show, Eq) data ExternalDeclaration = -- function declarations should be at top level (page 28) FunctionDeclaration FunctionPrototype | FunctionDefinition FunctionPrototype Compound | Declaration Declaration deriving (Show, Eq) -- TODO clean data Declaration = -- e.g. layout (origin_upper_left) in vec4 gl_FragCoord; -- struct name { ... }; -- struct name { ... } name; InitDeclaration InvariantOrType [InitDeclarator] | Precision PrecisionQualifier TypeSpecifierNoPrecision | Block TypeQualifier String [Field] (Maybe (String, Maybe (Maybe Expr))) -- constant expression -- e.g. layout (origin_upper_left) in; TODO check if it is only used for default layout. | TQ TypeQualifier deriving (Show, Eq) -- TODO regroup String (Maybe (Maybe Expr)) as Declarator and use it for -- StructDeclarator. data InitDeclarator = InitDecl String (Maybe (Maybe Expr)) (Maybe Expr) -- constant expression; assignment expression deriving (Show, Eq) data InvariantOrType = InvariantDeclarator | TypeDeclarator FullType deriving (Show, Eq) data FunctionPrototype = FuncProt FullType String [ParameterDeclaration] deriving (Show, Eq) data ParameterDeclaration = ParameterDeclaration (Maybe ParameterTypeQualifier) (Maybe ParameterQualifier) TypeSpecifier (Maybe (String, Maybe Expr)) -- constant expression deriving (Show, Eq) data FullType = FullType (Maybe TypeQualifier) TypeSpecifier deriving (Show, Eq) -- sto -- lay [sto] -- int [sto] -- inv [sto] -- inv int sto data TypeQualifier = TypeQualSto StorageQualifier | TypeQualLay LayoutQualifier (Maybe StorageQualifier) | TypeQualInt InterpolationQualifier (Maybe StorageQualifier) | TypeQualInv InvariantQualifier (Maybe StorageQualifier) | TypeQualInv3 InvariantQualifier InterpolationQualifier StorageQualifier deriving (Show, Eq) data TypeSpecifier = TypeSpec (Maybe PrecisionQualifier) TypeSpecifierNoPrecision deriving (Show, Eq) data InvariantQualifier = Invariant deriving (Show, Eq) data InterpolationQualifier = Smooth | Flat | NoPerspective deriving (Show, Eq) data LayoutQualifier = Layout [LayoutQualifierId] deriving (Show, Eq) data LayoutQualifierId = LayoutQualId String (Maybe Expr) -- TODO Expr should be IntConstant deriving (Show, Eq) data Statement = -- declaration statement DeclarationStatement Declaration -- jump statement | Continue | Break | Return (Maybe Expr) | Discard -- fragment shader only -- compound statement | CompoundStatement Compound -- expression statement | ExpressionStatement (Maybe Expr) -- selection statement | SelectionStatement Expr Statement (Maybe Statement) -- switch statement | SwitchStatement Expr [Statement] | CaseLabel CaseLabel -- iteration statement | While Condition Statement -- no new scope | DoWhile Statement Expr | For (Either (Maybe Expr) Declaration) (Maybe Condition) (Maybe Expr) Statement -- 1st stmt: expression or declaration, 2nd: no new scope deriving (Show, Eq) data Compound = Compound [Statement] deriving (Show, Eq) data Condition = Condition Expr | InitializedCondition FullType String Expr -- assignment expression deriving (Show, Eq) data CaseLabel = Case Expr | Default deriving (Show, Eq) data StorageQualifier = Const | Attribute -- vertex only | Varying | CentroidVarying | In | Out | CentroidIn | CentroidOut | Uniform deriving (Show, Eq) data TypeSpecifierNoPrecision = TypeSpecNoPrecision TypeSpecifierNonArray (Maybe (Maybe Expr)) -- constant expression deriving (Show, Eq) data TypeSpecifierNonArray = Void | Float | Int | UInt | Bool | Vec2 | Vec3 | Vec4 | BVec2 | BVec3 | BVec4 | IVec2 | IVec3 | IVec4 | UVec2 | UVec3 | UVec4 | Mat2 | Mat3 | Mat4 | Mat2x2 | Mat2x3 | Mat2x4 | Mat3x2 | Mat3x3 | Mat3x4 | Mat4x2 | Mat4x3 | Mat4x4 | Sampler1D | Sampler2D | Sampler3D | SamplerCube | Sampler1DShadow | Sampler2DShadow | SamplerCubeShadow | Sampler1DArray | Sampler2DArray | Sampler1DArrayShadow | Sampler2DArrayShadow | ISampler1D | ISampler2D | ISampler3D | ISamplerCube | ISampler1DArray | ISampler2DArray | USampler1D | USampler2D | USampler3D | USamplerCube | USampler1DArray | USampler2DArray | Sampler2DRect | Sampler2DRectShadow | ISampler2DRect | USampler2DRect | SamplerBuffer | ISamplerBuffer | USamplerBuffer | Sampler2DMS | ISampler2DMS | USampler2DMS | Sampler2DMSArray | ISampler2DMSArray | USampler2DMSArray | StructSpecifier (Maybe String) [Field] | TypeName String -- TODO user-defined type, should verify if it is declared deriving (Show, Eq) data PrecisionQualifier = HighP | MediumP | LowP deriving (Show, Eq) -- TODO The type qualifier can be present only when there is one or more declarators. -- There other restrictions, see 4.1.8. data Field = Field (Maybe TypeQualifier) TypeSpecifier [StructDeclarator] deriving (Show, Eq) data StructDeclarator = StructDeclarator String (Maybe (Maybe Expr)) -- constant expression deriving (Show, Eq) data Expr = -- primaryExpression Variable String | IntConstant IntConstantKind Integer | FloatConstant Float | BoolConstant Bool -- postfixExpression | Bracket Expr Expr | FieldSelection Expr String | MethodCall Expr FunctionIdentifier Parameters | FunctionCall FunctionIdentifier Parameters | PostInc Expr | PostDec Expr | PreInc Expr | PreDec Expr -- unary expression | UnaryPlus Expr | UnaryNegate Expr | UnaryNot Expr | UnaryOneComplement Expr -- binary expression | Mul Expr Expr | Div Expr Expr | Mod Expr Expr | Add Expr Expr | Sub Expr Expr | LeftShift Expr Expr | RightShift Expr Expr | Lt Expr Expr | Gt Expr Expr | Lte Expr Expr | Gte Expr Expr | Equ Expr Expr | Neq Expr Expr | BitAnd Expr Expr | BitXor Expr Expr | BitOr Expr Expr | And Expr Expr | Or Expr Expr | Selection Expr Expr Expr -- ternary _ ? _ : _ operator -- assignment, the left Expr should be unary expression | Equal Expr Expr | MulAssign Expr Expr | DivAssign Expr Expr | ModAssign Expr Expr | AddAssign Expr Expr | SubAssign Expr Expr | LeftAssign Expr Expr | RightAssign Expr Expr | AndAssign Expr Expr | XorAssign Expr Expr | OrAssign Expr Expr -- sequence | Sequence Expr Expr deriving (Show, Eq) data IntConstantKind = Hexadecimal | Octal | Decimal deriving (Show, Eq) data Parameters = ParamVoid | Params [Expr] deriving (Show, Eq) data ParameterQualifier = InParameter | OutParameter | InOutParameter deriving (Show, Eq) data ParameterTypeQualifier = ConstParameter deriving (Show, Eq) data FunctionIdentifier = -- TODO could be refine (I think a precision qualifier is not permitted, -- nor a complete struct definition) FuncIdTypeSpec TypeSpecifier | FuncId String deriving (Show, Eq) language-glsl-0.3.0/Language/GLSL/Pretty.hs0000644000000000000000000003212513342743400016534 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Language.GLSL.Pretty where import Text.PrettyPrint.HughesPJClass import Text.Printf import Language.GLSL.Syntax import Prelude hiding ((<>)) ---------------------------------------------------------------------- -- helpers (TODO clean) ---------------------------------------------------------------------- type Assoc = (Rational -> Rational, Rational -> Rational) assocLeft, assocRight, assocNone :: Assoc assocLeft = (id,bump) assocRight = (bump,id) assocNone = (bump,bump) bump :: Rational -> Rational bump = (+ 0.5) prettyBinary :: Pretty a => PrettyLevel -> Rational -> Rational -> Assoc -> String -> a -> a -> Doc prettyBinary l p op (lf,rf) o e1 e2 = prettyParen (p > op) $ pPrintPrec l (lf op) e1 <+> text o <+> pPrintPrec l (rf op) e2 option :: Pretty a => Maybe a -> Doc option Nothing = empty option (Just x) = pPrint x indexing :: Pretty a => Maybe (Maybe a) -> Doc indexing Nothing = empty indexing (Just Nothing) = brackets empty indexing (Just (Just e)) = brackets $ pPrint e indexing' :: Pretty a => Maybe (String, Maybe a) -> Doc indexing' Nothing = empty indexing' (Just (i, Nothing)) = text i indexing' (Just (i, Just e)) = text i <> brackets (pPrint e) initialize :: Pretty a => Maybe a -> Doc initialize Nothing = empty initialize (Just e) = char ' ' <> equals <+> pPrint e ident :: Pretty a => Maybe (String, Maybe (Maybe a)) -> Doc ident Nothing = empty ident (Just (i, Nothing)) = text i ident (Just (i, Just Nothing)) = text i <> brackets empty ident (Just (i, Just (Just e))) = text i <> brackets (pPrint e) initialize' :: Pretty a => Maybe (String, Maybe a) -> Doc initialize' Nothing = empty initialize' (Just (i, Nothing)) = text i initialize' (Just (i, Just e)) = text i <+> char '=' <+> pPrint e ---------------------------------------------------------------------- -- Pretty instances ---------------------------------------------------------------------- instance Pretty TranslationUnit where pPrint (TranslationUnit ds) = vcat $ map pPrint ds -- pPrint (Alternative p e) = text "(" <> nest 2 (vcat [pPrint p, pPrint e]) <> text ")" instance Pretty ExternalDeclaration where pPrint (FunctionDeclaration p) = pPrint p <> semi pPrint (FunctionDefinition p s) = vcat [pPrint p, pPrint s] pPrint (Declaration d) = pPrint d instance Pretty Declaration where pPrint (InitDeclaration it ds) = pPrint it <+> hsep (punctuate comma (map pPrint ds)) <> semi pPrint (Precision pq t) = text "precision" <+> pPrint pq <+> pPrint t <> semi pPrint (Block tq i ds n) = vcat [pPrint tq <+> text i, lbrace, nest 2 (vcat $ map pPrint ds), rbrace <+> ident n <> semi] pPrint (TQ tq) = pPrint tq <> semi instance Pretty InitDeclarator where pPrint (InitDecl i a b) = text i <> indexing a <> initialize b instance Pretty InvariantOrType where pPrint InvariantDeclarator = text "invariant" pPrint (TypeDeclarator ft) = pPrint ft instance Pretty FullType where pPrint (FullType tq ts) = option tq <+> pPrint ts instance Pretty TypeQualifier where pPrint (TypeQualSto sq) = pPrint sq pPrint (TypeQualLay lq sq) = pPrint lq <+> option sq pPrint (TypeQualInt iq sq) = pPrint iq <+> option sq pPrint (TypeQualInv iq sq) = pPrint iq <+> option sq pPrint (TypeQualInv3 iq iq' sq) = pPrint iq <+> pPrint iq' <+> pPrint sq instance Pretty StorageQualifier where pPrint q = case q of Const -> text "const" Attribute -> text "attribute" Varying -> text "varying" CentroidVarying -> text "centroid varying" In -> text "in" Out -> text "out" CentroidIn -> text "centroid in" CentroidOut -> text "centroid out" Uniform -> text "uniform" instance Pretty LayoutQualifier where pPrint (Layout is) = text "layout" <+> char '(' <> (hsep $ punctuate comma $ map pPrint is) <> char ')' instance Pretty LayoutQualifierId where pPrint (LayoutQualId i Nothing) = text i pPrint (LayoutQualId i (Just e)) = text i <+> char '=' <+> pPrint e instance Pretty InterpolationQualifier where pPrint q = case q of Smooth -> text "smooth" Flat -> text "flat" NoPerspective -> text "noperspective" instance Pretty InvariantQualifier where pPrint Invariant = text "invariant" instance Pretty TypeSpecifier where pPrint (TypeSpec (Just pq) t) = pPrint pq <+> pPrint t pPrint (TypeSpec Nothing t) = pPrint t instance Pretty PrecisionQualifier where pPrint HighP = text "highp" pPrint MediumP = text "mediump" pPrint LowP = text "lowp" instance Pretty TypeSpecifierNoPrecision where pPrint (TypeSpecNoPrecision t a) = pPrint t <+> indexing a instance Pretty TypeSpecifierNonArray where pPrint t = case t of Void -> text "void" Float -> text "float" Int -> text "int" UInt -> text "uint" Bool -> text "bool" Vec2 -> text "vec2" Vec3 -> text "vec3" Vec4 -> text "vec4" BVec2 -> text "bvec2" BVec3 -> text "bvec3" BVec4 -> text "bvec4" IVec2 -> text "ivec2" IVec3 -> text "ivec3" IVec4 -> text "ivec4" UVec2 -> text "uvec2" UVec3 -> text "uvec3" UVec4 -> text "uvec4" Mat2 -> text "mat2" Mat3 -> text "mat3" Mat4 -> text "mat4" Mat2x2 -> text "mat2x2" Mat2x3 -> text "mat2x3" Mat2x4 -> text "mat2x4" Mat3x2 -> text "mat3x2" Mat3x3 -> text "mat3x3" Mat3x4 -> text "mat3x4" Mat4x2 -> text "mat4x2" Mat4x3 -> text "mat4x3" Mat4x4 -> text "mat4x4" Sampler1D -> text "sampler1D" Sampler2D -> text "sampler2D" Sampler3D -> text "sampler3D" SamplerCube -> text "samplerCube" Sampler1DShadow -> text "sampler1DShadow" Sampler2DShadow -> text "sampler2DShadow" SamplerCubeShadow -> text "samplerCubeShadow" Sampler1DArray -> text "sampler1DArray" Sampler2DArray -> text "sampler2DArray" Sampler1DArrayShadow -> text "sampler1DArrayShadow" Sampler2DArrayShadow -> text "sampler2DArrayShadow" ISampler1D -> text "isampler1D" ISampler2D -> text "isampler2D" ISampler3D -> text "isampler3D" ISamplerCube -> text "isamplerCube" ISampler1DArray -> text "isampler1DArray" ISampler2DArray -> text "isampler2DArray" USampler1D -> text "usampler1D" USampler2D -> text "usampler2D" USampler3D -> text "usampler3D" USamplerCube -> text "usamplerCube" USampler1DArray -> text "usampler1DArray" USampler2DArray -> text "usampler2DArray" Sampler2DRect -> text "sampler2DRect" Sampler2DRectShadow -> text "sampler2DRectShadow" ISampler2DRect -> text "isampler2DRect" USampler2DRect -> text "usampler2DRect" SamplerBuffer -> text "samplerBuffer" ISamplerBuffer -> text "isamplerBuffer" USamplerBuffer -> text "usamplerBuffer" Sampler2DMS -> text "sampler2DMS" ISampler2DMS -> text "isampler2DMS" USampler2DMS -> text "usampler2DMS" Sampler2DMSArray -> text "sampler2DMSArray" ISampler2DMSArray -> text "isampler2DMSArray" USampler2DMSArray -> text "usampler2DMSArray" StructSpecifier i ds -> vcat [text "struct" <+> i', lbrace, nest 2 (vcat $ map pPrint ds), rbrace] where i' = case i of { Nothing -> empty ; Just n -> text n } TypeName i -> text i instance Pretty Field where pPrint (Field tq s ds) = option tq <+> pPrint s <+> hsep (punctuate comma $ map pPrint ds) <> semi instance Pretty StructDeclarator where pPrint (StructDeclarator i e) = ident (Just (i, e)) instance Pretty Expr where pPrintPrec l p e = case e of -- primaryExpression Variable v -> text v IntConstant Decimal i -> text (show i) IntConstant Hexadecimal i -> text (printf "0x%x" i) IntConstant Octal i -> text (printf "0%o" i) FloatConstant f -> text (show f) BoolConstant True -> text "true" BoolConstant False -> text "false" -- postfixExpression Bracket e1 e2 -> prettyParen (p > 16) $ pPrintPrec l 16 e1 <> brackets (pPrint e2) FieldSelection e1 f -> prettyParen (p > 16) $ pPrintPrec l 16 e1 <> char '.' <> text f MethodCall e1 i ps -> prettyParen (p > 16) $ pPrintPrec l 16 e1 <> char '.' <> pPrint i <+> parens (pPrint ps) FunctionCall i ps -> prettyParen (p > 16) $ pPrint i <+> parens (pPrint ps) PostInc e1 -> prettyParen (p > 15) $ pPrintPrec l 15 e1 <+> text "++" PostDec e1 -> prettyParen (p > 15) $ pPrintPrec l 15 e1 <+> text "--" PreInc e1 -> prettyParen (p > 15) $ text "++" <+> pPrintPrec l 15 e1 PreDec e1 -> prettyParen (p > 15) $ text "--" <+> pPrintPrec l 15 e1 -- unary expression UnaryPlus e1 -> prettyParen (p > 15) $ text "+" <> pPrintPrec l 15 e1 UnaryNegate e1 -> prettyParen (p > 15) $ text "-" <> pPrintPrec l 15 e1 UnaryNot e1 -> prettyParen (p > 15) $ text "!" <> pPrintPrec l 15 e1 UnaryOneComplement e1 -> prettyParen (p > 15) $ text "~" <> pPrintPrec l 15 e1 -- binary expression Mul e1 e2 -> prettyBinary l p 14 assocLeft "*" e1 e2 Div e1 e2 -> prettyBinary l p 14 assocLeft "/" e1 e2 Mod e1 e2 -> prettyBinary l p 14 assocLeft "%" e1 e2 Add e1 e2 -> prettyBinary l p 13 assocLeft "+" e1 e2 Sub e1 e2 -> prettyBinary l p 13 assocLeft "-" e1 e2 LeftShift e1 e2 -> prettyBinary l p 12 assocLeft "<<" e1 e2 RightShift e1 e2 -> prettyBinary l p 12 assocLeft ">>" e1 e2 Lt e1 e2 -> prettyBinary l p 11 assocLeft "<" e1 e2 Gt e1 e2 -> prettyBinary l p 11 assocLeft ">" e1 e2 Lte e1 e2 -> prettyBinary l p 11 assocLeft "<=" e1 e2 Gte e1 e2 -> prettyBinary l p 11 assocLeft ">=" e1 e2 Equ e1 e2 -> prettyBinary l p 10 assocLeft "==" e1 e2 Neq e1 e2 -> prettyBinary l p 10 assocLeft "!=" e1 e2 BitAnd e1 e2 -> prettyBinary l p 9 assocLeft "&" e1 e2 BitXor e1 e2 -> prettyBinary l p 8 assocLeft "^" e1 e2 BitOr e1 e2 -> prettyBinary l p 7 assocLeft "|" e1 e2 And e1 e2 -> prettyBinary l p 6 assocLeft "&&" e1 e2 -- TODO Xor 5 "^^" Or e1 e2 -> prettyBinary l p 4 assocLeft "||" e1 e2 Selection e1 e2 e3 -> prettyParen (p > 3) $ pPrintPrec l 3 e1 <+> char '?' <+> pPrintPrec l 3 e2 <+> char ':' <+> pPrintPrec l 3 e3 -- assignment, the left Expr should be unary expression Equal e1 e2 -> prettyBinary l p 2 assocRight "=" e1 e2 MulAssign e1 e2 -> prettyBinary l p 2 assocRight "*=" e1 e2 DivAssign e1 e2 -> prettyBinary l p 2 assocRight "/=" e1 e2 ModAssign e1 e2 -> prettyBinary l p 2 assocRight "%=" e1 e2 AddAssign e1 e2 -> prettyBinary l p 2 assocRight "+=" e1 e2 SubAssign e1 e2 -> prettyBinary l p 2 assocRight "-=" e1 e2 LeftAssign e1 e2 -> prettyBinary l p 2 assocRight "<<=" e1 e2 RightAssign e1 e2 -> prettyBinary l p 2 assocRight ">>=" e1 e2 AndAssign e1 e2 -> prettyBinary l p 2 assocRight "&=" e1 e2 XorAssign e1 e2 -> prettyBinary l p 2 assocRight "^=" e1 e2 OrAssign e1 e2 -> prettyBinary l p 2 assocRight "|=" e1 e2 -- sequence Sequence e1 e2 -> prettyParen (p > 1) $ pPrintPrec l 1 e1 <> char ',' <+> pPrintPrec l 1 e2 instance Pretty FunctionIdentifier where pPrint (FuncIdTypeSpec t) = pPrint t pPrint (FuncId i) = text i instance Pretty Parameters where pPrint ParamVoid = empty pPrint (Params es) = hsep $ punctuate comma $ map pPrint es instance Pretty FunctionPrototype where pPrint (FuncProt t i ps) = pPrint t <+> text i <+> char '(' <> hsep (punctuate comma $ map pPrint ps) <> text ")" instance Pretty ParameterDeclaration where pPrint (ParameterDeclaration tq q s i) = option tq <+> option q <+> pPrint s <+> indexing' i instance Pretty ParameterTypeQualifier where pPrint ConstParameter = text "const" instance Pretty ParameterQualifier where pPrint InParameter = text "in" pPrint OutParameter = text "out" pPrint InOutParameter = text "inout" instance Pretty Statement where pPrint s = case s of -- declaration statement DeclarationStatement d -> pPrint d -- jump statement Continue -> text "continue" <> semi Break -> text "break" <> semi Return e -> text "return" <+> option e <> semi Discard -> text "discard" <> semi -- compound statement CompoundStatement c -> pPrint c -- expression statement ExpressionStatement e -> option e <> semi -- selection statement SelectionStatement e s1 s2 -> vcat [text "if" <+> parens (pPrint e), nest 2 $ pPrint s1, option s2] -- switch statement SwitchStatement e s1 -> vcat [text "switch" <+> parens (pPrint e), lbrace, nest 2 $ vcat $ map pPrint s1, rbrace] CaseLabel l -> pPrint l -- iteration statement While c s1 -> vcat [text "while" <+> parens (pPrint c), pPrint s1] DoWhile s1 e -> vcat [text "do", pPrint s1, text "while" <+> parens (pPrint e)] For (Left e1) c e2 s1 -> vcat [text "for", parens (option e1 <+> semi <+> option c <+> semi <+> option e2), pPrint s1] For (Right d) c e2 s1 -> vcat [text "for", parens (pPrint d <+> semi <+> option c <+> semi <+> option e2), pPrint s1] instance Pretty Compound where pPrint (Compound s) = vcat [lbrace, nest 2 $ vcat $ map pPrint s, rbrace] instance Pretty Condition where pPrint (Condition e) = pPrint e pPrint (InitializedCondition t i e) = pPrint t <+> pPrint i <+> pPrint e instance Pretty CaseLabel where pPrint (Case e) = text "case" <+> pPrint e <> colon pPrint Default = text "default:" language-glsl-0.3.0/tests/0000755000000000000000000000000013342743400013564 5ustar0000000000000000language-glsl-0.3.0/tests/Tests.hs0000644000000000000000000003161413342743400015227 0ustar0000000000000000module Main where import Text.ParserCombinators.Parsec hiding (State, parse) -- TODO clean import Text.PrettyPrint.HughesPJClass (prettyShow, Pretty) import Test.HUnit import Test.Framework (defaultMain) import Test.Framework.Providers.HUnit (hUnitTestToTests) import Language.GLSL.Syntax import Language.GLSL.Parser import Language.GLSL.Pretty () main :: IO () main = defaultMain . hUnitTestToTests . TestList $ parsingTests parsingTests :: [Test] parsingTests = [ legalExpressionsTests , illegalExpressionsTests , legalDeclarationsTests , illegalDeclarationsTests , legalFunctionDefinitionsTests , legalCommentsTests , illegalCommentsTests , TestLabel "expressions id" $ TestList $ map expressionsId testExpressionsTrue , TestLabel "declarations id" $ TestList $ map declarationsId testDeclarationsTrue , TestLabel "function definitions id" $ TestList $ map functionDefinitionsId testFunctionDefinitionsTrue , sampleFileTest ] ---------------------------------------------------------------------- -- For QuickCheck testing ---------------------------------------------------------------------- -- Given an AST ast, pretty-print it and parse it back. The result be -- equal to the original ast, i.e. (parse . pretty) == id -- TODO refactor the common parts -- TODO Befor it is possible to use QC, the AST should enforce more -- constraints, and some sanity check funtions should be provided -- (to build only legal ASTs). parsePrettyId :: TranslationUnit -> Bool parsePrettyId e = case pass translationUnit (prettyShow e) of Left _ -> False Right e' -> e == e' parsePrettyIdExpr :: Expr -> Bool parsePrettyIdExpr e = case pass expression (prettyShow e) of Left _ -> False Right e' -> e == e' parsePrettyIdDecl :: Declaration -> Bool parsePrettyIdDecl e = case pass declaration (prettyShow e) of Left _ -> False Right e' -> e == e' check :: Pretty a => P a -> String -> IO () check p str = case pass p str of Left err -> print err Right ast -> putStrLn $ prettyShow ast parsePrettyIdFunc :: ExternalDeclaration -> Bool parsePrettyIdFunc e = case pass functionDefinition (prettyShow e) of Left _ -> False Right e' -> e == e' expressionsId :: String -> Test expressionsId str = TestCase . assertBool ("expressionsId: " ++ str) . parsePrettyIdExpr $ ast where ast = case pass expression str of Left _ -> error "does not even parse the original string" Right a -> a declarationsId :: String -> Test declarationsId str = TestCase . assertBool ("declarationsId: " ++ str) . parsePrettyIdDecl $ ast where ast = case pass declaration str of Left _ -> error "does not even parse the original string" Right a -> a functionDefinitionsId :: String -> Test functionDefinitionsId str = TestCase . assertBool ("functionDefinitionsId: " ++ str) . parsePrettyIdFunc $ ast where ast = case pass functionDefinition str of Left _ -> error "does not even parse the original string" Right a -> a ---------------------------------------------------------------------- -- helpers ---------------------------------------------------------------------- -- Just check if the parser passes of fails pass :: P a -> String -> Either ParseError a pass p = runParser (do {skipMany blank ; r <- p ; eof ; return r}) S "pass" isRight :: Either a b -> Bool isRight (Right _) = True isRight (Left _) = False isLeft :: Either a b -> Bool isLeft = not . isRight doesParse :: P a -> String -> Test doesParse p str = TestCase . assertBool ("doesParse: " ++ str) . isRight . pass p $ str doesNotParse :: P a -> String -> Test doesNotParse p str = TestCase . assertBool ("doesNotParse: " ++ str) . isLeft . pass p $ str ---------------------------------------------------------------------- -- expressions ---------------------------------------------------------------------- legalExpressionsTests :: Test legalExpressionsTests = TestLabel "legal expressions" $ TestList $ map (doesParse expression) testExpressionsTrue illegalExpressionsTests :: Test illegalExpressionsTests = TestLabel "illegal expressions" $ TestList $ map (doesNotParse expression) testExpressionsFalse testExpressionsTrue :: [String] testExpressionsTrue = [ "a" , "avoid" , "filters" , "0" , "1" , ".1" , "0x01" , "0xF" , "07" , "a++" , "a--" , "a++--" , "a--++" , "a++++" , "a----" , "++a" , "--a" , "++--a" , "--++a" , "++++a" , "----a" , "a ++" , "+a" , "+ a" , "a + b" , "a + b++" , "a + ++b" , "a + + b" , "a ++ +b" , "a()" , "float()" , "a ()" , "a( )" , "a ( )" , "a.a" , "a.a()" , "a.length()" , "a[1]" , "a[1].x" , "a[1].x()" , "a().b" , "a().b[1]" , "a().b()" , "a.b.c" ] testExpressionsFalse :: [String] testExpressionsFalse = [ "void" , "filter" , ".A" , "08" , "0A" , "+" , "++" , "a+" , "a +" , "a . a" -- TODO should it be allowed ? , "a[]" -- , "a[1][2]" -- TODO it is illegal to declare an array of arrays ] ---------------------------------------------------------------------- -- declarations ---------------------------------------------------------------------- legalDeclarationsTests :: Test legalDeclarationsTests = TestLabel "legal declarations" $ TestList $ map (doesParse declaration) testDeclarationsTrue illegalDeclarationsTests :: Test illegalDeclarationsTests = TestLabel "illegal declarations" $ TestList $ map (doesNotParse declaration) testDeclarationsFalse testDeclarationsTrue :: [String] testDeclarationsTrue = [ "int a;" , "int a, b, c;" , "precision highp float;" , "int a = 1;" , "struct a { int b; };" , "struct a { int b; float c; };" , "layout (origin_upper_left) in;" , "layout (origin_upper_left) in vec4 gl_FragCoord;" , "layout (origin_upper_left, pixel_center_integer) in vec4 gl_FragCoord;" , "bool success;" , "bool done = false;" , "int a = 123;" , "int a = 123u;" , "int a = 123U;" , "int a = 0123;" , "int a = 0123u;" , "int a = 0123U;" , "int a = 0x123;" , "int a = 0x123u;" , "int a = 0x123U;" , "int a = 0x12ABu;" , "int a = 0x12ABU;" , "int a = 0X123;" , "int a = 0X123u;" , "int a = 0X123U;" , "int a = 0X12ABu;" , "int a = 0X12ABU;" , "float a = 1.0;" , "float a = 1.;" , "float a = .0;" , "float a = 1e1;" , "float a = 1.0e1;" , "float a = 1.e1;" , "float a = 1.0e-1;" , "float a = 1.0e+1;" , "float a = 1.0e+1f;" , "float a = 1.0e+1F;" , "vec2 texcoord1, texcoord2;" , "mat3x2 m;" , "struct light { float intensity; vec3 position; } lightVar;" , "const struct light { float intensity; vec3 position; } lightVar;" , "float frequencies[3];" , "uniform vec4 lightPosition[4];" , "light lights[];" , "const int numLights = 2;" , "light lights[numLights];" , "float[5] a;" , "float a[5];" , "float a[5] = float[](3.4, 4.2, 5.0, 5.2, 1.1);" , "float a[5] = float[5](3.4, 4.2, 5.0, 5.2, 1.1);" , "const int a;" , "in int a;" , "centroid in int a;" , "smooth in int a;" , "bool success;" , "bool done = false;" , "int i;" , "int i, j = 42;" , "int j = 1;" , "uint k = 3u;" , "float x = 1.0;" , "float a = 1.5, b;" , "vec2 texcoord1, texcoord2;" , "vec3 position;" , "vec4 myRGBA;" , "ivec2 textureLookup;" , "bvec3 less;" , "mat2 mat2D;" , "mat3 optMatrix;" , "mat4 view;" , "mat3x2 m;" , "struct light\ \{\ \float intensity;\ \vec3 position;\ \} lightVar;" , "light lightVar3;" , "float frequencies[3];" , "uniform vec4 lightPosition[4];" , "light lights[];" , "const int numLights = 2;" , "light lights[numLights];" , "int a[5];" , "const float coef = 2.75;" , "const vec3 zAxis = vec3 (0.0, 0.0, 1.0);" , "in vec4 position;" , "in vec3 normal;" , "in vec2 texCoord[4];" , "in float foo[];" , "centroid out vec2 TexCoord;" , "invariant centroid out vec4 Color;" , "invariant flat centroid out vec4 Color;" , "noperspective out float temperature;" , "flat out vec3 myColor;" , "noperspective centroid out vec2 myTexCoord;" , "out vec4 FragmentColor;" , "out uint Luminosity;" , "uniform Transform\ \{\ \ mat4 ModelViewMatrix;\ \ mat4 ModelViewProjectionMatrix;\ \ uniform mat3 NormalMatrix;\ \ float Deformation;\ \};" , "in Material\ \{\ \ smooth in vec4 Color1;\ \ smooth vec4 Color2;\ \ vec2 TexCoord;\ \};" , "out Vertex\ \{\ \ vec4 Position;\ \ vec2 Texture;\ \} Coords;" , "uniform Transform {\ \ mat4 ModelViewMatrix;\ \ mat4 ModelViewProjectionMatrix;\ \ float Deformation;\ \} transforms[4];" , "layout (triangles) in;" , "layout (origin_upper_left) in vec4 gl_FragCoord;" , "layout (pixel_center_integer) in vec4 gl_FragCoord;" , "layout (origin_upper_left, pixel_center_integer) in vec4 gl_FragCoord;" , "layout (triangle_strip, max_vertices = 60) out;" , "layout (triangle_strip) out;" , "layout (max_vertices = 60) out;" , "layout (shared, column_major) uniform;" , "layout (std140) uniform Transform {\ \ mat4 M1;\ \ layout (column_major) mat4 M2;\ \ mat3 N1;\ \};" , "flat out vec4 gl_FrontColor;" , "lowp float color;" , "out mediump vec2 P;" , "highp mat4 m;" , "precision highp float;" , "precision highp int;" , "precision mediump int;" , "invariant gl_Position;" , "out vec3 Color;" , "invariant Color;" , "invariant centroid out vec3 Color;" , "vec4 color = vec4(0.0, 1.0, 0.0, 1.0);" , "int i = 1 - 5 * 4 + 3;" , "int i = 1 - (5 * 4) + 3;" , "int i = (1 - 5) * 4 + 3;" , "int i = (1 - 5) * (4 + 3);" , "bool b = 1 < 2;" ] testDeclarationsFalse :: [String] testDeclarationsFalse = [ "int a" , "int a, b c;" , "precision high float;" , "precision float f();" , "int float;" , "struct a { };" , "struct a { int b, float c; };" , "int a = 0128;" , "int a = 0xu;" , "float a = .e1;" , "float a = 1.0e+1G;" {- TODO embeded structs are not possible. , "struct light {\ \ struct { float intensity; };\ \ vec3 position;\ \} lightVar;" -} , "int f();" -- function declaration should be at top level -- TODO put these in legalTranslationUnitsTests , "int f(void);" , "int f ( void ) ;" , "lowp ivec2 foo(lowp mat3);" , "float[5] foo();" , "void foo (float[5]);" , "void foo (float a[5]);" , "float[] foo();" , "float[5] foo();" , "float[5] foo(int[4]);" , "int f ();" -- TODO qualifier only possible where declarators. -- , "const struct light { float intensity; vec3 position; };" , "float a[5][3];" -- interpolation qualifier may only preced [centroid]in/out. -- , "smooth const int a;" ] ---------------------------------------------------------------------- -- function definitions ---------------------------------------------------------------------- legalFunctionDefinitionsTests :: Test legalFunctionDefinitionsTests = TestLabel "legal function definition" $ TestList $ map (doesParse functionDefinition) testFunctionDefinitionsTrue testFunctionDefinitionsTrue :: [String] testFunctionDefinitionsTrue = [ "void main ()\n\ \{\n\ \}" , "void main ()\n\ \{\n\ \ if (intensity < 0.0)\n\ \ return;\n\ \}" ] ---------------------------------------------------------------------- -- comments (inside simple declarations) ---------------------------------------------------------------------- legalCommentsTests :: Test legalCommentsTests = TestLabel "legal comments" $ TestList $ map (doesParse declaration) testCommentsTrue illegalCommentsTests :: Test illegalCommentsTests = TestLabel "illegal comments" $ TestList $ map (doesNotParse declaration) testCommentsFalse testCommentsTrue :: [String] testCommentsTrue = [ "int a; // a comment" , "int a; /* another comment */" , "int a; // a comment\n" , "int a; /* another comment */\n" , "int a; /* another comment\non multiple\nlines.*/" , "int a; /* another comment\non multiple\nlines.*/\n" , "int a; /* another comment\non multiple\nlines.\n*/" , "/* before */ int a;" , "// before\nint a;" , "int /* middle */ a;" , "int/* middle */a;" , "int a/* middle */;" , "int a; /* not a // nested comment */" ] testCommentsFalse :: [String] testCommentsFalse = [ "int a; /* no /* nested */ comment */" ] ---------------------------------------------------------------------- -- translation unit ---------------------------------------------------------------------- legalTranslationUnitsTests :: Test legalTranslationUnitsTests = TestLabel "legal translation unit" $ TestList $ map (doesParse translationUnit) $ testDeclarationsTrue ++ testFunctionDefinitionsTrue ---------------------------------------------------------------------- -- kitchen sink ---------------------------------------------------------------------- sampleFileTest :: Test sampleFileTest = TestLabel "Parse/Pretty glsl/sample-01.glsl test" . TestCase . assert $ do content <- readFile $ "glsl/sample-01.glsl" case parse content of Left err -> do putStrLn $ "parse error: \n" ++ show err return False Right ast -> return $ parsePrettyId ast language-glsl-0.3.0/bin/0000755000000000000000000000000013342743400013172 5ustar0000000000000000language-glsl-0.3.0/bin/glsl-pprint.hs0000644000000000000000000000113713342743400016003 0ustar0000000000000000module Main where import System.Environment (getArgs) import Text.PrettyPrint.HughesPJClass import Language.GLSL info :: [String] info = [ "This is glsl-pprint." ] usage :: [String] usage = info ++ ["usage:\n glsl-pprint [-p] filename"] main :: IO () main = do args <- getArgs case args of [fn] -> do content <- readFile fn putStrLn . show . parse $ content ["-p", fn] -> do content <- readFile fn case parse content of Left err -> putStrLn $ "parse error:\n" ++ show err Right ast -> print . pPrint $ ast _ -> putStrLn $ unlines usage language-glsl-0.3.0/glsl/0000755000000000000000000000000013342743400013363 5ustar0000000000000000language-glsl-0.3.0/glsl/sample-01.glsl0000644000000000000000000000470013342743400015746 0ustar0000000000000000bool success; bool done = false; int i; int i, j = 42; int j = 1; uint k = 3u; float x = 1.0; float a = 1.5, b; vec2 texcoord1, texcoord2; vec3 position; vec4 myRGBA; ivec2 textureLookup; bvec3 less; mat2 mat2D; mat3 optMatrix; mat4 view; mat3x2 m; struct light { float intensity; vec3 position; } lightVar; light lightVar3; float frequencies[3]; uniform vec4 lightPosition[4]; light lights[]; const int numLights = 2; light lights[numLights]; int a[5]; const float coef = 2.75; int f (); float[5] foo(); void foo (float[5]); void foo (float a[5]); const vec3 zAxis = vec3 (0.0, 0.0, 1.0); in vec4 position; in vec3 normal; in vec2 texCoord[4]; in float foo[]; centroid out vec2 TexCoord; invariant centroid out vec4 Color; invariant flat centroid out vec4 Color; noperspective out float temperature; flat out vec3 myColor; noperspective centroid out vec2 myTexCoord; out vec4 FragmentColor; out uint Luminosity; uniform Transform { mat4 ModelViewMatrix; mat4 ModelViewProjectionMatrix; uniform mat3 NormalMatrix; float Deformation; }; in Material { smooth in vec4 Color1; smooth vec4 Color2; vec2 TexCoord; }; out Vertex { vec4 Position; vec2 Texture; } Coords; uniform Transform { mat4 ModelViewMatrix; mat4 ModelViewProjectionMatrix; float Deformation; } transforms[4]; layout (triangles) in; layout (origin_upper_left) in vec4 gl_FragCoord; layout (pixel_center_integer) in vec4 gl_FragCoord; layout (origin_upper_left, pixel_center_integer) in vec4 gl_FragCoord; layout (triangle_strip, max_vertices = 60) out; layout (triangle_strip) out; layout (max_vertices = 60) out; layout (shared, column_major) uniform; layout (std140) uniform Transform { mat4 M1; layout (column_major) mat4 M2; mat3 N1; }; flat out vec4 gl_FrontColor; lowp float color; out mediump vec2 P; lowp ivec2 foo(lowp mat3); highp mat4 m; precision highp float; precision highp int; precision mediump int; invariant gl_Position; out vec3 Color; invariant Color; invariant centroid out vec3 Color; vec4 color = vec4(0.0, 1.0, 0.0, 1.0); void main () { } int i = 1 - 5 * 4 + 3; int i = 1 - (5 * 4) + 3; int i = (1 - 5) * 4 + 3; int i = (1 - 5) * (4 + 3); bool b = 1 < 2; void main () { if (intensity < 0.0) /* a comment */ return; if (a & b) return; if (a | b) return; if (a && b) return; if (a || b) return; } layout (std140) uniform PatternBlock { float pattern[100]; float arr[]; }; float x = a / b / c; float x = (a / b) / c; float x = a / (b / c);