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

Merge branch 'shelly-git-action' into alternative-schema

Browse Source
This commit is contained in:
Timothy Clem 2019-03-26 09:59:17 -07:00
commit 0e288e52bb
54 changed files with 430 additions and 303 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.licenses/semantic/cabal/ghc-boot-th.txt
View File

@ -1,9 +1,9 @@
---
type: cabal
name: ghc-boot-th
version: 8.6.3
version: 8.6.4
summary: Shared functionality between GHC and the @template-haskell@
homepage:
license: bsd-3-clause
---
The Glasgow Haskell Compiler License

4
.licenses/semantic/cabal/ghc-boot.txt
View File

@ -1,9 +1,9 @@
---
type: cabal
name: ghc-boot
version: 8.6.3
version: 8.6.4
summary: Shared functionality between GHC and its boot libraries
homepage:
license: bsd-3-clause
---
The Glasgow Haskell Compiler License

4
.licenses/semantic/cabal/ghc-heap.txt
View File

@ -1,9 +1,9 @@
---
type: cabal
name: ghc-heap
version: 8.6.3
version: 8.6.4
summary: Functions for walking GHC's heap
homepage:
license: bsd-3-clause
---
Copyright (c) 2012-2013, Joachim Breitner

2
.licenses/semantic/cabal/ghc.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: ghc
version: 8.6.3
version: 8.6.4
summary: The GHC API
homepage: https://www.haskell.org/ghc/
license: bsd-3-clause

4
.licenses/semantic/cabal/ghci.txt
View File

@ -1,9 +1,9 @@
---
type: cabal
name: ghci
version: 8.6.3
version: 8.6.4
summary: The library supporting GHC's interactive interpreter
homepage:
license: bsd-3-clause
---
The Glasgow Haskell Compiler License

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

@ -1,7 +1,7 @@
---
type: cabal
name: http-types
version: 0.12.2
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

4
.licenses/semantic/cabal/process.txt
View File

@ -1,9 +1,9 @@
---
type: cabal
name: process
version: 1.6.3.0
version: 1.6.5.0
summary: Process libraries
homepage:
license: bsd-3-clause
---
This library (libraries/process) is derived from code from two

2
.licenses/semantic/cabal/recursion-schemes.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: recursion-schemes
version: 5.1.1
version: 5.1.2
summary: Generalized bananas, lenses and barbed wire
homepage: https://github.com/ekmett/recursion-schemes/
license: bsd-2-clause

2
.licenses/semantic/cabal/th-abstraction.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: th-abstraction
version: 0.2.10.0
version: 0.2.11.0
summary: Nicer interface for reified information about data types
homepage: https://github.com/glguy/th-abstraction
license: isc

4
.licenses/semantic/cabal/transformers.txt
View File

@ -1,9 +1,9 @@
---
type: cabal
name: transformers
version: 0.5.5.0
version: 0.5.6.2
summary: Concrete functor and monad transformers
homepage:
license: bsd-3-clause
---
The Glasgow Haskell Compiler License

5
semantic.cabal
View File

@ -54,6 +54,7 @@ common dependencies
, network
, recursion-schemes
, scientific
, safe-exceptions
, semilattices
, text
, these
@ -97,7 +98,6 @@ library
, Control.Abstract.ScopeGraph
, Control.Abstract.Value
-- Effects
, Control.Effect.Catch
, Control.Effect.Interpose
, Control.Effect.REPL
, Control.Rewriting
@ -132,6 +132,7 @@ library
, Data.Duration
, Data.Error
, Data.File
, Data.Flag
, Data.Functor.Both
, Data.Functor.Classes.Generic
, Proto3.Google.Timestamp
@ -370,6 +371,7 @@ test-suite test
, Graphing.Calls.Spec
, Integration.Spec
, Numeric.Spec
, Parsing.Spec
, Reprinting.Spec
, Rewriting.Go.Spec
, Rewriting.JSON.Spec
@ -383,6 +385,7 @@ test-suite test
, SpecHelpers
, Test.Hspec.LeanCheck
build-depends: semantic
, tree-sitter-json
, hspec >= 2.4.1
, hspec-core
, hspec-expectations-pretty-diff

5
src/Analysis/TOCSummary.hs
View File

@ -10,7 +10,8 @@ import Prologue hiding (project)
import Control.Arrow
import Control.Rewriting
import Data.Blob
import Data.Error (Error (..), showExpectation)
import Data.Error (Error (..), Colourize (..), showExpectation)
import Data.Flag
import Data.Language as Language
import Data.Location
import Data.Range
@ -86,7 +87,7 @@ instance CustomHasDeclaration whole Markdown.Heading where
instance CustomHasDeclaration whole Syntax.Error where
customToDeclaration Blob{..} ann err@Syntax.Error{}
= Just $ ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (locationSpan ann) err))) mempty (locationSpan ann) blobLanguage
where formatTOCError e = showExpectation False (errorExpected e) (errorActual e) ""
where formatTOCError e = showExpectation (flag Colourize False) (errorExpected e) (errorActual e) ""
-- | Produce a 'FunctionDeclaration' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range').
instance CustomHasDeclaration whole Declaration.Function where

4
src/Control/Abstract/Primitive.hs
View File

@ -45,9 +45,9 @@ defineBuiltIn declaration rel accessControl value = withCurrentCallStack callSta
-- TODO: This span is still wrong.
declare declaration rel accessControl emptySpan ScopeGraph.Unknown (Just associatedScope)
param <- gensym
withScope associatedScope $ do
declare (Declaration param) rel accessControl emptySpan ScopeGraph.Unknown Nothing
param <- gensym
declare (Declaration param) ScopeGraph.Gensym accessControl emptySpan ScopeGraph.Unknown Nothing
slot <- lookupSlot declaration
value <- builtIn associatedScope value

22
src/Control/Abstract/ScopeGraph.hs
View File

