github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-22 14:21:31 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into semantic-ast

Browse Source
This commit is contained in:
Ayman Nadeem 2019-09-25 13:31:08 -04:00
commit b152258213
17 changed files with 154 additions and 667 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
.licenses/semantic/cabal/cryptohash.txt
View File

@ -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 <vincent@snarc.org>
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.

38
.licenses/semantic/cabal/free.txt
View File

@ -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.

28
.licenses/semantic/cabal/http-client-tls.txt
View File

@ -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.

28
.licenses/semantic/cabal/http-client.txt
View File

@ -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.

28
.licenses/semantic/cabal/http-media.txt
View File

@ -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.

39
.licenses/semantic/cabal/http-types.txt
View File

@ -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.

1
semantic-python/semantic-python.cabal
View File

@ -67,6 +67,7 @@ test-suite test
, pathtype ^>= 0.8.1 , pathtype ^>= 0.8.1
, pretty-show ^>= 1.9.5 , pretty-show ^>= 1.9.5
, process ^>= 1.6.5 , process ^>= 1.6.5
, resourcet ^>= 1.2.2
, streaming ^>= 0.2.2 , streaming ^>= 0.2.2
, streaming-process ^>= 0.1 , streaming-process ^>= 0.1
, streaming-bytestring ^>= 0.1.6 , streaming-bytestring ^>= 0.1.6

99
semantic-python/src/Language/Python/Core.hs
View File

