Merge branch 'master' into semantic-tags

cabal.project

@@ -2,9 +2,6 @@ packages: . semantic-core semantic-python semantic-tags
 
 jobs: $ncpus
 
-package semantic
-  ghc-options: +RTS -A128m -n2m -RTS
-
 source-repository-package
   type: git
   location: https://github.com/joshvera/proto3-suite.git

semantic-core/src/Data/Core/Parser.hs

@@ -4,6 +4,8 @@ module Data.Core.Parser
   , core
   , lit
   , expr
+  , record
+  , comp
   , lvalue
   ) where
 

semantic-python/semantic-python.cabal

@@ -23,6 +23,7 @@ common haskell
   build-depends:       base ^>=4.12
                      , fused-effects ^>= 0.5
                      , semantic-core ^>= 0.0
+                     , text ^>= 1.2.3
                      , tree-sitter == 0.3.0.0
                      , tree-sitter-python == 0.4.0.0
 
@@ -63,7 +64,7 @@ test-suite test
                , containers ^>= 0.6
                , directory ^>= 1.3.3
                , exceptions ^>= 0.10.2
-               , filepath ^>= 1.4.2.1
+               , pathtype ^>= 0.8.1
                , pretty-show ^>= 1.9.5
                , process ^>= 1.6.5
                , streaming ^>= 0.2.2
@@ -71,6 +72,5 @@ test-suite test
                , streaming-bytestring ^>= 0.1.6
                , tasty ^>= 1.2.3
                , tasty-hunit ^>= 0.10.0.2
-               , text ^>= 1.2.3
                , trifecta >= 2 && <3
                , unordered-containers ^>= 0.2.10

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

