Merge pull request #246 from EpitechPromo2027/codegen-unit-test

chore: add codegen `unit` tests

Makefile

@@ -41,7 +41,7 @@ repl:
 
 .PHONY: format
 format:
-	ormolu -i $(shell find lib app -name "*.hs")
+	ormolu -i $(shell find lib app test -name "*.hs")
 
 .PHONY: help
 help:

glados.cabal

@@ -25,29 +25,29 @@ library
     Ast.Parser.Asm
     Ast.Parser.Expr
     Ast.Parser.Literal
+    Ast.Parser.PreProcessor
+    Ast.Parser.PreProcessor.Define
+    Ast.Parser.PreProcessor.Import
     Ast.Parser.Program
     Ast.Parser.State
     Ast.Parser.Type
     Ast.Parser.TypeDefinition
     Ast.Parser.Utils
-    Ast.Parser.PreProcessor
-    Ast.Parser.PreProcessor.Define
-    Ast.Parser.PreProcessor.Import
     Ast.Types
     Codegen.Codegen
-    Codegen.Utils
-    Codegen.State
     Codegen.Errors
-    Codegen.ExprGen.Types
-    Codegen.ExprGen.ExprGen
+    Codegen.ExprGen.Assembly
     Codegen.ExprGen.Cast
-    Codegen.ExprGen.Operator
     Codegen.ExprGen.ControlFlow
-    Codegen.ExprGen.Assembly
     Codegen.ExprGen.DataValue
-    Codegen.ExprGen.Variable
+    Codegen.ExprGen.ExprGen
     Codegen.ExprGen.Function
     Codegen.ExprGen.Global
+    Codegen.ExprGen.Operator
+    Codegen.ExprGen.Types
+    Codegen.ExprGen.Variable
+    Codegen.State
+    Codegen.Utils
     Shared.Utils
 
   build-depends:
@@ -91,12 +91,25 @@ test-suite glados-test
     Ast.Parser.TypeDefinitionSpec
     Ast.Parser.TypeSpec
     Codegen.CodegenSpec
+    Codegen.ErrorsSpec
+    Codegen.ExprGen.AssemblySpec
+    Codegen.ExprGen.CastSpec
+    Codegen.ExprGen.ControlFlowSpec
+    Codegen.ExprGen.DataValueSpec
+    Codegen.ExprGen.FunctionSpec
+    Codegen.ExprGen.GlobalSpec
+    Codegen.ExprGen.OperatorSpec
+    Codegen.ExprGen.VariableSpec
+    Codegen.StateSpec
+    Codegen.UtilsSpec
+    Shared.UtilsSpec
 
   hs-source-dirs: test
   main-is: Spec.hs
   build-depends:
     QuickCheck,
     base ^>=4.17.2.1,
+    bytestring >=0.11.2 && <0.12,
     glados,
     hspec,
     hspec-discover,

lib/Codegen/Codegen.hs

@@ -1,7 +1,7 @@
 module Codegen.Codegen where
 
 import qualified Ast.Types as AT
-import qualified Codegen.Errors as CC
+import qualified Codegen.Errors as CE
 import qualified Codegen.ExprGen.ExprGen ()
 import qualified Codegen.ExprGen.Global as EG
 import qualified Codegen.State as CS
@@ -13,7 +13,7 @@ import qualified LLVM.IRBuilder.Module as M
 import qualified LLVM.IRBuilder.Monad as IRM
 
 -- | Generate LLVM code for a program.
-codegen :: AT.Program -> Either CC.CodegenError AST.Module
+codegen :: AT.Program -> Either CE.CodegenError AST.Module
 codegen program =
   E.runExcept $
     M.buildModuleT (U.stringToByteString $ AT.sourceFile program) $

lib/Codegen/Errors.hs

@@ -10,6 +10,7 @@ data CodegenError = CodegenError
   { errorLoc :: AT.SrcLoc,
     errorType :: CodegenErrorType
   }
+  deriving (Eq)
 
 -- | Error types for code generation.
 data CodegenErrorType
@@ -31,7 +32,7 @@ data CodegenErrorType
   | BreakOutsideLoop
   | UnsupportedConversion T.Type T.Type
   | UnsupportedGlobalDeclaration AT.Expr
