Merge pull request #370 from github/concrete-python-tests

Add Check-Result directive for querying Python concrete evaluation.

semantic-python/semantic-python.cabal

@@ -23,6 +23,7 @@ common haskell
   build-depends:       base ^>=4.12
                      , fused-effects ^>= 0.5
                      , fused-syntax
+                     , parsers ^>= 0.12.10
                      , semantic-core ^>= 0.0
                      , semantic-source ^>= 0.0
                      , semantic-tags ^>= 0.0

semantic-python/src/Language/Python/Core.hs

@@ -363,7 +363,7 @@ instance Compile Py.String where
       Prj Py.EscapeSequence { text } -> pure text
       other                          -> fail ("Couldn't string-desugar " <> show other)
 
-    let new = pure "__semantic_prelude" ... "str" ... "__class" ... "__new__"
+    let new = pure "__semantic_prelude" ... "str" ... "__slots" ... "__new__"
     cc $ locate it (new $$ Core.string (mconcat contents))
 
 instance Compile Py.Subscript

semantic-python/src/Prelude.score

@@ -8,15 +8,10 @@
   // object's superclass is type itself
   object <- type "object" type #record{};
 
-  str <- type "str" object #record { };
+  str <- type "str" object #record { __new__: \prim -> instance #unit prim #record{} };
-  str.__new__ = (\contents -> instance str contents #record{});
 
   getitem <- \super -> \item -> \attr ->
     if item.slots.?attr then item.slots.attr else #unit;
 
-  new <- \class -> class.__new__;
+  #record { type: type, object: object, str: str, getitem: getitem}
-
-  example <- new str "hello";
-
-  #record { type: type, object: object, str: str, getitem: getitem, new: new, example: example }
 }

semantic-python/test/Directive.hs

