mirror of
https://github.com/github/semantic.git
synced 2024-12-22 06:11:49 +03:00
Merge branch 'master' into semantic-ast
This commit is contained in:
Ayman Nadeem
commit
b152258213
@ -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.
|
||||
@ -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.
|
||||
@ -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.
|
||||
@ -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.
|
||||
@ -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.
|
||||
@ -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.
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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]
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
# CHECK-JQ: .scope == {}
|
||||
# CHECK-TREE: { #unit; #record {} }
|
||||
# CHECK-TREE: (#unit)
|
||||
()
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
144
test/Examples.hs
144
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"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user