diff --git a/.licenses/semantic/cabal/cryptohash.txt b/.licenses/semantic/cabal/cryptohash.txt deleted file mode 100644 index 7f355aff1..000000000 --- a/.licenses/semantic/cabal/cryptohash.txt +++ /dev/null @@ -1,35 +0,0 @@ ---- -type: cabal -name: cryptohash -version: 0.11.9 -summary: collection of crypto hashes, fast, pure and practical -homepage: https://github.com/vincenthz/hs-cryptohash -license: bsd-3-clause ---- -Copyright (c) 2010-2014 Vincent Hanquez - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. diff --git a/.licenses/semantic/cabal/free.txt b/.licenses/semantic/cabal/free.txt deleted file mode 100644 index c0380c917..000000000 --- a/.licenses/semantic/cabal/free.txt +++ /dev/null @@ -1,38 +0,0 @@ ---- -type: cabal -name: free -version: '5.1' -summary: Monads for free -homepage: https://github.com/ekmett/free/ -license: bsd-3-clause ---- -Copyright 2008-2013 Edward Kmett - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, -STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN -ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. diff --git a/.licenses/semantic/cabal/http-client-tls.txt b/.licenses/semantic/cabal/http-client-tls.txt deleted file mode 100644 index 398db97fb..000000000 --- a/.licenses/semantic/cabal/http-client-tls.txt +++ /dev/null @@ -1,28 +0,0 @@ ---- -type: cabal -name: http-client-tls -version: 0.3.5.3 -summary: http-client backend using the connection package and tls library -homepage: https://github.com/snoyberg/http-client -license: mit ---- -The MIT License (MIT) - -Copyright (c) 2013 Michael Snoyman - -Permission is hereby granted, free of charge, to any person obtaining a copy of -this software and associated documentation files (the "Software"), to deal in -the Software without restriction, including without limitation the rights to -use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of -the Software, and to permit persons to whom the Software is furnished to do so, -subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS -FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR -COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. \ No newline at end of file diff --git a/.licenses/semantic/cabal/http-client.txt b/.licenses/semantic/cabal/http-client.txt deleted file mode 100644 index afc1a3454..000000000 --- a/.licenses/semantic/cabal/http-client.txt +++ /dev/null @@ -1,28 +0,0 @@ ---- -type: cabal -name: http-client -version: 0.5.14 -summary: An HTTP client engine -homepage: https://github.com/snoyberg/http-client -license: mit ---- -The MIT License (MIT) - -Copyright (c) 2013 Michael Snoyman - -Permission is hereby granted, free of charge, to any person obtaining a copy of -this software and associated documentation files (the "Software"), to deal in -the Software without restriction, including without limitation the rights to -use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of -the Software, and to permit persons to whom the Software is furnished to do so, -subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS -FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR -COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. \ No newline at end of file diff --git a/.licenses/semantic/cabal/http-media.txt b/.licenses/semantic/cabal/http-media.txt deleted file mode 100644 index 1013aec70..000000000 --- a/.licenses/semantic/cabal/http-media.txt +++ /dev/null @@ -1,28 +0,0 @@ ---- -type: cabal -name: http-media -version: 0.7.1.3 -summary: Processing HTTP Content-Type and Accept headers -homepage: https://github.com/zmthy/http-media -license: mit ---- -Copyright (c) 2012-2015 Timothy Jones - -Permission is hereby granted, free of charge, to any person obtaining a -copy of this software and associated documentation files (the -"Software"), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: - -The above copyright notice and this permission notice shall be included -in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. \ No newline at end of file diff --git a/.licenses/semantic/cabal/http-types.txt b/.licenses/semantic/cabal/http-types.txt deleted file mode 100644 index f2be57f9f..000000000 --- a/.licenses/semantic/cabal/http-types.txt +++ /dev/null @@ -1,39 +0,0 @@ ---- -type: cabal -name: http-types -version: 0.12.3 -summary: Generic HTTP types for Haskell (for both client and server code). -homepage: https://github.com/aristidb/http-types -license: bsd-3-clause ---- -Copyright (c) 2011, Aristid Breitkreuz -Copyright (c) 2011, Michael Snoyman - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Aristid Breitkreuz nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/semantic-python/semantic-python.cabal b/semantic-python/semantic-python.cabal index 1ca633456..83d9bf52c 100644 --- a/semantic-python/semantic-python.cabal +++ b/semantic-python/semantic-python.cabal @@ -67,6 +67,7 @@ test-suite test , pathtype ^>= 0.8.1 , pretty-show ^>= 1.9.5 , process ^>= 1.6.5 + , resourcet ^>= 1.2.2 , streaming ^>= 0.2.2 , streaming-process ^>= 0.1 , streaming-bytestring ^>= 0.1.6 diff --git a/semantic-python/src/Language/Python/Core.hs b/semantic-python/src/Language/Python/Core.hs index 8279d3996..b259be847 100644 --- a/semantic-python/src/Language/Python/Core.hs +++ b/semantic-python/src/Language/Python/Core.hs @@ -53,22 +53,8 @@ type CoreSyntax sig t = ( Member Core sig ) class Compile py where - -- Should this go away, and should compileCC be the main function to call? - -- FIXME: rather than failing the compilation process entirely -- with MonadFail, we should emit core that represents failure - compile :: ( CoreSyntax syn t - , Member (Reader SourcePath) sig - , Member (Reader Bindings) sig - , Carrier sig m - , MonadFail m - ) - => py - -> m (t Name) - - default compile :: (MonadFail m, Show py) => py -> m (t Name) - compile = defaultCompile - compileCC :: ( CoreSyntax syn t , Member (Reader SourcePath) sig , Member (Reader Bindings) sig @@ -78,8 +64,24 @@ class Compile py where => py -> m (t Name) -> m (t Name) - compileCC py cc = (>>>) <$> compile py <*> cc + default compileCC :: (MonadFail m, Show py) => py -> m (t Name) -> m (t Name) + compileCC a _ = defaultCompile a + +-- | TODO: This is not right, it should be a reference to a Preluded +-- NoneType instance, but it will do for now. +none :: (Member Core sig, Carrier sig t) => t Name +none = unit + +compile :: ( Compile py + , CoreSyntax syn t + , Member (Reader SourcePath) sig + , Member (Reader Bindings) sig + , Carrier sig m + , MonadFail m + ) + => py -> m (t Name) +compile t = compileCC t (pure none) locate :: ( HasField "ann" syntax Span , CoreSyntax syn t @@ -93,30 +95,12 @@ locate syn item = do 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. -none :: (Member Core sig, Carrier sig t) => t Name -none = unit - --- | Helper for delegating to compileCC. The presence of this function indicates --- that we might want to move 'compile' out of the Compile class entirely. -viaCompileCC :: ( Compile py - , CoreSyntax syn t - , Member (Reader SourcePath) sig - , Member (Reader Bindings) sig - , Carrier sig m - , MonadFail m - ) - => py -> m (t Name) -viaCompileCC t = compileCC t (pure none) - defaultCompile :: (MonadFail m, Show py) => py -> m (t Name) defaultCompile t = fail $ "compilation unimplemented for " <> show t newtype CompileSum py = CompileSum py instance (Generic py, GCompileSum (Rep py)) => Compile (CompileSum py) where - compile (CompileSum a) = gcompileSum . from $ a compileCC (CompileSum a) cc = gcompileCCSum (from a) cc deriving via CompileSum (Either l r) instance (Compile l, Compile r) => Compile (Either l r) @@ -138,8 +122,6 @@ instance Compile (Py.Assignment Span) where locate it =<< assigning <$> local (def name) cc compileCC other _ = fail ("Unhandled assignment case: " <> show other) - compile = viaCompileCC - instance Compile (Py.AugmentedAssignment Span) instance Compile (Py.Await Span) instance Compile (Py.BinaryOperator Span) @@ -147,8 +129,6 @@ instance Compile (Py.BinaryOperator Span) instance Compile (Py.Block Span) where compileCC it@Py.Block{ Py.extraChildren = body} cc = locate it =<< foldr compileCC cc body - compile = viaCompileCC - instance Compile (Py.BooleanOperator Span) instance Compile (Py.BreakStatement Span) instance Compile (Py.Call Span) @@ -174,14 +154,16 @@ instance Compile (Py.ExpressionStatement Span) where { Py.extraChildren = children } cc = do foldr compileCC cc children >>= locate it - compile = viaCompileCC instance Compile (Py.ExpressionList Span) where - compile it@Py.ExpressionList { Py.extraChildren = [child] } = compile child >>= locate it - compile Py.ExpressionList { Py.extraChildren = items } = fail ("unimplemented: ExpressionList of length " <> show items) + compileCC it@Py.ExpressionList { Py.extraChildren = [child] } cc + = compileCC child cc >>= locate it + compileCC Py.ExpressionList { Py.extraChildren = items } _ + = fail ("unimplemented: ExpressionList of length " <> show items) -instance Compile (Py.False Span) where compile it = locate it $ bool False +instance Compile (Py.False Span) where + compileCC it _ = locate it $ bool False instance Compile (Py.Float Span) instance Compile (Py.ForStatement Span) @@ -206,14 +188,12 @@ instance Compile (Py.FunctionDefinition Span) where unimplemented x = fail $ "unimplemented: " <> show x assigning item f = (Name.named' name :<- item) >>>= f - compile = viaCompileCC - instance Compile (Py.FutureImportStatement Span) instance Compile (Py.GeneratorExpression Span) instance Compile (Py.GlobalStatement Span) instance Compile (Py.Identifier Span) where - compile Py.Identifier { bytes } = pure (pure bytes) + compileCC Py.Identifier { bytes } _ = pure (pure bytes) instance Compile (Py.IfStatement Span) where compileCC it@Py.IfStatement{ condition, consequence, alternative} cc = @@ -222,8 +202,6 @@ instance Compile (Py.IfStatement Span) where clause (Left Py.ElifClause{ condition, consequence }) rest = if' <$> compile condition <*> compileCC consequence cc <*> rest - compile = viaCompileCC - instance Compile (Py.ImportFromStatement Span) instance Compile (Py.ImportStatement Span) @@ -233,7 +211,7 @@ instance Compile (Py.List Span) instance Compile (Py.ListComprehension Span) instance Compile (Py.Module Span) where - compile it@Py.Module { Py.extraChildren = stmts } = do + compileCC it@Py.Module { Py.extraChildren = stmts } _cc = do -- This action gets passed to compileCC, which means it is the -- final action taken after the compiling fold finishes. It takes -- care of listening for the current set of bound variables (which @@ -252,20 +230,18 @@ instance Compile (Py.NotOperator Span) instance Compile (Py.ParenthesizedExpression Span) instance Compile (Py.PassStatement Span) where - compile it@Py.PassStatement {} = locate it $ Core.unit + compileCC it@Py.PassStatement {} _ = locate it $ Core.unit deriving via CompileSum (Py.PrimaryExpression Span) instance Compile (Py.PrimaryExpression Span) instance Compile (Py.PrintStatement Span) instance Compile (Py.ReturnStatement Span) where - compile it@Py.ReturnStatement { Py.extraChildren = vals } = case vals of + compileCC it@Py.ReturnStatement { Py.extraChildren = vals } _ = case vals of Nothing -> locate it $ none 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 - instance Compile (Py.RaiseStatement Span) instance Compile (Py.Set Span) @@ -276,13 +252,16 @@ 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 = locate it $ bool True +instance Compile (Py.True Span) where + compileCC it _ = locate it $ bool True instance Compile (Py.TryStatement Span) instance Compile (Py.Tuple Span) where - compile it@Py.Tuple { Py.extraChildren = [] } = locate it $ Core.unit - compile it = fail ("Unimplemented: non-empty tuple " <> show it) + compileCC it@Py.Tuple { Py.extraChildren = [] } _ = locate it unit + + compileCC it _ + = fail ("Unimplemented: non-empty tuple " <> show it) instance Compile (Py.UnaryOperator Span) instance Compile (Py.WhileStatement Span) @@ -290,13 +269,6 @@ instance Compile (Py.WithStatement Span) instance Compile (Py.Yield Span) class GCompileSum f where - gcompileSum :: ( CoreSyntax syn t - , Member (Reader SourcePath) sig - , Member (Reader Bindings) sig - , Carrier sig m - , MonadFail m - ) => f a -> m (t Name) - gcompileCCSum :: ( CoreSyntax syn t , Member (Reader SourcePath) sig , Member (Reader Bindings) sig @@ -305,16 +277,11 @@ class GCompileSum f where ) => f a -> m (t Name) -> m (t Name) instance GCompileSum f => GCompileSum (M1 D d f) where - gcompileSum (M1 f) = gcompileSum f gcompileCCSum (M1 f) = gcompileCCSum f instance (GCompileSum l, GCompileSum r) => GCompileSum (l :+: r) where - gcompileSum (L1 l) = gcompileSum l - gcompileSum (R1 r) = gcompileSum r - gcompileCCSum (L1 l) = gcompileCCSum l gcompileCCSum (R1 r) = gcompileCCSum r instance Compile t => GCompileSum (M1 C c (M1 S s (K1 R t))) where - gcompileSum (M1 (M1 (K1 t))) = compile t gcompileCCSum (M1 (M1 (K1 t))) = compileCC t diff --git a/semantic-python/test/Directive.hs b/semantic-python/test/Directive.hs index b37ac8b1e..d9ed052a2 100644 --- a/semantic-python/test/Directive.hs +++ b/semantic-python/test/Directive.hs @@ -1,5 +1,5 @@ module Directive ( Directive (..) - , parseDirectives + , parseDirective , describe , toProcess ) where @@ -14,7 +14,6 @@ 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) -import Data.Coerce import System.Process import qualified Text.Trifecta as Trifecta @@ -57,23 +56,20 @@ fails = Fails <$ Trifecta.string "# CHECK-FAILS" jq :: Trifecta.Parser Directive jq = do - Trifecta.string "# CHECK-JQ: " + void $ 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) + Tree <$> Core.Parser.core directive :: Trifecta.Parser Directive directive = Trifecta.choice [ fails, jq, tree ] -toplevel :: Trifecta.Parser (NonEmpty Directive) -toplevel = directive `Trifecta.sepEndByNonEmpty` Trifecta.char '\n' - -parseDirectives :: ByteString -> Either String (NonEmpty Directive) -parseDirectives = Trifecta.foldResult (Left . show) Right - . Trifecta.parseByteString toplevel mempty +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] diff --git a/semantic-python/test/Test.hs b/semantic-python/test/Test.hs index e07092f2f..540f37a5b 100644 --- a/semantic-python/test/Test.hs +++ b/semantic-python/test/Test.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, DerivingStrategies, GeneralizedNewtypeDeriving, OverloadedStrings, TypeApplications, TypeOperators #-} +{-# LANGUAGE DeriveAnyClass, DerivingStrategies, GeneralizedNewtypeDeriving, OverloadedStrings, TypeApplications, TypeOperators, ScopedTypeVariables #-} module Main (main) where @@ -9,6 +9,7 @@ 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 qualified Data.Aeson as Aeson import qualified Data.Aeson.Encode.Pretty as Aeson import qualified Data.ByteString.Char8 as ByteString @@ -29,6 +30,7 @@ import GHC.Stack import qualified Language.Python.Core as Py import Prelude hiding (fail) import Streaming +import qualified Streaming.Prelude as Stream import qualified Streaming.Process import System.Directory import System.Exit @@ -75,14 +77,25 @@ assertJQExpressionSucceeds directive tree core = do fixtureTestTreeForFile :: HasCallStack => Path.RelFile -> Tasty.TestTree fixtureTestTreeForFile fp = HUnit.testCaseSteps (Path.toString fp) $ \step -> withFrozenCallStack $ do - let fullPath = Path.relDir "semantic-python/test/fixtures" fp + let fullPath = Path.relDir "semantic-python/test/fixtures" fp + perish s = liftIO (HUnit.assertFailure ("Directive parsing error: " <> s)) + isComment = (== Just '#') . fmap fst . ByteString.uncons - 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 + -- 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 let coreResult = Control.Effect.run . runFail . runReader (fromString @Py.SourcePath . Path.toString $ fp) diff --git a/semantic-python/test/fixtures/1-03-empty-tuple.py b/semantic-python/test/fixtures/1-03-empty-tuple.py index 28b0dc680..8a1c2671e 100644 --- a/semantic-python/test/fixtures/1-03-empty-tuple.py +++ b/semantic-python/test/fixtures/1-03-empty-tuple.py @@ -1,3 +1,3 @@ # CHECK-JQ: .scope == {} -# CHECK-TREE: { #unit; #record {} } +# CHECK-TREE: (#unit) () diff --git a/semantic.cabal b/semantic.cabal index 01eae1fda..80b066f3b 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -53,7 +53,6 @@ common dependencies , containers ^>= 0.6.0.1 , directory ^>= 1.3.3.0 , fastsum ^>= 0.1.1.0 - , free ^>= 5.1 , fused-effects ^>= 0.5.0.0 , fused-effects-exceptions ^>= 0.2.0.0 , hashable ^>= 1.2.7.0 @@ -283,7 +282,6 @@ library , array ^>= 0.5.3.0 , attoparsec ^>= 0.13.2.2 , cmark-gfm == 0.1.8 - , cryptohash ^>= 0.11.9 , deepseq ^>= 1.4.4.0 , directory-tree ^>= 0.12.1 , filepath ^>= 1.4.2.1 @@ -293,10 +291,6 @@ library , haskeline ^>= 0.7.5.0 , hostname ^>= 1.0 , hscolour ^>= 1.24.4 - , http-client ^>= 0.6.2 - , http-client-tls ^>= 0.3.5.3 - , http-types ^>= 0.12.3 - , http-media ^>= 0.7.1.3 , kdt ^>= 0.2.4 , lens ^>= 4.17 , mersenne-random-pure64 ^>= 0.2.2.0 @@ -405,9 +399,12 @@ test-suite parse-examples main-is: Examples.hs build-depends: semantic , Glob - , hspec - , hspec-core - , hspec-expectations + , foldl ^>= 1.4.5 + , resourcet ^>= 1.2 + , streaming + , streaming-bytestring ^>= 0.1.6 + , tasty + , tasty-hunit benchmark evaluation import: haskell, executable-flags diff --git a/src/Data/Blob/IO.hs b/src/Data/Blob/IO.hs index 1af383d18..df942cba0 100644 --- a/src/Data/Blob/IO.hs +++ b/src/Data/Blob/IO.hs @@ -37,9 +37,9 @@ readBlobFromFile' file = do maybeM (Prelude.fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile -- | Read all blobs in the directory with Language.supportedExts. -readBlobsFromDir :: MonadIO m => FilePath -> m [Blob] +readBlobsFromDir :: MonadIO m => Path.AbsRelDir -> m [Blob] readBlobsFromDir path = liftIO . fmap catMaybes $ - findFilesInDir path supportedExts mempty >>= Async.mapConcurrently (readBlobFromFile . fileForPath) + findFilesInDir (Path.toString path) supportedExts mempty >>= Async.mapConcurrently (readBlobFromFile . fileForPath) readBlobsFromGitRepoPath :: (Part.AbsRel ar, MonadIO m) => Path.Dir ar -> Git.OID -> [Path.RelFile] -> [Path.RelFile] -> m [Blob] readBlobsFromGitRepoPath path oid excludePaths includePaths diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index 8fb4be461..03f3eeb6f 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -29,6 +29,7 @@ import Semantic.Env import Semantic.Telemetry import qualified Semantic.Telemetry.Error as Error import qualified Semantic.Telemetry.Stat as Stat +import Semantic.Version (buildSHA) import System.Environment import System.IO (hIsTerminalDevice, stdout) import System.Posix.Process @@ -52,7 +53,7 @@ data Config , configIsTerminal :: Flag IsTerminal -- ^ Whether a terminal is attached (set automaticaly at runtime). , configLogPrintSource :: Flag LogPrintSource -- ^ Whether to print the source reference when logging errors (set automatically at runtime). , configLogFormatter :: LogFormatter -- ^ Log formatter to use (set automatically at runtime). - , configSHA :: Maybe String -- ^ Optional SHA to include in log messages. + , configSHA :: String -- ^ SHA to include in log messages (set automatically). , configFailParsingForTesting :: Flag FailTestParsing -- ^ Simulate internal parse failure for testing (default: False). , configOptions :: Options -- ^ Options configurable via command line arguments. } @@ -97,7 +98,7 @@ defaultConfig options@Options{..} = do , configIsTerminal = flag IsTerminal isTerminal , configLogPrintSource = flag LogPrintSource isTerminal , configLogFormatter = if isTerminal then terminalFormatter else logfmtFormatter - , configSHA = Nothing + , configSHA = buildSHA , configFailParsingForTesting = flag FailTestParsing False , configOptions = options @@ -121,7 +122,7 @@ logOptionsFromConfig Config{..} = LogOptions | otherwise = [ ("app", configAppName) , ("pid", show configProcessID) , ("hostname", configHostName) - , ("sha", fromMaybe "development" configSHA) + , ("sha", configSHA) ] diff --git a/src/Semantic/Task/Files.hs b/src/Semantic/Task/Files.hs index 41f59395e..466263445 100644 --- a/src/Semantic/Task/Files.hs +++ b/src/Semantic/Task/Files.hs @@ -31,11 +31,12 @@ import Prologue hiding (catch) import qualified Semantic.Git as Git import Semantic.IO import qualified System.IO as IO +import qualified System.Path as Path data Source blob where FromPath :: File -> Source Blob FromHandle :: Handle 'IO.ReadMode -> Source [Blob] - FromDir :: FilePath -> Source [Blob] + FromDir :: Path.AbsRelDir -> Source [Blob] FromGitRepo :: FilePath -> Git.OID -> PathFilter -> Source [Blob] FromPathPair :: Both File -> Source BlobPair FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair] @@ -108,7 +109,7 @@ readBlobs (FilesFromHandle handle) = send (Read (FromHandle handle) pure) readBlobs (FilesFromPaths [path]) = do isDir <- isDirectory (filePath path) if isDir - then send (Read (FromDir (filePath path)) pure) + then send (Read (FromDir (Path.path (filePath path))) pure) else pure <$> send (Read (FromPath path) pure) readBlobs (FilesFromPaths paths) = traverse (send . flip Read pure . FromPath) paths readBlobs (FilesFromGitRepo path sha filter) = send (Read (FromGitRepo path sha filter) pure) diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs index d2ca561a5..af2177cde 100644 --- a/test/Data/Functor/Listable.hs +++ b/test/Data/Functor/Listable.hs @@ -11,16 +11,12 @@ module Data.Functor.Listable , cons5 , cons6 , (\/) -, ListableF(..) , addWeight , ofWeight , ListableSyntax ) where -import Analysis.CyclomaticComplexity import Analysis.TOCSummary -import Control.Monad.Free as Free -import Control.Monad.Trans.Free as FreeF import Data.Abstract.ScopeGraph (AccessControl(..)) import Data.Bifunctor.Join import Data.Diff @@ -30,20 +26,13 @@ import Data.List.NonEmpty import Data.Patch import Data.Semigroup.App import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Literal as Literal import qualified Data.Syntax.Comment as Comment import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Directive as Directive import qualified Data.Syntax.Statement as Statement -import qualified Data.Syntax.Expression as Expression -import qualified Language.Ruby.Syntax as Ruby.Syntax -import qualified Language.Python.Syntax as Python.Syntax import qualified Data.Abstract.Name as Name import Data.Term import Data.Text as T (Text, pack) -import Data.These import Data.Sum -import Diffing.Algorithm.RWS import Source.Loc import Source.Span import Test.LeanCheck @@ -110,18 +99,6 @@ liftCons6 :: [Tier a] -> [Tier b] -> [Tier c] -> [Tier d] -> [Tier e] -> [Tier f liftCons6 tiers1 tiers2 tiers3 tiers4 tiers5 tiers6 f = mapT (uncurry6 f) (tiers1 >< tiers2 >< tiers3 >< tiers4 >< tiers5 >< tiers6) `addWeight` 1 where uncurry6 g (a, (b, (c, (d, (e, f))))) = g a b c d e f --- | Convenient wrapper for 'Listable1' type constructors and 'Listable' types, where a 'Listable' instance would necessarily be orphaned. -newtype ListableF f a = ListableF { unListableF :: f a } - deriving Show - --- | Convenient wrapper for 'Listable2' type constructors and 'Listable' types, where a 'Listable' instance would necessarily be orphaned. -newtype ListableF2 f a b = ListableF2 { unListableF2 :: f a b } - deriving Show - -instance (Listable2 f, Listable a, Listable b) => Listable (ListableF2 f a b) where - tiers = ListableF2 `mapT` tiers2 - - -- Instances instance Listable1 Maybe where @@ -149,25 +126,6 @@ instance Listable2 p => Listable1 (Join p) where instance Listable1 Both where liftTiers tiers = liftCons2 tiers tiers Both -instance Listable2 These where - liftTiers2 this that = liftCons1 this This \/ liftCons1 that That \/ liftCons2 this that These - -instance Listable1 f => Listable2 (FreeF f) where - liftTiers2 pureTiers recurTiers = liftCons1 pureTiers FreeF.Pure \/ liftCons1 (liftTiers recurTiers) FreeF.Free - -instance (Listable1 f, Listable a) => Listable1 (FreeF f a) where - liftTiers = liftTiers2 tiers - -instance Listable1 f => Listable1 (Free.Free f) where - liftTiers pureTiers = go - where go = liftCons1 (liftTiers2 pureTiers go) free - free (FreeF.Free f) = Free.Free f - free (FreeF.Pure a) = Free.Pure a - -instance (Listable1 f, Listable a) => Listable (ListableF f a) where - tiers = ListableF `mapT` tiers1 - - instance Listable1 f => Listable2 (TermF f) where liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) In @@ -232,9 +190,6 @@ instance Listable1 Declaration.Method where instance Listable1 Statement.If where liftTiers tiers = liftCons3 tiers tiers tiers Statement.If -instance Listable1 Statement.Return where - liftTiers tiers = liftCons1 tiers Statement.Return - instance Listable1 Syntax.Context where liftTiers tiers = liftCons2 (liftTiers tiers) tiers Syntax.Context @@ -244,256 +199,6 @@ instance Listable1 Syntax.Empty where instance Listable1 Syntax.Identifier where liftTiers _ = cons1 Syntax.Identifier -instance Listable1 Literal.KeyValue where - liftTiers tiers = liftCons2 tiers tiers Literal.KeyValue - -instance Listable1 Literal.Array where - liftTiers tiers = liftCons1 (liftTiers tiers) Literal.Array - -instance Listable1 Literal.Boolean where - liftTiers _ = cons1 Literal.Boolean - -instance Listable1 Literal.Hash where - liftTiers tiers = liftCons1 (liftTiers tiers) Literal.Hash - -instance Listable1 Literal.Float where - liftTiers _ = cons1 Literal.Float - -instance Listable1 Literal.Null where - liftTiers _ = cons0 Literal.Null - -instance Listable1 Literal.TextElement where - liftTiers _ = cons1 Literal.TextElement - -instance Listable1 Literal.EscapeSequence where - liftTiers _ = cons1 Literal.EscapeSequence - -instance Listable1 Literal.InterpolationElement where - liftTiers tiers = liftCons1 tiers Literal.InterpolationElement - -instance Listable1 Literal.Character where - liftTiers _ = cons1 Literal.Character - -instance Listable1 Statement.Statements where - liftTiers tiers = liftCons1 (liftTiers tiers) Statement.Statements - -instance Listable1 Syntax.Error where - liftTiers tiers = liftCons4 mempty mempty mempty (liftTiers tiers) Syntax.Error - -instance Listable1 Directive.File where - liftTiers _ = cons0 Directive.File - -instance Listable1 Directive.Line where - liftTiers _ = cons0 Directive.Line - -instance Listable1 Expression.Plus where - liftTiers tiers = liftCons2 tiers tiers Expression.Plus - -instance Listable1 Expression.Minus where - liftTiers tiers = liftCons2 tiers tiers Expression.Minus - -instance Listable1 Expression.Times where - liftTiers tiers = liftCons2 tiers tiers Expression.Times - -instance Listable1 Expression.DividedBy where - liftTiers tiers = liftCons2 tiers tiers Expression.DividedBy - -instance Listable1 Expression.FloorDivision where - liftTiers tiers = liftCons2 tiers tiers Expression.FloorDivision - -instance Listable1 Expression.Modulo where - liftTiers tiers = liftCons2 tiers tiers Expression.Modulo - -instance Listable1 Expression.Power where - liftTiers tiers = liftCons2 tiers tiers Expression.Power - -instance Listable1 Expression.Negate where - liftTiers tiers = liftCons1 tiers Expression.Negate - -instance Listable1 Expression.BOr where - liftTiers tiers = liftCons2 tiers tiers Expression.BOr - -instance Listable1 Expression.BAnd where - liftTiers tiers = liftCons2 tiers tiers Expression.BAnd - -instance Listable1 Expression.BXOr where - liftTiers tiers = liftCons2 tiers tiers Expression.BXOr - -instance Listable1 Expression.LShift where - liftTiers tiers = liftCons2 tiers tiers Expression.LShift - -instance Listable1 Expression.RShift where - liftTiers tiers = liftCons2 tiers tiers Expression.RShift - -instance Listable1 Expression.UnsignedRShift where - liftTiers tiers = liftCons2 tiers tiers Expression.UnsignedRShift - -instance Listable1 Expression.Complement where - liftTiers tiers = liftCons1 tiers Expression.Complement - -instance Listable1 Expression.Or where - liftTiers tiers = liftCons2 tiers tiers Expression.Or - -instance Listable1 Expression.And where - liftTiers tiers = liftCons2 tiers tiers Expression.And - -instance Listable1 Expression.Not where - liftTiers tiers = liftCons1 tiers Expression.Not - -instance Listable1 Expression.XOr where - liftTiers tiers = liftCons2 tiers tiers Expression.XOr - -instance Listable1 Expression.Call where - liftTiers tiers = liftCons4 (liftTiers tiers) tiers (liftTiers tiers) tiers Expression.Call - -instance Listable1 Expression.LessThan where - liftTiers tiers = liftCons2 tiers tiers Expression.LessThan - -instance Listable1 Expression.LessThanEqual where - liftTiers tiers = liftCons2 tiers tiers Expression.LessThanEqual - -instance Listable1 Expression.GreaterThan where - liftTiers tiers = liftCons2 tiers tiers Expression.GreaterThan - -instance Listable1 Expression.GreaterThanEqual where - liftTiers tiers = liftCons2 tiers tiers Expression.GreaterThanEqual - -instance Listable1 Expression.Equal where - liftTiers tiers = liftCons2 tiers tiers Expression.Equal - -instance Listable1 Expression.StrictEqual where - liftTiers tiers = liftCons2 tiers tiers Expression.StrictEqual - -instance Listable1 Expression.Comparison where - liftTiers tiers = liftCons2 tiers tiers Expression.Comparison - -instance Listable1 Expression.Enumeration where - liftTiers tiers = liftCons3 tiers tiers tiers Expression.Enumeration - -instance Listable1 Expression.Matches where - liftTiers tiers = liftCons2 tiers tiers Expression.Matches - -instance Listable1 Expression.NotMatches where - liftTiers tiers = liftCons2 tiers tiers Expression.NotMatches - -instance Listable1 Expression.MemberAccess where - liftTiers tiers = liftCons2 tiers mempty Expression.MemberAccess - -instance Listable1 Expression.ScopeResolution where - liftTiers tiers = liftCons1 (liftTiers tiers) Expression.ScopeResolution - -instance Listable1 Expression.Subscript where - liftTiers tiers = liftCons2 tiers (liftTiers tiers) Expression.Subscript - -instance Listable1 Expression.Member where - liftTiers tiers = liftCons2 tiers tiers Expression.Member - -instance Listable1 Expression.This where - liftTiers _ = cons0 Expression.This - -instance Listable1 Literal.Complex where - liftTiers _ = cons1 Literal.Complex - -instance Listable1 Literal.Integer where - liftTiers _ = cons1 Literal.Integer - -instance Listable1 Literal.Rational where - liftTiers _ = cons1 Literal.Rational - -instance Listable1 Literal.Regex where - liftTiers _ = cons1 Literal.Regex - -instance Listable1 Literal.String where - liftTiers tiers = liftCons1 (liftTiers tiers) Literal.String - -instance Listable1 Literal.Symbol where - liftTiers tiers = liftCons1 (liftTiers tiers) Literal.Symbol - -instance Listable1 Literal.SymbolElement where - liftTiers _ = cons1 Literal.SymbolElement - -instance Listable1 Statement.Assignment where - liftTiers tiers = liftCons3 (liftTiers tiers) tiers tiers Statement.Assignment - -instance Listable1 Statement.Break where - liftTiers tiers = liftCons1 tiers Statement.Break - -instance Listable1 Statement.Catch where - liftTiers tiers = liftCons2 tiers tiers Statement.Catch - -instance Listable1 Statement.Continue where - liftTiers tiers = liftCons1 tiers Statement.Continue - -instance Listable1 Statement.Else where - liftTiers tiers = liftCons2 tiers tiers Statement.Else - -instance Listable1 Statement.Finally where - liftTiers tiers = liftCons1 tiers Statement.Finally - -instance Listable1 Statement.ForEach where - liftTiers tiers = liftCons3 tiers tiers tiers Statement.ForEach - -instance Listable1 Statement.Match where - liftTiers tiers = liftCons2 tiers tiers Statement.Match - -instance Listable1 Statement.Pattern where - liftTiers tiers = liftCons2 tiers tiers Statement.Pattern - -instance Listable1 Statement.Retry where - liftTiers tiers = liftCons1 tiers Statement.Retry - -instance Listable1 Statement.ScopeEntry where - liftTiers tiers = liftCons1 (liftTiers tiers) Statement.ScopeEntry - -instance Listable1 Statement.ScopeExit where - liftTiers tiers = liftCons1 (liftTiers tiers) Statement.ScopeExit - -instance Listable1 Statement.Try where - liftTiers tiers = liftCons2 tiers (liftTiers tiers) Statement.Try - -instance Listable1 Statement.While where - liftTiers tiers = liftCons2 tiers tiers Statement.While - -instance Listable1 Statement.Yield where - liftTiers tiers = liftCons1 tiers Statement.Yield - -instance Listable1 Ruby.Syntax.Assignment where - liftTiers tiers = liftCons3 (liftTiers tiers) tiers tiers Ruby.Syntax.Assignment - -instance Listable1 Ruby.Syntax.Class where - liftTiers tiers = liftCons3 tiers (liftTiers tiers) tiers Ruby.Syntax.Class - -instance Listable1 Ruby.Syntax.Load where - liftTiers tiers = liftCons2 tiers (liftTiers tiers) Ruby.Syntax.Load - -instance Listable1 Ruby.Syntax.LowPrecedenceOr where - liftTiers tiers = liftCons2 tiers tiers Ruby.Syntax.LowPrecedenceOr - -instance Listable1 Ruby.Syntax.LowPrecedenceAnd where - liftTiers tiers = liftCons2 tiers tiers Ruby.Syntax.LowPrecedenceAnd - -instance Listable1 Ruby.Syntax.Module where - liftTiers tiers = liftCons2 tiers (liftTiers tiers) Ruby.Syntax.Module - -instance Listable1 Ruby.Syntax.Require where - liftTiers tiers' = liftCons2 tiers tiers' Ruby.Syntax.Require - -instance Listable1 Ruby.Syntax.ZSuper where - liftTiers _ = cons0 Ruby.Syntax.ZSuper - -instance Listable1 Ruby.Syntax.Send where - liftTiers tiers = liftCons4 (liftTiers tiers) (liftTiers tiers) (liftTiers tiers) (liftTiers tiers) Ruby.Syntax.Send - -instance Listable Python.Syntax.QualifiedName where - tiers = liftCons1 tiers1 Python.Syntax.QualifiedName \/ liftCons2 tiers tiers1 Python.Syntax.RelativeQualifiedName - -instance Listable1 Python.Syntax.Import where - liftTiers tiers' = liftCons2 tiers (liftTiers tiers') Python.Syntax.Import - -instance Listable1 Python.Syntax.Alias where - liftTiers tiers = liftCons2 tiers tiers Python.Syntax.Alias - - type ListableSyntax = Sum '[ Comment.Comment , Declaration.Function @@ -508,13 +213,6 @@ type ListableSyntax = Sum instance Listable Name.Name where tiers = cons1 Name.name -instance Listable1 Gram where - liftTiers tiers = liftCons2 (liftTiers (liftTiers tiers)) (liftTiers (liftTiers tiers)) Gram - -instance Listable a => Listable (Gram a) where - tiers = tiers1 - - instance Listable Text where tiers = pack `mapT` tiers @@ -524,9 +222,6 @@ instance Listable Declaration where \/ cons4 FunctionDeclaration \/ cons3 (\ a b c -> ErrorDeclaration a b c Language.Unknown) -instance Listable CyclomaticComplexity where - tiers = cons1 CyclomaticComplexity - instance Listable Language.Language where tiers = cons0 Language.Go diff --git a/test/Examples.hs b/test/Examples.hs index c0f59b3aa..50b476559 100644 --- a/test/Examples.hs +++ b/test/Examples.hs @@ -1,90 +1,53 @@ {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -O1 #-} module Main (main) where import Control.Effect import Control.Exception (displayException) +import qualified Control.Foldl as Foldl +import Data.Function ((&)) +import Control.Concurrent.Async (forConcurrently) import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Trans.Resource (ResIO, runResourceT) +import Data.Blob import qualified Data.ByteString as B import Data.ByteString.Builder import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.ByteString.Streaming.Char8 as ByteStream import Data.Either -import Data.Blob (fileForRelPath) -import Data.Flag -import Data.Foldable -import Data.List -import Data.Maybe -import Data.Quieterm -import Data.Typeable (cast) -import Data.Void -import Parsing.Parser -import Semantic.Api (TermOutputFormat (..), parseTermBuilder) -import Semantic.Config (Config (..), Options (..), FailOnWarning (..), defaultOptions) -import qualified Semantic.IO as IO -import Semantic.Task -import Semantic.Task.Files -import System.Directory -import System.Exit (die) +import Data.Set (Set) +import Data.Traversable +import Data.Typeable +import qualified Streaming.Prelude as Stream import System.FilePath.Glob -import qualified System.Path as Path import System.Path (()) -import System.Process -import Test.Hspec +import qualified System.Path as Path +import qualified System.Process as Process +import Data.Flag +import Semantic.Api (TermOutputFormat (..), parseTermBuilder) +import Semantic.Config as Config +import Semantic.Task +import Semantic.Task.Files -main :: IO () -main = withOptions opts $ \ config logger statter -> hspec . parallel $ do - let args = TaskSession config "-" False logger statter - - runIO setupExampleRepos - - for_ languages $ \ lang@LanguageExample{..} -> do - let tsLang = Path.relDir ("tree-sitter-" <> languageName) - tsDir = languagesDir tsLang Path.relDir "vendor" tsLang - parallel . describe languageName $ parseExamples args lang tsDir - - where - parseExamples session LanguageExample{..} tsDir = do - knownFailures <- runIO $ knownFailuresForPath tsDir languageKnownFailuresTxt - files <- runIO $ globDir1 (compile ("**/*" <> languageExtension)) (Path.toString (tsDir languageExampleDir)) - let paths = Path.relFile <$> files - for_ paths $ \file -> it (Path.toString file) $ do - res <- runTask session (parseFilePath file) - case res of - Left (SomeException e) -> case cast e of - -- We have a number of known assignment timeouts, consider these pending specs instead of failing the build. - Just AssignmentTimedOut -> pendingWith $ show (displayException e) - Just ParserTimedOut -> pendingWith $ show (displayException e) - -- Other exceptions are true failures - _ -> expectationFailure (show (displayException e)) - _ -> if file `elem` knownFailures - then pendingWith $ "Known parse failures " <> show ("Assignment: OK" <$ res) - else res `shouldSatisfy` isRight - - setupExampleRepos = readProcess "script/clone-example-repos" mempty mempty >>= print - opts = defaultOptions { optionsFailOnWarning = flag FailOnWarning True, optionsLogLevel = Nothing } - - knownFailuresForPath :: Path.RelDir -> Maybe Path.RelFile -> IO [Path.RelFile] - knownFailuresForPath _ Nothing = pure [] - knownFailuresForPath tsDir (Just path) = do - known <- BC.lines <$> B.readFile (Path.toString (tsDir path)) - let stripComments = filter (\line -> not (BC.null line) && BC.head line == '#') - let failures = Path.relFile . BC.unpack <$> stripComments known - pure ((tsDir ) <$> failures) +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as HUnit data LanguageExample = LanguageExample - { languageName :: String - , languageExtension :: String - , languageExampleDir :: Path.RelDir + { languageName :: String + , languageExtension :: String + , languageExampleDir :: Path.RelDir , languageKnownFailuresTxt :: Maybe Path.RelFile } deriving (Eq, Show) le :: String -> String -> Path.RelDir -> Maybe Path.RelFile -> LanguageExample le = LanguageExample -languages :: [LanguageExample] -languages = +examples :: [LanguageExample] +examples = [ le "python" ".py" examples (Just $ Path.relFile "script/known_failures.txt") , le "ruby" ".rb" examples (Just $ Path.relFile "script/known_failures.txt") , le "typescript" ".ts" examples (Just $ Path.relFile "typescript/script/known_failures.txt") @@ -105,8 +68,57 @@ languages = -- , ("php", ".php") -- TODO: No parse-examples in tree-sitter yet ] where examples = Path.relDir "examples" +buildExamples :: TaskSession -> LanguageExample -> Path.RelDir -> IO Tasty.TestTree +buildExamples session lang tsDir = do + knownFailures <- knownFailuresForPath tsDir (languageKnownFailuresTxt lang) + files <- globDir1 (compile ("**/*" <> languageExtension lang)) (Path.toString (tsDir languageExampleDir lang)) + let paths = Path.relFile <$> files + trees <- forConcurrently paths $ \file -> pure $ HUnit.testCase (Path.toString file) $ do + res <- runTask session (parseFilePath file) + case res of + Left (SomeException e) -> case cast e of + -- We have a number of known assignment timeouts, consider these pending specs instead of failing the build. + Just AssignmentTimedOut -> pure () + Just ParserTimedOut -> pure () + -- Other exceptions are true failures + _ -> HUnit.assertFailure (show (displayException e)) + _ -> if file `elem` knownFailures + then pure () + else (isRight res) HUnit.@? ("Error: " <> either show show res) + pure (Tasty.testGroup (languageName lang) trees) + +testOptions :: Config.Options +testOptions = defaultOptions + { optionsFailOnWarning = flag FailOnWarning True + , optionsLogLevel = Nothing + } + +main :: IO () +main = withOptions testOptions $ \ config logger statter -> do + void $ Process.system "script/clone-example-repos" + + let session = TaskSession config "-" False logger statter + + allTests <- forConcurrently examples $ \lang@LanguageExample{..} -> do + let tsLang = Path.relDir ("tree-sitter-" <> languageName) + let tsDir = Path.relDir "tmp/haskell-tree-sitter" tsLang Path.relDir "vendor" tsLang + buildExamples session lang tsDir + + Tasty.defaultMain $ Tasty.testGroup "parse-examples" allTests + +knownFailuresForPath :: Path.RelDir -> Maybe Path.RelFile -> IO (Set Path.RelFile) +knownFailuresForPath _ Nothing = pure mempty +knownFailuresForPath tsDir (Just path) + = runResourceT + ( ByteStream.readFile @ResIO (Path.toString (tsDir path)) + & ByteStream.lines + & ByteStream.denull + & Stream.mapped ByteStream.toLazy + & Stream.filter ((/= '#') . BLC.head) + & Stream.map (Path.relFile . BLC.unpack) + & Foldl.purely Stream.fold_ Foldl.set + ) + + parseFilePath :: (Member (Error SomeException) sig, Member Distribute sig, Member Task sig, Member Files sig, Carrier sig m, MonadIO m) => Path.RelFile -> m Bool parseFilePath path = readBlob (fileForRelPath path) >>= parseTermBuilder @[] TermShow . pure >>= const (pure True) - -languagesDir :: Path.RelDir -languagesDir = Path.relDir "tmp/haskell-tree-sitter"