@@ -1,17 +1,22 @@
11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−module Parse.Literal (literal) where
2+module Parse.Literal (literal, shader) where
33
4−--import Prelude hiding (exponent)
5−--import Control.Monad (join)
6−--import qualified Data.Char as Char
7−--import qualified Data.List as List
8−--import qualified Data.Map as Map
9−--import qualified Language.GLSL.Parser as GLP
10−--import qualified Language.GLSL.Syntax as GLS
4+import qualified Data.List as List
5+import qualified Data.Map as Map
6+import qualified Data.Text as Text
7+import qualified Language.GLSL.Parser as GLP
8+import qualified Language.GLSL.Syntax as GLS
9+import qualified Text.Parsec as Parsec
10+import qualified Text.Parsec.Error as Parsec
1111
12+import qualified AST.Expression.Source as Src
1213import qualified AST.Literal as L
13−import Parse.Helpers (Parser, string, character, number, oneOf)
14−--import qualified Reporting.Error.Syntax as Error
14+import qualified Reporting.Annotation as A
15+import qualified Reporting.Region as R
16+import Parse.Helpers
17+ ( Parser, character, getPosition, number, oneOf
18+ , shaderSource, shaderFailure, string
19+ )
1520
1621
1722
@@ -28,74 +33,85 @@ literal =
2833
2934
3035
31−{-- SHADERS
36+-- SHADERS
3237
3338
34−shader :: Parser (String, L.GLShaderTipe)
35−shader =
36− do text "[glsl|"
37− rawSrc <- closeShader id
38− case stringToShader rawSrc of
39− Left err -> parserFail . show $ err
40− Right tipe -> return (rawSrc, tipe)
39+shader :: R.Position -> Parser Src.RawExpr
40+shader start@(R.Position row col) =
41+ do src <- shaderSource
42+ shdr <- parseSource row col (Text.unpack src)
43+ end@(R.Position row2 col2) <- getPosition
44+ let uid = List.intercalate ":" (map show [row, col, row2, col2])
45+ return (A.at start end (Src.GLShader (Text.pack uid) src shdr))
4146
4247
43−closeShader :: (String -> a) -> Parser a
44−closeShader builder =
45− choice
46− [ do try (string "|]")
47− return (builder "")
48− , do c <- anyChar
49− closeShader (builder . (c:))
50− ]
51−
52−
53−stringToShader :: String -> Either ParseError L.Shader
54−stringToShader src =
48+parseSource :: Int -> Int -> String -> Parser L.Shader
49+parseSource startRow startCol src =
5550 case GLP.parse src of
56− Left e ->
57− Left e
58−
5951 Right (GLS.TranslationUnit decls) ->
60− Right $ foldr addGLinput emptyDecls $ join $
61− map extractGLinputs decls
62− where
63− emptyDecls = L.GLShaderTipe Map.empty Map.empty Map.empty
64−
65− addGLinput (qual,tipe,name) glDecls =
66− case qual of
67− GLS.Attribute ->
68− glDecls { L.attribute = Map.insert name tipe $ L.attribute glDecls }
69−
70− GLS.Uniform ->
71− glDecls { L.uniform = Map.insert name tipe $ L.uniform glDecls }
72−
73− GLS.Varying ->
74− glDecls { L.varying = Map.insert name tipe $ L.varying glDecls }
75−
76− _ -> error "Should never happen due to below filter"
77−
78− extractGLinputs decl =
79− case decl of
80− GLS.Declaration
81− (GLS.InitDeclaration
82− (GLS.TypeDeclarator
83− (GLS.FullType
84− (Just (GLS.TypeQualSto qual))
85− (GLS.TypeSpec _prec (GLS.TypeSpecNoPrecision tipe _mexpr1))))
86− [GLS.InitDecl name _mexpr2 _mexpr3]
87− ) ->
88− case elem qual [GLS.Attribute, GLS.Varying, GLS.Uniform] of
89− False -> []
90− True ->
91− case tipe of
92− GLS.Vec2 -> return (qual, L.V2, name)
93− GLS.Vec3 -> return (qual, L.V3, name)
94− GLS.Vec4 -> return (qual, L.V4, name)
95− GLS.Mat4 -> return (qual, L.M4, name)
96− GLS.Int -> return (qual, L.Int, name)
97− GLS.Float -> return (qual, L.Float, name)
98− GLS.Sampler2D -> return (qual, L.Texture, name)
99− _ -> []
100− _ -> []
101−-}
52+ return (foldr addInput emptyShader (concatMap extractInputs decls))
53+
54+ Left err ->
55+ let
56+ pos = Parsec.errorPos err
57+ row = Parsec.sourceLine pos
58+ col = Parsec.sourceColumn pos
59+ msg =
60+ Parsec.showErrorMessages
61+ "or"
62+ "unknown parse error"
63+ "expecting"
64+ "unexpected"
65+ "end of input"
66+ (Parsec.errorMessages err)
67+ in
68+ if row == 1 then
69+ shaderFailure startRow (startCol + 6 + col) (Text.pack msg)
70+ else
71+ shaderFailure (startRow + row - 1) col (Text.pack msg)
72+
73+
74+emptyShader :: L.Shader
75+emptyShader =
76+ L.Shader Map.empty Map.empty Map.empty
77+
78+
79+addInput :: (GLS.StorageQualifier, L.GLType, Text.Text) -> L.Shader -> L.Shader
80+addInput ( qual, tipe, name ) glDecls =
81+ case qual of
82+ GLS.Attribute ->
83+ glDecls { L.attribute = Map.insert name tipe (L.attribute glDecls) }
84+
85+ GLS.Uniform ->
86+ glDecls { L.uniform = Map.insert name tipe (L.uniform glDecls) }
87+
88+ GLS.Varying ->
89+ glDecls { L.varying = Map.insert name tipe (L.varying glDecls) }
90+
91+ _ -> error "Should never happen due to below filter"
92+
93+
94+extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, L.GLType, Text.Text)]
95+extractInputs decl =
96+ case decl of
97+ GLS.Declaration
98+ (GLS.InitDeclaration
99+ (GLS.TypeDeclarator
100+ (GLS.FullType
101+ (Just (GLS.TypeQualSto qual))
102+ (GLS.TypeSpec _prec (GLS.TypeSpecNoPrecision tipe _mexpr1))))
103+ [GLS.InitDecl name _mexpr2 _mexpr3]
104+ ) ->
105+ case elem qual [GLS.Attribute, GLS.Varying, GLS.Uniform] of
106+ False -> []
107+ True ->
108+ case tipe of
109+ GLS.Vec2 -> [(qual, L.V2, Text.pack name)]
110+ GLS.Vec3 -> [(qual, L.V3, Text.pack name)]
111+ GLS.Vec4 -> [(qual, L.V4, Text.pack name)]
112+ GLS.Mat4 -> [(qual, L.M4, Text.pack name)]
113+ GLS.Int -> [(qual, L.Int, Text.pack name)]
114+ GLS.Float -> [(qual, L.Float, Text.pack name)]
115+ GLS.Sampler2D -> [(qual, L.Texture, Text.pack name)]
116+ _ -> []
117+ _ -> []