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 'master' into alephd-testing

Browse Source
This commit is contained in:
Rick Winfrey 2019-03-25 15:30:41 -07:00
commit 5824409984
11 changed files with 138 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
semantic.cabal
View File

@ -132,6 +132,7 @@ library
, Data.Duration
, Data.Error
, Data.File
, Data.Flag
, Data.Functor.Both
, Data.Functor.Classes.Generic
, Proto3.Google.Timestamp

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

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)))

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 #-}

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")

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 []

2
vendor/haskell-tree-sitter vendored

@ -1 +1 @@
Subproject commit c1f68ad52aa03c875a579dd862d7d3e096251931
Subproject commit fd22b2cfa318a989759d8a9334d178eb3748813a