-  deriving (Show)
+  deriving (Eq, Show)
 
 instance Show CodegenError where
   show :: CodegenError -> String

lib/Codegen/ExprGen/Cast.hs

@@ -38,30 +38,19 @@ llvmCast loc operand fromType toType = case (fromType, toType) of
   (T.IntegerType _, T.FloatingPointType _) -> I.sitofp operand toType
   (T.FloatingPointType _, T.IntegerType _) -> I.fptosi operand toType
   (x, y) | isBitcastable x y -> I.bitcast operand toType
-  (T.VectorType n fromEl, T.VectorType m toEl)
-    | n == m && isBitcastable fromEl toEl -> I.bitcast operand toType
-    | n < m -> I.zext operand toType
-    | n > m -> I.trunc operand toType
-  (T.IntegerType _, T.VectorType _ _) -> I.inttoptr operand toType
-  (T.VectorType _ _, T.IntegerType _) -> I.ptrtoint operand toType
   _ -> E.throwError $ CC.CodegenError loc $ CC.UnsupportedConversion fromType toType
   where
     isLargerFP T.FloatFP T.DoubleFP = True
-    isLargerFP T.FloatFP T.X86_FP80FP = True
-    isLargerFP T.DoubleFP T.X86_FP80FP = True
     isLargerFP _ _ = False
 
     isSmallerFP T.DoubleFP T.FloatFP = True
-    isSmallerFP T.X86_FP80FP T.DoubleFP = True
-    isSmallerFP T.X86_FP80FP T.FloatFP = True
     isSmallerFP _ _ = False
 
     isBitcastable (T.PointerType _ _) (T.PointerType _ _) = True
     isBitcastable (T.ArrayType _ _) (T.PointerType _ _) = True
     isBitcastable (T.ArrayType _ _) (T.ArrayType _ _) = True
     isBitcastable (T.PointerType _ _) (T.IntegerType _) = True
     isBitcastable (T.IntegerType _) (T.PointerType _ _) = True
-    isBitcastable (T.VectorType n fromEl) (T.VectorType m toEl) = n == m && isBitcastable fromEl toEl
     isBitcastable _ _ = False
 
 -- | Convert an operand to match a desired LLVM type if needed.

lib/Codegen/ExprGen/Function.hs

@@ -4,7 +4,7 @@
 module Codegen.ExprGen.Function where
 
 import qualified Ast.Types as AT