@ -3,6 +3,7 @@
module Control.Abstract.ScopeGraph
( lookup
, declare
, declareMaybeName
, reference
, newScope
, newPreludeScope
@ -79,6 +80,27 @@ declare decl rel accessControl span kind scope = do
moduleInfo <- ask @ModuleInfo
modify (fst . ScopeGraph.declare decl moduleInfo rel accessControl span kind scope currentAddress)
-- | If the provided name is 'Nothing' we want to reflect that the declaration's name was a generated name (gensym).
-- We use the 'Gensym' relation to indicate that. Otherwise, we use the provided 'relation'.
declareMaybeName :: ( Carrier sig m
, Member (State (ScopeGraph address)) sig
, Member (Reader (CurrentScope address)) sig
, Member (Reader ModuleInfo) sig
, Member Fresh sig
, Ord address
)
=> Maybe Name
-> Relation
-> AccessControl
-> Span
-> Kind
-> Maybe address
-> Evaluator term address value m Name
declareMaybeName maybeName relation ac span kind scope = do
case maybeName of
Just name -> declare (Declaration name) relation ac span kind scope >> pure name
_ -> gensym >>= \name -> declare (Declaration name) Gensym ac span kind scope >> pure name
putDeclarationScope :: ( Ord address
, Member (Reader (CurrentScope address)) sig
, Member (State (ScopeGraph address)) sig

61
src/Control/Effect/Catch.hs
View File

@ -1,61 +0,0 @@
{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,
MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
-- | An effect that enables catching exceptions thrown from
-- impure computations such as IO.
module Control.Effect.Catch
( Catch (..)
, catch
, runCatch
, CatchC (..)
) where
import Control.Effect.Carrier
import Control.Effect.Reader
import Control.Effect.Sum
import qualified Control.Exception as Exc
import Control.Monad.IO.Class
data Catch m k
= forall output e . Exc.Exception e => CatchIO (m output) (e -> m output) (output -> k)
deriving instance Functor (Catch m)
instance HFunctor Catch where
hmap f (CatchIO go cleanup k) = CatchIO (f go) (f . cleanup) k
instance Effect Catch where
handle state handler (CatchIO go cleanup k)
= CatchIO (handler (go <$ state)) (\se -> handler (cleanup se <$ state)) (handler . fmap k)
-- | Like 'Control.Effect.Error.catchError', but delegating to
-- 'Control.Exception.catch' under the hood, which allows catching
-- errors that might occur when lifting 'IO' computations.
-- Unhandled errors are rethrown. Use 'SomeException' if you want
-- to catch all errors.
catch :: (Member Catch sig, Carrier sig m, Exc.Exception e)
=> m a
-> (e -> m a)
-> m a
catch go cleanup = send (CatchIO go cleanup pure)
-- | Evaulate a 'Catch' effect.
runCatch :: (forall x . m x -> IO x)
-> CatchC m a
-> m a
runCatch handler = runReader (Handler handler) . runCatchC
newtype Handler m = Handler (forall x . m x -> IO x)
runHandler :: Handler m -> CatchC m a -> IO a
runHandler h@(Handler handler) = handler . runReader h . runCatchC
newtype CatchC m a = CatchC { runCatchC :: ReaderC (Handler m) m a }
deriving (Functor, Applicative, Monad, MonadIO)
instance (Carrier sig m, MonadIO m) => Carrier (Catch :+: sig) (CatchC m) where
eff (L (CatchIO act cleanup k)) = do
handler <- CatchC ask
liftIO (Exc.catch (runHandler handler act) (runHandler handler . cleanup)) >>= k
eff (R other) = CatchC (eff (R (handleCoercible other)))

4
src/Data/Abstract/Evaluatable.hs
View File

@ -30,7 +30,7 @@ import Data.Abstract.Declarations as X
import Data.Abstract.FreeVariables as X
import Data.Abstract.Module
import Data.Abstract.Name as X
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Abstract.ScopeGraph (Relation(..))
import Data.Abstract.AccessControls.Class as X
import Data.Language
@ -192,7 +192,7 @@ defineSelf :: ( Carrier sig m
=> Evaluator term address value m ()
defineSelf = do
let self = Declaration X.__self
declare self Default Public emptySpan ScopeGraph.Unknown Nothing
declare self ScopeGraph.Gensym Public emptySpan ScopeGraph.Unknown Nothing
slot <- lookupSlot self
assign slot =<< object =<< currentFrame

2
src/Data/Abstract/ScopeGraph.hs
View File

@ -86,7 +86,7 @@ instance Ord AccessControl where
(<=) Public _ = False
data Relation = Default | Instance | Prelude
data Relation = Default | Instance | Prelude | Gensym
deriving (Eq, Show, Ord, Generic, NFData)
instance Lower Relation where

7
src/Data/Blob.hs
View File

@ -33,6 +33,7 @@ data Blob = Blob
{ blobSource :: Source -- ^ The UTF-8 encoded source text of the blob.
, blobPath :: FilePath -- ^ The file path to the blob.
, blobLanguage :: Language -- ^ The language of this blob.
, blobOid :: Text -- ^ Git OID for this blob, mempty if blob is not from a git db.
}
deriving (Show, Eq, Generic)
@ -49,12 +50,12 @@ nullBlob :: Blob -> Bool
nullBlob Blob{..} = nullSource blobSource
sourceBlob :: FilePath -> Language -> Source -> Blob
sourceBlob filepath language source = Blob source filepath language
sourceBlob filepath language source = Blob source filepath language mempty
inferringLanguage :: Source -> FilePath -> Language -> Blob
inferringLanguage src pth lang
| knownLanguage lang = Blob src pth lang
| otherwise = Blob src pth (languageForFilePath pth)
| knownLanguage lang = Blob src pth lang mempty
| otherwise = Blob src pth (languageForFilePath pth) mempty
decodeBlobs :: BL.ByteString -> Either String [Blob]
decodeBlobs = fmap blobs <$> eitherDecode

38
src/Data/Error.hs
View File

@ -6,6 +6,9 @@ module Data.Error
, showExpectation
, showExcerpt
, withSGRCode
-- * Flags affecting 'Error' values
, LogPrintSource (..)
, Colourize (..)
) where
import Prologue
@ -16,9 +19,13 @@ import Data.List (intersperse, isSuffixOf)
import System.Console.ANSI
import Data.Blob
import Data.Flag as Flag
import Data.Source
import Data.Span
data LogPrintSource = LogPrintSource
data Colourize = Colourize
-- | Rather than using the Error constructor directly, you probably
-- want to call 'makeError', which takes care of inserting the call
-- stack for you.
@ -38,21 +45,18 @@ instance Exception (Error String)
makeError :: HasCallStack => Span -> [grammar] -> Maybe grammar -> Error grammar
makeError s e a = withFrozenCallStack (Error s e a callStack)
type IncludeSource = Bool
type Colourize = Bool
-- | Format an 'Error', optionally with reference to the source where it occurred.
formatError :: IncludeSource -> Colourize -> Blob -> Error String -> String
formatError :: Flag LogPrintSource -> Flag Colourize -> Blob -> Error String -> String
formatError includeSource colourize blob@Blob{..} Error{..}
= ($ "")
$ withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showSpan path errorSpan . showString ": ")
. withSGRCode colourize [SetColor Foreground Vivid Red] (showString "error") . showString ": " . showExpectation colourize errorExpected errorActual . showChar '\n'
. (if includeSource then showExcerpt colourize errorSpan blob else id)
. (if Flag.toBool LogPrintSource includeSource then showExcerpt colourize errorSpan blob else id)
. showCallStack colourize callStack . showChar '\n'
where
path = Just $ if includeSource then blobPath else "<filtered>"
path = Just $ if Flag.toBool LogPrintSource includeSource then blobPath else "<filtered>"
showExcerpt :: Colourize -> Span -> Blob -> ShowS
showExcerpt :: Flag Colourize -> Span -> Blob -> ShowS
showExcerpt colourize Span{..} Blob{..}
= showString context . (if "\n" `isSuffixOf` context then id else showChar '\n')
. showString (replicate (caretPaddingWidth + lineNumberDigits) ' ') . withSGRCode colourize [SetColor Foreground Vivid Green] (showString caret) . showChar '\n'
@ -67,23 +71,19 @@ showExcerpt colourize Span{..} Blob{..}
caret | posLine spanStart == posLine spanEnd = replicate (max 1 (posColumn spanEnd - posColumn spanStart)) '^'
| otherwise = "^..."
withSGRCode :: Colourize -> [SGR] -> ShowS -> ShowS
withSGRCode useColour code content =
if useColour then
showString (setSGRCode code)
. content
. showString (setSGRCode [])
else
content
withSGRCode :: Flag Colourize -> [SGR] -> ShowS -> ShowS
withSGRCode useColour code content
| Flag.toBool Colourize useColour = showString (setSGRCode code) . content . showString (setSGRCode [])
| otherwise = content
showExpectation :: Colourize -> [String] -> Maybe String -> ShowS
showExpectation :: Flag Colourize -> [String] -> Maybe String -> ShowS
showExpectation colourize = go
where go [] Nothing = showString "no rule to match at " . showActual "end of branch"
go expected Nothing = showString "expected " . showSymbols colourize expected . showString " at " . showActual "end of branch"
go expected (Just actual) = showString "expected " . showSymbols colourize expected . showString ", but got " . showActual actual
showActual = withSGRCode colourize [SetColor Foreground Vivid Green] . showString
showSymbols :: Colourize -> [String] -> ShowS
showSymbols :: Flag Colourize -> [String] -> ShowS
showSymbols colourize = go
where go [] = showString "end of input nodes"
go [symbol] = showSymbol symbol
@ -96,8 +96,8 @@ showSpan :: Maybe FilePath -> Span -> ShowS
showSpan path Span{..} = maybe (showParen True (showString "interactive")) showString path . showChar ':' . (if spanStart == spanEnd then showPos spanStart else showPos spanStart . showChar '-' . showPos spanEnd)
where showPos Pos{..} = shows posLine . showChar ':' . shows posColumn
showCallStack :: Colourize -> CallStack -> ShowS
showCallStack :: Flag Colourize -> CallStack -> ShowS
showCallStack colourize callStack = foldr (.) id (intersperse (showChar '\n') (uncurry (showCallSite colourize) <$> getCallStack callStack))
showCallSite :: Colourize -> String -> SrcLoc -> ShowS
showCallSite :: Flag Colourize -> String -> SrcLoc -> ShowS
showCallSite colourize symbol loc@SrcLoc{..} = showString symbol . showChar ' ' . withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showParen True (showSpan (Just srcLocFile) (spanFromSrcLoc loc)))

2
src/Data/File.hs
View File

@ -32,7 +32,7 @@ file path = File path (languageForFilePath path)
-- This is kind of a wart; Blob and File should be two views of
-- the same higher-kinded datatype.
toFile :: Blob -> File
toFile (Blob _ p l) = File p l
toFile (Blob _ p l _) = File p l
-- | Read a utf8-encoded file to a 'Blob'.
readBlobFromFile :: forall m. MonadIO m => File -> m (Maybe Blob)

44
src/Data/Flag.hs Normal file
View File

@ -0,0 +1,44 @@
{-# LANGUAGE RankNTypes, KindSignatures #-}
-- | -- This technique is due to Oleg Grenrus: <http://oleg.fi/gists/posts/2019-03-21-flag.html>
-- The implementation is clean-room due to unclear licensing of the original post.
module Data.Flag
( Flag
, flag
, toBool
, switch
, choose
) where
import Data.Coerce
-- | To declare a new flag, declare a singly-inhabited type:
-- @data MyFlag = MyFlag@
-- then use the @flag MyFlag@ to create one from a 'Bool'.
-- This is more verbose than using 'Bool' for everything but prevents classes of errors when
-- working with multiple flag values in flight, as the 'toBool' deconstructor provides a witness
-- that you really want the given semantic flag value from the flag datum.
newtype Flag (t :: *) = Flag Bool
-- | The constructor for a 'Flag'. You specify @t@ with a visible type application.
flag :: t -> Bool -> Flag t
flag _ = Flag
{-# INLINE flag #-}
-- | The destructor for a 'Flag'. You pass in the inhabitant of @t@ to
-- avoid boolean blindness.
toBool :: t -> Flag t -> Bool
toBool _ = coerce
{-# INLINE toBool #-}
switch :: a -> b -> Flag a -> Flag b
switch _ _ = coerce
-- | Case analysis, like 'bool'.
choose :: t -- ^ Witness
-> a -- ^ False case
-> a -- ^ True case
-> Flag t
-> a
choose _ f t flag = if coerce flag then t else f
{-# INLINE choose #-}

53
src/Data/Syntax/Declaration.hs
View File

@ -28,15 +28,10 @@ instance Diffable Function where
instance Evaluatable Function where
eval _ _ Function{..} = do
name <- maybeM (throwNoNameError functionName) (declaredName functionName)
span <- ask @Span
associatedScope <- declareFunction name ScopeGraph.Public span ScopeGraph.Function
(name, associatedScope) <- declareFunction (declaredName functionName) ScopeGraph.Public span ScopeGraph.Function
params <- withScope associatedScope . for functionParameters $ \paramNode -> do
param <- maybeM (throwNoNameError paramNode) (declaredName paramNode)
let paramSpan = getSpan paramNode
param <$ declare (Declaration param) Default ScopeGraph.Public paramSpan ScopeGraph.Parameter Nothing
params <- withScope associatedScope . for functionParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (getSpan paramNode) ScopeGraph.Parameter Nothing
addr <- lookupSlot (Declaration name)
v <- function name params functionBody associatedScope
@ -50,17 +45,17 @@ declareFunction :: ( Carrier sig m
, Member Fresh sig
, Ord address
)
=> Name
=> Maybe Name
-> ScopeGraph.AccessControl
-> Span
-> ScopeGraph.Kind
-> Evaluator term address value m address
-> Evaluator term address value m (Name, address)
declareFunction name accessControl span kind = do
currentScope' <- currentScope
let lexicalEdges = Map.singleton Lexical [ currentScope' ]
associatedScope <- newScope lexicalEdges
declare (Declaration name) Default accessControl span kind (Just associatedScope)
pure associatedScope
name' <- declareMaybeName name Default accessControl span kind (Just associatedScope)
pure (name', associatedScope)
instance Tokenize Function where
tokenize Function{..} = within' Scope.Function $ do
@ -92,16 +87,13 @@ instance Diffable Method where
-- local environment.
instance Evaluatable Method where
eval _ _ Method{..} = do
name <- maybeM (throwNoNameError methodName) (declaredName methodName)
span <- ask @Span
associatedScope <- declareFunction name methodAccessControl span ScopeGraph.Method
(name, associatedScope) <- declareFunction (declaredName methodName) methodAccessControl span ScopeGraph.Method
params <- withScope associatedScope $ do
-- TODO: Should we give `self` a special Relation?
declare (Declaration __self) Prelude ScopeGraph.Public emptySpan ScopeGraph.Unknown Nothing
for methodParameters $ \paramNode -> do
param <- maybeM (throwNoNameError paramNode) (declaredName paramNode)
param <$ declare (Declaration param) Default ScopeGraph.Public span ScopeGraph.Parameter Nothing
declare (Declaration __self) ScopeGraph.Prelude ScopeGraph.Public emptySpan ScopeGraph.Unknown Nothing
for methodParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (getSpan paramNode) ScopeGraph.Parameter Nothing
addr <- lookupSlot (Declaration name)
v <- function name params methodBody associatedScope
@ -144,9 +136,8 @@ instance Declarations1 RequiredParameter where
-- TODO: Implement Eval instance for RequiredParameter
instance Evaluatable RequiredParameter where
eval _ _ RequiredParameter{..} = do
name <- maybeM (throwNoNameError requiredParameter) (declaredName requiredParameter)
span <- ask @Span
declare (Declaration name) Default ScopeGraph.Public span ScopeGraph.RequiredParameter Nothing
_ <- declareMaybeName (declaredName requiredParameter) Default ScopeGraph.Public span ScopeGraph.RequiredParameter Nothing
unit
@ -170,9 +161,8 @@ instance Evaluatable VariableDeclaration where
eval _ _ (VariableDeclaration []) = unit
eval eval _ (VariableDeclaration decs) = do
for_ decs $ \declaration -> do
name <- maybeM (throwNoNameError declaration) (declaredName declaration)
let declarationSpan = getSpan declaration
declare (Declaration name) Default ScopeGraph.Public declarationSpan ScopeGraph.VariableDeclaration Nothing
let span = getSpan declaration
_ <- declareMaybeName (declaredName declaration) Default ScopeGraph.Public span ScopeGraph.VariableDeclaration Nothing
eval declaration
unit
@ -209,10 +199,8 @@ data PublicFieldDefinition a = PublicFieldDefinition
instance Evaluatable PublicFieldDefinition where
eval eval _ PublicFieldDefinition{..} = do
span <- ask @Span
propertyName <- maybeM (throwNoNameError publicFieldPropertyName) (declaredName publicFieldPropertyName)
declare (Declaration propertyName) Instance publicFieldAccessControl span ScopeGraph.PublicField Nothing
slot <- lookupSlot (Declaration propertyName)
name <- declareMaybeName (declaredName publicFieldPropertyName) Instance publicFieldAccessControl span ScopeGraph.PublicField Nothing
slot <- lookupSlot (Declaration name)
value <- eval publicFieldValue
assign slot value
unit
@ -236,12 +224,13 @@ instance Diffable Class where
instance Evaluatable Class where
eval eval _ Class{..} = do
name <- maybeM (throwNoNameError classIdentifier) (declaredName classIdentifier)
span <- ask @Span
currentScope' <- currentScope
superScopes <- for classSuperclasses $ \superclass -> do
name <- maybeM (throwNoNameError superclass) (declaredName superclass)
name <- case declaredName superclass of
Just name -> pure name
Nothing -> gensym
scope <- associatedScope (Declaration name)
slot <- lookupSlot (Declaration name)
superclassFrame <- scopedEnvironment =<< deref slot
@ -253,7 +242,7 @@ instance Evaluatable Class where
current = (Lexical, ) <$> pure (pure currentScope')
edges = Map.fromList (superclassEdges <> current)
classScope <- newScope edges
declare (Declaration name) Default ScopeGraph.Public span ScopeGraph.Class (Just classScope)
name <- declareMaybeName (declaredName classIdentifier) Default ScopeGraph.Public span ScopeGraph.Class (Just classScope)
let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes))
classFrame <- newFrame classScope frameEdges
@ -323,13 +312,11 @@ data TypeAlias a = TypeAlias { typeAliasContext :: ![a], typeAliasIdentifier ::
instance Evaluatable TypeAlias where
eval _ _ TypeAlias{..} = do
name <- maybeM (throwNoNameError typeAliasIdentifier) (declaredName typeAliasIdentifier)
-- This use of `throwNoNameError` is good -- we aren't declaring something new so `declareMaybeName` is not useful here.
kindName <- maybeM (throwNoNameError typeAliasKind) (declaredName typeAliasKind)
span <- ask @Span
assocScope <- associatedScope (Declaration kindName)
-- TODO: Should we consider a special Relation for `TypeAlias`?
declare (Declaration name) Default ScopeGraph.Public span ScopeGraph.TypeAlias assocScope
name <- declareMaybeName (declaredName typeAliasIdentifier) Default ScopeGraph.Public span ScopeGraph.TypeAlias assocScope
slot <- lookupSlot (Declaration name)
kindSlot <- lookupSlot (Declaration kindName)

1
src/Data/Syntax/Expression.hs
View File

@ -427,6 +427,7 @@ instance Evaluatable MemberAccess where
let lhsAccessControl = fromMaybe Public (termToAccessControl lhs)
infos <- declarationsByAccessControl rhsScope lhsAccessControl
-- This means we always throw an 'AccessControlError' whenever we have a rhs term whose 'declaredName' is 'Nothing'.
rhsName <- maybeM (throwNoNameError rhs) (declaredName rhs)
rhsValue' <- case find (\Info{..} -> Declaration rhsName == infoDeclaration) infos of
Just _ -> pure rhsValue

6
src/Data/Syntax/Statement.hs
View File

@ -121,13 +121,13 @@ data Let a = Let { letVariable :: !a, letValue :: !a, letBody :: !a }
instance Evaluatable Let where
eval eval _ Let{..} = do
name <- maybeM (throwNoNameError letVariable) (declaredName letVariable)
letSpan <- ask @Span
-- This use of 'throwNoNameError' is okay until we have a better way of mapping gensym names to terms in the scope graph.
valueName <- maybeM (throwNoNameError letValue) (declaredName letValue)
assocScope <- associatedScope (Declaration valueName)
_ <- withLexicalScopeAndFrame $ do
declare (Declaration name) Default Public letSpan ScopeGraph.Let assocScope
letSpan <- ask @Span
name <- declareMaybeName (declaredName letVariable) Default Public letSpan ScopeGraph.Let assocScope
letVal <- eval letValue
slot <- lookupSlot (Declaration name)
assign slot letVal

5
src/Language/Go/Syntax.hs
View File

@ -75,11 +75,10 @@ data QualifiedImport a = QualifiedImport { qualifiedImportFrom :: !ImportPath, q
instance Evaluatable QualifiedImport where
eval _ _ (QualifiedImport importPath aliasTerm) = do
paths <- resolveGoImport importPath
alias <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm)
span <- ask @Span
scopeAddress <- newScope mempty
declare (Declaration alias) Default Public span ScopeGraph.QualifiedImport (Just scopeAddress)
aliasSlot <- lookupSlot (Declaration alias)
name <- declareMaybeName (declaredName aliasTerm) Default Public span ScopeGraph.QualifiedImport (Just scopeAddress)
aliasSlot <- lookupSlot (Declaration name)
withScope scopeAddress $ do
let

1
src/Language/PHP/Syntax.hs
View File

@ -172,6 +172,7 @@ data QualifiedName a = QualifiedName { name :: a, identifier :: a }
instance Evaluatable QualifiedName where
eval _ _ (QualifiedName obj iden) = do
-- TODO: Consider gensym'ed names used for References.
name <- maybeM (throwNoNameError obj) (declaredName obj)
let objSpan = getSpan obj
reference (Reference name) objSpan ScopeGraph.Identifier (Declaration name)

1
src/Language/Python/Syntax.hs
View File

@ -187,6 +187,7 @@ newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: NonEmpty a
-- import a.b.c
instance Evaluatable QualifiedImport where
eval _ _ (QualifiedImport qualifiedNames) = do
-- TODO: Consider gensym'ed names for imports.
qualifiedName <- fmap (T.unpack . formatName) <$> traverse (\term -> maybeM (throwNoNameError term) (declaredName term)) qualifiedNames
modulePaths <- resolvePythonModules (QualifiedName qualifiedName)
let namesAndPaths = toList (NonEmpty.zip (NonEmpty.zip qualifiedNames (Data.Abstract.Evaluatable.name . T.pack <$> qualifiedName)) modulePaths)

18
src/Language/Ruby/Syntax.hs
View File

@ -181,7 +181,9 @@ instance Diffable Class where
instance Evaluatable Class where
eval eval _ Class{..} = do
name <- maybeM (throwNoNameError classIdentifier) (declaredName classIdentifier)
(name, relation) <- case declaredName classIdentifier of
Just name -> pure (name, Default)
_ -> gensym >>= \name -> pure (name, Gensym)
span <- ask @Span
currentScope' <- currentScope
@ -210,7 +212,7 @@ instance Evaluatable Class where
current = (Lexical, ) <$> pure (pure currentScope')
edges = Map.fromList (superclassEdges <> current)
classScope <- newScope edges
declare (Declaration name) Default Public span ScopeGraph.Class (Just classScope)
declare (Declaration name) relation Public span ScopeGraph.Class (Just classScope)
let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes))
childFrame <- newFrame classScope frameEdges
@ -241,7 +243,9 @@ data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
instance Evaluatable Module where
eval eval _ Module{..} = do
name <- maybeM (throwNoNameError moduleIdentifier) (declaredName moduleIdentifier)
(name, relation) <- case declaredName moduleIdentifier of
Just name -> pure (name, Default)
_ -> gensym >>= \name -> pure (name, Gensym)
span <- ask @Span
currentScope' <- currentScope
@ -260,7 +264,7 @@ instance Evaluatable Module where
Nothing -> do
let edges = Map.singleton Lexical [ currentScope' ]
classScope <- newScope edges
declare (Declaration name) Default Public span ScopeGraph.Module (Just classScope)
declare (Declaration name) relation Public span ScopeGraph.Module (Just classScope)
currentFrame' <- currentFrame
let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
@ -323,10 +327,12 @@ instance Declarations1 Assignment where
instance Evaluatable Assignment where
eval eval ref Assignment{..} = do
lhsName <- maybeM (throwNoNameError assignmentTarget) (declaredName assignmentTarget)
(lhsName, relation) <- case declaredName assignmentTarget of
Just name -> pure (name, Default)
_ -> gensym >>= \name -> pure (name, Gensym)
maybeSlot <- maybeLookupDeclaration (Declaration lhsName)
assignmentSpan <- ask @Span
maybe (declare (Declaration lhsName) Default Public assignmentSpan ScopeGraph.Assignment Nothing) (const (pure ())) maybeSlot
maybe (declare (Declaration lhsName) relation Public assignmentSpan ScopeGraph.Assignment Nothing) (const (pure ())) maybeSlot
lhs <- ref assignmentTarget
rhs <- eval assignmentValue

6
src/Language/TypeScript/Syntax/Import.hs
View File

@ -58,10 +58,8 @@ instance Evaluatable QualifiedAliasedImport where
importScope <- newScope (Map.singleton ScopeGraph.Import [ moduleScope ])
let scopeMap = Map.singleton moduleScope moduleFrame
aliasFrame <- newFrame importScope (Map.singleton ScopeGraph.Import scopeMap)
alias <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm)
declare (Declaration alias) Default Public span ScopeGraph.QualifiedAliasedImport (Just importScope)
aliasSlot <- lookupSlot (Declaration alias)
name <- declareMaybeName (declaredName aliasTerm) Default Public span ScopeGraph.QualifiedAliasedImport (Just importScope)
aliasSlot <- lookupSlot (Declaration name)
assign aliasSlot =<< object aliasFrame
unit

3
src/Language/TypeScript/Syntax/JSX.hs
View File

@ -76,9 +76,8 @@ instance Declarations1 RequiredParameter where
instance Evaluatable RequiredParameter where
eval eval ref RequiredParameter{..} = do
name <- maybeM (throwNoNameError requiredParameterSubject) (declaredName requiredParameterSubject)
span <- ask @Span
declare (Declaration name) Default Public span ScopeGraph.RequiredParameter Nothing
_ <- declareMaybeName (declaredName requiredParameterSubject) Default Public span ScopeGraph.RequiredParameter Nothing
lhs <- ref requiredParameterSubject
rhs <- eval requiredParameterValue

9
src/Language/TypeScript/Syntax/TypeScript.hs
View File

@ -193,7 +193,9 @@ declareModule :: ( AbstractValue term address value m
-> [term]
-> Evaluator term address value m value
declareModule eval identifier statements = do
name <- maybeM (throwNoNameError identifier) (declaredName identifier)
(name, relation) <- case declaredName identifier of
Just name -> pure (name, Default)
_ -> gensym >>= \name -> pure (name, Gensym)
span <- ask @Span
currentScope' <- currentScope
@ -212,7 +214,7 @@ declareModule eval identifier statements = do
Nothing -> do
let edges = Map.singleton Lexical [ currentScope' ]
childScope <- newScope edges
declare (Declaration name) Default Public span ScopeGraph.Module (Just childScope)
declare (Declaration name) relation Public span ScopeGraph.Module (Just childScope)
currentFrame' <- currentFrame
let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
@ -257,7 +259,6 @@ instance Declarations a => Declarations (AbstractClass a) where
instance Evaluatable AbstractClass where
eval eval _ AbstractClass{..} = do
name <- maybeM (throwNoNameError abstractClassIdentifier) (declaredName abstractClassIdentifier)
span <- ask @Span
currentScope' <- currentScope
@ -274,7 +275,7 @@ instance Evaluatable AbstractClass where
current = (Lexical, ) <$> pure (pure currentScope')
edges = Map.fromList (superclassEdges <> current)
classScope <- newScope edges
declare (Declaration name) Default Public span ScopeGraph.AbstractClass (Just classScope)
name <- declareMaybeName (declaredName abstractClassIdentifier) Default Public span ScopeGraph.AbstractClass (Just classScope)
let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes))
childFrame <- newFrame classScope frameEdges

27
src/Parsing/TreeSitter.hs
View File

@ -6,7 +6,6 @@ module Parsing.TreeSitter
import Prologue hiding (bracket)
import Control.Concurrent.Async
import qualified Control.Exception as Exc (bracket)
import Control.Effect
import Control.Effect.Resource
@ -23,7 +22,6 @@ import Data.Location
import Data.Source
import Data.Span
import Data.Term
import Semantic.Timeout
import qualified TreeSitter.Language as TS
import qualified TreeSitter.Node as TS
@ -60,7 +58,6 @@ parseToAST :: ( Bounded grammar
, Carrier sig m
, Enum grammar
, Member Resource sig
, Member Timeout sig
, Member Trace sig
, MonadIO m
)
@ -69,25 +66,15 @@ parseToAST :: ( Bounded grammar
-> Blob
-> m (Maybe (AST [] grammar))
parseToAST parseTimeout language Blob{..} = bracket (liftIO TS.ts_parser_new) (liftIO . TS.ts_parser_delete) $ \ parser -> do
liftIO $ do
result <- liftIO $ do
let timeoutMicros = fromIntegral $ toMicroseconds parseTimeout
TS.ts_parser_set_timeout_micros parser timeoutMicros
TS.ts_parser_halt_on_error parser (CBool 1)
TS.ts_parser_set_language parser language
trace $ "tree-sitter: beginning parsing " <> blobPath
parsing <- liftIO . async $ runParser parser blobSource
-- Kick the parser off asynchronously and wait according to the provided timeout.
res <- timeout parseTimeout $ liftIO (wait parsing)
case res of
Just Failed -> Nothing <$ trace ("tree-sitter: parsing failed " <> blobPath)
Just (Succeeded ast) -> Just ast <$ trace ("tree-sitter: parsing succeeded " <> blobPath)
Nothing -> do
trace $ "tree-sitter: parsing timed out " <> blobPath
liftIO (TS.ts_parser_set_enabled parser (CBool 0))
Nothing <$ liftIO (wait parsing)
runParser parser blobSource
case result of
Failed -> Nothing <$ trace ("tree-sitter: parsing failed " <> blobPath)
(Succeeded ast) -> Just ast <$ trace ("tree-sitter: parsing succeeded " <> blobPath)
toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node)
toAST node@TS.Node{..} = do

72
src/Proto3/Google/Timestamp.hs
View File

@ -1,15 +1,63 @@
{-# LANGUAGE DeriveAnyClass #-}
module Proto3.Google.Timestamp (Timestamp (..)) where
import Prologue
import Data.Aeson
import Proto3.Suite
-- Code generated by protoc-gen-haskell 0.1.0, DO NOT EDIT.
{-# LANGUAGE DerivingVia, DeriveAnyClass, DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists #-}
-- | Predefined timestamp message provided by Google. The schema can be found
-- <https://github.com/protocolbuffers/protobuf/blob/master/src/google/protobuf/timestamp.proto here>.
module Proto3.Google.Timestamp (Timestamp (..)) where
import Control.DeepSeq
import Control.Monad (msum)
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as E
import Data.ByteString (ByteString)
import Data.Int
import Data.Text (Text)
import qualified Data.Text as T
import Data.Vector (Vector)
import Data.Word
import GHC.Generics
import Proto3.Suite (decodeMessageField, encodeMessageField, nestedvec, packedvec)
import qualified Proto3.Suite as Proto3
import Proto3.Suite.JSONPB as JSONPB
import Proto3.Wire (at, oneof)
data Timestamp = Timestamp
{ timestampSeconds :: Int64
, timestampNanos :: Int32
} deriving (Eq, Ord, Show, Generic, Message, Named, NFData, FromJSON, ToJSON)
{ seconds :: Int64
, nanos :: Int32
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Proto3.Named, NFData)
instance FromJSONPB Timestamp where
parseJSONPB = A.withObject "Timestamp" $ \obj -> Timestamp
<$> obj .: "seconds"
<*> obj .: "nanos"
instance ToJSONPB Timestamp where
toJSONPB Timestamp{..} = object
[
"seconds" .= seconds
, "nanos" .= nanos
]
toEncodingPB Timestamp{..} = pairs
[
"seconds" .= seconds
, "nanos" .= nanos
]
instance FromJSON Timestamp where
parseJSON = parseJSONPB
instance ToJSON Timestamp where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance Proto3.Message Timestamp where
encodeMessage _ Timestamp{..} = mconcat
[
encodeMessageField 1 seconds
, encodeMessageField 2 nanos
]
decodeMessage _ = Timestamp
<$> at decodeMessageField 1
<*> at decodeMessageField 2
dotProto = undefined

24
src/Proto3/Google/Wrapped.hs
View File

@ -6,7 +6,10 @@ module Proto3.Google.Wrapped
import Prologue
import qualified Data.Aeson as A
import Proto3.Suite
import Proto3.Suite.JSONPB as JSONPB
-- | Because protobuf primitive types (string, int32, etc.) are not nullable, Google provides a set of standard
-- <https://github.com/protocolbuffers/protobuf/blob/master/src/google/protobuf/wrappers.proto wrappers>
@ -16,6 +19,27 @@ import Proto3.Suite
newtype Wrapped a = Wrapped { value :: a }
deriving (Eq, Show, Ord, Generic, NFData)
instance (HasDefault a, FromJSONPB a) => FromJSONPB (Wrapped a) where
parseJSONPB = A.withObject "Value" $ \obj -> Wrapped
<$> obj .: "value"
instance (HasDefault a, ToJSONPB a) => ToJSONPB (Wrapped a) where
toJSONPB Wrapped{..} = object
[
"value" .= value
]
toEncodingPB Wrapped{..} = pairs
[
"value" .= value
]
instance (HasDefault a, FromJSONPB a) => FromJSON (Wrapped a) where
parseJSON = parseJSONPB
instance (HasDefault a, ToJSONPB a) => ToJSON (Wrapped a) where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance Named (Wrapped Text) where nameOf _ = "StringValue"
instance Named (Wrapped ByteString) where nameOf _ = "BytesValue"
instance Named (Wrapped Double) where nameOf _ = "DoubleValue"

2
src/Semantic/Api/Bridge.hs
View File

@ -98,7 +98,7 @@ instance APIBridge T.Text Data.Language where
instance APIBridge API.Blob Data.Blob where
bridging = iso apiBlobToBlob blobToApiBlob where
blobToApiBlob Data.Blob{..} = API.Blob (toText blobSource) (T.pack blobPath) (bridging # blobLanguage)
apiBlobToBlob API.Blob{..} = Data.Blob (fromText content) (T.unpack path) (language ^. bridging)
apiBlobToBlob API.Blob{..} = Data.Blob (fromText content) (T.unpack path) (language ^. bridging) mempty
instance APIConvert API.BlobPair Data.BlobPair where

11
src/Semantic/Api/Symbols.hs
View File

@ -37,8 +37,12 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap
go blob@Blob{..} = (doParse blob >>= withSomeTerm (renderToSymbols blob)) `catchError` (\(SomeException _) -> pure (pure emptyFile))
where emptyFile = Legacy.File (pack blobPath) (pack (show blobLanguage)) []
-- Legacy symbols output doesn't include Function Calls.
symbolsToSummarize :: [Text]
symbolsToSummarize = ["Function", "Method", "Class", "Module"]
renderToSymbols :: (IsTaggable f, Applicative m) => Blob -> Term f Location -> m [Legacy.File]
renderToSymbols blob term = pure $ either mempty (pure . tagsToFile blob) (runTagging blob term)
renderToSymbols blob term = pure $ either mempty (pure . tagsToFile blob) (runTagging blob symbolsToSummarize term)
tagsToFile :: Blob -> [Tag] -> Legacy.File
tagsToFile Blob{..} tags = Legacy.File (pack blobPath) (pack (show blobLanguage)) (fmap tagToSymbol tags)
@ -63,8 +67,11 @@ parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distribut
where
errorFile e = File (pack blobPath) (bridging # blobLanguage) mempty (V.fromList [ParseError (T.pack e)])
symbolsToSummarize :: [Text]
symbolsToSummarize = ["Function", "Method", "Class", "Module", "Call", "Send"]
renderToSymbols :: (IsTaggable f, Applicative m) => Blob -> Term f Location -> m File
renderToSymbols blob@Blob{..} term = pure $ either (errorFile . show) (tagsToFile blob) (runTagging blob term)
renderToSymbols blob@Blob{..} term = pure $ either (errorFile . show) (tagsToFile blob) (runTagging blob symbolsToSummarize term)
tagsToFile :: Blob -> [Tag] -> File
tagsToFile Blob{..} tags = File (pack blobPath) (bridging # blobLanguage) (V.fromList (fmap tagToSymbol tags)) mempty

3
src/Semantic/CLI.hs
View File

@ -9,6 +9,7 @@ import Data.List (intercalate, uncons)
import Data.List.Split (splitWhen)
import Data.Project
import qualified Data.Text as T
import qualified Data.Flag as Flag
import Options.Applicative hiding (style)
import Prologue
import Semantic.Api hiding (File)
@ -48,7 +49,7 @@ optionsParser = do
(long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.")
failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.")
failOnParseError <- switch (long "fail-on-parse-error" <> help "Fail on tree-sitter parse errors.")
pure $ Options logLevel failOnWarning failOnParseError
pure $ Options logLevel (Flag.flag FailOnWarning failOnWarning) (Flag.flag FailOnParseError failOnParseError)
argumentsParser :: Parser (Task.TaskEff ())
argumentsParser = do

81
src/Semantic/Config.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE LambdaCase #-}
module Semantic.Config
( Config (..)
, defaultConfig
@ -13,9 +11,17 @@ module Semantic.Config
, withLoggerFromConfig
, withStatterFromConfig
, withTelemetry
-- * Flags
, IsTerminal (..)
, LogPrintSource (..)
, FailTestParsing (..)
, FailOnWarning (..)
, FailOnParseError (..)
) where
import Data.Duration
import Data.Error (LogPrintSource(..))
import Data.Flag
import Network.HostName
import Network.HTTP.Client.TLS
import Network.URI
@ -29,43 +35,46 @@ import System.IO (hIsTerminalDevice, stdout)
import System.Posix.Process
import System.Posix.Types
data IsTerminal = IsTerminal
data FailTestParsing = FailTestParsing
data FailOnWarning = FailOnWarning
data FailOnParseError = FailOnParseError
data Config
= Config
{ configAppName :: String -- ^ Application name ("semantic")
, configHostName :: String -- ^ HostName from getHostName
, configProcessID :: ProcessID -- ^ ProcessID from getProcessID
, configHaystackURL :: Maybe String -- ^ URL of Haystack (with creds) from environment
, configStatsHost :: Stat.Host -- ^ Host of statsd/datadog (default: "127.0.0.1")
, configStatsPort :: Stat.Port -- ^ Port of statsd/datadog (default: "28125")
, configTreeSitterParseTimeout :: Duration -- ^ Timeout in milliseconds before canceling tree-sitter parsing (default: 6000).
, configAssignmentTimeout :: Duration -- ^ Millisecond timeout for assignment (default: 4000)
, configMaxTelemetyQueueSize :: Int -- ^ Max size of telemetry queues before messages are dropped (default: 1000).
, configIsTerminal :: Bool -- ^ Whether a terminal is attached (set automaticaly at runtime).
, configLogPrintSource :: Bool -- ^ Whether to print the source reference when logging errors (set automatically at runtime).
, configLogFormatter :: LogFormatter -- ^ Log formatter to use (set automaticaly at runtime).
, configSHA :: Maybe String -- ^ Optional SHA to include in log messages.
, configFailParsingForTesting :: Bool -- ^ Simulate internal parse failure for testing (default: False).
, configOptions :: Options -- ^ Options configurable via command line arguments.
{ configAppName :: String -- ^ Application name ("semantic")
, configHostName :: String -- ^ HostName from getHostName
, configProcessID :: ProcessID -- ^ ProcessID from getProcessID
, configHaystackURL :: Maybe String -- ^ URL of Haystack (with creds) from environment
, configStatsHost :: Stat.Host -- ^ Host of statsd/datadog (default: "127.0.0.1")
, configStatsPort :: Stat.Port -- ^ Port of statsd/datadog (default: "28125")
, configTreeSitterParseTimeout :: Duration -- ^ Timeout in milliseconds before canceling tree-sitter parsing (default: 6000).
, configAssignmentTimeout :: Duration -- ^ Millisecond timeout for assignment (default: 4000)
, configMaxTelemetyQueueSize :: Int -- ^ Max size of telemetry queues before messages are dropped (default: 1000).
, 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.
, configFailParsingForTesting :: Flag FailTestParsing -- ^ Simulate internal parse failure for testing (default: False).
, configOptions :: Options -- ^ Options configurable via command line arguments.
}
-- Options configurable via command line arguments.
data Options
= Options
{ optionsLogLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disables logging.
, optionsFailOnWarning :: Bool -- ^ Should semantic fail fast on assignment warnings (for testing)
, optionsFailOnParseError :: Bool -- ^ Should semantic fail fast on tree-sitter parser errors (for testing)
{ optionsLogLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disables logging.
, optionsFailOnWarning :: Flag FailOnWarning -- ^ Should semantic fail fast on assignment warnings (for testing)
, optionsFailOnParseError :: Flag FailOnParseError -- ^ Should semantic fail fast on tree-sitter parser errors (for testing)
}
defaultOptions :: Options
defaultOptions = Options (Just Warning) False False
defaultOptions = Options (Just Warning) (flag FailOnWarning False) (flag FailOnParseError False)
debugOptions :: Options
debugOptions = Options (Just Debug) False False
debugOptions = defaultOptions { optionsLogLevel = Just Debug }
infoOptions :: Options
infoOptions = Options (Just Info) False False
infoOptions = defaultOptions { optionsLogLevel = Just Info }
defaultConfig :: Options -> IO Config
defaultConfig options@Options{..} = do
@ -88,11 +97,11 @@ defaultConfig options@Options{..} = do
, configTreeSitterParseTimeout = fromMilliseconds parseTimeout
, configAssignmentTimeout = fromMilliseconds assignTimeout
, configMaxTelemetyQueueSize = size
, configIsTerminal = isTerminal
, configLogPrintSource = isTerminal
, configIsTerminal = flag IsTerminal isTerminal
, configLogPrintSource = flag LogPrintSource isTerminal
, configLogFormatter = if isTerminal then terminalFormatter else logfmtFormatter
, configSHA = Nothing
, configFailParsingForTesting = False
, configFailParsingForTesting = flag FailTestParsing False
, configOptions = options
}
@ -108,15 +117,15 @@ logOptionsFromConfig :: Config -> LogOptions
logOptionsFromConfig Config{..} = LogOptions
{ logOptionsLevel = optionsLogLevel configOptions
, logOptionsFormatter = configLogFormatter
, logOptionsContext = logOptionsContext' configIsTerminal
, logOptionsContext = logOptionsContext'
}
where logOptionsContext' = \case
False -> [ ("app", configAppName)
, ("pid", show configProcessID)
, ("hostname", configHostName)
, ("sha", fromMaybe "development" configSHA)
]
_ -> []
where logOptionsContext'
| toBool IsTerminal configIsTerminal = []
| otherwise = [ ("app", configAppName)
, ("pid", show configProcessID)
, ("hostname", configHostName)
, ("sha", fromMaybe "development" configSHA)
]
withLoggerFromConfig :: Config -> (LogQueue -> IO c) -> IO c

5
src/Semantic/REPL.hs
View File

@ -18,8 +18,9 @@ import Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Package
import Data.Abstract.Value.Concrete as Concrete
import Data.Blob (Blob(..))
import Data.Error (showExcerpt)
import Data.Error (Colourize (..), showExcerpt)
import Data.File (File (..), readBlobFromFile)
import Data.Flag (flag)
import Data.Graph (topologicalSort)
import Data.Language as Language
import Data.List (uncons)
@ -138,7 +139,7 @@ step blobs recur term = do
where list = do
path <- asks modulePath
span <- ask
maybe (pure ()) (\ blob -> output (T.pack (showExcerpt True span blob ""))) (Prelude.lookup path blobs)
maybe (pure ()) (\ blob -> output (T.pack (showExcerpt (flag Colourize True) span blob ""))) (Prelude.lookup path blobs)
help = do
output "Commands available from the prompt:"
output ""

24
src/Semantic/Task.hs
View File

@ -68,11 +68,11 @@ import Control.Effect.Trace
import Control.Monad
import Control.Monad.IO.Class
import Data.Blob
import Data.Bool
import Data.ByteString.Builder
import Data.Coerce
import Data.Diff
import qualified Data.Error as Error
import qualified Data.Flag as Flag
import Data.Location
import Data.Source (Source)
import Data.Sum
@ -240,7 +240,7 @@ instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader
Semantic.Task.Diff terms k -> k (diffTermPair terms)
Render renderer input k -> k (renderer input)
Serialize format input k -> do
formatStyle <- asks (bool Plain Colourful . configIsTerminal . config)
formatStyle <- asks (Flag.choose IsTerminal Plain Colourful . configIsTerminal . config)
k (runSerialize formatStyle format input)
@ -253,9 +253,9 @@ logError :: (Member Telemetry sig, Carrier sig m)
-> [(String, String)]
-> m ()
logError TaskSession{..} level blob err =
let configLogPrintSource' = configLogPrintSource config
configIsTerminal' = configIsTerminal config
in writeLog level (Error.formatError configLogPrintSource' configIsTerminal' blob err)
let shouldLogSource = configLogPrintSource config
shouldColorize = Flag.switch IsTerminal Error.Colourize $ configIsTerminal config
in writeLog level (Error.formatError shouldLogSource shouldColorize blob err)
data ParserCancelled = ParserTimedOut | AssignmentTimedOut
deriving (Show, Typeable)
@ -308,8 +308,13 @@ runParser blob@Blob{..} parser = case parser of
taskSession <- ask
let requestID' = ("github_request_id", requestID taskSession)
let isPublic' = ("github_is_public", show (isPublic taskSession))
let blobFields = ("path", if isPublic taskSession || configLogPrintSource (config taskSession) then blobPath else "<filtered>")
let logPrintFlag = configLogPrintSource . config $ taskSession
let blobFields = ("path", if isPublic taskSession || Flag.toBool LogPrintSource logPrintFlag then blobPath else "<filtered>")
let logFields = requestID' : isPublic' : blobFields : languageTag
let shouldFailForTesting = configFailParsingForTesting $ config taskSession
let shouldFailOnParsing = optionsFailOnParseError . configOptions $ config taskSession
let shouldFailOnWarning = optionsFailOnWarning . configOptions $ config taskSession
ast <- runParser blob parser `catchError` \ (SomeException err) -> do
writeStat (increment "parse.parse_failures" languageTag)
writeLog Error "failed parsing" (("task", "parse") : logFields)
@ -326,15 +331,14 @@ runParser blob@Blob{..} parser = case parser of
Just "ParseError" -> do
when (i == 0) $ writeStat (increment "parse.parse_errors" languageTag)
logError taskSession Warning blob err (("task", "parse") : logFields)
when (optionsFailOnParseError (configOptions (config taskSession))) $ throwError (toException err)
when (Flag.toBool FailOnParseError shouldFailOnParsing) (throwError (toException err))
_ -> do
when (i == 0) $ writeStat (increment "parse.assign_warnings" languageTag)
logError taskSession Warning blob err (("task", "assign") : logFields)
when (optionsFailOnWarning (configOptions (config taskSession))) $ throwError (toException err)
when (Flag.toBool FailOnWarning shouldFailOnWarning) (throwError (toException err))
term <$ writeStat (count "parse.nodes" (length term) languageTag)
case res of
Just r | not (configFailParsingForTesting (config taskSession))
-> pure r
Just r | not (Flag.toBool FailTestParsing shouldFailForTesting) -> pure r
_ -> do
writeStat (increment "assign.assign_timeouts" languageTag)
writeLog Error "assignment timeout" (("task", "assign") : logFields)

5
src/Semantic/Telemetry/Log.hs
View File

@ -8,7 +8,8 @@ module Semantic.Telemetry.Log
, writeLogMessage
) where
import Data.Error (withSGRCode)
import Data.Error (Colourize (..), withSGRCode)
import Data.Flag as Flag
import Data.List (intersperse)
import qualified Data.Time.Format as Time
import qualified Data.Time.LocalTime as LocalTime
@ -75,7 +76,7 @@ terminalFormatter LogOptions{..} (Message level message pairs time) =
. showPairs (pairs <> logOptionsContext)
. showChar '\n' $ ""
where
colourize = True
colourize = flag Colourize True
showLevel Error = withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "ERROR")
showLevel Warning = withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString " WARN")
showLevel Info = withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString " INFO")

11
src/Tags/Taggable.hs
View File

@ -200,6 +200,15 @@ instance Taggable TypeScript.Module where
snippet ann (TypeScript.Module _ _ ) = Just $ locationByteRange ann
symbolName = declaredName . TypeScript.moduleIdentifier
instance Taggable Expression.Call where
snippet ann (Expression.Call _ _ _ (Term (In body _))) = Just $ subtractLocation ann body
symbolName = declaredName . Expression.callFunction
instance Taggable Ruby.Send where
snippet ann (Ruby.Send _ _ _ (Just (Term (In body _)))) = Just $ subtractLocation ann body
snippet ann _ = Just $ locationByteRange ann
symbolName Ruby.Send{..} = maybe Nothing declaredName sendSelector
instance Taggable []
instance Taggable Comment.Comment
instance Taggable Comment.HashBang
@ -209,7 +218,6 @@ instance Taggable Expression.Await
instance Taggable Expression.BAnd
instance Taggable Expression.BOr
instance Taggable Expression.BXOr
instance Taggable Expression.Call
instance Taggable Expression.Cast
instance Taggable Expression.Comparison
instance Taggable Expression.Complement
@ -606,7 +614,6 @@ instance Taggable PHP.PropertyModifier
instance Taggable PHP.InterfaceDeclaration
instance Taggable PHP.Declare
instance Taggable Ruby.Send
instance Taggable Ruby.Require
instance Taggable Ruby.Load
instance Taggable Ruby.LowPrecedenceAnd

12
src/Tags/Tagging.hs
View File

@ -21,19 +21,17 @@ import Data.Term
import Data.Text hiding (empty)
import Tags.Taggable
symbolsToSummarize :: [Text]
symbolsToSummarize = ["Function", "Method", "Class", "Module"]
runTagging :: (IsTaggable syntax)
=> Blob
-> [Text]
-> Term syntax Location
-> Either TranslationError [Tag]
runTagging blob tree
runTagging blob symbolsToSummarize tree
= Eff.run
. Error.runError
. State.evalState mempty
. runT $ source (tagging blob tree)
~> contextualizing blob
~> contextualizing blob symbolsToSummarize
type ContextToken = (Text, Maybe Range)
@ -41,8 +39,8 @@ type Contextualizer
= StateC [ContextToken]
( ErrorC TranslationError PureC)
contextualizing :: Blob -> Machine.ProcessT Contextualizer Token Tag
contextualizing Blob{..} = repeatedly $ await >>= \case
contextualizing :: Blob -> [Text] -> Machine.ProcessT Contextualizer Token Tag
contextualizing Blob{..} symbolsToSummarize = repeatedly $ await >>= \case
Enter x r -> enterScope (x, r)
Exit x r -> exitScope (x, r)
Iden iden span docsLiteralRange -> lift State.get >>= \case

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

@ -568,7 +568,7 @@ instance Listable Span where
tiers = cons2 Span
instance Listable Blob where
tiers = cons3 Blob
tiers = cons4 Blob
instance Listable BlobPair where
tiers = liftTiers tiers

5
test/Examples.hs
View File

@ -10,6 +10,7 @@ import Data.ByteString.Builder
import qualified Data.ByteString.Char8 as BC
import Data.Either
import Data.File (file)
import Data.Flag
import Data.Foldable
import Data.List
import Data.Maybe
@ -18,7 +19,7 @@ import Data.Typeable (cast)
import Data.Void
import Parsing.Parser
import Semantic.Api (TermOutputFormat (..), parseTermBuilder)
import Semantic.Config (Config (..), Options (..), defaultOptions)
import Semantic.Config (Config (..), Options (..), FailOnWarning (..), defaultOptions)
import qualified Semantic.IO as IO
import Semantic.Task
import Semantic.Task.Files
@ -58,7 +59,7 @@ main = withOptions opts $ \ config logger statter -> hspec . parallel $ do
else res `shouldSatisfy` isRight
setupExampleRepos = readProcess "script/clone-example-repos" mempty mempty >>= print
opts = defaultOptions { optionsFailOnWarning = True, optionsLogLevel = Nothing }
opts = defaultOptions { optionsFailOnWarning = flag FailOnWarning True, optionsLogLevel = Nothing }
knownFailuresForPath :: FilePath -> Maybe FilePath -> IO [FilePath]
knownFailuresForPath _ Nothing = pure []

37
test/Parsing/Spec.hs Normal file
View File

@ -0,0 +1,37 @@
module Parsing.Spec (spec) where
import Control.Effect
import Data.AST
import Data.Blob
import Data.ByteString.Char8 (pack)
import Data.Duration
import Data.Language
import Data.Maybe
import Data.Source
import Language.JSON.Grammar (Grammar)
import Parsing.TreeSitter
import Semantic.Config
import SpecHelpers
import System.Timeout
import TreeSitter.JSON
spec :: Spec
spec = parallel $ do
describe "parseToAST" $ do
let source = toJSONSource $ take 10000 [1..]
let largeBlob = sourceBlob "large.json" JSON source
it "returns a result when the timeout does not expire" $ do
let timeout = fromMicroseconds 0 -- Zero microseconds indicates no timeout
let parseTask = parseToAST timeout tree_sitter_json largeBlob :: TaskEff (Maybe (AST [] Grammar))
result <- runTaskOrDie parseTask
(isJust result) `shouldBe` True
it "returns nothing when the timeout expires" $ do
let timeout = fromMicroseconds 1000
let parseTask = parseToAST timeout tree_sitter_json largeBlob :: TaskEff (Maybe (AST [] Grammar))
result <- runTaskOrDie parseTask
(isNothing result) `shouldBe` True
toJSONSource :: Show a => a -> Source
toJSONSource = fromUTF8 . pack . show

2
test/Reprinting/Spec.hs
View File

@ -67,5 +67,5 @@ spec = describe "reprinting" $ do
it "should be able to parse the output of a refactor" $ do
let (Just tagged) = rewrite (mark Unmodified tree) (topDownAny increaseNumbers)
let (Right printed) = runReprinter src defaultJSONPipeline tagged
tree' <- runTaskOrDie (parse jsonParser (Blob printed path Language.JSON))
tree' <- runTaskOrDie (parse jsonParser (Blob printed path Language.JSON mempty))
length tree' `shouldSatisfy` (/= 0)

23
test/Semantic/IO/Spec.hs
View File

@ -11,11 +11,6 @@ import System.IO (IOMode (..))
import Parsing.TreeSitter
import System.Timeout
import qualified TreeSitter.Language as TS
import qualified TreeSitter.Node as TS
import qualified TreeSitter.Parser as TS
import qualified TreeSitter.Tree as TS
import Data.Blob
import Data.Handle
import SpecHelpers hiding (readFile)
@ -79,24 +74,6 @@ spec = parallel $ do
h <- openFileForReading "test/fixtures/cli/diff-null-both-sides.json"
readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1)
describe "cancelable parsing" $
it "should be cancelable asynchronously" $ do
p <- TS.ts_parser_new
churn <- async $ do
TS.ts_parser_loop_until_cancelled p nullPtr nullPtr 0
pure True
res <- timeout 2500 (wait churn)
res `shouldBe` Nothing
TS.ts_parser_set_enabled p (CBool 0)
done <- timeout 2500 (wait churn)
done `shouldBe` (Just True)
TS.ts_parser_delete p
describe "readBlobsFromHandle" $ do
it "returns blobs for valid JSON encoded parse input" $ do
h <- openFileForReading "test/fixtures/cli/parse.json"

2
test/Semantic/Spec.hs
View File

@ -22,4 +22,4 @@ spec = parallel $ do
output <- fmap runBuilder . runTaskOrDie $ parseTermBuilder TermSExpression [methodsBlob]
output `shouldBe` "(Statements\n (Method\n (Empty)\n (Identifier)\n (Statements)))\n"
where
methodsBlob = Blob "def foo\nend\n" "methods.rb" Ruby
methodsBlob = Blob "def foo\nend\n" "methods.rb" Ruby mempty

2
test/Spec.hs
View File

@ -23,6 +23,7 @@ import qualified Diffing.Interpreter.Spec
import qualified Graphing.Calls.Spec
import qualified Integration.Spec
import qualified Numeric.Spec
import qualified Parsing.Spec
import qualified Rendering.TOC.Spec
import qualified Reprinting.Spec
import qualified Rewriting.Go.Spec
@ -75,3 +76,4 @@ main = do
describe "Semantic.CLI" Semantic.CLI.Spec.spec
describe "Semantic.IO" Semantic.IO.Spec.spec
describe "Integration" (Integration.Spec.spec args)
describe "Parsing" Parsing.Spec.spec

49
test/Tags/Spec.hs
View File

@ -1,7 +1,8 @@
module Tags.Spec (spec) where
import Tags.Tagging
import Data.Text (Text)
import SpecHelpers
import Tags.Tagging
spec :: Spec
@ -9,35 +10,40 @@ spec = parallel $ do
describe "go" $ do
it "produces tags for functions with docs" $ do
(blob, tree) <- parseTestFile goParser "test/fixtures/go/tags/simple_functions.go"
runTagging blob tree `shouldBe` Right
[ Tag "TestFromBits" "Function" (Span (Pos 6 1) (Pos 7 2)) ["Statements"] (Just "func TestFromBits(t *testing.T)") (Just "// TestFromBits ...")
, Tag "Hi" "Function" (Span (Pos 9 1) (Pos 10 2)) ["Statements"] (Just "func Hi()") Nothing ]
runTagging blob symbolsToSummarize tree `shouldBe` Right
[ Tag "TestFromBits" "Function" (Span (Pos 6 1) (Pos 8 2)) ["Statements"] (Just "func TestFromBits(t *testing.T) {") (Just "// TestFromBits ...")
, Tag "Hi" "Function" (Span (Pos 10 1) (Pos 11 2)) ["Statements"] (Just "func Hi()") Nothing ]
it "produces tags for methods" $ do
(blob, tree) <- parseTestFile goParser "test/fixtures/go/tags/method.go"
runTagging blob tree `shouldBe` Right
runTagging blob symbolsToSummarize tree `shouldBe` Right
[ Tag "CheckAuth" "Method" (Span (Pos 3 1) (Pos 3 100)) ["Statements"] (Just "func (c *apiClient) CheckAuth(req *http.Request, user, repo string) (*authenticatedActor, error)") Nothing]
it "produces tags for calls" $ do
(blob, tree) <- parseTestFile goParser "test/fixtures/go/tags/simple_functions.go"
runTagging blob ["Call"] tree `shouldBe` Right
[ Tag "Hi" "Call" (Span (Pos 7 2) (Pos 7 6)) ["Function", "Context", "Statements"] (Just "Hi()") Nothing]
describe "javascript and typescript" $ do
it "produces tags for functions with docs" $ do
(blob, tree) <- parseTestFile typescriptParser "test/fixtures/javascript/tags/simple_function_with_docs.js"
runTagging blob tree `shouldBe` Right
runTagging blob symbolsToSummarize tree `shouldBe` Right
[ Tag "myFunction" "Function" (Span (Pos 2 1) (Pos 4 2)) ["Statements"] (Just "function myFunction()") (Just "// This is myFunction") ]
it "produces tags for classes" $ do
(blob, tree) <- parseTestFile typescriptParser "test/fixtures/typescript/tags/class.ts"
runTagging blob tree `shouldBe` Right
runTagging blob symbolsToSummarize tree `shouldBe` Right
[ Tag "FooBar" "Class" (Span (Pos 1 1) (Pos 1 16)) ["Statements"] (Just "class FooBar") Nothing ]
it "produces tags for modules" $ do
(blob, tree) <- parseTestFile typescriptParser "test/fixtures/typescript/tags/module.ts"
runTagging blob tree `shouldBe` Right
runTagging blob symbolsToSummarize tree `shouldBe` Right
[ Tag "APromise" "Module" (Span (Pos 1 1) (Pos 1 20)) ["Statements"] (Just "module APromise { }") Nothing ]
describe "python" $ do
it "produces tags for functions" $ do
(blob, tree) <- parseTestFile pythonParser "test/fixtures/python/tags/simple_functions.py"
runTagging blob tree `shouldBe` Right
runTagging blob symbolsToSummarize tree `shouldBe` Right
[ Tag "Foo" "Function" (Span (Pos 1 1) (Pos 5 17)) ["Statements"] (Just "def Foo(x)") Nothing
, Tag "Bar" "Function" (Span (Pos 7 1) (Pos 11 13)) ["Statements"] (Just "def Bar()") Nothing
, Tag "local" "Function" (Span (Pos 8 5) (Pos 9 17)) ["Statements", "Function", "Statements"] (Just "def local()") Nothing
@ -45,35 +51,43 @@ spec = parallel $ do
it "produces tags for functions with docs" $ do
(blob, tree) <- parseTestFile pythonParser "test/fixtures/python/tags/simple_function_with_docs.py"
runTagging blob tree `shouldBe` Right
runTagging blob symbolsToSummarize tree `shouldBe` Right
[ Tag "Foo" "Function" (Span (Pos 1 1) (Pos 3 13)) ["Statements"] (Just "def Foo(x)") (Just "\"\"\"This is the foo function\"\"\"") ]
it "produces tags for classes" $ do
(blob, tree) <- parseTestFile pythonParser "test/fixtures/python/tags/class.py"
runTagging blob tree `shouldBe` Right
runTagging blob symbolsToSummarize tree `shouldBe` Right
[ Tag "Foo" "Class" (Span (Pos 1 1) (Pos 5 17)) ["Statements"] (Just "class Foo") (Just "\"\"\"The Foo class\"\"\"")
, Tag "f" "Function" (Span (Pos 3 5) (Pos 5 17)) ["Statements", "Class", "Statements"] (Just "def f(self)") (Just "\"\"\"The f method\"\"\"")
]
it "produces tags for multi-line functions" $ do
(blob, tree) <- parseTestFile pythonParser "test/fixtures/python/tags/multiline.py"
runTagging blob tree `shouldBe` Right
runTagging blob symbolsToSummarize tree `shouldBe` Right
[ Tag "Foo" "Function" (Span (Pos 1 1) (Pos 3 13)) ["Statements"] (Just "def Foo(x,") Nothing ]
describe "ruby" $ do
it "produces tags for methods" $ do
(blob, tree) <- parseTestFile rubyParser "test/fixtures/ruby/tags/simple_method.rb"
runTagging blob tree `shouldBe` Right
[ Tag "foo" "Method" (Span (Pos 1 1) (Pos 2 4)) ["Statements"] (Just "def foo") Nothing ]
runTagging blob symbolsToSummarize tree `shouldBe` Right
[ Tag "foo" "Method" (Span (Pos 1 1) (Pos 4 4)) ["Statements"] (Just "def foo") Nothing ]
it "produces tags for sends" $ do
(blob, tree) <- parseTestFile rubyParser "test/fixtures/ruby/tags/simple_method.rb"
runTagging blob ["Send"] tree `shouldBe` Right
[ Tag "puts" "Send" (Span (Pos 2 3) (Pos 2 12)) ["Statements", "Method", "Statements"] (Just "puts \"hi\"") Nothing
, Tag "bar" "Send" (Span (Pos 3 3) (Pos 3 8)) ["Statements", "Method", "Statements"] (Just "a.bar") Nothing
, Tag "a" "Send" (Span (Pos 3 3) (Pos 3 4)) ["Send", "Statements", "Method", "Statements"] (Just "a") Nothing
]
it "produces tags for methods with docs" $ do
(blob, tree) <- parseTestFile rubyParser "test/fixtures/ruby/tags/simple_method_with_docs.rb"
runTagging blob tree `shouldBe` Right
runTagging blob symbolsToSummarize tree `shouldBe` Right
[ Tag "foo" "Method" (Span (Pos 2 1) (Pos 3 4)) ["Statements"] (Just "def foo") (Just "# Public: foo") ]
it "produces tags for methods and classes with docs" $ do
(blob, tree) <- parseTestFile rubyParser "test/fixtures/ruby/tags/class_module.rb"
runTagging blob tree `shouldBe` Right
runTagging blob symbolsToSummarize tree `shouldBe` Right
[ Tag "Foo" "Module" (Span (Pos 2 1 ) (Pos 12 4)) ["Statements"] (Just "module Foo") (Just "# Public: Foo")
, Tag "Bar" "Class" (Span (Pos 5 3 ) (Pos 11 6)) ["Module", "Context", "Statements"] (Just "class Bar") (Just "# Public: Bar")
, Tag "baz" "Method" (Span (Pos 8 5 ) (Pos 10 8)) ["Class", "Context", "Module", "Context", "Statements"] (Just "def baz(a)") (Just "# Public: baz")
@ -81,3 +95,6 @@ spec = parallel $ do
, Tag "foo" "Method" (Span (Pos 15 3) (Pos 17 6)) ["Statements", "Class", "Statements"] (Just "def foo") Nothing
, Tag "foo" "Method" (Span (Pos 18 3) (Pos 19 6)) ["Statements", "Class", "Statements"] (Just "def self.foo") Nothing
]
symbolsToSummarize :: [Text]
symbolsToSummarize = ["Function", "Method", "Class", "Module"]

1
test/fixtures/go/tags/simple_functions.go vendored
View File

@ -4,6 +4,7 @@ import "testing"
// TestFromBits ...
func TestFromBits(t *testing.T) {
Hi()
}
func Hi() {

2
test/fixtures/ruby/tags/simple_method.rb vendored
View File

@ -1,2 +1,4 @@
def foo
puts "hi"
a.bar
end

2
vendor/haskell-tree-sitter vendored

@ -1 +1 @@
Subproject commit 53dbe815fd85726484294833dfaece544d5f423d
Subproject commit fd22b2cfa318a989759d8a9334d178eb3748813a