@@ -1,19 +1,35 @@
+{-# LANGUAGE TypeApplications, TypeOperators #-}
+
+-- | FileCheck-style directives for testing Core compilers.
 module Directive ( Directive (..)
-                 , parseDirective
+                 , readDirectivesFromFile
                  , describe
                  , toProcess
                  ) where
 
+import           Analysis.Concrete (Concrete (..))
 import           Control.Applicative
+import           Control.Effect
 import           Control.Monad
+import           Control.Monad.Trans.Resource (ResourceT, runResourceT)
 import           Core.Core (Core)
+import qualified Core.Core as Core
+import           Core.Name (Name)
 import qualified Core.Parser
 import qualified Core.Pretty
-import           Core.Name (Name)
 import           Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as ByteString
+import qualified Data.ByteString.Streaming.Char8 as ByteStream
+import           Data.Text (Text)
+import qualified Data.Text as T
+import qualified Source.Span as Source
+import qualified Streaming.Prelude as Stream
 import           Syntax.Term (Term)
+import qualified System.Path as Path
+import qualified System.Path.PartClass as Path.Class
 import           System.Process
+import qualified Text.Parser.Token.Style as Style
+import           Text.Trifecta (CharParsing, TokenParsing (..))
 import qualified Text.Trifecta as Trifecta
 
 {- |
@@ -42,29 +58,62 @@ projects.
 -}
 data Directive = JQ ByteString -- | @# CHECK-JQ: expr@
                | Tree (Term Core Name) -- | @# CHECK-TREE: core@
+               | Result Text (Concrete (Term (Core.Ann Source.Span :+: Core)) Name) -- | @# CHECK-RESULT key: expected
                | Fails -- | @# CHECK-FAILS@ fails unless translation fails.
                  deriving (Eq, Show)
 
-describe :: Directive -> String
+-- | Extract all directives from a file.
-describe Fails = "<expect failure>"
+readDirectivesFromFile :: Path.Class.AbsRel ar => Path.File ar -> IO [Directive]
-describe (Tree t) =  Core.Pretty.showCore t
+readDirectivesFromFile
-describe (JQ b) = ByteString.unpack b
+  = runResourceT
+  . Stream.toList_
+  . Stream.mapM (either perish pure . parseDirective)
+  . Stream.takeWhile isComment
+  . Stream.mapped ByteStream.toStrict
+  . ByteStream.lines
+  . ByteStream.readFile @(ResourceT IO)
+  . Path.toString
+    where
+      perish s  = fail ("Directive parsing error: " <> s)
+      isComment = (== Just '#') . fmap fst . ByteString.uncons
 
-fails :: Trifecta.Parser Directive
+
+describe :: Directive -> String
+describe Fails        = "<expect failure>"
+describe (Tree t)     =  Core.Pretty.showCore t
+describe (JQ b)       = ByteString.unpack b
+describe (Result t e) = T.unpack t <> ": " <> show e
+
+fails :: CharParsing m => m Directive
 fails = Fails <$ Trifecta.string "# CHECK-FAILS"
 
-jq :: Trifecta.Parser Directive
+jq :: (Monad m, CharParsing m) => m Directive
 jq = do
   void $ Trifecta.string "# CHECK-JQ: "
   JQ . ByteString.pack <$> many (Trifecta.noneOf "\n")
 
-tree :: Trifecta.Parser Directive
+tree :: (Monad m, TokenParsing m) => m Directive
 tree = do
   void $ Trifecta.string "# CHECK-TREE: "
   Tree <$> Core.Parser.core
 
-directive :: Trifecta.Parser Directive
+result :: (Monad m, TokenParsing m) => m Directive
-directive = Trifecta.choice [ fails, jq, tree ]
+result = do
+  void $ Trifecta.string "# CHECK-RESULT "
+  key <- Trifecta.ident Style.haskellIdents
+  void $ Trifecta.symbolic ':'
+  Result key <$> concrete
+
+concrete :: TokenParsing m => m (Concrete term Name)
+concrete = Trifecta.choice
+  [ String <$> Trifecta.stringLiteral
+  , Bool True <$ Trifecta.symbol "#true"
+  , Bool False <$ Trifecta.symbol "#false"
+  , Unit <$ Trifecta.symbol "#unit"
+  ]
+
+directive :: (Monad m, TokenParsing m) => m Directive
+directive = Trifecta.choice [ fails, result, jq, tree ]
 
 parseDirective :: ByteString -> Either String Directive
 parseDirective = Trifecta.foldResult (Left . show) Right

semantic-python/test/Test.hs

@@ -1,7 +1,9 @@
-{-# LANGUAGE DeriveAnyClass, DerivingStrategies, GeneralizedNewtypeDeriving, OverloadedStrings, TypeApplications, TypeOperators, ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TypeApplications, TypeOperators #-}
 
 module Main (main) where
 
+import           Analysis.Concrete (Concrete)
+import qualified Analysis.Concrete as Concrete
 import           Analysis.File
 import           Analysis.ScopeGraph
 import           Control.Effect
@@ -10,12 +12,11 @@ import           Control.Effect.Reader
 import           Control.Monad hiding (fail)
 import           Control.Monad.Catch
 import           Control.Monad.IO.Class
-import           Control.Monad.Trans.Resource (ResourceT, runResourceT)
 import           Core.Core
-import qualified Core.Parser
-import           Core.Pretty
 import qualified Core.Eval as Eval
 import           Core.Name
+import qualified Core.Parser
+import           Core.Pretty
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Encode.Pretty as Aeson
 import qualified Data.ByteString.Char8 as ByteString
@@ -23,21 +24,23 @@ import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy
 import qualified Data.ByteString.Streaming.Char8 as ByteStream
 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           Prelude hiding (fail)
 import           Source.Span
 import           Streaming
-import qualified Streaming.Prelude as Stream
 import qualified Streaming.Process
 import           Syntax.Term
 import           System.Directory
 import           System.Exit
+import           System.Path ((</>))
 import qualified System.Path as Path
 import qualified System.Path.Directory as Path
-import           System.Path ((</>))
 import           Text.Show.Pretty (ppShow)
 import qualified Text.Trifecta as Trifecta
 import qualified TreeSitter.Python as TSP
@@ -49,15 +52,17 @@ 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)
 
 assertJQExpressionSucceeds :: Show a => Directive.Directive -> a -> Term (Ann Span :+: Core) Name -> HUnit.Assertion
 assertJQExpressionSucceeds directive tree core = do
-  preludesrc <- ByteString.readFile "semantic-python/src/Prelude.score"
+  prelude <- parsePrelude
-  let ePrelude = Trifecta.parseByteString (Core.Parser.core <* Trifecta.eof) mempty preludesrc
-  prelude <- case Trifecta.foldResult (Left . show) Right ePrelude of
-    Right r -> pure r
-    Left s -> HUnit.assertFailure ("Couldn't parse prelude: " <> s)
-
   let allTogether = (named' "__semantic_prelude" :<- prelude) >>>= core
 
   bod <- case scopeGraph Eval.eval [File (Path.absRel "<interactive>") (Span (Pos 1 1) (Pos 1 1)) allTogether] of
@@ -67,64 +72,73 @@ assertJQExpressionSucceeds directive tree core = do
       ]
     other -> HUnit.assertFailure ("Couldn't run scope dumping mechanism: " <> showCore (stripAnnotations allTogether) <> "\n" <> show other)
 
-  let ignore = ByteStream.effects . hoist ByteStream.effects
+  let ignore     = ByteStream.effects . hoist ByteStream.effects
-      sgJSON = ByteStream.fromLazy $ Aeson.encode bod
+      sgJSON     = ByteStream.fromLazy $ Aeson.encode bod
       jqPipeline = Streaming.Process.withStreamingProcess (Directive.toProcess directive) sgJSON ignore
-      errorMsg = "jq(1) returned non-zero exit code"
+      errorMsg   = "jq(1) returned non-zero exit code"
-      dirMsg    = "jq expression: " <> show directive
+      dirMsg     = "jq expression: " <> show directive
-      jsonMsg   = "JSON value: " <> ByteString.Lazy.unpack (Aeson.encodePretty bod)
+      jsonMsg    = "JSON value: " <> ByteString.Lazy.unpack (Aeson.encodePretty bod)
-      astMsg    = "AST (pretty): " <> ppShow tree
+      astMsg     = "AST (pretty): " <> ppShow tree
-      treeMsg   = "Core expr (pretty): " <> showCore (stripAnnotations core)
+      treeMsg    = "Core expr (pretty): " <> showCore (stripAnnotations core)
-      treeMsg'  = "Core expr (Show): " <> ppShow (stripAnnotations core)
+      treeMsg'   = "Core expr (Show): " <> ppShow (stripAnnotations core)
 
 
   catch @_ @Streaming.Process.ProcessExitedUnsuccessfully jqPipeline $ \err -> do
     HUnit.assertFailure (unlines [errorMsg, dirMsg, jsonMsg, astMsg, treeMsg, treeMsg', show err])
 
-fixtureTestTreeForFile :: HasCallStack => Path.RelFile -> Tasty.TestTree
+-- handles CHECK-RESULT directives
-fixtureTestTreeForFile fp = HUnit.testCaseSteps (Path.toString fp) $ \step -> withFrozenCallStack $ do
+assertEvaluatesTo :: Term (Ann Span :+: Core) Name -> Text -> Concrete (Term (Ann Span :+: Core)) Name -> HUnit.Assertion
+assertEvaluatesTo core k val = do
+  prelude <- parsePrelude
+  let allTogether = (named' "__semantic_prelude" :<- prelude) >>>= core
+  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
+
+-- 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
-      perish s  = liftIO (HUnit.assertFailure ("Directive parsing error: " <> s))
+  directives <- Directive.readDirectivesFromFile fullPath
-      isComment = (== Just '#') . fmap fst . ByteString.uncons
-
-
-  -- Slurp the input file, taking lines from the beginning until we
-  -- encounter a line that doesn't have a '#'. For each line, parse
-  -- a directive out of it, failing if the directive can't be parsed.
-  directives <-
-    runResourceT
-    . Stream.toList_
-    . Stream.mapM (either perish pure . Directive.parseDirective)
-    . Stream.takeWhile isComment
-    . Stream.mapped ByteStream.toStrict
-    . ByteStream.lines
-    . ByteStream.readFile @(ResourceT IO)
-    $ Path.toString fullPath
-
   result <- ByteString.readFile (Path.toString fullPath) >>= TS.parseByteString TSP.tree_sitter_python
+
+  -- Run the compiler
   let coreResult = Control.Effect.run
                    . runFail
                    . runReader @Py.Bindings mempty
                    . Py.toplevelCompile
                    <$> 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 ()
+      (Right (Left _), Directive.Fails)          -> pure ()
-      (Left err, _)                          -> HUnit.assertFailure ("Parsing failed: " <> err)
+      (Left err, _)                              -> HUnit.assertFailure ("Parsing failed: " <> err)
-      (Right (Left err), _)                  -> HUnit.assertFailure ("Compilation failed: " <> err)
+      (Right (Left err), _)                      -> HUnit.assertFailure ("Compilation failed: " <> err)
-      (Right (Right _), Directive.Fails)     -> HUnit.assertFailure ("Expected translation to fail")
+      (Right (Right _), Directive.Fails)         -> HUnit.assertFailure "Expected translation to fail"
-      (Right (Right item), Directive.JQ _)   -> assertJQExpressionSucceeds directive result item
+      (Right (Right item), Directive.Result k v) -> assertEvaluatesTo item k v
-      (Right (Right item), Directive.Tree t) -> let msg = "got (pretty): " <> showCore item'
+      (Right (Right item), Directive.JQ _)       -> assertJQExpressionSucceeds directive result item
-                                                    item' = stripAnnotations item
+      (Right (Right item), Directive.Tree t)     -> assertTreeEqual (stripAnnotations item) t
-                                                in HUnit.assertEqual msg t item' where
 
 milestoneFixtures :: IO Tasty.TestTree
-milestoneFixtures = do
+milestoneFixtures = buildTests <$> readFiles
-  files <- liftIO (Path.filesInDir (Path.relDir "semantic-python/test/fixtures"))
+  where
-  let pythons = sort (filter (Path.hasExtension ".py") files)
+    readFiles  = liftIO . Path.filesInDir . Path.relDir $ "semantic-python/test/fixtures"
-  pure $ Tasty.testGroup "Translation" (fmap fixtureTestTreeForFile pythons)
+    buildTests = Tasty.testGroup "Python" . fmap checkPythonFile . sort . filter (Path.hasExtension ".py")
 
 main :: IO ()
 main = do

semantic-python/test/fixtures/1-04-toplevel-assignment.py

@@ -1,4 +1,5 @@
 # CHECK-JQ: .scope | has("hello") and has("goodbye")
 # CHECK-TREE: { hello <- #unit; goodbye <- #unit; #record { hello: hello, goodbye: goodbye }}
+# CHECK-RESULT hello: #unit
 hello = ()
 goodbye = ()