assertica / test /Test /Backend /CodeGen.hs

October 2026 main drop: mirror from GitHub

a10b189 verified about 1 month ago

8.31 kB

{-# LANGUAGE OverloadedStrings #-}

module Test.Backend.CodeGen
  ( tests
  ) where

import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck as QC
import qualified Data.Text as T
import Data.Text (Text)

import Assertica.Core.AST
import Assertica.Core.Module
import Assertica.Backend.CodeGen

-- ============================================================================
-- TEST SUITE
-- ============================================================================

tests :: TestTree
tests = testGroup "Assertica.Backend.CodeGen"
  [ testGroup "Simple Expression Compilation"
      [ testCase "Compile integer literal" testIntLiteral
      , testCase "Compile boolean literal" testBoolLiteral
      , testCase "Compile unit constant" testUnitConstant
      , testCase "Compile string literal" testStringLiteral
      ]
  , testGroup "Variable Compilation"
      [ testCase "Compile simple variable" testSimpleVar
      , testCase "Compile qualified variable" testQualifiedVar
      ]
  , testGroup "Lambda and Application"
      [ testCase "Compile simple lambda" testSimpleLambda
      , testCase "Compile application" testApplication
      , testCase "Compile nested application" testNestedApp
      ]
  , testGroup "Type Compilation"
      [ testCase "Compile function type" testFunctionType
      , testCase "Compile type variable" testTypeVar
      , testCase "Compile type constructor" testTypeConstructor
      ]
  , testGroup "Error Handling"
      [ testCase "Reject invalid qualified name" testInvalidQName
      ]
  , testGroup "Configuration"
      [ testCase "Default config has comments enabled" testDefaultConfig
      , testCase "Config affects output" testConfigAffectsOutput
      ]
  ]

-- ============================================================================
-- UNIT TESTS
-- ============================================================================

testIntLiteral :: Assertion
testIntLiteral = do
  let term = Const (IntLit 42)
  let result = compileExpression defaultConfig term
  case result of
    Left err -> assertFailure $ "Unexpected error: " ++ err
    Right expr -> do
      let code = heExpr expr
      assertBool "Should contain '42'" ("42" `T.isInfixOf` code)

testBoolLiteral :: Assertion
testBoolLiteral = do
  let term = Const (BoolLit True)
  let result = compileExpression defaultConfig term
  case result of
    Left err -> assertFailure $ "Unexpected error: " ++ err
    Right expr -> do
      let code = heExpr expr
      assertBool "Should contain 'True'" ("True" `T.isInfixOf` code)

testUnitConstant :: Assertion
testUnitConstant = do
  let term = Const UnitConst
  let result = compileExpression defaultConfig term
  case result of
    Left err -> assertFailure $ "Unexpected error: " ++ err
    Right expr -> do
      let code = heExpr expr
      assertEqual "Should be unit" "()" code

testStringLiteral :: Assertion
testStringLiteral = do
  let term = Const (StringLit "hello")
  let result = compileExpression defaultConfig term
  case result of
    Left err -> assertFailure $ "Unexpected error: " ++ err
    Right expr -> do
      let code = heExpr expr
      assertBool "Should contain string" ("hello" `T.isInfixOf` code)

testSimpleVar :: Assertion
testSimpleVar = do
  let var = Var (Var "x" 0)
  let result = compileExpression defaultConfig var
  case result of
    Left err -> assertFailure $ "Unexpected error: " ++ err
    Right expr -> do
      let code = heExpr expr
      assertEqual "Should be variable name" "x" code

testQualifiedVar :: Assertion
testQualifiedVar = do
  let var = Var (Var "map" 0)
  let result = compileExpression defaultConfig var
  case result of
    Left err -> assertFailure $ "Unexpected error: " ++ err
    Right expr -> do
      let code = heExpr expr
      assertBool "Should contain variable" ("map" `T.isInfixOf` code)

testSimpleLambda :: Assertion
testSimpleLambda = do
  let lambda = Lam (Binder (Var "x" 0) Nothing) (Var (Var "x" 0))
  let result = compileExpression defaultConfig lambda
  case result of
    Left err -> assertFailure $ "Unexpected error: " ++ err
    Right expr -> do
      let code = heExpr expr
      assertBool "Should contain lambda" ("\\" `T.isInfixOf` code)
      assertBool "Should contain variable" ("x" `T.isInfixOf` code)

testApplication :: Assertion
testApplication = do
  let f = Var (Var "f" 0)
  let x = Var (Var "x" 0)
  let app = App f x
  let result = compileExpression defaultConfig app
  case result of
    Left err -> assertFailure $ "Unexpected error: " ++ err
    Right expr -> do
      let code = heExpr expr
      assertBool "Should contain f" ("f" `T.isInfixOf` code)
      assertBool "Should contain x" ("x" `T.isInfixOf` code)

testNestedApp :: Assertion
testNestedApp = do
  let f = Var (Var "f" 0)
  let x = Var (Var "x" 0)
  let y = Var (Var "y" 0)
  let app1 = App f x
  let app2 = App app1 y
  let result = compileExpression defaultConfig app2
  case result of
    Left err -> assertFailure $ "Unexpected error: " ++ err
    Right expr -> do
      let code = heExpr expr
      assertBool "Should be valid expression" (not (T.null code))

testFunctionType :: Assertion
testFunctionType = do
  let tyInt = TyConst (QName [] "Int") []
  let tyBool = TyConst (QName [] "Bool") []
  let funType = TyFun tyInt tyBool
  let result = compileType defaultConfig funType
  case result of
    Left err -> assertFailure $ "Unexpected error: " ++ err
    Right expr -> do
      let code = heExpr expr
      assertBool "Should contain arrow" ("->" `T.isInfixOf` code)

testTypeVar :: Assertion
testTypeVar = do
  let tv = TyVar (Var "a" 0)
  let result = compileType defaultConfig tv
  case result of
    Left err -> assertFailure $ "Unexpected error: " ++ err
    Right expr -> do
      let code = heExpr expr
      assertEqual "Should be type variable" "a" code

testTypeConstructor :: Assertion
testTypeConstructor = do
  let intType = TyConst (QName [] "Int") []
  let result = compileType defaultConfig intType
  case result of
    Left err -> assertFailure $ "Unexpected error: " ++ err
    Right expr -> do
      let code = heExpr expr
      assertEqual "Should be Int" "Int" code

testInvalidQName :: Assertion
testInvalidQName = do
  -- This test checks that invalid qualified names are handled
  -- For now, most constructs compile, but this is a placeholder
  let qname = QName ["Assertica", "Core"] "someType"
  let ty = TyConst qname []
  let result = compileType defaultConfig ty
  case result of
    Left _ -> return ()  -- Error is acceptable
    Right expr -> do
      let code = heExpr expr
      assertBool "Should produce valid code" (not (T.null code))

testDefaultConfig :: Assertion
testDefaultConfig = do
  assertEqual "Add comments enabled" True (cgcAddComments defaultConfig)
  assertEqual "Add type signatures enabled" True (cgcAddTypeSignatures defaultConfig)

testConfigAffectsOutput :: Assertion
testConfigAffectsOutput = do
  let config1 = defaultConfig { cgcAddComments = True }
  let config2 = defaultConfig { cgcAddComments = False }

  let term = Const (IntLit 42)
  let result1 = compileExpression config1 term
  let result2 = compileExpression config2 term

  case (result1, result2) of
    (Right e1, Right e2) ->
      -- Both should produce valid expressions
      assertBool "First result valid" (not (T.null (heExpr e1)))
      assertBool "Second result valid" (not (T.null (heExpr e2)))
    (Left e, _) -> assertFailure $ "Unexpected error: " ++ e
    (_, Left e) -> assertFailure $ "Unexpected error: " ++ e

-- ============================================================================
-- PROPERTY TESTS
-- ============================================================================

-- Property: Code generation is deterministic
propDeterministic :: Term -> Bool
propDeterministic term =
  let result1 = compileExpression defaultConfig term
      result2 = compileExpression defaultConfig term
  in case (result1, result2) of
    (Right e1, Right e2) -> heExpr e1 == heExpr e2
    (Left err1, Left err2) -> err1 == err2
    _ -> False

-- Property: Simple constants compile without errors
propSimpleConstantsCompile :: Constant -> Bool
propSimpleConstantsCompile c =
  let term = Const c
      result = compileExpression defaultConfig term
  in case result of
    Right _ -> True
    Left _ -> False

	{-# LANGUAGE OverloadedStrings #-}

	module Test.Backend.CodeGen
	( tests
	) where

	import Test.Tasty
	import Test.Tasty.HUnit
	import Test.Tasty.QuickCheck as QC
	import qualified Data.Text as T
	import Data.Text (Text)

	import Assertica.Core.AST
	import Assertica.Core.Module
	import Assertica.Backend.CodeGen

	-- ============================================================================
	-- TEST SUITE
	-- ============================================================================

	tests :: TestTree
	tests = testGroup "Assertica.Backend.CodeGen"
	[ testGroup "Simple Expression Compilation"
	[ testCase "Compile integer literal" testIntLiteral
	, testCase "Compile boolean literal" testBoolLiteral
	, testCase "Compile unit constant" testUnitConstant
	, testCase "Compile string literal" testStringLiteral
	]
	, testGroup "Variable Compilation"
	[ testCase "Compile simple variable" testSimpleVar
	, testCase "Compile qualified variable" testQualifiedVar
	]
	, testGroup "Lambda and Application"
	[ testCase "Compile simple lambda" testSimpleLambda
	, testCase "Compile application" testApplication
	, testCase "Compile nested application" testNestedApp
	]
	, testGroup "Type Compilation"
	[ testCase "Compile function type" testFunctionType
	, testCase "Compile type variable" testTypeVar
	, testCase "Compile type constructor" testTypeConstructor
	]
	, testGroup "Error Handling"
	[ testCase "Reject invalid qualified name" testInvalidQName
	]
	, testGroup "Configuration"
	[ testCase "Default config has comments enabled" testDefaultConfig
	, testCase "Config affects output" testConfigAffectsOutput
	]
	]

	-- ============================================================================
	-- UNIT TESTS
	-- ============================================================================

	testIntLiteral :: Assertion
	testIntLiteral = do
	let term = Const (IntLit 42)
	let result = compileExpression defaultConfig term
	case result of
	Left err -> assertFailure $ "Unexpected error: " ++ err
	Right expr -> do
	let code = heExpr expr
	assertBool "Should contain '42'" ("42" `T.isInfixOf` code)

	testBoolLiteral :: Assertion
	testBoolLiteral = do
	let term = Const (BoolLit True)
	let result = compileExpression defaultConfig term
	case result of
	Left err -> assertFailure $ "Unexpected error: " ++ err
	Right expr -> do
	let code = heExpr expr
	assertBool "Should contain 'True'" ("True" `T.isInfixOf` code)

	testUnitConstant :: Assertion
	testUnitConstant = do
	let term = Const UnitConst
	let result = compileExpression defaultConfig term
	case result of
	Left err -> assertFailure $ "Unexpected error: " ++ err
	Right expr -> do
	let code = heExpr expr
	assertEqual "Should be unit" "()" code

	testStringLiteral :: Assertion
	testStringLiteral = do
	let term = Const (StringLit "hello")
	let result = compileExpression defaultConfig term
	case result of
	Left err -> assertFailure $ "Unexpected error: " ++ err
	Right expr -> do
	let code = heExpr expr
	assertBool "Should contain string" ("hello" `T.isInfixOf` code)

	testSimpleVar :: Assertion
	testSimpleVar = do
	let var = Var (Var "x" 0)
	let result = compileExpression defaultConfig var
	case result of
	Left err -> assertFailure $ "Unexpected error: " ++ err
	Right expr -> do
	let code = heExpr expr
	assertEqual "Should be variable name" "x" code

	testQualifiedVar :: Assertion
	testQualifiedVar = do
	let var = Var (Var "map" 0)
	let result = compileExpression defaultConfig var
	case result of
	Left err -> assertFailure $ "Unexpected error: " ++ err
	Right expr -> do
	let code = heExpr expr
	assertBool "Should contain variable" ("map" `T.isInfixOf` code)

	testSimpleLambda :: Assertion
	testSimpleLambda = do
	let lambda = Lam (Binder (Var "x" 0) Nothing) (Var (Var "x" 0))
	let result = compileExpression defaultConfig lambda
	case result of
	Left err -> assertFailure $ "Unexpected error: " ++ err
	Right expr -> do
	let code = heExpr expr
	assertBool "Should contain lambda" ("\\" `T.isInfixOf` code)
	assertBool "Should contain variable" ("x" `T.isInfixOf` code)

	testApplication :: Assertion
	testApplication = do
	let f = Var (Var "f" 0)
	let x = Var (Var "x" 0)
	let app = App f x
	let result = compileExpression defaultConfig app
	case result of
	Left err -> assertFailure $ "Unexpected error: " ++ err
	Right expr -> do
	let code = heExpr expr
	assertBool "Should contain f" ("f" `T.isInfixOf` code)
	assertBool "Should contain x" ("x" `T.isInfixOf` code)

	testNestedApp :: Assertion
	testNestedApp = do
	let f = Var (Var "f" 0)
	let x = Var (Var "x" 0)
	let y = Var (Var "y" 0)
	let app1 = App f x
	let app2 = App app1 y
	let result = compileExpression defaultConfig app2
	case result of
	Left err -> assertFailure $ "Unexpected error: " ++ err
	Right expr -> do
	let code = heExpr expr
	assertBool "Should be valid expression" (not (T.null code))

	testFunctionType :: Assertion
	testFunctionType = do
	let tyInt = TyConst (QName [] "Int") []
	let tyBool = TyConst (QName [] "Bool") []
	let funType = TyFun tyInt tyBool
	let result = compileType defaultConfig funType
	case result of
	Left err -> assertFailure $ "Unexpected error: " ++ err
	Right expr -> do
	let code = heExpr expr
	assertBool "Should contain arrow" ("->" `T.isInfixOf` code)

	testTypeVar :: Assertion
	testTypeVar = do
	let tv = TyVar (Var "a" 0)
	let result = compileType defaultConfig tv
	case result of
	Left err -> assertFailure $ "Unexpected error: " ++ err
	Right expr -> do
	let code = heExpr expr
	assertEqual "Should be type variable" "a" code

	testTypeConstructor :: Assertion
	testTypeConstructor = do
	let intType = TyConst (QName [] "Int") []
	let result = compileType defaultConfig intType
	case result of
	Left err -> assertFailure $ "Unexpected error: " ++ err
	Right expr -> do
	let code = heExpr expr
	assertEqual "Should be Int" "Int" code

	testInvalidQName :: Assertion
	testInvalidQName = do
	-- This test checks that invalid qualified names are handled
	-- For now, most constructs compile, but this is a placeholder
	let qname = QName ["Assertica", "Core"] "someType"
	let ty = TyConst qname []
	let result = compileType defaultConfig ty
	case result of
	Left _ -> return () -- Error is acceptable
	Right expr -> do
	let code = heExpr expr
	assertBool "Should produce valid code" (not (T.null code))

	testDefaultConfig :: Assertion
	testDefaultConfig = do
	assertEqual "Add comments enabled" True (cgcAddComments defaultConfig)
	assertEqual "Add type signatures enabled" True (cgcAddTypeSignatures defaultConfig)

	testConfigAffectsOutput :: Assertion
	testConfigAffectsOutput = do
	let config1 = defaultConfig { cgcAddComments = True }
	let config2 = defaultConfig { cgcAddComments = False }

	let term = Const (IntLit 42)
	let result1 = compileExpression config1 term
	let result2 = compileExpression config2 term

	case (result1, result2) of
	(Right e1, Right e2) ->
	-- Both should produce valid expressions
	assertBool "First result valid" (not (T.null (heExpr e1)))
	assertBool "Second result valid" (not (T.null (heExpr e2)))
	(Left e, _) -> assertFailure $ "Unexpected error: " ++ e
	(_, Left e) -> assertFailure $ "Unexpected error: " ++ e

	-- ============================================================================
	-- PROPERTY TESTS
	-- ============================================================================

	-- Property: Code generation is deterministic
	propDeterministic :: Term -> Bool
	propDeterministic term =
	let result1 = compileExpression defaultConfig term
	result2 = compileExpression defaultConfig term
	in case (result1, result2) of
	(Right e1, Right e2) -> heExpr e1 == heExpr e2
	(Left err1, Left err2) -> err1 == err2
	_ -> False

	-- Property: Simple constants compile without errors
	propSimpleConstantsCompile :: Constant -> Bool
	propSimpleConstantsCompile c =
	let term = Const c
	result = compileExpression defaultConfig term
	in case result of
	Right _ -> True
	Left _ -> False