Trying to bring up this test harness

semantic-core/src/Data/Loc.hs

@@ -26,7 +26,6 @@ data Loc = Loc
   }
   deriving (Eq, Ord, Show)
 
-
 data Span = Span
   { spanStart :: {-# UNPACK #-} !Pos
   , spanEnd   :: {-# UNPACK #-} !Pos

semantic-python/semantic-python.cabal

@@ -50,9 +50,22 @@ test-suite test
   type: exitcode-stdio-1.0
   hs-source-dirs: test
   main-is: Test.hs
+  ghc-options: -threaded
+
+  other-modules: ScopeDump
+               , Directive
+
   build-depends: semantic-python == 0.0.0.0
+               , aeson ^>= 1.4.4.0
+               , aeson-pretty ^>= 0.8.7
+               , bytestring ^>= 0.10.8.2
+               , directory ^>= 1.3.3.0
+               , exceptions ^>= 0.10.2
+               , filepath ^>= 1.4.2.1
+               , process ^>= 1.6.5
+               , streaming-process ^>= 0.1
+               , streaming-bytestring ^>= 0.1.6
                , tasty ^>= 1.2.3
                , tasty-hunit ^>= 0.10.0.2
-               , directory ^>= 1.3.3.0
-               , filepath ^>= 1.4.2.1
-               , bytestring ^>= 0.10.8.2
+               , trifecta >= 2 && <3
+               , unordered-containers ^>= 0.2.10

semantic-python/test/Directive.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Directive ( Directive (..)
+                 , parseDirective
+                 , toProcess
+                 ) where
+
+import           Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as ByteString
+import           Data.Coerce
+import           System.Process
+import qualified Text.Trifecta as Trifecta
+
+newtype Directive = JQ ByteString
+
+instance Show Directive where
+  show = ByteString.unpack . coerce
+
+directive :: Trifecta.Parser Directive
+directive = do
+  Trifecta.string "# CHECK-JQ: "
+  JQ <$> Trifecta.restOfLine
+
+parseDirective :: ByteString -> Either String Directive
+parseDirective = Trifecta.foldResult (Left . show) Right
+               . Trifecta.parseByteString (directive <* Trifecta.eof) mempty
+
+toProcess :: Directive -> CreateProcess
+toProcess (JQ d) = proc "jq" ["-e", ByteString.unpack d]

semantic-python/test/ScopeDump.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE OverloadedStrings, RecordWildCards, TypeOperators #-}
+
+module ScopeDump ( ScopeDump (..), runScopeDump ) where
+
+import qualified Analysis.Eval as Eval
+import           Control.Effect
+import           Control.Effect.Fail
+import           Control.Effect.Reader
+import qualified Data.Aeson as Aeson
+import           Data.Core
+import           Data.Function
+import           Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import           Data.Loc
+import           Data.Name
+import           Data.Term
+
+data ScopeDump
+  = DumpRecord (HashMap Name ScopeDump)
+  | Nil
+    deriving (Eq, Show)
+
+instance Semigroup ScopeDump where
+  DumpRecord lhs <> DumpRecord rhs = DumpRecord (HashMap.unionWith (<>) lhs rhs)
+  Nil <> rhs = rhs
+  lhs <> Nil = lhs
+
+instance Aeson.ToJSON ScopeDump where
+  toJSON (DumpRecord hs) = Aeson.Object (fmap Aeson.toJSON hs)
+  toJSON Nil             = Aeson.Null
+
+scopeDump :: Applicative m => Eval.Analysis term () ScopeDump m
+scopeDump = Eval.Analysis {..} where
+  alloc _name = pure ()
+  bind _name _addr within = within
+  lookupEnv _name = pure (Just ())
+  deref _addr = pure (Just Nil)
+  assign _addr _value = pure ()
+  abstract _thing _name _term = pure Nil
+  apply _thing _fn _arg = pure Nil
+  unit = pure Nil
+  bool _b = pure Nil
+  asBool _val = pure True
+  string _s = pure Nil
+  asString _val = pure ""
+  record = pure . DumpRecord . HashMap.fromList
+  _addr ... _name = pure (Just ())
+
+unhelpful :: Loc
+unhelpful = Loc "<interactive>" emptySpan
+
+runScopeDump :: Term (Ann :+: Core) Name -> Either String ScopeDump
+runScopeDump
+  = run
+  . runFail
+  . runReader unhelpful
+  . fix (Eval.eval scopeDump)

semantic-python/test/Test.hs

@@ -1,14 +1,23 @@
-{-# LANGUAGE FlexibleInstances, TypeApplications #-}
+{-# OPTIONS_GHC -Werror #-}
+{-# LANGUAGE FlexibleInstances, TypeApplications, RecordWildCards, FlexibleContexts, TypeOperators, OverloadedStrings #-}
 
 module Main (main) where
 
+import Prelude hiding (fail)
 import           Control.Effect
-import           Control.Monad
+import           Control.Effect.Fresh
+import           Control.Effect.Fail
+import           Control.Effect.Reader
+import Data.Function
+import           Control.Monad hiding (fail)
 import           Control.Monad.Fail
 import           Control.Monad.IO.Class
-import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Char8 as ByteString
+import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy
 import           Data.Core
+import           Data.File
 import           Data.Foldable
+import           Data.Loc
 import           Data.List (sort, isInfixOf)
 import           Data.Name
 import           Data.Term
@@ -19,20 +28,56 @@ import           System.FilePath
 import qualified TreeSitter.Python as TSP
 import qualified TreeSitter.Python.AST as TSP
 import qualified TreeSitter.Unmarshal as TS
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Encode.Pretty as Aeson
+import qualified Analysis.Eval as Eval
+import           Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import qualified Streaming.Process
+import qualified Data.ByteString.Streaming.Char8 as ByteStream
+import System.Exit
+import Control.Monad.Catch
+import Data.Core.Pretty
+import Data.Maybe
 
 import qualified Test.Tasty as Tasty
 import qualified Test.Tasty.HUnit as HUnit
 
+import qualified Directive
+import ScopeDump
+
 instance MonadFail (Either String) where fail = Left
 
 assertTranslationSucceeds :: HasCallStack => FilePath -> HUnit.Assertion
 assertTranslationSucceeds fp = withFrozenCallStack $ do
-  let shouldFail = "fails" `isInfixOf` fp || "disabled" `isInfixOf` fp
-  parsed <- ByteString.readFile ("semantic-python/test/fixtures" </> fp) >>= TS.parseByteString TSP.tree_sitter_python
-  case fmap (Py.compile @TSP.Module @_ @(Term Core)) parsed of
-    Right (Left err) -> unless shouldFail (HUnit.assertFailure ("Compilation failed: " <> err))
+  let skipThisTest = "fails" `isInfixOf` fp || "disabled" `isInfixOf` fp
+  unless skipThisTest $ do
+    fileContents <- ByteString.readFile ("semantic-python/test/fixtures" </> fp)
+    let first = ByteString.takeWhile (/= '\n') fileContents
+    directive <- case Directive.parseDirective first of
+      Right dir -> pure dir
+      Left err -> HUnit.assertFailure ("Directive parsing error: " <> err)
+
+
+    result <- TS.parseByteString TSP.tree_sitter_python fileContents
+    core <- case fmap (Py.compile @TSP.Module @_ @(Term Core)) result of
+      Right (Right item) -> pure item
+      Right (Left err)   -> HUnit.assertFailure ("Compilation failed: " <> err)
       Left err           -> HUnit.assertFailure ("Parsing failed: " <> err)
-    _                -> pure ()
+
+    dump <- case runScopeDump _ of
+      Left e  -> HUnit.assertFailure ("Couldn't run scope dumping mechanism; this shouldn't happen (" <> e <> ")")
+      Right d -> pure $ Aeson.encodePretty d
+
+    let jqPipeline = Streaming.Process.streamInput (Directive.toProcess directive) (ByteStream.fromLazy dump)
+        errorMsg = "jq(1) returned non-zero exit code"
+        dirMsg    = "jq expression: " <> show directive
+        jsonMsg   = "JSON value: " <> ByteString.Lazy.unpack dump
+        treeMsg   = "Core expr: " <> showCore core
+
+    catch jqPipeline $ \err -> do
+      HUnit.assertFailure (lines [errorMsg, dirMsg, jsonMsg, treeMsg])
+
 
 milestoneFixtures :: Tasty.TestTree
 milestoneFixtures = HUnit.testCaseSteps "Bootstrapping" $ \step -> do
@@ -49,4 +94,7 @@ tests = Tasty.testGroup "Fixtures"
   ]
 
 main :: IO ()
-main = Tasty.defaultMain tests
+main = do
+  jq <- findExecutable "jq"
+  when (isNothing jq) (die "Error: jq(1) not found in $PATH.")
+  Tasty.defaultMain tests

semantic-python/test/fixtures/1-01-empty-module.py

@@ -1 +1 @@
-# CHECK-TOPLEVEL: empty
+# CHECK-JQ: . == {}

semantic-python/test/fixtures/1-02-pass-statement.py

@@ -1,2 +1,2 @@
+# CHECK: top is record
 pass
-# CHECK-TOPLEVEL: empty