diff --git a/src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs b/src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs index 3d8b71651c..98285d8425 100644 --- a/src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs +++ b/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 diff --git a/src/Juvix/Compiler/Tree/Transformation/Base.hs b/src/Juvix/Compiler/Tree/Transformation/Base.hs index 2fb394621b..f73e4002f7 100644 --- a/src/Juvix/Compiler/Tree/Transformation/Base.hs +++ b/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)) diff --git a/test/Tree.hs b/test/Tree.hs index fc354934ea..d4febc6dac 100644 --- a/test/Tree.hs +++ b/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] diff --git a/test/Tree/Eval/Base.hs b/test/Tree/Eval/Base.hs index ba75017aab..e6b46c8254 100644 --- a/test/Tree/Eval/Base.hs +++ b/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' diff --git a/test/Tree/Eval/Positive.hs b/test/Tree/Eval/Positive.hs index 927ec37b68..49ed936317 100644 --- a/test/Tree/Eval/Positive.hs +++ b/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] diff --git a/test/Tree/Transformation.hs b/test/Tree/Transformation.hs new file mode 100644 index 0000000000..bd056da0c4 --- /dev/null +++ b/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 + ] diff --git a/test/Tree/Transformation/Base.hs b/test/Tree/Transformation/Base.hs new file mode 100644 index 0000000000..9f7e88e06b --- /dev/null +++ b/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 + } diff --git a/test/Tree/Transformation/Identity.hs b/test/Tree/Transformation/Identity.hs new file mode 100644 index 0000000000..e17afdb2a7 --- /dev/null +++ b/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 + }