@ -53,22 +53,8 @@ type CoreSyntax sig t = ( Member Core sig
) )
class Compile py where 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 -- FIXME: rather than failing the compilation process entirely
-- with MonadFail, we should emit core that represents failure -- 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 compileCC :: ( CoreSyntax syn t
, Member (Reader SourcePath) sig , Member (Reader SourcePath) sig
, Member (Reader Bindings) sig , Member (Reader Bindings) sig
@ -78,8 +64,24 @@ class Compile py where
=> py => py
-> m (t Name) -> m (t Name)
-> 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 locate :: ( HasField "ann" syntax Span
, CoreSyntax syn t , CoreSyntax syn t
@ -93,30 +95,12 @@ locate syn item = do
pure (Core.annAt (locFromTSSpan (getField @"ann" syn)) item) 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 :: (MonadFail m, Show py) => py -> m (t Name)
defaultCompile t = fail $ "compilation unimplemented for " <> show t defaultCompile t = fail $ "compilation unimplemented for " <> show t
newtype CompileSum py = CompileSum py newtype CompileSum py = CompileSum py
instance (Generic py, GCompileSum (Rep py)) => Compile (CompileSum py) where instance (Generic py, GCompileSum (Rep py)) => Compile (CompileSum py) where
compile (CompileSum a) = gcompileSum . from $ a
compileCC (CompileSum a) cc = gcompileCCSum (from a) cc compileCC (CompileSum a) cc = gcompileCCSum (from a) cc
deriving via CompileSum (Either l r) instance (Compile l, Compile r) => Compile (Either l r) 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 locate it =<< assigning <$> local (def name) cc
compileCC other _ = fail ("Unhandled assignment case: " <> show other) compileCC other _ = fail ("Unhandled assignment case: " <> show other)
compile = viaCompileCC
instance Compile (Py.AugmentedAssignment Span) instance Compile (Py.AugmentedAssignment Span)
instance Compile (Py.Await Span) instance Compile (Py.Await Span)
instance Compile (Py.BinaryOperator Span) instance Compile (Py.BinaryOperator Span)
@ -147,8 +129,6 @@ instance Compile (Py.BinaryOperator Span)
instance Compile (Py.Block Span) where instance Compile (Py.Block Span) where
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
compile = viaCompileCC
instance Compile (Py.BooleanOperator Span) instance Compile (Py.BooleanOperator Span)
instance Compile (Py.BreakStatement Span) instance Compile (Py.BreakStatement Span)
instance Compile (Py.Call Span) instance Compile (Py.Call Span)
@ -174,14 +154,16 @@ instance Compile (Py.ExpressionStatement Span) where
{ Py.extraChildren = children { Py.extraChildren = children
} cc = do } cc = do
foldr compileCC cc children >>= locate it foldr compileCC cc children >>= locate it
compile = viaCompileCC
instance Compile (Py.ExpressionList Span) where instance Compile (Py.ExpressionList Span) where
compile it@Py.ExpressionList { Py.extraChildren = [child] } = compile child >>= locate it compileCC it@Py.ExpressionList { Py.extraChildren = [child] } cc
compile Py.ExpressionList { Py.extraChildren = items } = fail ("unimplemented: ExpressionList of length " <> show items) = 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.Float Span)
instance Compile (Py.ForStatement Span) instance Compile (Py.ForStatement Span)
@ -206,14 +188,12 @@ instance Compile (Py.FunctionDefinition Span) where
unimplemented x = fail $ "unimplemented: " <> show x unimplemented x = fail $ "unimplemented: " <> show x
assigning item f = (Name.named' name :<- item) >>>= f assigning item f = (Name.named' name :<- item) >>>= f
compile = viaCompileCC
instance Compile (Py.FutureImportStatement Span) instance Compile (Py.FutureImportStatement Span)
instance Compile (Py.GeneratorExpression Span) instance Compile (Py.GeneratorExpression Span)
instance Compile (Py.GlobalStatement Span) instance Compile (Py.GlobalStatement Span)
instance Compile (Py.Identifier Span) where 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 instance Compile (Py.IfStatement Span) where
compileCC it@Py.IfStatement{ condition, consequence, alternative} cc = 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 = clause (Left Py.ElifClause{ condition, consequence }) rest =
if' <$> compile condition <*> compileCC consequence cc <*> rest if' <$> compile condition <*> compileCC consequence cc <*> rest
compile = viaCompileCC
instance Compile (Py.ImportFromStatement Span) instance Compile (Py.ImportFromStatement Span)
instance Compile (Py.ImportStatement Span) instance Compile (Py.ImportStatement Span)
@ -233,7 +211,7 @@ instance Compile (Py.List Span)
instance Compile (Py.ListComprehension Span) instance Compile (Py.ListComprehension Span)
instance Compile (Py.Module Span) where 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 -- This action gets passed to compileCC, which means it is the
-- final action taken after the compiling fold finishes. It takes -- final action taken after the compiling fold finishes. It takes
-- care of listening for the current set of bound variables (which -- 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.ParenthesizedExpression Span)
instance Compile (Py.PassStatement Span) where 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) deriving via CompileSum (Py.PrimaryExpression Span) instance Compile (Py.PrimaryExpression Span)
instance Compile (Py.PrintStatement Span) instance Compile (Py.PrintStatement Span)
instance Compile (Py.ReturnStatement Span) where 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 Nothing -> locate it $ none
Just Py.ExpressionList { extraChildren = [val] } -> compile val >>= locate it Just Py.ExpressionList { extraChildren = [val] } -> compile val >>= locate it
Just Py.ExpressionList { extraChildren = vals } -> fail ("unimplemented: return statement returning " <> show (length vals) <> " values") 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.RaiseStatement Span)
instance Compile (Py.Set 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.String Span)
instance Compile (Py.Subscript 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.TryStatement Span)
instance Compile (Py.Tuple Span) where instance Compile (Py.Tuple Span) where
compile it@Py.Tuple { Py.extraChildren = [] } = locate it $ Core.unit compileCC it@Py.Tuple { Py.extraChildren = [] } _ = locate it unit
compile it = fail ("Unimplemented: non-empty tuple " <> show it)
compileCC it _
= fail ("Unimplemented: non-empty tuple " <> show it)
instance Compile (Py.UnaryOperator Span) instance Compile (Py.UnaryOperator Span)
instance Compile (Py.WhileStatement Span) instance Compile (Py.WhileStatement Span)
@ -290,13 +269,6 @@ instance Compile (Py.WithStatement Span)
instance Compile (Py.Yield Span) instance Compile (Py.Yield Span)
class GCompileSum f where 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 gcompileCCSum :: ( CoreSyntax syn t
, Member (Reader SourcePath) sig , Member (Reader SourcePath) sig
, Member (Reader Bindings) sig , Member (Reader Bindings) sig
@ -305,16 +277,11 @@ class GCompileSum f where
) => f a -> m (t Name) -> m (t Name) ) => f a -> m (t Name) -> m (t Name)
instance GCompileSum f => GCompileSum (M1 D d f) where instance GCompileSum f => GCompileSum (M1 D d f) where
gcompileSum (M1 f) = gcompileSum f
gcompileCCSum (M1 f) = gcompileCCSum f gcompileCCSum (M1 f) = gcompileCCSum f
instance (GCompileSum l, GCompileSum r) => GCompileSum (l :+: r) where 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 (L1 l) = gcompileCCSum l
gcompileCCSum (R1 r) = gcompileCCSum r gcompileCCSum (R1 r) = gcompileCCSum r
instance Compile t => GCompileSum (M1 C c (M1 S s (K1 R t))) where 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 gcompileCCSum (M1 (M1 (K1 t))) = compileCC t

