mirror of
https://github.com/github/semantic.git
synced 2024-11-28 10:15:55 +03:00
122 lines
5.1 KiB
Haskell
122 lines
5.1 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
||
{-# LANGUAGE ScopedTypeVariables #-}
|
||
{-# LANGUAGE TypeApplications #-}
|
||
{-# LANGUAGE TypeOperators #-}
|
||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||
module Main (main) where
|
||
|
||
import Analysis.Concrete (Concrete)
|
||
import qualified Analysis.Concrete as Concrete
|
||
import Analysis.File
|
||
import Control.Algebra
|
||
import Control.Carrier.Fail.Either
|
||
import Control.Carrier.Reader
|
||
import Control.Monad hiding (fail)
|
||
import Control.Monad.IO.Class
|
||
import Core.Core
|
||
import qualified Core.Eval as Eval
|
||
import Core.Name
|
||
import qualified Core.Parser
|
||
import Core.Pretty
|
||
import qualified Data.ByteString.Char8 as ByteString
|
||
import Data.Foldable
|
||
import Data.Function
|
||
import qualified Data.IntMap as IntMap
|
||
import Data.List (sort)
|
||
import qualified Data.Map as Map
|
||
import Data.Maybe
|
||
import Data.Text (Text)
|
||
import GHC.Stack
|
||
import qualified Language.Python.Core as Py
|
||
import Language.Python.Failure
|
||
import Prelude hiding (fail)
|
||
import Source.Span
|
||
import Syntax.Term
|
||
import Syntax.Var (closed)
|
||
import System.Directory
|
||
import System.Exit
|
||
import System.Path ((</>))
|
||
import qualified System.Path as Path
|
||
import qualified System.Path.Directory as Path
|
||
import qualified Text.Trifecta as Trifecta
|
||
import qualified Language.Python.Grammar as TSP
|
||
import qualified AST.Unmarshal as TS
|
||
|
||
import qualified Test.Tasty as Tasty
|
||
import qualified Test.Tasty.HUnit as HUnit
|
||
|
||
import qualified Directive
|
||
import Instances ()
|
||
|
||
parsePrelude :: IO (Term (Ann Span :+: Core) Name)
|
||
parsePrelude = do
|
||
preludesrc <- ByteString.readFile "semantic-python/src/Prelude.score"
|
||
let ePrelude = Trifecta.parseByteString (Core.Parser.core <* Trifecta.eof) mempty preludesrc
|
||
case Trifecta.foldResult (Left . show) Right ePrelude of
|
||
Right r -> pure r
|
||
Left s -> HUnit.assertFailure ("Couldn't parse prelude: " <> s)
|
||
|
||
-- handles CHECK-RESULT directives
|
||
assertEvaluatesTo :: Term (Ann Span :+: Core) Name -> Text -> Concrete (Term (Ann Span :+: Core)) -> HUnit.Assertion
|
||
assertEvaluatesTo core k val = do
|
||
prelude <- parsePrelude
|
||
let withPrelude = (named' "__semantic_prelude" :<- prelude) >>>= core
|
||
allTogether <- maybe (HUnit.assertFailure ("Can’t evaluate open term: " <> showCore (stripAnnotations withPrelude))) pure (closed withPrelude)
|
||
let filius = [File (Path.absRel "<interactive>") (Span (Pos 1 1) (Pos 1 1)) allTogether]
|
||
|
||
(heap, env) <- case Concrete.concrete Eval.eval filius of
|
||
(heap, [File _ _ (Right (Concrete.Record env))]) ->
|
||
pure (heap, env)
|
||
(_, [File _ _ (Left (_, span, err))]) ->
|
||
HUnit.assertFailure ("Failed evaluation (" <> show span <> "): " <> err)
|
||
(_, files) ->
|
||
HUnit.assertFailure ("Unexpected number of files: " <> show (length files))
|
||
|
||
let found = Map.lookup (name k) env >>= flip IntMap.lookup heap
|
||
found HUnit.@?= Just val
|
||
{-# HLINT ignore assertEvaluatesTo #-}
|
||
|
||
-- handles CHECK-TREE directives
|
||
assertTreeEqual :: Term Core Name -> Term Core Name -> HUnit.Assertion
|
||
assertTreeEqual t item = HUnit.assertEqual ("got (pretty)" <> showCore item) t item
|
||
|
||
|
||
checkPythonFile :: HasCallStack => Path.RelFile -> Tasty.TestTree
|
||
checkPythonFile fp = HUnit.testCaseSteps (Path.toString fp) $ \step -> withFrozenCallStack $ do
|
||
-- Extract the directives and the core associated with the provided file
|
||
let fullPath = Path.relDir "semantic-python/test/fixtures" </> fp
|
||
directives <- Directive.readDirectivesFromFile fullPath
|
||
result <- ByteString.readFile (Path.toString fullPath) >>= TS.parseByteString TSP.tree_sitter_python
|
||
|
||
-- Run the compiler
|
||
let coreResult = Control.Algebra.run
|
||
. runFail
|
||
. eliminateFailures
|
||
. Control.Algebra.run
|
||
. runReader @Py.Bindings mempty
|
||
. Py.toplevelCompile @(Failure :+: Ann Span :+: Core) @(Term _)
|
||
<$> result
|
||
|
||
-- Dispatch based on the result-directive pair
|
||
for_ directives $ \directive -> do
|
||
step (Directive.describe directive)
|
||
case (coreResult, directive) of
|
||
(Right (Left _), Directive.Fails) -> pure ()
|
||
(Left err, _) -> HUnit.assertFailure ("Parsing failed: " <> err)
|
||
(Right (Left err), _) -> HUnit.assertFailure ("Compilation failed: " <> err)
|
||
(Right (Right _), Directive.Fails) -> HUnit.assertFailure "Expected translation to fail"
|
||
(Right (Right item), Directive.Result k v) -> assertEvaluatesTo item k v
|
||
(Right (Right item), Directive.Tree t) -> assertTreeEqual (stripAnnotations item) t
|
||
|
||
milestoneFixtures :: IO Tasty.TestTree
|
||
milestoneFixtures = buildTests <$> readFiles
|
||
where
|
||
readFiles = liftIO . Path.filesInDir . Path.relDir $ "semantic-python/test/fixtures"
|
||
buildTests = Tasty.testGroup "Python" . fmap checkPythonFile . sort . filter (Path.hasExtension ".py")
|
||
|
||
main :: IO ()
|
||
main = do
|
||
jq <- findExecutable "jq"
|
||
when (isNothing jq) (die "Error: jq(1) not found in $PATH.")
|
||
milestoneFixtures >>= Tasty.defaultMain
|