From 80cd0f70e2cf131e42e6172cd26eeb4b6accda6d Mon Sep 17 00:00:00 2001 From: mtgmonkey Date: Sun, 30 Nov 2025 14:08:37 +0100 Subject: [PATCH] basic checks --- package.nix | 1 + src/Main.hs | 12 ++- src/Types.hs | 263 ++++++++++++++++++++++++++++++++++++++------------- 3 files changed, 206 insertions(+), 70 deletions(-) diff --git a/package.nix b/package.nix index c16b4b2..fccd835 100644 --- a/package.nix +++ b/package.nix @@ -7,6 +7,7 @@ ghcExeOptions = "-O -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N"; ghcPackages = p: [ p.relude + p.pretty-simple ]; in stdenv.mkDerivation { diff --git a/src/Main.hs b/src/Main.hs index 8f1d49f..cb01c34 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -5,6 +5,8 @@ module Main (main) where -- IMPORTS -- +import Text.Pretty.Simple + import Relude import Types @@ -13,9 +15,11 @@ import Types main :: IO () main = do - putTextLn "hallo Welt" - putStrLn $ generateGLSL vertShader - putStrLn $ generateGLSL fragShader + let a = generateCheckedGLSL fragShader + let b = generateCheckedGLSL vertShader + pPrint a + pPrint b + return () fragShader :: Program fragShader = @@ -34,7 +38,7 @@ vertShader = , VariableDeclaration Nothing Out fragColorOut , MainStart , VariableAssignment GL_POSITION vertexPosition - , VariableAssignment fragColorIn vertexColor + , VariableAssignment fragColorOut vertexColor ] fragColorIn = Variable "fragColorIn" $ GLSLVec4 GLSLFloat diff --git a/src/Types.hs b/src/Types.hs index 6f338a3..b85aad6 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,12 +1,98 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module Types where +module Types + ( Program + , Expressions + , Expression(..) + , RequestedGLVersion + , RequestedGLType(..) + , ParameterQualifier(..) + , LayoutQualifier(..) + , Variables + , VariableName + , Variable(..) + , GLSLType(..) + , generateCheckedGLSL + ) +where -- IMPORTS -- import Relude -import qualified Text.Show + +-- CLASSES -- + +class GLSLExpression a where + -- should display the token that the type represents + toGLSLText :: a -> Text + +instance GLSLExpression Program where + toGLSLText expressions = + foldr ((<>)) "}" $ map (toGLSLText) expressions + +instance GLSLExpression Expression where + toGLSLText + (VersionDeclaration requestedGLVersion requestedGLType) = + "#version " <> + (toGLSLText requestedGLVersion) <> + " " <> + (toGLSLText requestedGLType) <> + "\n" + toGLSLText + (VariableDeclaration + (Just (Location location)) + parameterQualifier + (Variable variableName glslType)) = + "layout (location = " <> + (toGLSLText location) <> + ") " <> + (toGLSLText parameterQualifier) <> + " " <> + (toGLSLText glslType) <> + " " <> + variableName <> + ";\n" + toGLSLText + (VariableDeclaration + Nothing + parameterQualifier + (Variable variableName glslType)) = + (toGLSLText parameterQualifier) <> + " " <> + (toGLSLText glslType) <> + " " <> + variableName <> + ";\n" + toGLSLText + MainStart = + "void main()\n{\n" + toGLSLText + (VariableAssignment + variable0 + variable1) = + (toGLSLText variable0) <> + " = " <> + (toGLSLText variable1) <> + ";\n" + +instance GLSLExpression RequestedGLVersion where + toGLSLText i = show i + +instance GLSLExpression RequestedGLType where + toGLSLText Core = "core" + +instance GLSLExpression ParameterQualifier where + toGLSLText In = "in" + toGLSLText Out = "out" + +instance GLSLExpression Variable where + toGLSLText GL_POSITION = "gl_position" + toGLSLText (Variable name _) = name + +instance GLSLExpression GLSLType where + toGLSLText (GLSLVec4 _) = "vec4" + toGLSLText GLSLFloat = "float" -- TYPES -- @@ -17,43 +103,33 @@ type Program = Expressions type RequestedGLVersion = Int data RequestedGLType = Core - -instance Show RequestedGLType where - show Core = "core" + deriving Show -- variables data ParameterQualifier = In | Out - -instance Show ParameterQualifier where - show In = "in" - show Out = "out" + deriving (Eq, Show) data LayoutQualifier = Location Int + deriving Show type Variables = [Variable] -type VariableName = String +type VariableName = Text data Variable = Variable VariableName GLSLType | GL_POSITION - -nameOf :: Variable -> String -nameOf GL_POSITION = "gl_position" -nameOf (Variable name _) = name + deriving (Eq, Show) data GLSLType = GLSLFloat | GLSLVec4 GLSLType - -instance Show GLSLType where - show (GLSLVec4 _) = "vec4" - show GLSLFloat = "float" + deriving (Eq, Show) -- expressions @@ -71,52 +147,107 @@ data Expression | VariableAssignment Variable Variable + deriving Show -generateGLSL :: Program -> String -generateGLSL [] = "}" -generateGLSL (expression:expressions) = - (++) - ( - case expression of - VersionDeclaration - requestedGLVersion - requestedGLType -> - "#version " ++ - (show requestedGLVersion) ++ - " " ++ - (show requestedGLType) ++ - "\n" - VariableDeclaration - (Just layoutQualifier@(Location location)) - parameterQualifier - (Variable variableName glslType) -> - "layout (location = " ++ - (show location) ++ - ") " ++ - (show parameterQualifier) ++ - " " ++ - (show glslType) ++ - " " ++ - variableName ++ - ";\n" - VariableDeclaration - Nothing - parameterQualifier - (Variable variableName glslType) -> - (show parameterQualifier) ++ - " " ++ - (show glslType) ++ - " " ++ - variableName ++ - ";\n" - MainStart -> - "void main()\n{\n" - VariableAssignment - variable0 - variable1 -> - (nameOf variable0) ++ - " = " ++ - (nameOf variable1) ++ - ";\n" - ) - $ generateGLSL expressions +-- errors + +type Check = CheckSuccess -> CheckResult +type CheckResult = Either CheckFailure CheckSuccess +type CheckSuccess = (Program, [Warn]) +type CheckFailure = (Error, [Warn]) + +type LineNumber = Int + +data Error + = ErrUnimplementedCheckProgram + | ErrVariableDeclaredMultipleTimes Variables + | ErrVariableOutputUnassigned Variables + deriving Show + +data Warn + = WarnVariableAssignedMultipleTimes Variable Int + | WarnVariableUnassigned Variable + deriving Show + +generateGLSL :: Program -> Text +generateGLSL = toGLSLText + +generateCheckedGLSL :: Program -> Either CheckFailure (Text, [Warn]) +generateCheckedGLSL program = + case checkProgram (program, []) of + Left (e, warnings) -> Left (e, warnings) + Right (program, warnings) -> Right (toGLSLText program, warnings) + +checkProgram :: Check +checkProgram program + = checkVariableDeclaredMultipleTimes program + >>= checkVariableOutputUnassigned + >>= checkVariableAssignedMultipleTimes + >>= checkVariableUnassigned + +-- throws error if variable declared multiple times +checkVariableDeclaredMultipleTimes :: Check +checkVariableDeclaredMultipleTimes (program, warnings) + = case [var | (var, ct) <- counts [v | VariableDeclaration _ _ v <- program] + , ct > 1 + ] of + [] -> Right (program, warnings) + a -> Left (ErrVariableDeclaredMultipleTimes a, warnings) + +-- throws error if `out` variable unassigned +checkVariableOutputUnassigned :: Check +checkVariableOutputUnassigned (program, warnings) + = case + [v | v <- [var | VariableDeclaration _ Out var <- program] + , not $ elem v [var | VariableAssignment var _ <- program] + ] of + [] -> Right (program, warnings) + a -> Left (ErrVariableOutputUnassigned a, warnings) + +-- throws warning if variable assigned multiple times +checkVariableAssignedMultipleTimes :: Check +checkVariableAssignedMultipleTimes (program, warnings) + = case [(var, ct) | (var, ct) <- counts [v | VariableAssignment v _ <- program] + , ct > 1 + ] of + [] -> Right (program, warnings) + a -> Right + (program + , (map + (\(var, ct) -> WarnVariableAssignedMultipleTimes var ct) + a) ++ warnings + ) + +-- throws warning if non-input variable unassigned +checkVariableUnassigned :: Check +checkVariableUnassigned (program, warnings) + = case + [WarnVariableUnassigned var | VariableDeclaration _ parameterQualifier var <- program + , parameterQualifier /= In + , not $ elem var [var | VariableAssignment var _ <- program] + ] of + [] -> Right (program, warnings) + a -> Right (program, a ++ warnings) + +-- utilities + +counts :: (Eq a) => [a] -> [(a, Int)] +counts arr = counts' arr [] + +counts' :: (Eq a) => [a] -> [(a, Int)] -> [(a, Int)] +counts' [] cts = cts +counts' (x:xs) cts = + counts' + xs + $ if [] == [0 | (a, _) <- cts + , a == x + ] + then + (x, 1):cts + else + [(a, ct + 1) | (a, ct) <- cts + , a == x + ] ++ + [t | t@(a, ct) <- cts + , a /= x + ]