16
semantic-python/test/Directive.hs
View File

@ -1,5 +1,5 @@
module Directive ( Directive (..) module Directive ( Directive (..)
, parseDirectives , parseDirective
, describe , describe
, toProcess , toProcess
) where ) where
@ -14,7 +14,6 @@ import qualified Data.Core.Pretty as Core.Pretty
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as ByteString import qualified Data.ByteString.Char8 as ByteString
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import Data.Coerce
import System.Process import System.Process
import qualified Text.Trifecta as Trifecta import qualified Text.Trifecta as Trifecta
@ -57,23 +56,20 @@ fails = Fails <$ Trifecta.string "# CHECK-FAILS"
jq :: Trifecta.Parser Directive jq :: Trifecta.Parser Directive
jq = do jq = do
Trifecta.string "# CHECK-JQ: " void $ Trifecta.string "# CHECK-JQ: "
JQ . ByteString.pack <$> many (Trifecta.noneOf "\n") JQ . ByteString.pack <$> many (Trifecta.noneOf "\n")
tree :: Trifecta.Parser Directive tree :: Trifecta.Parser Directive
tree = do tree = do
void $ Trifecta.string "# CHECK-TREE: " void $ Trifecta.string "# CHECK-TREE: "
Tree <$> (Core.Parser.record <|> Core.Parser.comp) Tree <$> Core.Parser.core
directive :: Trifecta.Parser Directive directive :: Trifecta.Parser Directive
directive = Trifecta.choice [ fails, jq, tree ] directive = Trifecta.choice [ fails, jq, tree ]
toplevel :: Trifecta.Parser (NonEmpty Directive) parseDirective :: ByteString -> Either String Directive
toplevel = directive `Trifecta.sepEndByNonEmpty` Trifecta.char '\n' parseDirective = Trifecta.foldResult (Left . show) Right
. Trifecta.parseByteString (directive <* Trifecta.eof) mempty
parseDirectives :: ByteString -> Either String (NonEmpty Directive)
parseDirectives = Trifecta.foldResult (Left . show) Right
. Trifecta.parseByteString toplevel mempty
toProcess :: Directive -> CreateProcess toProcess :: Directive -> CreateProcess
toProcess (JQ d) = proc "jq" ["-e", ByteString.unpack d] toProcess (JQ d) = proc "jq" ["-e", ByteString.unpack d]

25
semantic-python/test/Test.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE DeriveAnyClass, DerivingStrategies, GeneralizedNewtypeDeriving, OverloadedStrings, TypeApplications, TypeOperators #-} {-# LANGUAGE DeriveAnyClass, DerivingStrategies, GeneralizedNewtypeDeriving, OverloadedStrings, TypeApplications, TypeOperators, ScopedTypeVariables #-}
module Main (main) where module Main (main) where
@ -9,6 +9,7 @@ import Control.Effect.Reader
import Control.Monad hiding (fail) import Control.Monad hiding (fail)
import Control.Monad.Catch import Control.Monad.Catch
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Data.ByteString.Char8 as ByteString import qualified Data.ByteString.Char8 as ByteString
@ -29,6 +30,7 @@ import GHC.Stack
import qualified Language.Python.Core as Py import qualified Language.Python.Core as Py
import Prelude hiding (fail) import Prelude hiding (fail)
import Streaming import Streaming
import qualified Streaming.Prelude as Stream
import qualified Streaming.Process import qualified Streaming.Process
import System.Directory import System.Directory
import System.Exit import System.Exit
@ -76,13 +78,24 @@ assertJQExpressionSucceeds directive tree core = do
fixtureTestTreeForFile :: HasCallStack => Path.RelFile -> Tasty.TestTree fixtureTestTreeForFile :: HasCallStack => Path.RelFile -> Tasty.TestTree
fixtureTestTreeForFile fp = HUnit.testCaseSteps (Path.toString fp) $ \step -> withFrozenCallStack $ do 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 let coreResult = Control.Effect.run
. runFail . runFail
. runReader (fromString @Py.SourcePath . Path.toString $ fp) . runReader (fromString @Py.SourcePath . Path.toString $ fp)