-import qualified Codegen.Errors as CC
+import qualified Codegen.Errors as CE
 import {-# SOURCE #-} qualified Codegen.ExprGen.ExprGen as EG
 import qualified Codegen.ExprGen.Types as ET
 import qualified Codegen.State as CS
@@ -49,7 +49,7 @@ generateFunction (AT.Function _ name (AT.TFunction ret params var) paramNames bo
       )
     mkParam t n = (ET.toLLVM t, M.ParameterName $ U.stringToByteString n)
 generateFunction expr =
-  E.throwError $ CC.CodegenError (SU.getLoc expr) $ CC.UnsupportedDefinition expr
+  E.throwError $ CE.CodegenError (SU.getLoc expr) $ CE.UnsupportedDefinition expr
 
 -- | Pre-allocate variables before generating code.
 preAllocateVars :: (CS.MonadCodegen m, EG.ExprGen AT.Expr) => AT.Expr -> m ()
@@ -102,7 +102,7 @@ generateForeignFunction (AT.ForeignFunction _ name (AT.TFunction ret params var)
 
   pure $ AST.ConstantOperand $ C.GlobalReference funcType funcName
 generateForeignFunction expr =
-  E.throwError $ CC.CodegenError (SU.getLoc expr) $ CC.UnsupportedDefinition expr
+  E.throwError $ CE.CodegenError (SU.getLoc expr) $ CE.UnsupportedDefinition expr
 
 -- | Generate LLVM code for function calls.
 generateFunctionCall :: (CS.MonadCodegen m, EG.ExprGen AT.Expr) => AT.Expr -> m AST.Operand
@@ -113,6 +113,6 @@ generateFunctionCall (AT.Call loc (AT.Var _ funcName _) args) = do
       argOperands <- mapM EG.generateExpr args
       I.call funcOperand (map (,[]) argOperands)
     Nothing ->
-      E.throwError $ CC.CodegenError loc $ CC.UnsupportedFunctionCall funcName
+      E.throwError $ CE.CodegenError loc $ CE.UnsupportedFunctionCall funcName
 generateFunctionCall expr =
-  E.throwError $ CC.CodegenError (SU.getLoc expr) $ CC.UnsupportedDefinition expr
+  E.throwError $ CE.CodegenError (SU.getLoc expr) $ CE.UnsupportedDefinition expr

lib/Codegen/ExprGen/Operator.hs

@@ -65,19 +65,14 @@ integerBinaryOperators =
     BinaryOp AT.BitShl I.shl,
     BinaryOp AT.BitShr I.ashr,
     BinaryOp AT.And I.and,
-    BinaryOp AT.Or I.or
+    BinaryOp AT.Or I.or,
+    BinaryOp AT.Lt $ I.icmp IP.SLT,
+    BinaryOp AT.Gt $ I.icmp IP.SGT,
+    BinaryOp AT.Lte $ I.icmp IP.SLE,
+    BinaryOp AT.Gte $ I.icmp IP.SGE,
+    BinaryOp AT.Eq $ I.icmp IP.EQ,
+    BinaryOp AT.Ne $ I.icmp IP.NE
   ]
-    ++ map mkComparisonOp comparisonOps
-  where
-    mkComparisonOp (op, pre) = BinaryOp op (I.icmp pre)
-    comparisonOps =
-      [ (AT.Lt, IP.SLT),
-        (AT.Gt, IP.SGT),
-        (AT.Lte, IP.SLE),
-        (AT.Gte, IP.SGE),
-        (AT.Eq, IP.EQ),
-        (AT.Ne, IP.NE)
-      ]
 
 -- | List of supported floating-point binary operators.
 floatingPointBinaryOperators :: (CS.MonadCodegen m) => [BinaryOp m]
@@ -86,19 +81,14 @@ floatingPointBinaryOperators =
     BinaryOp AT.Sub I.fsub,
     BinaryOp AT.Mul I.fmul,
     BinaryOp AT.Div I.fdiv,
-    BinaryOp AT.Mod I.frem
+    BinaryOp AT.Mod I.frem,
+    BinaryOp AT.Lt $ I.fcmp FP.OLT,
+    BinaryOp AT.Gt $ I.fcmp FP.OGT,
+    BinaryOp AT.Lte $ I.fcmp FP.OLE,
+    BinaryOp AT.Gte $ I.fcmp FP.OGE,
+    BinaryOp AT.Eq $ I.fcmp FP.OEQ,
+    BinaryOp AT.Ne $ I.fcmp FP.ONE
   ]
-    ++ map mkComparisonOp comparisonOps
-  where
-    mkComparisonOp (op, pre) = BinaryOp op (I.fcmp pre)
-    comparisonOps =
-      [ (AT.Lt, FP.OLT),
-        (AT.Gt, FP.OGT),
-        (AT.Lte, FP.OLE),
-        (AT.Gte, FP.OGE),
-        (AT.Eq, FP.OEQ),
-        (AT.Ne, FP.ONE)
-      ]
 
 -- | Unary operation data type.
 data UnaryOp m = UnaryOp

lib/Codegen/State.hs

@@ -52,35 +52,35 @@ class (Monad m) => VarBinding m where
   getGlobalVar :: String -> m (Maybe AST.Operand)
   addGlobalVar :: String -> AST.Operand -> m ()
 
-instance (MonadCodegen m, Monad m) => VarBinding m where
-  getVar :: (MonadCodegen m, Monad m) => String -> m (Maybe AST.Operand)
+instance (S.MonadState CodegenState m, Monad m) => VarBinding m where
+  getVar :: (S.MonadState CodegenState m, Monad m) => String -> m (Maybe AST.Operand)
   getVar name = do
     state <- S.get
     return $
       lookup name (allocatedVars state)
         `S.mplus` lookup name (localState state)
         `S.mplus` lookup name (globalState state)
 
-  addVar :: (MonadCodegen m, Monad m) => String -> AST.Operand -> m ()
+  addVar :: (S.MonadState CodegenState m, Monad m) => String -> AST.Operand -> m ()
   addVar name operand = S.modify (\s -> s {localState = (name, operand) : localState s})
 
