1
1
mirror of https://github.com/anoma/juvix.git synced 2024-12-14 17:32:00 +03:00
juvix/test/BackendGeb/FromCore/Base.hs

94 lines
4.6 KiB
Haskell
Raw Normal View History

module BackendGeb.FromCore.Base where
import Base
import Data.Text.IO qualified as TIO
import Juvix.Compiler.Backend (Target (TargetGeb))
import Juvix.Compiler.Backend.Geb qualified as Geb
import Juvix.Compiler.Core qualified as Core
import Juvix.Compiler.Pipeline
import Juvix.Prelude.Pretty
coreToGebtranslationAssertion ::
Path Abs File ->
Path Abs File ->
(String -> IO ()) ->
Assertion
coreToGebtranslationAssertion mainFile expectedFile step = do
step "Parse Juvix Core file"
input <- readFile . toFilePath $ mainFile
cwd <- getCurrentDir
let entryPoint = (defaultEntryPoint cwd mainFile) {_entryPointTarget = TargetGeb}
case Core.runParserMain mainFile Core.emptyInfoTable input of
Left err -> assertFailure . show . pretty $ err
Right coreInfoTable -> coreToGebTranslationAssertion' coreInfoTable entryPoint expectedFile step
coreToGebTranslationAssertion' ::
Core.InfoTable ->
EntryPoint ->
Path Abs File ->
(String -> IO ()) ->
Assertion
coreToGebTranslationAssertion' coreInfoTable entryPoint expectedFile step = do
step "Prepare the Juvix Core node for translation to Geb"
case run . runReader entryPoint . runError @Geb.JuvixError $ Core.toGeb coreInfoTable of
Left err ->
assertFailure . show . pretty $
fromJuvixError @GenericError err
Right readyCoreInfoTable -> do
step "Translate the Juvix Core node to Geb"
let (translatedMorphism, translatedObj) = Geb.fromCore readyCoreInfoTable
step "Typecheck the translated Geb node"
let typeMorph =
Geb.TypedMorphism
{ _typedMorphism = translatedMorphism,
_typedMorphismObject = translatedObj
}
case run . runError @Geb.CheckingError $ Geb.check' typeMorph of
Left err ->
assertFailure . show . pretty $
fromJuvixError @GenericError (JuvixError err)
Right _ -> do
step "Try evaluating the JuvixCore node"
let resultCoreEval :: Core.Node = Core.evalInfoTable stderr readyCoreInfoTable
step "Translate the result of the evaluated JuvixCore node to Geb"
let (gebCoreEvalResult, _) = Geb.fromCore $ Core.setupMainFunction readyCoreInfoTable resultCoreEval
case ( Geb.eval' Geb.defaultEvalEnv translatedMorphism,
Geb.eval' Geb.defaultEvalEnv gebCoreEvalResult
) of
(Left err, _) -> do
step "The evaluation of the translated Geb node failed"
assertFailure . show . pretty $
fromJuvixError @GenericError (JuvixError err)
(_, Left err) -> do
step "The evaluation of gebCoreEvalResult failed"
assertFailure . show . pretty $ fromJuvixError @GenericError (JuvixError err)
( Right resEvalTranslatedMorph,
Right resEvalGebCoreEvalResult
) -> do
step "Compare the geb value of the Core eval output and the Geb eval output"
if
| resEvalTranslatedMorph /= resEvalGebCoreEvalResult ->
assertFailure "The evaluation for the Core node and the Geb node are not equal"
| otherwise -> do
let fpath = toFilePath expectedFile
expectedInput <- TIO.readFile fpath
step "Compare expected and actual program output"
let compareEvalOutput morph =
case Geb.eval' Geb.defaultEvalEnv morph of
Left err ->
assertFailure . show . pretty $
fromJuvixError @GenericError (JuvixError err)
Right resEvalExpected -> do
if
| resEvalTranslatedMorph /= resEvalExpected ->
assertFailure $
"The result of evaluating the translated Geb"
<> "node is not equal to the expected output"
| otherwise -> assertBool "" True
case Geb.runParser expectedFile expectedInput of
Left parseErr -> assertFailure . show . pretty $ parseErr
Right (Geb.ExpressionMorphism m) -> compareEvalOutput m
Right (Geb.ExpressionTypedMorphism m) -> compareEvalOutput (m ^. Geb.typedMorphism)
Right (Geb.ExpressionObject _) ->
assertFailure "Expected a morphism, but got an object for the expected output"