2
semantic-python/test/fixtures/1-03-empty-tuple.py vendored
View File

@ -1,3 +1,3 @@
# CHECK-JQ: .scope == {} # CHECK-JQ: .scope == {}
# CHECK-TREE: { #unit; #record {} } # CHECK-TREE: (#unit)
() ()

15
semantic.cabal
View File

@ -53,7 +53,6 @@ common dependencies
, containers ^>= 0.6.0.1 , containers ^>= 0.6.0.1
, directory ^>= 1.3.3.0 , directory ^>= 1.3.3.0
, fastsum ^>= 0.1.1.0 , fastsum ^>= 0.1.1.0
, free ^>= 5.1
, fused-effects ^>= 0.5.0.0 , fused-effects ^>= 0.5.0.0
, fused-effects-exceptions ^>= 0.2.0.0 , fused-effects-exceptions ^>= 0.2.0.0
, hashable ^>= 1.2.7.0 , hashable ^>= 1.2.7.0
@ -283,7 +282,6 @@ library
, array ^>= 0.5.3.0 , array ^>= 0.5.3.0
, attoparsec ^>= 0.13.2.2 , attoparsec ^>= 0.13.2.2
, cmark-gfm == 0.1.8 , cmark-gfm == 0.1.8
, cryptohash ^>= 0.11.9
, deepseq ^>= 1.4.4.0 , deepseq ^>= 1.4.4.0
, directory-tree ^>= 0.12.1 , directory-tree ^>= 0.12.1
, filepath ^>= 1.4.2.1 , filepath ^>= 1.4.2.1
@ -293,10 +291,6 @@ library
, haskeline ^>= 0.7.5.0 , haskeline ^>= 0.7.5.0
, hostname ^>= 1.0 , hostname ^>= 1.0
, hscolour ^>= 1.24.4 , 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 , kdt ^>= 0.2.4
, lens ^>= 4.17 , lens ^>= 4.17
, mersenne-random-pure64 ^>= 0.2.2.0 , mersenne-random-pure64 ^>= 0.2.2.0
@ -405,9 +399,12 @@ test-suite parse-examples
main-is: Examples.hs main-is: Examples.hs
build-depends: semantic build-depends: semantic
, Glob , Glob
, hspec , foldl ^>= 1.4.5
, hspec-core , resourcet ^>= 1.2
, hspec-expectations , streaming
, streaming-bytestring ^>= 0.1.6
, tasty
, tasty-hunit
benchmark evaluation benchmark evaluation
import: haskell, executable-flags import: haskell, executable-flags

4
src/Data/Blob/IO.hs
View File

@ -37,9 +37,9 @@ readBlobFromFile' file = do
maybeM (Prelude.fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile maybeM (Prelude.fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile
-- | Read all blobs in the directory with Language.supportedExts. -- | 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 $ 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 :: (Part.AbsRel ar, MonadIO m) => Path.Dir ar -> Git.OID -> [Path.RelFile] -> [Path.RelFile] -> m [Blob]
readBlobsFromGitRepoPath path oid excludePaths includePaths readBlobsFromGitRepoPath path oid excludePaths includePaths

7
src/Semantic/Config.hs
View File

@ -29,6 +29,7 @@ import Semantic.Env
import Semantic.Telemetry import Semantic.Telemetry
import qualified Semantic.Telemetry.Error as Error import qualified Semantic.Telemetry.Error as Error
import qualified Semantic.Telemetry.Stat as Stat import qualified Semantic.Telemetry.Stat as Stat
import Semantic.Version (buildSHA)
import System.Environment import System.Environment
import System.IO (hIsTerminalDevice, stdout) import System.IO (hIsTerminalDevice, stdout)
import System.Posix.Process import System.Posix.Process
@ -52,7 +53,7 @@ data Config
, configIsTerminal :: Flag IsTerminal -- ^ Whether a terminal is attached (set automaticaly at runtime). , 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). , 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). , 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). , configFailParsingForTesting :: Flag FailTestParsing -- ^ Simulate internal parse failure for testing (default: False).
, configOptions :: Options -- ^ Options configurable via command line arguments. , configOptions :: Options -- ^ Options configurable via command line arguments.
} }
@ -97,7 +98,7 @@ defaultConfig options@Options{..} = do
, configIsTerminal = flag IsTerminal isTerminal , configIsTerminal = flag IsTerminal isTerminal
, configLogPrintSource = flag LogPrintSource isTerminal , configLogPrintSource = flag LogPrintSource isTerminal
, configLogFormatter = if isTerminal then terminalFormatter else logfmtFormatter , configLogFormatter = if isTerminal then terminalFormatter else logfmtFormatter
, configSHA = Nothing , configSHA = buildSHA
, configFailParsingForTesting = flag FailTestParsing False , configFailParsingForTesting = flag FailTestParsing False
, configOptions = options , configOptions = options
@ -121,7 +122,7 @@ logOptionsFromConfig Config{..} = LogOptions
| otherwise = [ ("app", configAppName) | otherwise = [ ("app", configAppName)
, ("pid", show configProcessID) , ("pid", show configProcessID)
, ("hostname", configHostName) , ("hostname", configHostName)
, ("sha", fromMaybe "development" configSHA) , ("sha", configSHA)
] ]