-  getGlobalVar :: (MonadCodegen m, Monad m) => String -> m (Maybe AST.Operand)
+  getGlobalVar :: (S.MonadState CodegenState m, Monad m) => String -> m (Maybe AST.Operand)
   getGlobalVar name = S.gets (lookup name . globalState)
 
-  addGlobalVar :: (MonadCodegen m, Monad m) => String -> AST.Operand -> m ()
+  addGlobalVar :: (S.MonadState CodegenState m, Monad m) => String -> AST.Operand -> m ()
   addGlobalVar name operand = S.modify (\s -> s {globalState = (name, operand) : globalState s})
 
--- | Generates a fresh unique name.
-fresh :: (MonadCodegen m) => m AST.Name
+-- Generates a fresh unique name.
+fresh :: (S.MonadState CodegenState m) => m AST.Name
 fresh = do
   state <- S.get
   let uniqueName = uniqueNameState state
   S.put $ state {uniqueNameState = uniqueName + 1}
   let fullName = "_" ++ show uniqueName
   return $ AST.Name (CU.stringToByteString fullName)
 
--- | Generates a fresh unique name with the given prefix.
-freshName :: (MonadCodegen m) => String -> m AST.Name
+-- Generates a fresh unique name with the given prefix.
+freshName :: (S.MonadState CodegenState m) => String -> m AST.Name
 freshName prefix = do
   state <- S.get
   let uniqueName = uniqueNameState state

