1{-# OPTIONS_GHC -fno-warn-orphans #-} 2module Language.GLSL.Pretty where 3 4import Text.PrettyPrint.HughesPJClass 5import Text.Printf 6 7import Language.GLSL.Syntax 8import Prelude hiding ((<>)) 9 10---------------------------------------------------------------------- 11-- helpers (TODO clean) 12---------------------------------------------------------------------- 13 14type Assoc = (Rational -> Rational, Rational -> Rational) 15 16assocLeft, assocRight, assocNone :: Assoc 17assocLeft = (id,bump) 18assocRight = (bump,id) 19assocNone = (bump,bump) 20 21bump :: Rational -> Rational 22bump = (+ 0.5) 23 24prettyBinary :: Pretty a => 25 PrettyLevel -> Rational -> Rational -> Assoc -> String -> a -> a -> Doc 26prettyBinary l p op (lf,rf) o e1 e2 = prettyParen (p > op) $ 27 pPrintPrec l (lf op) e1 <+> text o <+> pPrintPrec l (rf op) e2 28 29option :: Pretty a => Maybe a -> Doc 30option Nothing = empty 31option (Just x) = pPrint x 32 33indexing :: Pretty a => Maybe (Maybe a) -> Doc 34indexing Nothing = empty 35indexing (Just Nothing) = brackets empty 36indexing (Just (Just e)) = brackets $ pPrint e 37 38indexing' :: Pretty a => Maybe (String, Maybe a) -> Doc 39indexing' Nothing = empty 40indexing' (Just (i, Nothing)) = text i 41indexing' (Just (i, Just e)) = text i <> brackets (pPrint e) 42 43initialize :: Pretty a => Maybe a -> Doc 44initialize Nothing = empty 45initialize (Just e) = char ' ' <> equals <+> pPrint e 46 47ident :: Pretty a => Maybe (String, Maybe (Maybe a)) -> Doc 48ident Nothing = empty 49ident (Just (i, Nothing)) = text i 50ident (Just (i, Just Nothing)) = text i <> brackets empty 51ident (Just (i, Just (Just e))) = text i <> brackets (pPrint e) 52 53initialize' :: Pretty a => Maybe (String, Maybe a) -> Doc 54initialize' Nothing = empty 55initialize' (Just (i, Nothing)) = text i 56initialize' (Just (i, Just e)) = text i <+> char '=' <+> pPrint e 57 58---------------------------------------------------------------------- 59-- Pretty instances 60---------------------------------------------------------------------- 61 62instance Pretty TranslationUnit where 63 pPrint (TranslationUnit ds) = vcat $ map pPrint ds 64-- pPrint (Alternative p e) = text "(" <> nest 2 (vcat [pPrint p, pPrint e]) <> text ")" 65 66instance Pretty ExternalDeclaration where 67 pPrint (FunctionDeclaration p) = pPrint p <> semi 68 pPrint (FunctionDefinition p s) = vcat [pPrint p, pPrint s] 69 pPrint (Declaration d) = pPrint d 70 71instance Pretty Declaration where 72 pPrint (InitDeclaration it ds) = pPrint it <+> hsep (punctuate comma (map pPrint ds)) <> semi 73 pPrint (Precision pq t) = text "precision" <+> pPrint pq <+> pPrint t <> semi 74 pPrint (Block tq i ds n) = vcat [pPrint tq <+> text i, lbrace, nest 2 (vcat $ map pPrint ds), rbrace <+> ident n <> semi] 75 pPrint (TQ tq) = pPrint tq <> semi 76 77instance Pretty InitDeclarator where 78 pPrint (InitDecl i a b) = text i <> indexing a <> initialize b 79 80instance Pretty InvariantOrType where 81 pPrint InvariantDeclarator = text "invariant" 82 pPrint (TypeDeclarator ft) = pPrint ft 83 84instance Pretty FullType where 85 pPrint (FullType tq ts) = option tq <+> pPrint ts 86 87instance Pretty TypeQualifier where 88 pPrint (TypeQualSto sq) = pPrint sq 89 pPrint (TypeQualLay lq sq) = pPrint lq <+> option sq 90 pPrint (TypeQualInt iq sq) = pPrint iq <+> option sq 91 pPrint (TypeQualInv iq sq) = pPrint iq <+> option sq 92 pPrint (TypeQualInv3 iq iq' sq) = pPrint iq <+> pPrint iq' <+> pPrint sq 93 94instance Pretty StorageQualifier where 95 pPrint q = case q of 96 Const -> text "const" 97 Attribute -> text "attribute" 98 Varying -> text "varying" 99 CentroidVarying -> text "centroid varying" 100 In -> text "in" 101 Out -> text "out" 102 CentroidIn -> text "centroid in" 103 CentroidOut -> text "centroid out" 104 Uniform -> text "uniform" 105 106instance Pretty LayoutQualifier where 107 pPrint (Layout is) = text "layout" <+> char '(' <> 108 (hsep $ punctuate comma $ map pPrint is) <> char ')' 109 110instance Pretty LayoutQualifierId where 111 pPrint (LayoutQualId i Nothing) = text i 112 pPrint (LayoutQualId i (Just e)) = text i <+> char '=' <+> pPrint e 113 114instance Pretty InterpolationQualifier where 115 pPrint q = case q of 116 Smooth -> text "smooth" 117 Flat -> text "flat" 118 NoPerspective -> text "noperspective" 119 120instance Pretty InvariantQualifier where 121 pPrint Invariant = text "invariant" 122 123instance Pretty TypeSpecifier where 124 pPrint (TypeSpec (Just pq) t) = pPrint pq <+> pPrint t 125 pPrint (TypeSpec Nothing t) = pPrint t 126 127instance Pretty PrecisionQualifier where 128 pPrint HighP = text "highp" 129 pPrint MediumP = text "mediump" 130 pPrint LowP = text "lowp" 131 132instance Pretty TypeSpecifierNoPrecision where 133 pPrint (TypeSpecNoPrecision t a) = pPrint t <+> indexing a 134 135instance Pretty TypeSpecifierNonArray where 136 pPrint t = case t of 137 Void -> text "void" 138 Float -> text "float" 139 Int -> text "int" 140 UInt -> text "uint" 141 Bool -> text "bool" 142 Vec2 -> text "vec2" 143 Vec3 -> text "vec3" 144 Vec4 -> text "vec4" 145 BVec2 -> text "bvec2" 146 BVec3 -> text "bvec3" 147 BVec4 -> text "bvec4" 148 IVec2 -> text "ivec2" 149 IVec3 -> text "ivec3" 150 IVec4 -> text "ivec4" 151 UVec2 -> text "uvec2" 152 UVec3 -> text "uvec3" 153 UVec4 -> text "uvec4" 154 Mat2 -> text "mat2" 155 Mat3 -> text "mat3" 156 Mat4 -> text "mat4" 157 Mat2x2 -> text "mat2x2" 158 Mat2x3 -> text "mat2x3" 159 Mat2x4 -> text "mat2x4" 160 Mat3x2 -> text "mat3x2" 161 Mat3x3 -> text "mat3x3" 162 Mat3x4 -> text "mat3x4" 163 Mat4x2 -> text "mat4x2" 164 Mat4x3 -> text "mat4x3" 165 Mat4x4 -> text "mat4x4" 166 Sampler1D -> text "sampler1D" 167 Sampler2D -> text "sampler2D" 168 Sampler3D -> text "sampler3D" 169 SamplerCube -> text "samplerCube" 170 Sampler1DShadow -> text "sampler1DShadow" 171 Sampler2DShadow -> text "sampler2DShadow" 172 SamplerCubeShadow -> text "samplerCubeShadow" 173 Sampler1DArray -> text "sampler1DArray" 174 Sampler2DArray -> text "sampler2DArray" 175 Sampler1DArrayShadow -> text "sampler1DArrayShadow" 176 Sampler2DArrayShadow -> text "sampler2DArrayShadow" 177 ISampler1D -> text "isampler1D" 178 ISampler2D -> text "isampler2D" 179 ISampler3D -> text "isampler3D" 180 ISamplerCube -> text "isamplerCube" 181 ISampler1DArray -> text "isampler1DArray" 182 ISampler2DArray -> text "isampler2DArray" 183 USampler1D -> text "usampler1D" 184 USampler2D -> text "usampler2D" 185 USampler3D -> text "usampler3D" 186 USamplerCube -> text "usamplerCube" 187 USampler1DArray -> text "usampler1DArray" 188 USampler2DArray -> text "usampler2DArray" 189 Sampler2DRect -> text "sampler2DRect" 190 Sampler2DRectShadow -> text "sampler2DRectShadow" 191 ISampler2DRect -> text "isampler2DRect" 192 USampler2DRect -> text "usampler2DRect" 193 SamplerBuffer -> text "samplerBuffer" 194 ISamplerBuffer -> text "isamplerBuffer" 195 USamplerBuffer -> text "usamplerBuffer" 196 Sampler2DMS -> text "sampler2DMS" 197 ISampler2DMS -> text "isampler2DMS" 198 USampler2DMS -> text "usampler2DMS" 199 Sampler2DMSArray -> text "sampler2DMSArray" 200 ISampler2DMSArray -> text "isampler2DMSArray" 201 USampler2DMSArray -> text "usampler2DMSArray" 202 StructSpecifier i ds -> 203 vcat [text "struct" <+> i', lbrace, nest 2 (vcat $ map pPrint ds), rbrace] 204 where i' = case i of { Nothing -> empty ; Just n -> text n } 205 TypeName i -> text i 206 207instance Pretty Field where 208 pPrint (Field tq s ds) = 209 option tq <+> pPrint s <+> hsep (punctuate comma $ map pPrint ds) <> semi 210 211instance Pretty StructDeclarator where 212 pPrint (StructDeclarator i e) = ident (Just (i, e)) 213 214instance Pretty Expr where 215 pPrintPrec l p e = case e of 216 -- primaryExpression 217 Variable v -> text v 218 IntConstant Decimal i -> text (show i) 219 IntConstant Hexadecimal i -> text (printf "0x%x" i) 220 IntConstant Octal i -> text (printf "0%o" i) 221 FloatConstant f -> text (show f) 222 BoolConstant True -> text "true" 223 BoolConstant False -> text "false" 224 -- postfixExpression 225 Bracket e1 e2 -> prettyParen (p > 16) $ 226 pPrintPrec l 16 e1 <> brackets (pPrint e2) 227 FieldSelection e1 f -> prettyParen (p > 16) $ 228 pPrintPrec l 16 e1 <> char '.' <> text f 229 MethodCall e1 i ps -> prettyParen (p > 16) $ 230 pPrintPrec l 16 e1 <> char '.' <> pPrint i <+> parens (pPrint ps) 231 FunctionCall i ps -> prettyParen (p > 16) $ 232 pPrint i <+> parens (pPrint ps) 233 PostInc e1 -> prettyParen (p > 15) $ 234 pPrintPrec l 15 e1 <+> text "++" 235 PostDec e1 -> prettyParen (p > 15) $ 236 pPrintPrec l 15 e1 <+> text "--" 237 PreInc e1 -> prettyParen (p > 15) $ 238 text "++" <+> pPrintPrec l 15 e1 239 PreDec e1 -> prettyParen (p > 15) $ 240 text "--" <+> pPrintPrec l 15 e1 241 -- unary expression 242 UnaryPlus e1 -> prettyParen (p > 15) $ 243 text "+" <> pPrintPrec l 15 e1 244 UnaryNegate e1 -> prettyParen (p > 15) $ 245 text "-" <> pPrintPrec l 15 e1 246 UnaryNot e1 -> prettyParen (p > 15) $ 247 text "!" <> pPrintPrec l 15 e1 248 UnaryOneComplement e1 -> prettyParen (p > 15) $ 249 text "~" <> pPrintPrec l 15 e1 250 -- binary expression 251 Mul e1 e2 -> prettyBinary l p 14 assocLeft "*" e1 e2 252 Div e1 e2 -> prettyBinary l p 14 assocLeft "/" e1 e2 253 Mod e1 e2 -> prettyBinary l p 14 assocLeft "%" e1 e2 254 Add e1 e2 -> prettyBinary l p 13 assocLeft "+" e1 e2 255 Sub e1 e2 -> prettyBinary l p 13 assocLeft "-" e1 e2 256 LeftShift e1 e2 -> prettyBinary l p 12 assocLeft "<<" e1 e2 257 RightShift e1 e2 -> prettyBinary l p 12 assocLeft ">>" e1 e2 258 Lt e1 e2 -> prettyBinary l p 11 assocLeft "<" e1 e2 259 Gt e1 e2 -> prettyBinary l p 11 assocLeft ">" e1 e2 260 Lte e1 e2 -> prettyBinary l p 11 assocLeft "<=" e1 e2 261 Gte e1 e2 -> prettyBinary l p 11 assocLeft ">=" e1 e2 262 Equ e1 e2 -> prettyBinary l p 10 assocLeft "==" e1 e2 263 Neq e1 e2 -> prettyBinary l p 10 assocLeft "!=" e1 e2 264 BitAnd e1 e2 -> prettyBinary l p 9 assocLeft "&" e1 e2 265 BitXor e1 e2 -> prettyBinary l p 8 assocLeft "^" e1 e2 266 BitOr e1 e2 -> prettyBinary l p 7 assocLeft "|" e1 e2 267 And e1 e2 -> prettyBinary l p 6 assocLeft "&&" e1 e2 268-- TODO Xor 5 "^^" 269 Or e1 e2 -> prettyBinary l p 4 assocLeft "||" e1 e2 270 Selection e1 e2 e3 -> prettyParen (p > 3) $ 271 pPrintPrec l 3 e1 <+> char '?' <+> pPrintPrec l 3 e2 272 <+> char ':' <+> pPrintPrec l 3 e3 273 -- assignment, the left Expr should be unary expression 274 Equal e1 e2 -> prettyBinary l p 2 assocRight "=" e1 e2 275 MulAssign e1 e2 -> prettyBinary l p 2 assocRight "*=" e1 e2 276 DivAssign e1 e2 -> prettyBinary l p 2 assocRight "/=" e1 e2 277 ModAssign e1 e2 -> prettyBinary l p 2 assocRight "%=" e1 e2 278 AddAssign e1 e2 -> prettyBinary l p 2 assocRight "+=" e1 e2 279 SubAssign e1 e2 -> prettyBinary l p 2 assocRight "-=" e1 e2 280 LeftAssign e1 e2 -> prettyBinary l p 2 assocRight "<<=" e1 e2 281 RightAssign e1 e2 -> prettyBinary l p 2 assocRight ">>=" e1 e2 282 AndAssign e1 e2 -> prettyBinary l p 2 assocRight "&=" e1 e2 283 XorAssign e1 e2 -> prettyBinary l p 2 assocRight "^=" e1 e2 284 OrAssign e1 e2 -> prettyBinary l p 2 assocRight "|=" e1 e2 285 -- sequence 286 Sequence e1 e2 -> prettyParen (p > 1) $ 287 pPrintPrec l 1 e1 <> char ',' <+> pPrintPrec l 1 e2 288 289instance Pretty FunctionIdentifier where 290 pPrint (FuncIdTypeSpec t) = pPrint t 291 pPrint (FuncId i) = text i 292 293instance Pretty Parameters where 294 pPrint ParamVoid = empty 295 pPrint (Params es) = hsep $ punctuate comma $ map pPrint es 296 297instance Pretty FunctionPrototype where 298 pPrint (FuncProt t i ps) = pPrint t <+> text i <+> char '(' <> hsep (punctuate comma $ map pPrint ps) <> text ")" 299 300instance Pretty ParameterDeclaration where 301 pPrint (ParameterDeclaration tq q s i) = 302 option tq <+> option q <+> pPrint s <+> indexing' i 303 304instance Pretty ParameterTypeQualifier where 305 pPrint ConstParameter = text "const" 306 307instance Pretty ParameterQualifier where 308 pPrint InParameter = text "in" 309 pPrint OutParameter = text "out" 310 pPrint InOutParameter = text "inout" 311 312instance Pretty Statement where 313 pPrint s = case s of 314 -- declaration statement 315 DeclarationStatement d -> pPrint d 316 -- jump statement 317 Continue -> text "continue" <> semi 318 Break -> text "break" <> semi 319 Return e -> text "return" <+> option e <> semi 320 Discard -> text "discard" <> semi 321 -- compound statement 322 CompoundStatement c -> pPrint c 323 -- expression statement 324 ExpressionStatement e -> option e <> semi 325 -- selection statement 326 SelectionStatement e s1 s2 -> vcat [text "if" <+> parens (pPrint e), nest 2 $ pPrint s1, option s2] 327 -- switch statement 328 SwitchStatement e s1 -> vcat [text "switch" <+> parens (pPrint e), lbrace, nest 2 $ vcat $ map pPrint s1, rbrace] 329 CaseLabel l -> pPrint l 330 -- iteration statement 331 While c s1 -> vcat [text "while" <+> parens (pPrint c), pPrint s1] 332 DoWhile s1 e -> vcat [text "do", pPrint s1, text "while" <+> parens (pPrint e)] 333 For (Left e1) c e2 s1 -> vcat [text "for", parens (option e1 <+> semi <+> option c <+> semi <+> option e2), pPrint s1] 334 For (Right d) c e2 s1 -> vcat [text "for", parens (pPrint d <+> semi <+> option c <+> semi <+> option e2), pPrint s1] 335 336instance Pretty Compound where 337 pPrint (Compound s) = vcat [lbrace, nest 2 $ vcat $ map pPrint s, rbrace] 338 339instance Pretty Condition where 340 pPrint (Condition e) = pPrint e 341 pPrint (InitializedCondition t i e) = pPrint t <+> pPrint i <+> pPrint e 342 343instance Pretty CaseLabel where 344 pPrint (Case e) = text "case" <+> pPrint e <> colon 345 pPrint Default = text "default:" 346 347