5
src/Semantic/Task/Files.hs
View File

@ -31,11 +31,12 @@ import Prologue hiding (catch)
import qualified Semantic.Git as Git import qualified Semantic.Git as Git
import Semantic.IO import Semantic.IO
import qualified System.IO as IO import qualified System.IO as IO
import qualified System.Path as Path
data Source blob where data Source blob where
FromPath :: File -> Source Blob FromPath :: File -> Source Blob
FromHandle :: Handle 'IO.ReadMode -> Source [Blob] FromHandle :: Handle 'IO.ReadMode -> Source [Blob]
FromDir :: FilePath -> Source [Blob] FromDir :: Path.AbsRelDir -> Source [Blob]
FromGitRepo :: FilePath -> Git.OID -> PathFilter -> Source [Blob] FromGitRepo :: FilePath -> Git.OID -> PathFilter -> Source [Blob]
FromPathPair :: Both File -> Source BlobPair FromPathPair :: Both File -> Source BlobPair
FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair] FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair]
@ -108,7 +109,7 @@ readBlobs (FilesFromHandle handle) = send (Read (FromHandle handle) pure)
readBlobs (FilesFromPaths [path]) = do readBlobs (FilesFromPaths [path]) = do
isDir <- isDirectory (filePath path) isDir <- isDirectory (filePath path)
if isDir 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) else pure <$> send (Read (FromPath path) pure)
readBlobs (FilesFromPaths paths) = traverse (send . flip Read pure . FromPath) paths readBlobs (FilesFromPaths paths) = traverse (send . flip Read pure . FromPath) paths
readBlobs (FilesFromGitRepo path sha filter) = send (Read (FromGitRepo path sha filter) pure) readBlobs (FilesFromGitRepo path sha filter) = send (Read (FromGitRepo path sha filter) pure)

305
test/Data/Functor/Listable.hs
View File