test/Codegen/ErrorsSpec.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Codegen.ErrorsSpec (spec) where
+
+import qualified Ast.Types as AT
+import qualified Codegen.Errors as CE
+import qualified LLVM.AST.Type as T
+import qualified Test.Hspec as H
+
+spec :: H.Spec
+spec = H.describe "Codegen.Errors" $ do
+  H.describe "CodegenError" $ do
+    H.it "should create a CodegenError with correct location and type" $ do
+      let loc = AT.SrcLoc "test.c" 1 1
+      let err = CE.CodegenError loc (CE.VariableNotFound "x")
+      CE.errorLoc err `H.shouldBe` loc
+      CE.errorType err `H.shouldBe` CE.VariableNotFound "x"
+
+  H.describe "Show instance for CodegenError" $ do
+    H.it "should format error message correctly" $ do
+      let loc = AT.SrcLoc "test.c" 1 1
+      let err = CE.CodegenError loc (CE.VariableNotFound "x")
+      show err `H.shouldBe` "test.c:1:1: Variable not found: x"
+
+  H.describe "showErrorType" $ do
+    H.it "should format UnsupportedTopLevel correctly" $ do
+      let expr = AT.Lit (AT.SrcLoc "test.c" 1 1) (AT.LInt 42)
+      CE.showErrorType (CE.UnsupportedTopLevel expr) `H.shouldBe` "Unsupported top-level expression: Lit (SrcLoc {srcFile = \"test.c\", srcLine = 1, srcCol = 1}) (LInt 42)"
+
+    H.it "should format UnsupportedOperator correctly" $ do
+      CE.showErrorType (CE.UnsupportedOperator AT.Add) `H.shouldBe` "Unsupported operator: Add"
+
+    H.it "should format UnsupportedUnaryOperator correctly" $ do
+      CE.showErrorType (CE.UnsupportedUnaryOperator AT.Not) `H.shouldBe` "Unsupported unary operator: Not"
+
+    H.it "should format UnsupportedLiteral correctly" $ do
+      CE.showErrorType (CE.UnsupportedLiteral (AT.LInt 42)) `H.shouldBe` "Unsupported literal: LInt 42"
+
+    H.it "should format UnsupportedType correctly" $ do
+      CE.showErrorType (CE.UnsupportedType AT.TVoid) `H.shouldBe` "Unsupported type: TVoid"
+
+    H.it "should format VariableNotFound correctly" $ do
+      CE.showErrorType (CE.VariableNotFound "x") `H.shouldBe` "Variable not found: x"
+
+    H.it "should format UnsupportedFunctionCall correctly" $ do
+      CE.showErrorType (CE.UnsupportedFunctionCall "foo") `H.shouldBe` "Invalid function call: foo"
+
+    H.it "should format ContinueOutsideLoop correctly" $ do
+      CE.showErrorType CE.ContinueOutsideLoop `H.shouldBe` "Continue statement outside loop"
+
+    H.it "should format BreakOutsideLoop correctly" $ do
+      CE.showErrorType CE.BreakOutsideLoop `H.shouldBe` "Break statement outside loop"
+
+    H.it "should format UnsupportedDefinition correctly" $ do
+      let expr = AT.Lit (AT.SrcLoc "test.c" 1 1) (AT.LInt 42)
+      CE.showErrorType (CE.UnsupportedDefinition expr) `H.shouldBe` "Unsupported definition: Lit (SrcLoc {srcFile = \"test.c\", srcLine = 1, srcCol = 1}) (LInt 42)"
+
+    H.it "should format UnsupportedStructureAccess correctly" $ do
+      let expr = AT.Lit (AT.SrcLoc "test.c" 1 1) (AT.LInt 42)
+      CE.showErrorType (CE.UnsupportedStructureAccess expr) `H.shouldBe` "Invalid structure access: Lit (SrcLoc {srcFile = \"test.c\", srcLine = 1, srcCol = 1}) (LInt 42)"
+
+    H.it "should format UnsupportedConversion correctly" $ do
+      CE.showErrorType (CE.UnsupportedConversion T.i32 T.float) `H.shouldBe` "Unsupported conversion from IntegerType {typeBits = 32} to FloatingPointType {floatingPointType = FloatFP}"
+
+    H.it "should format UnsupportedTopLevel" $ do
+      let expr = AT.Lit (AT.SrcLoc "test.c" 1 1) (AT.LInt 42)
+      CE.showErrorType (CE.UnsupportedTopLevel expr)
+        `H.shouldBe` "Unsupported top-level expression: Lit (SrcLoc {srcFile = \"test.c\", srcLine = 1, srcCol = 1}) (LInt 42)"
+
+    H.it "should format loop control errors" $ do
+      CE.showErrorType CE.ContinueOutsideLoop `H.shouldBe` "Continue statement outside loop"
+      CE.showErrorType CE.BreakOutsideLoop `H.shouldBe` "Break statement outside loop"
+
+    H.it "should format structure errors" $ do
+      CE.showErrorType (CE.StructureFieldNotFound "field1")
+        `H.shouldBe` "Structure field not found: field1"
+
+    H.it "should format function errors" $ do
+      CE.showErrorType (CE.UnsupportedFunctionCall "main")
+        `H.shouldBe` "Invalid function call: main"
+
+    H.it "should format literal errors" $ do
+      CE.showErrorType (CE.UnsupportedLiteral (AT.LArray []))
+        `H.shouldBe` "Unsupported literal: LArray []"
+
+    H.it "should format loop definition errors" $ do
+      let expr = AT.Lit (AT.SrcLoc "test.c" 1 1) (AT.LInt 0)
+      CE.showErrorType (CE.UnsupportedForDefinition expr)
+        `H.shouldBe` "Invalid for loop: Lit (SrcLoc {srcFile = \"test.c\", srcLine = 1, srcCol = 1}) (LInt 0)"
+      CE.showErrorType (CE.UnsupportedWhileDefinition expr)
+        `H.shouldBe` "Invalid while loop: Lit (SrcLoc {srcFile = \"test.c\", srcLine = 1, srcCol = 1}) (LInt 0)"
+
+    H.it "should format global declaration errors" $ do
+      let expr = AT.Lit (AT.SrcLoc "test.c" 1 1) (AT.LInt 42)
+      CE.showErrorType (CE.UnsupportedGlobalDeclaration expr)
+        `H.shouldBe` "Unsupported global declaration: Lit (SrcLoc {srcFile = \"test.c\", srcLine = 1, srcCol = 1}) (LInt 42)"
+
+    H.it "should format variable errors" $ do
+      let lit = AT.LInt 42
+      CE.showErrorType (CE.UnsupportedGlobalVar lit) `H.shouldBe` "Unsupported global variable: LInt 42"
+      CE.showErrorType (CE.UnsupportedLocalVar lit) `H.shouldBe` "Unsupported local variable: LInt 42"