tests

src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs

@@ -47,6 +47,21 @@ emptyBuilderState =
       _stateIdents = mempty
     }
 
+runInfoTableBuilderWithTab :: InfoTable' t e -> Sem (InfoTableBuilder' t e ': r) b -> Sem r (InfoTable' t e, b)
+runInfoTableBuilderWithTab tab = fmap (first (^. stateInfoTable)) . runInfoTableBuilder' st
+  where
+    st =
+      BuilderState
+        { _stateNextSymbolId = maximum (0 : map (^. symbolId) (HashMap.keys (tab ^. infoFunctions) ++ HashMap.keys (tab ^. infoInductives))),
+          _stateNextUserTag = maximum (0 : mapMaybe getUserTagId (HashMap.keys (tab ^. infoConstrs))),
+          _stateInfoTable = tab,
+          _stateIdents =
+            HashMap.fromList $
+              map (\fi -> (fi ^. functionName, IdentFun (fi ^. functionSymbol))) (HashMap.elems (tab ^. infoFunctions))
+                ++ map (\ii -> (ii ^. inductiveName, IdentInd (ii ^. inductiveSymbol))) (HashMap.elems (tab ^. infoInductives))
+                ++ map (\ci -> (ci ^. constructorName, IdentConstr (ci ^. constructorTag))) (HashMap.elems (tab ^. infoConstrs))
+        }
+
 runInfoTableBuilder :: Sem (InfoTableBuilder' t e ': r) b -> Sem r (InfoTable' t e, b)
 runInfoTableBuilder = fmap (first (^. stateInfoTable)) . runInfoTableBuilder' emptyBuilderState
 

src/Juvix/Compiler/Tree/Transformation/Base.hs

@@ -34,7 +34,7 @@ mapT f = over infoFunctions (HashMap.mapWithKey (over functionCode . f))
 mapT' :: (Symbol -> Node -> Sem (InfoTableBuilder ': r) Node) -> InfoTable -> Sem r InfoTable
 mapT' f tab =
   fmap fst $
-    runInfoTableBuilder $
+    runInfoTableBuilderWithTab tab $
       mapM_
         (\(sym, fi) -> overM functionCode (f sym) fi >>= registerFunction)
         (HashMap.toList (tab ^. infoFunctions))

test/Tree.hs

@@ -3,6 +3,7 @@ module Tree where
 import Base
 import Tree.Asm qualified as Asm
 import Tree.Eval qualified as Eval
+import Tree.Transformation qualified as Transformation
 
 allTests :: TestTree
-allTests = testGroup "JuvixTree tests" [Eval.allTests, Asm.allTests]
+allTests = testGroup "JuvixTree tests" [Eval.allTests, Asm.allTests, Transformation.allTests]

test/Tree/Eval/Base.hs

@@ -2,25 +2,33 @@ module Tree.Eval.Base where
 
 import Base
 import Juvix.Compiler.Tree.Data.InfoTable
+import Juvix.Compiler.Tree.Data.TransformationId
 import Juvix.Compiler.Tree.Error
 import Juvix.Compiler.Tree.Evaluator
 import Juvix.Compiler.Tree.Language.Base
 import Juvix.Compiler.Tree.Language.Value
 import Juvix.Compiler.Tree.Pretty
+import Juvix.Compiler.Tree.Transformation
 import Juvix.Compiler.Tree.Translation.FromSource
 import Juvix.Data.PPOutput
 
 treeEvalAssertion ::
   Path Abs File ->
   Path Abs File ->
+  [TransformationId] ->
+  (InfoTable -> Assertion) ->
   (String -> IO ()) ->
   Assertion
-treeEvalAssertion mainFile expectedFile step = do
+treeEvalAssertion mainFile expectedFile trans testTrans step = do
   step "Parse"
   s <- readFile (toFilePath mainFile)
   case runParser (toFilePath mainFile) s of
     Left err -> assertFailure (show (pretty err))
-    Right tab -> do
+    Right tab0 -> do
+      unless (null trans) $
+        step "Transform"
+      let tab = run $ applyTransformations trans tab0
+      testTrans tab
       case tab ^. infoMainFunction of
         Just sym -> do
           withTempDir'

test/Tree/Eval/Positive.hs

@@ -23,7 +23,7 @@ testDescr PosTest {..} =
    in TestDescr
         { _testName = _name,
           _testRoot = tRoot,
-          _testAssertion = Steps $ treeEvalAssertion file' expected'
+          _testAssertion = Steps $ treeEvalAssertion file' expected' [] (const (return ()))
         }
 
 filterOutTests :: [String] -> [PosTest] -> [PosTest]

test/Tree/Transformation.hs

@@ -0,0 +1,11 @@
+module Tree.Transformation where
+
+import Base
+import Tree.Transformation.Identity qualified as Identity
+
+allTests :: TestTree
+allTests =
+  testGroup
+    "JuvixTree transformations"
+    [ Identity.allTests
+    ]

test/Tree/Transformation/Base.hs

@@ -0,0 +1,31 @@
+module Tree.Transformation.Base where
+
+import Base
+import Juvix.Compiler.Tree.Data.InfoTable
+import Juvix.Compiler.Tree.Transformation
+import Tree.Eval.Base
+import Tree.Eval.Positive qualified as Eval
+
+data Test = Test
+  { _testTransformations :: [TransformationId],
+    _testAssertion :: InfoTable -> Assertion,
+    _testEval :: Eval.PosTest
+  }
+
+fromTest :: Test -> TestTree
+fromTest = mkTest . toTestDescr
+
+root :: Path Abs Dir
+root = relToProject $(mkRelDir "tests/Tree/positive/")
+
+toTestDescr :: Test -> TestDescr
+toTestDescr Test {..} =
+  let Eval.PosTest {..} = _testEval
+      tRoot = root <//> _relDir
+      file' = tRoot <//> _file
+      expected' = tRoot <//> _expectedFile
+   in TestDescr
+        { _testName = _name,
+          _testRoot = tRoot,
+          _testAssertion = Steps $ treeEvalAssertion file' expected' _testTransformations _testAssertion
+        }

test/Tree/Transformation/Identity.hs

@@ -0,0 +1,21 @@
+module Tree.Transformation.Identity (allTests) where
+
+import Base
+import Juvix.Compiler.Tree.Transformation
+import Tree.Eval.Positive qualified as Eval
+import Tree.Transformation.Base
+
+allTests :: TestTree
+allTests = testGroup "Identity" (map liftTest Eval.tests)
+
+pipe :: [TransformationId]
+pipe = [Identity, IdentityU, IdentityD]
+
+liftTest :: Eval.PosTest -> TestTree
+liftTest _testEval =
+  fromTest
+    Test
+      { _testTransformations = pipe,
+        _testAssertion = const (return ()),
+        _testEval
+      }