@ -11,16 +11,12 @@ module Data.Functor.Listable
, cons5 , cons5
, cons6 , cons6
, (\/) , (\/)
, ListableF(..)
, addWeight , addWeight
, ofWeight , ofWeight
, ListableSyntax , ListableSyntax
) where ) where
import Analysis.CyclomaticComplexity
import Analysis.TOCSummary import Analysis.TOCSummary
import Control.Monad.Free as Free
import Control.Monad.Trans.Free as FreeF
import Data.Abstract.ScopeGraph (AccessControl(..)) import Data.Abstract.ScopeGraph (AccessControl(..))
import Data.Bifunctor.Join import Data.Bifunctor.Join
import Data.Diff import Data.Diff
@ -30,20 +26,13 @@ import Data.List.NonEmpty
import Data.Patch import Data.Patch
import Data.Semigroup.App import Data.Semigroup.App
import qualified Data.Syntax as Syntax import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Literal as Literal
import qualified Data.Syntax.Comment as Comment import qualified Data.Syntax.Comment as Comment
import qualified Data.Syntax.Declaration as Declaration 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.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 qualified Data.Abstract.Name as Name
import Data.Term import Data.Term
import Data.Text as T (Text, pack) import Data.Text as T (Text, pack)
import Data.These
import Data.Sum import Data.Sum
import Diffing.Algorithm.RWS
import Source.Loc import Source.Loc
import Source.Span import Source.Span
import Test.LeanCheck 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 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 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 -- Instances
instance Listable1 Maybe where instance Listable1 Maybe where
@ -149,25 +126,6 @@ instance Listable2 p => Listable1 (Join p) where
instance Listable1 Both where instance Listable1 Both where
liftTiers tiers = liftCons2 tiers tiers Both 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 instance Listable1 f => Listable2 (TermF f) where
liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) In liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) In
@ -232,9 +190,6 @@ instance Listable1 Declaration.Method where
instance Listable1 Statement.If where instance Listable1 Statement.If where
liftTiers tiers = liftCons3 tiers tiers tiers Statement.If liftTiers tiers = liftCons3 tiers tiers tiers Statement.If
instance Listable1 Statement.Return where
liftTiers tiers = liftCons1 tiers Statement.Return
instance Listable1 Syntax.Context where instance Listable1 Syntax.Context where
liftTiers tiers = liftCons2 (liftTiers tiers) tiers Syntax.Context liftTiers tiers = liftCons2 (liftTiers tiers) tiers Syntax.Context
@ -244,256 +199,6 @@ instance Listable1 Syntax.Empty where
instance Listable1 Syntax.Identifier where instance Listable1 Syntax.Identifier where
liftTiers _ = cons1 Syntax.Identifier 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 type ListableSyntax = Sum
'[ Comment.Comment '[ Comment.Comment
, Declaration.Function , Declaration.Function
@ -508,13 +213,6 @@ type ListableSyntax = Sum
instance Listable Name.Name where instance Listable Name.Name where
tiers = cons1 Name.name 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 instance Listable Text where
tiers = pack `mapT` tiers tiers = pack `mapT` tiers
@ -524,9 +222,6 @@ instance Listable Declaration where
\/ cons4 FunctionDeclaration \/ cons4 FunctionDeclaration
\/ cons3 (\ a b c -> ErrorDeclaration a b c Language.Unknown) \/ cons3 (\ a b c -> ErrorDeclaration a b c Language.Unknown)
instance Listable CyclomaticComplexity where
tiers = cons1 CyclomaticComplexity
instance Listable Language.Language where instance Listable Language.Language where
tiers tiers
= cons0 Language.Go = cons0 Language.Go

136
test/Examples.hs
View File

@ -1,76 +1,39 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -O1 #-}
module Main (main) where module Main (main) where
import Control.Effect import Control.Effect
import Control.Exception (displayException) import Control.Exception (displayException)
import qualified Control.Foldl as Foldl
import Data.Function ((&))
import Control.Concurrent.Async (forConcurrently)
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Resource (ResIO, runResourceT)
import Data.Blob
import qualified Data.ByteString as B import qualified Data.ByteString as B
import Data.ByteString.Builder import Data.ByteString.Builder
import qualified Data.ByteString.Char8 as BC 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.Either
import Data.Blob (fileForRelPath) import Data.Set (Set)
import Data.Traversable
import Data.Typeable
import qualified Streaming.Prelude as Stream
import System.FilePath.Glob
import System.Path ((</>))
import qualified System.Path as Path
import qualified System.Process as Process
import Data.Flag 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.Api (TermOutputFormat (..), parseTermBuilder)
import Semantic.Config (Config (..), Options (..), FailOnWarning (..), defaultOptions) import Semantic.Config as Config
import qualified Semantic.IO as IO
import Semantic.Task import Semantic.Task
import Semantic.Task.Files import Semantic.Task.Files
import System.Directory
import System.Exit (die)
import System.FilePath.Glob
import qualified System.Path as Path
import System.Path ((</>))
import System.Process
import Test.Hspec
import qualified Test.Tasty as Tasty
main :: IO () import qualified Test.Tasty.HUnit as HUnit
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)
data LanguageExample data LanguageExample
= LanguageExample = LanguageExample
@ -83,8 +46,8 @@ data LanguageExample
le :: String -> String -> Path.RelDir -> Maybe Path.RelFile -> LanguageExample le :: String -> String -> Path.RelDir -> Maybe Path.RelFile -> LanguageExample
le = LanguageExample le = LanguageExample
languages :: [LanguageExample] examples :: [LanguageExample]
languages = examples =
[ le "python" ".py" examples (Just $ Path.relFile "script/known_failures.txt") [ le "python" ".py" examples (Just $ Path.relFile "script/known_failures.txt")
, le "ruby" ".rb" 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") , 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 -- , ("php", ".php") -- TODO: No parse-examples in tree-sitter yet
] where examples = Path.relDir "examples" ] 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 :: (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) parseFilePath path = readBlob (fileForRelPath path) >>= parseTermBuilder @[] TermShow . pure >>= const (pure True)
languagesDir :: Path.RelDir
languagesDir = Path.relDir "tmp/haskell-tree-sitter"