@@ -1,26 +1,34 @@
 {-# LANGUAGE ConstraintKinds, DataKinds, DefaultSignatures, DeriveAnyClass, DeriveGeneric, DerivingStrategies,
-             DerivingVia, DisambiguateRecordFields, FlexibleContexts, FlexibleInstances, NamedFieldPuns,
+             DerivingVia, DisambiguateRecordFields, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,
-             OverloadedLists, OverloadedStrings, ScopedTypeVariables, StandaloneDeriving, TypeApplications,
+             NamedFieldPuns, OverloadedLists, OverloadedStrings, ScopedTypeVariables, StandaloneDeriving,
-             TypeOperators, UndecidableInstances #-}
+             TypeApplications, TypeOperators, UndecidableInstances #-}
 
 module Language.Python.Core
 ( compile
+, SourcePath
 ) where
 
 import Prelude hiding (fail)
 
 import           Control.Effect hiding ((:+:))
+import           Control.Effect.Reader
 import           Control.Monad.Fail
 import           Data.Core as Core
 import           Data.Foldable
+import qualified Data.Loc
 import           Data.Name as Name
+import           Data.String (IsString)
+import           Data.Text (Text)
 import           GHC.Generics
 import           GHC.Records
-import qualified Data.Loc
 import qualified TreeSitter.Python.AST as Py
 import           TreeSitter.Span (Span)
 import qualified TreeSitter.Span as TreeSitter
 
+newtype SourcePath = SourcePath { rawPath :: Text }
+  deriving stock (Eq, Show)
+  deriving newtype IsString
+
 -- We leave the representation of Core syntax abstract so that it's not
 -- possible for us to 'cheat' by pattern-matching on or eliminating a
 -- compiled term.
@@ -32,21 +40,38 @@ type CoreSyntax sig t = ( Member Core sig
 
 class Compile py where
   -- FIXME: we should really try not to fail
-  compile :: (CoreSyntax sig t, MonadFail m) => py -> m (t Name)
+  compile :: ( CoreSyntax syn t
+             , Member (Reader SourcePath) sig
+             , Carrier sig m
+             , MonadFail m
+             )
+          => py
+          -> m (t Name)
 
   default compile :: (MonadFail m, Show py) => py -> m (t Name)
   compile = defaultCompile
 
-  compileCC :: (CoreSyntax sig t, MonadFail m) => py -> m (t Name) -> m (t Name)
+  compileCC :: ( CoreSyntax syn t
-
+               , Member (Reader SourcePath) sig
-  default compileCC :: (CoreSyntax sig t, MonadFail m) => py -> m (t Name) -> m (t Name)
+               , Carrier sig m
+               , MonadFail m
+               )
+            => py
+            -> m (t Name)
+            -> m (t Name)
   compileCC py cc = (>>>) <$> compile py <*> cc
 
-locate :: (HasField "ann" syntax Span, CoreSyntax sig t) => syntax -> t a -> t a
+locate :: ( HasField "ann" syntax Span
-locate syn = Core.annAt (locFromTSSpan (getField @"ann" syn))
+          , CoreSyntax syn t
-  where
+          , Member (Reader SourcePath) sig
-    locFromTSSpan (TreeSitter.Span (TreeSitter.Pos a b) (TreeSitter.Pos c d))
+          , Carrier sig m
-      = Data.Loc.Loc mempty (Data.Loc.Span (Data.Loc.Pos a b) (Data.Loc.Pos c d))
+          ) => syntax -> t a -> m (t a)
+locate syn item = do
+  fp <- asks @SourcePath rawPath
+  let locFromTSSpan (TreeSitter.Span (TreeSitter.Pos a b) (TreeSitter.Pos c d))
+        = Data.Loc.Loc fp (Data.Loc.Span (Data.Loc.Pos a b) (Data.Loc.Pos c d))
+
+  pure (Core.annAt (locFromTSSpan (getField @"ann" syn)) item)
 
 -- | TODO: This is not right, it should be a reference to a Preluded
 -- NoneType instance, but it will do for now.
@@ -71,7 +96,7 @@ instance Compile (Py.Assignment Span) where
   compile it@Py.Assignment { Py.left = Py.ExpressionList { Py.extraChildren = [lhs] }, Py.right = Just rhs } = do
     target <- compile lhs
     value  <- compile rhs
-    pure . locate it $ target .= value
+    locate it $ target .= value
   compile other = fail ("Unhandled assignment case: " <> show other)
 
 instance Compile (Py.AugmentedAssignment Span)
@@ -81,7 +106,7 @@ instance Compile (Py.BinaryOperator Span)
 instance Compile (Py.Block Span) where
   compile t = compileCC t (pure none)
 
-  compileCC it@Py.Block{ Py.extraChildren = body} cc = locate it <$> foldr compileCC cc body
+  compileCC it@Py.Block{ Py.extraChildren = body} cc = locate it =<< foldr compileCC cc body
 
 instance Compile (Py.BooleanOperator Span)
 instance Compile (Py.BreakStatement Span)
@@ -106,15 +131,15 @@ deriving via CompileSum (Py.Expression Span) instance Compile (Py.Expression Spa
 instance Compile (Py.ExpressionStatement Span) where
   compile it@Py.ExpressionStatement { Py.extraChildren = children } = do
     actions <- traverse compile children
-    pure . locate it $ do' (fmap (Nothing :<-) actions)
+    locate it $ do' (fmap (Nothing :<-) actions)
 
 instance Compile (Py.ExpressionList Span) where
   compile it@Py.ExpressionList { Py.extraChildren = exprs } = do
     actions <- traverse compile exprs
-    pure . locate it $ do' (fmap (Nothing :<-) actions)
+    locate it $ do' (fmap (Nothing :<-) actions)
 
 
-instance Compile (Py.False Span) where compile it = pure . locate it $ bool False
+instance Compile (Py.False Span) where compile it = locate it $ bool False
 
 instance Compile (Py.Float Span)
 instance Compile (Py.ForStatement Span)
@@ -127,7 +152,7 @@ instance Compile (Py.FunctionDefinition Span) where
     } = do
       parameters' <- traverse param parameters
       body' <- compile body
-      pure . locate it $ (pure name .= lams parameters' body')
+      locate it $ (pure name .= lams parameters' body')
     where param (Py.IdentifierParameter (Py.Identifier _pann pname)) = pure (named' pname)
           param x                                                    = unimplemented x
           unimplemented x = fail $ "unimplemented: " <> show x
@@ -143,7 +168,7 @@ instance Compile (Py.IfStatement Span) where
   compile stmt = compileCC stmt (pure none)
 
   compileCC it@Py.IfStatement{ condition, consequence, alternative} cc =
-    locate it <$> (if' <$> compile condition <*> compileCC consequence cc <*> foldr clause cc alternative)
+    locate it =<< (if' <$> compile condition <*> compileCC consequence cc <*> foldr clause cc alternative)
     where clause (Right Py.ElseClause{ body }) _ = compileCC body cc
           clause (Left  Py.ElifClause{ condition, consequence }) rest  =
             if' <$> compile condition <*> compileCC consequence cc <*> rest
@@ -162,7 +187,7 @@ instance Compile (Py.Module Span) where
     -- to top-level scope.
     res <- traverse compile stmts
     let names = concatMap toList res
-    pure . locate it . record $ zip names res
+    locate it . record $ zip names res
 
 instance Compile (Py.NamedExpression Span)
 instance Compile (Py.None Span)
@@ -171,7 +196,7 @@ instance Compile (Py.NotOperator Span)
 instance Compile (Py.ParenthesizedExpression Span)
 
 instance Compile (Py.PassStatement Span) where
-  compile it@Py.PassStatement {} = pure . locate it $ Core.unit
+  compile it@Py.PassStatement {} = locate it $ Core.unit
 
 deriving via CompileSum (Py.PrimaryExpression Span) instance Compile (Py.PrimaryExpression Span)
 
@@ -179,8 +204,8 @@ instance Compile (Py.PrintStatement Span)
 
 instance Compile (Py.ReturnStatement Span) where
   compile it@Py.ReturnStatement { Py.extraChildren = vals } = case vals of
-    Nothing -> pure . locate it $ none
+    Nothing -> locate it $ none
-    Just Py.ExpressionList { extraChildren = [val] } -> locate it <$> compile val
+    Just Py.ExpressionList { extraChildren = [val] } -> compile val >>= locate it
     Just Py.ExpressionList { extraChildren = vals  } -> fail ("unimplemented: return statement returning " <> show (length vals) <> " values")
 
   compileCC r _ = compile r
@@ -195,12 +220,12 @@ deriving via CompileSum (Py.SimpleStatement Span) instance Compile (Py.SimpleSta
 instance Compile (Py.String Span)
 instance Compile (Py.Subscript Span)
 
-instance Compile (Py.True Span) where compile it = pure . locate it $ bool True
+instance Compile (Py.True Span) where compile it = locate it $ bool True
 
 instance Compile (Py.TryStatement Span)
 
 instance Compile (Py.Tuple Span) where
-  compile it@Py.Tuple { Py.extraChildren = [] } = pure . locate it $ Core.unit
+  compile it@Py.Tuple { Py.extraChildren = [] } = locate it $ Core.unit
   compile it                                    = fail ("Unimplemented: non-empty tuple " <> show it)
 
 instance Compile (Py.UnaryOperator Span)
@@ -209,9 +234,17 @@ instance Compile (Py.WithStatement Span)
 instance Compile (Py.Yield Span)
 
 class GCompileSum f where
-  gcompileSum :: (CoreSyntax sig t, MonadFail m) => f a -> m (t Name)
+  gcompileSum :: ( CoreSyntax syn t
+                 , Member (Reader SourcePath) sig
+                 , Carrier sig m
+                 , MonadFail m
+                 ) => f a -> m (t Name)
 
-  gcompileCCSum :: (CoreSyntax sig t, MonadFail m) => f a -> m (t Name) -> m (t Name)
+  gcompileCCSum :: ( CoreSyntax syn t
+                   , Member (Reader SourcePath) sig
+                   , Carrier sig m
+                   , MonadFail m
+                   ) => f a -> m (t Name) -> m (t Name)
 
 instance GCompileSum f => GCompileSum (M1 D d f) where
   gcompileSum (M1 f) = gcompileSum f

semantic-python/test/Directive.hs

@@ -5,6 +5,12 @@ module Directive ( Directive (..)
                  ) where
 
 import           Control.Applicative
+import           Control.Monad
+import           Data.Name (Name)
+import           Data.Term (Term)
+import           Data.Core (Core)
+import qualified Data.Core.Parser as Core.Parser
+import qualified Data.Core.Pretty as Core.Pretty
 import           Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as ByteString
 import           Data.List.NonEmpty (NonEmpty)
@@ -37,11 +43,13 @@ projects.
 
 -}
 data Directive = JQ ByteString -- | @# CHECK-JQ: expr@
+               | Tree (Term Core Name) -- | @# CHECK-TREE: core@
                | Fails -- | @# CHECK-FAILS@ fails unless translation fails.
                  deriving (Eq, Show)
 
 describe :: Directive -> String
 describe Fails = "<expect failure>"
+describe (Tree t) =  Core.Pretty.showCore t
 describe (JQ b) = ByteString.unpack b
 
 fails :: Trifecta.Parser Directive
@@ -52,8 +60,13 @@ jq = do
   Trifecta.string "# CHECK-JQ: "
   JQ . ByteString.pack <$> many (Trifecta.noneOf "\n")
 
+tree :: Trifecta.Parser Directive
+tree = do
+  void $ Trifecta.string "# CHECK-TREE: "
+  Tree <$> (Core.Parser.record <|> Core.Parser.comp)
+
 directive :: Trifecta.Parser Directive
-directive = fails <|> jq
+directive = Trifecta.choice [ fails, jq, tree ]
 
 toplevel :: Trifecta.Parser (NonEmpty Directive)
 toplevel = directive `Trifecta.sepEndByNonEmpty` Trifecta.char '\n'

semantic-python/test/Test.hs

@@ -5,6 +5,7 @@ module Main (main) where
 import qualified Analysis.Eval as Eval
 import           Control.Effect
 import           Control.Effect.Fail
+import           Control.Effect.Reader
 import           Control.Monad hiding (fail)
 import           Control.Monad.Catch
 import           Control.Monad.IO.Class
@@ -23,6 +24,7 @@ import           Data.Loc
 import           Data.Maybe
 import           Data.Name
 import           Data.Term
+import           Data.String (fromString)
 import           GHC.Stack
 import qualified Language.Python.Core as Py
 import           Prelude hiding (fail)
@@ -30,12 +32,14 @@ import           Streaming
 import qualified Streaming.Process
 import           System.Directory
 import           System.Exit
-import           System.FilePath
 import qualified TreeSitter.Span as TS (Span)
 import qualified TreeSitter.Python as TSP
 import qualified TreeSitter.Python.AST as TSP
 import qualified TreeSitter.Unmarshal as TS
 import           Text.Show.Pretty (ppShow)
+import qualified System.Path as Path
+import qualified System.Path.Directory as Path
+import           System.Path ((</>))
 
 import qualified Test.Tasty as Tasty
 import qualified Test.Tasty.HUnit as HUnit
@@ -44,6 +48,7 @@ import           Analysis.ScopeGraph
 import qualified Directive
 import           Instances ()
 
+
 assertJQExpressionSucceeds :: Show a => Directive.Directive -> a -> Term (Ann :+: Core) Name -> HUnit.Assertion
 assertJQExpressionSucceeds directive tree core = do
   bod <- case scopeGraph Eval.eval [File interactive core] of
@@ -68,29 +73,38 @@ assertJQExpressionSucceeds directive tree core = do
   catch @_ @Streaming.Process.ProcessExitedUnsuccessfully jqPipeline $ \err -> do
     HUnit.assertFailure (unlines [errorMsg, dirMsg, jsonMsg, astMsg, treeMsg, treeMsg', show err])
 
-fixtureTestTreeForFile :: HasCallStack => FilePath -> Tasty.TestTree
+fixtureTestTreeForFile :: HasCallStack => Path.RelFile -> Tasty.TestTree
-fixtureTestTreeForFile fp = HUnit.testCaseSteps fp $ \step -> withFrozenCallStack $ do
+fixtureTestTreeForFile fp = HUnit.testCaseSteps (Path.toString fp) $ \step -> withFrozenCallStack $ do
-  fileContents <- ByteString.readFile ("semantic-python/test/fixtures" </> fp)
+  let fullPath = Path.relDir "semantic-python/test/fixtures" </> fp
+
+  fileContents <- ByteString.readFile (Path.toString fullPath)
   directives <- case Directive.parseDirectives fileContents of
     Right dir -> pure dir
     Left err  -> HUnit.assertFailure ("Directive parsing error: " <> err)
 
   result <- TS.parseByteString TSP.tree_sitter_python fileContents
-  let coreResult = fmap (Control.Effect.run . runFail . Py.compile @(TSP.Module TS.Span) @_ @(Term (Ann :+: Core))) result
+  let coreResult = Control.Effect.run
+                   . runFail
+                   . runReader (fromString @Py.SourcePath . Path.toString $ fp)
+                   . Py.compile @(TSP.Module TS.Span) @_ @(Term (Ann :+: Core))
+                   <$> result
+
   for_ directives $ \directive -> do
     step (Directive.describe directive)
-    case coreResult of
+    case (coreResult, directive) of
-      Left err           -> HUnit.assertFailure ("Parsing failed: " <> err)
+      (Right (Left _), Directive.Fails)      -> pure ()
-      Right (Left _)     | directive == Directive.Fails -> pure ()
+      (Left err, _)                          -> HUnit.assertFailure ("Parsing failed: " <> err)
-      Right (Right _)    | directive == Directive.Fails -> HUnit.assertFailure ("Expected translation to fail")
+      (Right (Left err), _)                  -> HUnit.assertFailure ("Compilation failed: " <> err)
-      Right (Right item) -> assertJQExpressionSucceeds directive result item
+      (Right (Right _), Directive.Fails)     -> HUnit.assertFailure ("Expected translation to fail")
-      Right (Left err)   -> HUnit.assertFailure ("Compilation failed: " <> err)
+      (Right (Right item), Directive.JQ _)   -> assertJQExpressionSucceeds directive result item
-
+      (Right (Right item), Directive.Tree t) -> let msg = "lhs = " <> showCore t <> "\n rhs " <> showCore item'
+                                                    item' = stripAnnotations item
+                                                in HUnit.assertEqual msg t item' where
 
 milestoneFixtures :: IO Tasty.TestTree
 milestoneFixtures = do
-  files <- liftIO (listDirectory "semantic-python/test/fixtures")
+  files <- liftIO (Path.filesInDir (Path.relDir "semantic-python/test/fixtures"))
-  let pythons = sort (filter ("py" `isExtensionOf`) files)
+  let pythons = sort (filter (Path.hasExtension ".py") files)
   pure $ Tasty.testGroup "Translation" (fmap fixtureTestTreeForFile pythons)
 
 main :: IO ()

semantic-python/test/fixtures/1-03-empty-tuple.py

@@ -1,2 +1,3 @@
-# CHECK-JQ: .scope == {} and .tree.contents == []
+# CHECK-JQ: .scope == {}
+# CHECK-TREE: #record {}
 ()

semantic-python/test/fixtures/2-01-return-statement.py

@@ -1,3 +1,3 @@
-# CHECK-JQ: .tree.contents[0][1].contents[1].contents.value.value == []
+# CHECK-TREE: #record { foo : foo = (\a -> a) }
 def foo(a):
     return a

semantic-python/test/fixtures/2-02-return-doesnt-translate.py

@@ -1,4 +1,4 @@
-# CHECK-JQ: .tree.contents[0][1].contents[1].contents.value.value == []
+# CHECK-TREE: #record { foo : foo = (\a -> a) }
 
 def foo(a):
     return a

semantic.cabal

@@ -329,8 +329,6 @@ library
                      , tree-sitter-java == 0.2.0.0
   if flag(release)
     cpp-options:       -DCOMPUTE_GIT_SHA
-  else
-    ghc-options:       +RTS -A128m -n2m -RTS
 
 executable semantic
   import:              haskell, dependencies, executable-flags