basic checks

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 {

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"
+  let a = generateCheckedGLSL fragShader
-  putStrLn $ generateGLSL vertShader
+  let b = generateCheckedGLSL vertShader
-  putStrLn $ generateGLSL fragShader
+  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

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
-
+  deriving Show
-instance Show RequestedGLType where
-  show Core = "core"
 
 -- variables
 
 data ParameterQualifier
   = In
   | Out
-
+  deriving (Eq, Show)
-instance Show ParameterQualifier where
-  show In = "in"
-  show Out = "out"
 
 data LayoutQualifier
   = Location Int
+  deriving Show
 
 type Variables = [Variable]
-type VariableName = String
+type VariableName = Text
 
 data Variable
   = Variable
       VariableName
       GLSLType
   | GL_POSITION
-
+  deriving (Eq, Show)
-nameOf :: Variable -> String
-nameOf GL_POSITION = "gl_position"
-nameOf (Variable name _) = name
 
 data GLSLType
   = GLSLFloat
   | GLSLVec4 GLSLType
-
+  deriving (Eq, Show)
-instance Show GLSLType where
-  show (GLSLVec4 _) = "vec4"
-  show GLSLFloat = "float"
 
 -- expressions
 
@@ -71,52 +147,107 @@ data Expression
   | VariableAssignment
       Variable
       Variable
+  deriving Show
 
-generateGLSL :: Program -> String
+-- errors
-generateGLSL [] = "}"
+
-generateGLSL (expression:expressions) =
+type Check = CheckSuccess -> CheckResult
-  (++)
+type CheckResult = Either CheckFailure CheckSuccess
-    (
+type CheckSuccess = (Program, [Warn])
-    case expression of
+type CheckFailure = (Error, [Warn])
-      VersionDeclaration
+
-        requestedGLVersion
+type LineNumber = Int
-        requestedGLType ->
+
-          "#version " ++
+data Error
-          (show requestedGLVersion) ++
+  = ErrUnimplementedCheckProgram
-          " " ++
+  | ErrVariableDeclaredMultipleTimes Variables
-          (show requestedGLType) ++
+  | ErrVariableOutputUnassigned Variables
-          "\n"
+  deriving Show
-      VariableDeclaration
+
-        (Just layoutQualifier@(Location location))
+data Warn
-        parameterQualifier
+  = WarnVariableAssignedMultipleTimes Variable Int
-        (Variable variableName glslType) ->
+  | WarnVariableUnassigned Variable
-          "layout (location = " ++
+  deriving Show
-          (show location) ++
+
-          ") " ++
+generateGLSL :: Program -> Text
-          (show parameterQualifier) ++
+generateGLSL = toGLSLText
-          " " ++
+
-          (show glslType) ++
+generateCheckedGLSL :: Program -> Either CheckFailure (Text, [Warn])
-          " " ++
+generateCheckedGLSL program =
-          variableName ++
+  case checkProgram (program, []) of
-          ";\n"
+    Left (e, warnings) -> Left (e, warnings)
-      VariableDeclaration
+    Right (program, warnings) -> Right (toGLSLText program, warnings)
-        Nothing
+
-        parameterQualifier
+checkProgram :: Check
-        (Variable variableName glslType) ->
+checkProgram program
-          (show parameterQualifier) ++
+  = checkVariableDeclaredMultipleTimes program
-          " " ++
+  >>= checkVariableOutputUnassigned
-          (show glslType) ++
+  >>= checkVariableAssignedMultipleTimes
-          " " ++
+  >>= checkVariableUnassigned
-          variableName ++
+
-          ";\n"
+-- throws error if variable declared multiple times
-      MainStart ->
+checkVariableDeclaredMultipleTimes :: Check
-        "void main()\n{\n"
+checkVariableDeclaredMultipleTimes (program, warnings)
-      VariableAssignment
+  = case [var | (var, ct) <- counts [v | VariableDeclaration _ _ v <- program]
-        variable0
+              , ct > 1
-        variable1 ->
+              ] of
-          (nameOf variable0) ++
+      [] -> Right (program, warnings)
-          " = " ++
+      a -> Left (ErrVariableDeclaredMultipleTimes a, warnings)
-          (nameOf variable1) ++
+
-          ";\n"
+-- throws error if `out` variable unassigned
-    )
+checkVariableOutputUnassigned :: Check
-    $ generateGLSL expressions
+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
+        ]