From 36b5ac8aa910f0623ec69800eacb97dc07b3cdf7 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Wed, 13 Jun 2018 11:42:51 +1000 Subject: [PATCH 01/46] move multiple into AbstractValue and rename to tuple --- src/Control/Abstract/Value.hs | 6 +++--- src/Data/Abstract/Type.hs | 3 ++- src/Data/Abstract/Value.hs | 5 ++--- src/Data/Syntax/Declaration.hs | 2 +- src/Data/Syntax/Literal.hs | 2 +- 5 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 3d710ef6b..96d6fb515 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -73,9 +73,6 @@ class Show value => AbstractIntro value where -- | Construct a rational value. rational :: Rational -> value - -- | Construct an N-ary tuple of multiple (possibly-disjoint) values - multiple :: [value] -> value - -- | Construct a key-value pair for use in a hash. kvPair :: value -> value -> value @@ -114,6 +111,9 @@ class (AbstractFunction address value effects, AbstractIntro value) => AbstractV liftBitwise2 :: (forall a . (Integral a, Bits a) => a -> a -> a) -> (value -> value -> Evaluator address value effects value) + -- | Construct an N-ary tuple of multiple (possibly-disjoint) values + tuple :: [value] -> Evaluator address value effects value + -- | Construct an array of zero or more values. array :: [value] -> Evaluator address value effects value diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 7b018c54d..cecff696f 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -108,7 +108,6 @@ instance AbstractIntro Type where float _ = Float symbol _ = Symbol rational _ = Rational - multiple = zeroOrMoreProduct hash = Hash kvPair k v = k :* v @@ -153,6 +152,8 @@ instance ( Member (Allocator address Type) effects var <- fresh Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fields + tuple = pure . zeroOrMoreProduct + klass _ _ _ = pure Object namespace _ _ = pure Unit diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index eacdaa6ea..4217aa586 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -92,8 +92,6 @@ instance Show address => AbstractIntro (Value address body) where symbol = Symbol rational = Rational . Number.Ratio - multiple = Tuple - kvPair = KVPair hash = Hash . map (uncurry KVPair) @@ -117,7 +115,8 @@ instance ( Coercible body (Eff effects) | KVPair k v <- val = pure (k, v) | otherwise = throwValueError $ KeyValueError val - array = pure . Array + tuple = pure . Tuple + array = pure . Array klass n [] env = pure $ Class n env klass n supers env = do diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 240af7443..ed418a7ff 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -101,7 +101,7 @@ instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable VariableDeclaration where eval (VariableDeclaration []) = rvalBox unit - eval (VariableDeclaration decs) = rvalBox =<< (multiple <$> traverse subtermValue decs) + eval (VariableDeclaration decs) = rvalBox =<< tuple =<< traverse subtermValue decs instance Declarations a => Declarations (VariableDeclaration a) where declaredName (VariableDeclaration vars) = case vars of diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index bab376729..51afb1ab2 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -200,7 +200,7 @@ instance Ord1 Tuple where liftCompare = genericLiftCompare instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Tuple where - eval (Tuple cs) = rvalBox =<< (multiple <$> traverse subtermValue cs) + eval (Tuple cs) = rvalBox =<< tuple =<< traverse subtermValue cs newtype Set a = Set { setElements :: [a] } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable) From c3d3425600a2b7de181128de7f4c8768e7d9d89c Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 14:23:55 -0700 Subject: [PATCH 02/46] Intermediate, but compiling refactor of config and telemetry --- semantic.cabal | 8 +- src/Semantic/CLI.hs | 12 +- src/Semantic/Config.hs | 76 +++++++++--- src/Semantic/Diff.hs | 2 +- src/Semantic/Log.hs | 117 ------------------ src/Semantic/Task.hs | 60 ++++----- src/Semantic/Telemetry.hs | 64 +++++++++- .../{Queue.hs => Telemetry/AsyncQueue.hs} | 42 +++---- src/Semantic/{ => Telemetry}/Haystack.hs | 18 +-- src/Semantic/Telemetry/Log.hs | 78 ++++++++++++ src/Semantic/{ => Telemetry}/Stat.hs | 29 +---- 11 files changed, 263 insertions(+), 243 deletions(-) delete mode 100644 src/Semantic/Log.hs rename src/Semantic/{Queue.hs => Telemetry/AsyncQueue.hs} (50%) rename src/Semantic/{ => Telemetry}/Haystack.hs (77%) create mode 100644 src/Semantic/Telemetry/Log.hs rename src/Semantic/{ => Telemetry}/Stat.hs (82%) diff --git a/semantic.cabal b/semantic.cabal index 86110c8db..5959d5d37 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -155,13 +155,13 @@ library , Semantic.Distribute , Semantic.Env , Semantic.Graph - , Semantic.Haystack , Semantic.IO - , Semantic.Log , Semantic.Parse - , Semantic.Queue + , Semantic.Telemetry.Log + , Semantic.Telemetry.AsyncQueue + , Semantic.Telemetry.Haystack + , Semantic.Telemetry.Stat , Semantic.Resolution - , Semantic.Stat , Semantic.Task , Semantic.Telemetry , Semantic.Util diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index c92f8bbaf..f19f690aa 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -7,10 +7,10 @@ module Semantic.CLI , Parse.runParse ) where -import Data.Project import Data.Language (ensureLanguage) import Data.List (intercalate) import Data.List.Split (splitWhen) +import Data.Project import Data.Version (showVersion) import Development.GitRev import Options.Applicative hiding (style) @@ -18,13 +18,14 @@ import qualified Paths_semantic as Library (version) import Prologue import Rendering.Renderer import qualified Semantic.AST as AST +import Semantic.Config import qualified Semantic.Diff as Diff import qualified Semantic.Graph as Graph import Semantic.IO as IO -import qualified Semantic.Log as Log import qualified Semantic.Parse as Parse import qualified Semantic.Task as Task -import Serializing.Format +import qualified Semantic.Telemetry.Log as Log +import Serializing.Format hiding (Options) import Text.Read main :: IO () @@ -33,7 +34,7 @@ main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTa -- | A parser for the application's command-line arguments. -- -- Returns a 'Task' to read the input, run the requested operation, and write the output to the specified output path or stdout. -arguments :: ParserInfo (Log.Options, Task.TaskEff ()) +arguments :: ParserInfo (Options, Task.TaskEff ()) arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsParser)) description where version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program") @@ -41,12 +42,11 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar description = fullDesc <> header "semantic -- Parse and diff semantically" optionsParser = do - disableColour <- not <$> switch (long "disable-colour" <> long "disable-color" <> help "Disable ANSI colors in log messages even if the terminal is a TTY.") logLevel <- options [ ("error", Just Log.Error) , ("warning", Just Log.Warning) , ("info", Just Log.Info) , ("debug", Just Log.Debug) , ("none", Nothing)] (long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.") requestId <- optional (strOption $ long "request-id" <> help "A string to use as the request identifier for any logged messages." <> metavar "id") failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.") - pure $ Log.Options disableColour logLevel requestId False False Log.logfmtFormatter 0 failOnWarning + pure $ Options logLevel requestId failOnWarning argumentsParser = do subparser <- hsubparser (diffCommand <> parseCommand <> tsParseCommand <> graphCommand) diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index 52a302478..2999849c3 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -1,53 +1,93 @@ module Semantic.Config where +import Control.Exception import Network.BSD import Network.HTTP.Client.TLS import Network.URI import Prologue -import Semantic.Haystack -import Semantic.Log -import Semantic.Stat +import Semantic.Telemetry +import Semantic.Telemetry.AsyncQueue +import qualified Semantic.Telemetry.Stat as Stat +import qualified Semantic.Telemetry.Log as Log +import Semantic.Env import System.Environment -import System.IO (stderr) +import System.IO (hIsTerminalDevice, stderr) import System.Posix.Process import System.Posix.Types 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 - , configStatsAddr :: StatsAddr -- ^ Address of statsd/datadog - , configLogOptions :: Options -- ^ Options pertaining to logging + { 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 + , configStatsAddr :: StatsAddr -- ^ Address of statsd/datadog + + , configMaxTelemetyQueueSize :: Int -- ^ Max size of telemetry queues before messages are dropped. + , 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). + + , 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' disabled logging. + , optionsRequestID :: Maybe String -- ^ Optional request id for tracing across systems. + , optionsFailOnWarning :: Bool -- ^ Should semantic fail fast on assignment warnings (for testing) } data StatsAddr = StatsAddr { addrHost :: String, addrPort :: String } +defaultOptions :: Options +defaultOptions = Options (Just Warning) Nothing False + defaultConfig :: IO Config -defaultConfig = do +defaultConfig = defaultConfig' defaultOptions + +defaultConfig' :: Options -> IO Config +defaultConfig' options@Options{..} = do pid <- getProcessID hostName <- getHostName + isTerminal <- hIsTerminalDevice stderr haystackURL <- lookupEnv "HAYSTACK_URL" statsAddr <- lookupStatsAddr - logOptions <- configureOptionsForHandle stderr defaultOptions + size <- envLookupInt 1000 "MAX_TELEMETRY_QUEUE_SIZE" pure Config { configAppName = "semantic" , configHostName = hostName , configProcessID = pid , configHaystackURL = haystackURL , configStatsAddr = statsAddr - , configLogOptions = logOptions - } -defaultHaystackClient :: IO HaystackClient -defaultHaystackClient = defaultConfig >>= haystackClientFromConfig + , configMaxTelemetyQueueSize = size + , configIsTerminal = isTerminal + , configLogPrintSource = isTerminal + , configLogFormatter = logfmtFormatter + + , configOptions = options + } haystackClientFromConfig :: Config -> IO HaystackClient haystackClientFromConfig Config{..} = haystackClient configHaystackURL tlsManagerSettings configHostName configAppName -defaultStatsClient :: IO StatsClient -defaultStatsClient = defaultConfig >>= statsClientFromConfig + +withLogger :: Config -> (LogQueue -> IO c) -> IO c +withLogger c = bracket (defaultLoggerFromConfig c) closeAsyncQueue + +defaultLoggerFromConfig :: Config -> IO LogQueue +defaultLoggerFromConfig Config{..} = + newAsyncQueue configMaxTelemetyQueueSize Log.writeLogMessage LogOptions{ + optionsLevel = optionsLogLevel configOptions + , optionsFormatter = configLogFormatter + , optionsLogContext = [("app", configAppName), ("process_id", show configProcessID)] <> [("request_id", x) | x <- toList (optionsRequestID configOptions) ] + } + + +defaultStatterFromConfig :: Config -> IO StatQueue +defaultStatterFromConfig c@Config{..} = statsClientFromConfig c >>= newAsyncQueue configMaxTelemetyQueueSize Stat.sendStat statsClientFromConfig :: Config -> IO StatsClient statsClientFromConfig Config{..} = statsClient (addrHost configStatsAddr) (addrPort configStatsAddr) configAppName diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index d100e7e57..c36d23b57 100644 --- a/src/Semantic/Diff.hs +++ b/src/Semantic/Diff.hs @@ -15,7 +15,7 @@ import Prologue hiding (MonadError(..)) import Rendering.Graph import Rendering.Renderer import Semantic.IO (noLanguageForBlob) -import Semantic.Stat as Stat +import Semantic.Telemetry as Stat import Semantic.Task as Task import Serializing.Format diff --git a/src/Semantic/Log.hs b/src/Semantic/Log.hs deleted file mode 100644 index 81fae6269..000000000 --- a/src/Semantic/Log.hs +++ /dev/null @@ -1,117 +0,0 @@ -module Semantic.Log where - -import Control.Monad.IO.Class -import Data.Error (withSGRCode) -import Data.List (intersperse) -import qualified Data.Time.Clock.POSIX as Time (getCurrentTime) -import qualified Data.Time.Format as Time -import qualified Data.Time.LocalTime as LocalTime -import Prologue -import Semantic.Queue -import System.Console.ANSI -import System.IO -import System.Posix.Process -import System.Posix.Types -import Text.Printf - --- | A log message at a specific level. -data Message = Message Level String [(String, String)] LocalTime.ZonedTime - deriving (Show) - -data Level - = Error - | Warning - | Info - | Debug - deriving (Eq, Ord, Show) - -type LogQueue = AsyncQueue Message Options - --- | Queue a message to be logged. -queueLogMessage :: MonadIO io => LogQueue -> Level -> String -> [(String, String)] -> io () -queueLogMessage q@AsyncQueue{..} level message pairs - | Just logLevel <- optionsLevel asyncQueueExtra, level <= logLevel = liftIO Time.getCurrentTime >>= liftIO . LocalTime.utcToLocalZonedTime >>= liftIO . queue q . Message level message pairs - | otherwise = pure () - --- | Log a message to stderr. -logMessage :: MonadIO io => Options -> Message -> io () -logMessage options@Options{..} = liftIO . hPutStr stderr . optionsFormatter options - --- | Format log messaging using "logfmt". --- --- Logfmt is a loosely defined logging format (see https://brandur.org/logfmt) --- for structured data, which plays very well with indexing tools like Splunk. --- --- Example: --- time=2006-01-02T15:04:05Z07:00 msg="this is a message" key=val int=42 key2="val with word" float=33.33 -logfmtFormatter :: Options -> Message -> String -logfmtFormatter Options{..} (Message level message pairs time) = - showPairs - ( kv "time" (showTime time) - : kv "msg" (shows message) - : kv "level" (shows level) - : kv "process_id" (shows optionsProcessID) - : kv "app" (showString "semantic") - : (uncurry kv . second shows <$> pairs) - <> [ kv "request_id" (shows x) | x <- toList optionsRequestID ] ) - . showChar '\n' $ "" - where - kv k v = showString k . showChar '=' . v - showPairs = foldr (.) id . intersperse (showChar ' ') - showTime = showString . Time.formatTime Time.defaultTimeLocale "%FT%XZ%z" - --- | Format log messages to a terminal. Suitable for local development. --- --- Example: --- [16:52:41] INFO this is a message key=val language=Ruby time=0.000098s -terminalFormatter :: Options -> Message -> String -terminalFormatter Options{..} (Message level message pairs time) = - showChar '[' . showTime time . showString "] " - . showLevel level . showChar ' ' - . showString (printf "%-20s " message) - . showPairs pairs - . showChar '\n' $ "" - where - colourize = optionsIsTerminal && optionsEnableColour - 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") - showLevel Debug = withSGRCode colourize [SetColor Foreground Vivid White, SetConsoleIntensity BoldIntensity] (showString "DEBUG") - showPairs pairs = foldr (.) id $ intersperse (showChar ' ') (showPair <$> pairs) - showPair (k, v) = showString k . showChar '=' . withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString v) - showTime = showString . Time.formatTime Time.defaultTimeLocale "%X" - --- | Options controlling logging, error handling, &c. -data Options = Options - { optionsEnableColour :: Bool -- ^ Whether to enable colour formatting for logging (Only works when logging to a terminal that supports ANSI colors). - , optionsLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging. - , optionsRequestID :: Maybe String -- ^ Optional request id for tracing across systems. - , optionsIsTerminal :: Bool -- ^ Whether a terminal is attached (set automaticaly at runtime). - , optionsPrintSource :: Bool -- ^ Whether to print the source reference when logging errors (set automatically at runtime). - , optionsFormatter :: Options -> Message -> String -- ^ Log formatter to use (set automaticaly at runtime). - , optionsProcessID :: CPid -- ^ ProcessID (set automaticaly at runtime). - , optionsFailOnWarning :: Bool - } - -defaultOptions :: Options -defaultOptions = Options - { optionsEnableColour = True - , optionsLevel = Just Warning - , optionsRequestID = Nothing - , optionsIsTerminal = False - , optionsPrintSource = False - , optionsFormatter = logfmtFormatter - , optionsProcessID = 0 - , optionsFailOnWarning = False - } - -configureOptionsForHandle :: MonadIO io => Handle -> Options -> io Options -configureOptionsForHandle handle options = liftIO $ do - pid <- getProcessID - isTerminal <- hIsTerminalDevice handle - pure $ options - { optionsIsTerminal = isTerminal - , optionsFormatter = if isTerminal then terminalFormatter else logfmtFormatter - , optionsPrintSource = isTerminal - , optionsProcessID = pid - } diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 8da449dde..2628e3225 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -31,14 +31,13 @@ module Semantic.Task , distributeFor , distributeFoldMap -- * Configuration -, defaultOptions -, configureOptionsForHandle +, defaultConfig , terminalFormatter , logfmtFormatter -- * Interpreting , runTask , runTaskWithOptions -, runTaskWithOptions' +, runTaskWithConfig -- * Re-exports , Distribute , Eff @@ -71,12 +70,13 @@ import Parsing.CMark import Parsing.Parser import Parsing.TreeSitter import Prologue hiding (MonadError (..), project) +import Semantic.Config import Semantic.Distribute import qualified Semantic.IO as IO +-- import Semantic.Log +-- import Semantic.Queue import Semantic.Resolution -import Semantic.Log -import Semantic.Queue -import Semantic.Stat as Stat +import Semantic.Telemetry.Stat as Stat import Semantic.Telemetry import Serializing.Format hiding (Options) import System.Exit (die) @@ -87,7 +87,7 @@ type TaskEff = Eff '[Distribute WrappedTask , Task , Resolution , IO.Files - , Reader Options + , Reader Config , Trace , Telemetry , Exc SomeException @@ -129,23 +129,23 @@ serialize format = send . Serialize format runTask :: TaskEff a -> IO a runTask = runTaskWithOptions defaultOptions --- | Execute a 'TaskEff' with the passed 'Options', yielding its result value in 'IO'. +-- | Execute a 'TaskEff' with the passed 'Config', yielding its result value in 'IO'. runTaskWithOptions :: Options -> TaskEff a -> IO a -runTaskWithOptions options task = do - let size = 100 -- Max size of telemetry queues, less important for the CLI. - options <- configureOptionsForHandle stderr options - statter <- defaultStatsClient >>= newQueue size sendStat - logger <- newQueue size logMessage options +runTaskWithOptions opts task = do + config <- defaultConfig' opts + statter <- defaultStatterFromConfig config + -- logger <- defaultLoggerFromConfig c - result <- runTaskWithOptions' options logger statter task + result <- withLogger config $ \logger -> + runTaskWithConfig config logger statter task - closeQueue statter - closeStatClient (asyncQueueExtra statter) - closeQueue logger + -- closeQueue statter + -- closeStatClient (asyncQueueExtra statter) + -- closeQueue logger either (die . displayException) pure result -runTaskWithOptions' :: Options -> LogQueue -> AsyncQueue Stat StatsClient -> TaskEff a -> IO (Either SomeException a) -runTaskWithOptions' options logger statter task = do +runTaskWithConfig :: Config -> LogQueue -> StatQueue -> TaskEff a -> IO (Either SomeException a) +runTaskWithConfig options logger statter task = do (result, stat) <- withTiming "run" [] $ do let run :: TaskEff a -> IO (Either SomeException a) run = runM . runError @@ -157,7 +157,7 @@ runTaskWithOptions' options logger statter task = do . runTaskF . runDistribute (run . unwrapTask) run task - queue statter stat + queueStat statter stat pure result runTraceInTelemetry :: Member Telemetry effects => Eff (Trace ': effects) a -> Eff effects a @@ -174,7 +174,7 @@ data Task output where Serialize :: Format input -> input -> Task Builder -- | Run a 'Task' effect by performing the actions in 'IO'. -runTaskF :: (Member (Exc SomeException) effs, Member IO effs, Member (Reader Options) effs, Member Telemetry effs, Member Trace effs) => Eff (Task ': effs) a -> Eff effs a +runTaskF :: (Member (Exc SomeException) effs, Member IO effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs) => Eff (Task ': effs) a -> Eff effs a runTaskF = interpret $ \ task -> case task of Parse parser blob -> runParser blob parser Analyze interpret analysis -> pure (interpret analysis) @@ -182,13 +182,13 @@ runTaskF = interpret $ \ task -> case task of Semantic.Task.Diff terms -> pure (diffTermPair terms) Render renderer input -> pure (renderer input) Serialize format input -> do - formatStyle <- asks (bool Colourful Plain . optionsEnableColour) + formatStyle <- asks (bool Colourful Plain . configIsTerminal) pure (runSerialize formatStyle format input) -- | Log an 'Error.Error' at the specified 'Level'. -logError :: Member Telemetry effs => Options -> Level -> Blob -> Error.Error String -> [(String, String)] -> Eff effs () -logError Options{..} level blob err = writeLog level (Error.formatError optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob err) +logError :: Member Telemetry effs => Config -> Level -> Blob -> Error.Error String -> [(String, String)] -> Eff effs () +logError Config{..} level blob err = writeLog level (Error.formatError configLogPrintSource configIsTerminal blob err) data ParserCancelled = ParserTimedOut deriving (Show, Typeable) @@ -198,7 +198,7 @@ defaultTimeout :: Timeout defaultTimeout = Milliseconds 5000 -- | Parse a 'Blob' in 'IO'. -runParser :: (Member (Exc SomeException) effs, Member IO effs, Member (Reader Options) effs, Member Telemetry effs, Member Trace effs) => Blob -> Parser term -> Eff effs term +runParser :: (Member (Exc SomeException) effs, Member IO effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs) => Blob -> Parser term -> Eff effs term runParser blob@Blob{..} parser = case parser of ASTParser language -> time "parse.tree_sitter_ast_parse" languageTag $ @@ -210,22 +210,22 @@ runParser blob@Blob{..} parser = case parser of writeStat (Stat.increment "parse.parse_failures" languageTag) writeLog Error "failed parsing" (("task", "parse") : blobFields) throwError (toException err) - options <- ask + config <- ask time "parse.assign" languageTag $ case Assignment.assign blobSource assignment ast of Left err -> do writeStat (Stat.increment "parse.assign_errors" languageTag) - logError options Error blob err (("task", "assign") : blobFields) + logError config Error blob err (("task", "assign") : blobFields) throwError (toException err) Right term -> do for_ (errors term) $ \ err -> case Error.errorActual err of Just "ParseError" -> do writeStat (Stat.increment "parse.parse_errors" languageTag) - logError options Warning blob err (("task", "parse") : blobFields) + logError config Warning blob err (("task", "parse") : blobFields) _ -> do writeStat (Stat.increment "parse.assign_warnings" languageTag) - logError options Warning blob err (("task", "assign") : blobFields) - when (optionsFailOnWarning options) $ throwError (toException err) + logError config Warning blob err (("task", "assign") : blobFields) + when (optionsFailOnWarning (configOptions config)) $ throwError (toException err) writeStat (Stat.count "parse.nodes" (length term) languageTag) pure term MarkdownParser -> diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index ca0628ab8..3144bf472 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -1,6 +1,28 @@ {-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-} module Semantic.Telemetry -( writeLog +( + LogQueue +, StatQueue +, HaystackQueue +, queueLogMessage +, queueErrorReport +, queueStat + +, Stat.count +, statsClient +, StatsClient + +, haystackClient +, HaystackClient + +, Level(..) +, LogOptions(..) +, logfmtFormatter +, terminalFormatter +, LogFormatter + +-- Eff interface +, writeLog , writeStat , time , Telemetry @@ -8,11 +30,41 @@ module Semantic.Telemetry , ignoreTelemetry ) where +import Control.Exception import Control.Monad.Effect import Control.Monad.IO.Class -import Semantic.Log -import Semantic.Queue -import Semantic.Stat +import Semantic.Telemetry.AsyncQueue +import Semantic.Telemetry.Haystack +import Semantic.Telemetry.Log +import Semantic.Telemetry.Stat as Stat +import qualified Data.Time.Clock.POSIX as Time (getCurrentTime) +import qualified Data.Time.Format as Time +import qualified Data.Time.LocalTime as LocalTime + +type LogQueue = AsyncQueue Message LogOptions +type StatQueue = AsyncQueue Stat StatsClient +type HaystackQueue = AsyncQueue ErrorReport HaystackClient + +-- data TelemetryQueues = TelemetryQueues LogQueue StatQueue HaystackQueue + + +-- | Queue a message to be logged. +queueLogMessage :: MonadIO io => LogQueue -> Level -> String -> [(String, String)] -> io () +queueLogMessage q@AsyncQueue{..} level message pairs + | Just logLevel <- optionsLevel asyncQueueExtra + , level <= logLevel = liftIO Time.getCurrentTime >>= liftIO . LocalTime.utcToLocalZonedTime >>= liftIO . writeAsyncQueue q . Message level message pairs + | otherwise = pure () + +-- | Queue an error to be reported to haystack. +queueErrorReport :: MonadIO io => HaystackQueue -> SomeException -> [(String, String)] -> io () +queueErrorReport q@AsyncQueue{..} message = liftIO . writeAsyncQueue q . ErrorReport message + +-- | Queue a stat to be sent to statsd. +queueStat :: MonadIO io => StatQueue -> Stat -> io () +queueStat q = liftIO . writeAsyncQueue q + + +-- Eff interface -- | A task which logs a message at a specific log level to stderr. writeLog :: Member Telemetry effs => Level -> String -> [(String, String)] -> Eff effs () @@ -35,9 +87,9 @@ data Telemetry output where WriteLog :: Level -> String -> [(String, String)] -> Telemetry () -- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to. -runTelemetry :: Member IO effects => LogQueue -> AsyncQueue Stat StatsClient -> Eff (Telemetry ': effects) a -> Eff effects a +runTelemetry :: Member IO effects => LogQueue -> StatQueue -> Eff (Telemetry ': effects) a -> Eff effects a runTelemetry logger statter = interpret (\ t -> case t of - WriteStat stat -> liftIO (queue statter stat) + WriteStat stat -> queueStat statter stat WriteLog level message pairs -> queueLogMessage logger level message pairs) -- | Run a 'Telemetry' effect by ignoring statting/logging. diff --git a/src/Semantic/Queue.hs b/src/Semantic/Telemetry/AsyncQueue.hs similarity index 50% rename from src/Semantic/Queue.hs rename to src/Semantic/Telemetry/AsyncQueue.hs index 7b992ca3d..220c169e8 100644 --- a/src/Semantic/Queue.hs +++ b/src/Semantic/Telemetry/AsyncQueue.hs @@ -1,10 +1,10 @@ -module Semantic.Queue +module Semantic.Telemetry.AsyncQueue ( AsyncQueue(..) -, newQueue -, newQueue' -, queue -, closeQueue +, newAsyncQueue +-- , newAsyncQueue' +, writeAsyncQueue +, closeAsyncQueue ) where @@ -20,36 +20,36 @@ import GHC.Conc -- * 'extra' - any other type needed to process messages on the queue. data AsyncQueue a extra = AsyncQueue - { asyncQueue :: TBMQueue a -- ^ The underlying 'TBMQueue'. - , asyncQueueSink :: Async () -- ^ A sink that will drain the queue. - , asyncQueueExtra :: extra -- ^ Any exta data the queue needs to use. + { asyncQueue :: TBMQueue a -- ^ The underlying 'TBMQueue'. + , asyncQueueSink :: Async () -- ^ A sink that will drain the queue. + , asyncQueueExtra :: extra -- ^ Any exta data the queue needs to use. } --- | Create a new AsyncQueue with the given capacity using the default sink. -newQueue :: Int -> (extra -> a -> IO ()) -> extra -> IO (AsyncQueue a extra) -newQueue i = newQueue' i . sink +-- | Create a new AsyncQueue with the given capacity using the defaultSink. +newAsyncQueue :: Int -> (extra -> a -> IO ()) -> extra -> IO (AsyncQueue a extra) +newAsyncQueue i = newAsyncQueue' i . defaultSink -- | Create a new AsyncQueue with the given capacity, specifying a custom sink. -newQueue' :: Int -> (extra -> TBMQueue a -> IO ()) -> extra -> IO (AsyncQueue a extra) -newQueue' i f extra = do +newAsyncQueue' :: Int -> (extra -> TBMQueue a -> IO ()) -> extra -> IO (AsyncQueue a extra) +newAsyncQueue' i f extra = do q <- newTBMQueueIO i s <- Async.async (f extra q) pure (AsyncQueue q s extra) --- | Queue a message. -queue :: AsyncQueue a extra -> a -> IO () -queue AsyncQueue{..} = void . atomically . tryWriteTBMQueue asyncQueue +-- | Write a message to the queue. +writeAsyncQueue :: AsyncQueue a extra -> a -> IO () +writeAsyncQueue AsyncQueue{..} = void . atomically . tryWriteTBMQueue asyncQueue -- | Drain messages from the queue, calling the specified function for each message. -sink :: (extra -> a -> IO ()) -> extra -> TBMQueue a -> IO () -sink f extra q = do +defaultSink :: (extra -> a -> IO ()) -> extra -> TBMQueue a -> IO () +defaultSink f extra q = do msg <- atomically (readTBMQueue q) maybe (pure ()) go msg - where go msg = f extra msg >> sink f extra q + where go msg = f extra msg >> defaultSink f extra q -- | Close the queue. -closeQueue :: AsyncQueue a extra -> IO () -closeQueue AsyncQueue{..} = do +closeAsyncQueue :: AsyncQueue a extra -> IO () +closeAsyncQueue AsyncQueue{..} = do atomically (closeTBMQueue asyncQueue) Async.wait asyncQueueSink diff --git a/src/Semantic/Haystack.hs b/src/Semantic/Telemetry/Haystack.hs similarity index 77% rename from src/Semantic/Haystack.hs rename to src/Semantic/Telemetry/Haystack.hs index e6d43b5d4..4686ddcff 100644 --- a/src/Semantic/Haystack.hs +++ b/src/Semantic/Telemetry/Haystack.hs @@ -1,4 +1,4 @@ -module Semantic.Haystack where +module Semantic.Telemetry.Haystack where import Control.Exception import Control.Monad.IO.Class @@ -10,8 +10,6 @@ import qualified Data.Text.Encoding as Text import Network.HTTP.Client import Network.HTTP.Types.Status (statusCode) import Prologue hiding (hash) -import Semantic.Log -import Semantic.Queue import System.IO.Error data ErrorReport @@ -29,10 +27,6 @@ data HaystackClient } | NullHaystackClient -- ^ Doesn't report needles, good for testing or when the 'HAYSTACK_URL' env var isn't set. --- Queue an error to be reported to haystack. -queueErrorReport :: MonadIO io => AsyncQueue ErrorReport HaystackClient -> SomeException -> [(String, String)] -> io () -queueErrorReport q@AsyncQueue{..} message = liftIO . queue q . ErrorReport message - -- Create a Haystack HTTP client. haystackClient :: Maybe String -> ManagerSettings -> String -> String -> IO HaystackClient haystackClient maybeURL managerSettings hostName appName @@ -47,12 +41,12 @@ haystackClient maybeURL managerSettings hostName appName | otherwise = pure NullHaystackClient -- Report an error to Haystack over HTTP (blocking). -reportError :: MonadIO io => String -> LogQueue -> HaystackClient -> ErrorReport -> io () -reportError _ logger NullHaystackClient ErrorReport{..} = let msg = takeWhile (/= '\n') (displayException errorReportException) in queueLogMessage logger Error msg errorReportContext +reportError :: MonadIO io => String -> (String -> [(String, String)] -> io ()) -> HaystackClient -> ErrorReport -> io () +reportError _ logger NullHaystackClient ErrorReport{..} = let msg = takeWhile (/= '\n') (displayException errorReportException) in logger msg errorReportContext reportError sha logger HaystackClient{..} ErrorReport{..} = do let fullMsg = displayException errorReportException let summary = takeWhile (/= '\n') fullMsg - queueLogMessage logger Error summary errorReportContext + logger summary errorReportContext let payload = object $ [ "app" .= haystackClientAppName , "host" .= haystackClientHostName @@ -66,11 +60,11 @@ reportError sha logger HaystackClient{..} ErrorReport{..} = do response <- liftIO . tryIOError $ httpLbs request haystackClientManager case response of - Left e -> queueLogMessage logger Error ("Failed to report error to haystack: " <> displayException e) [] + Left e -> logger ("Failed to report error to haystack: " <> displayException e) [] Right response -> do let status = statusCode (responseStatus response) if status /= 201 - then queueLogMessage logger Error ("Failed to report error to haystack, status=" <> show status <> ".") [] + then logger ("Failed to report error to haystack, status=" <> show status <> ".") [] else pure () where rollup :: String -> Text diff --git a/src/Semantic/Telemetry/Log.hs b/src/Semantic/Telemetry/Log.hs new file mode 100644 index 000000000..7ad10bbd8 --- /dev/null +++ b/src/Semantic/Telemetry/Log.hs @@ -0,0 +1,78 @@ +module Semantic.Telemetry.Log where + +import Control.Monad.IO.Class +import Data.Error (withSGRCode) +import Data.List (intersperse) +import qualified Data.Time.Format as Time +import qualified Data.Time.LocalTime as LocalTime +import Prologue +import System.Console.ANSI +import System.IO +import Text.Printf + +-- | A log message at a specific level. +data Message = Message Level String [(String, String)] LocalTime.ZonedTime + deriving (Show) + +-- | A formatter function for crafting log messages. +type LogFormatter = LogOptions -> Message -> String + +-- | Logging level +data Level + = Error + | Warning + | Info + | Debug + deriving (Eq, Ord, Show) + +-- | Options for controlling logging +data LogOptions = LogOptions + { optionsLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging. + , optionsFormatter :: LogFormatter -- ^ Log formatter to use. + , optionsLogContext :: [(String, String)] + } + +-- | Write a log a message to stderr. +writeLogMessage :: MonadIO io => LogOptions -> Message -> io () +writeLogMessage options@LogOptions{..} = liftIO . hPutStr stderr . optionsFormatter options + +-- | Format log messaging using "logfmt". +-- +-- Logfmt is a loosely defined logging format (see https://brandur.org/logfmt) +-- for structured data, which plays very well with indexing tools like Splunk. +-- +-- Example: +-- time=2006-01-02T15:04:05Z07:00 msg="this is a message" key=val int=42 key2="val with word" float=33.33 +logfmtFormatter :: LogFormatter +logfmtFormatter LogOptions{..} (Message level message pairs time) = + showPairs + ( kv "time" (showTime time) + : kv "msg" (shows message) + : kv "level" (shows level) + : (uncurry kv . second shows <$> (pairs <> optionsLogContext))) + . showChar '\n' $ "" + where + kv k v = showString k . showChar '=' . v + showPairs = foldr (.) id . intersperse (showChar ' ') + showTime = showString . Time.formatTime Time.defaultTimeLocale "%FT%XZ%z" + +-- | Format log messages to a terminal. Suitable for local development. +-- +-- Example: +-- [16:52:41] INFO this is a message key=val language=Ruby time=0.000098s +terminalFormatter :: LogFormatter +terminalFormatter LogOptions{..} (Message level message pairs time) = + showChar '[' . showTime time . showString "] " + . showLevel level . showChar ' ' + . showString (printf "%-20s " message) + . showPairs pairs + . showChar '\n' $ "" + where + 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") + showLevel Debug = withSGRCode colourize [SetColor Foreground Vivid White, SetConsoleIntensity BoldIntensity] (showString "DEBUG") + showPairs pairs = foldr (.) id $ intersperse (showChar ' ') (showPair <$> pairs) + showPair (k, v) = showString k . showChar '=' . withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString v) + showTime = showString . Time.formatTime Time.defaultTimeLocale "%X" diff --git a/src/Semantic/Stat.hs b/src/Semantic/Telemetry/Stat.hs similarity index 82% rename from src/Semantic/Stat.hs rename to src/Semantic/Telemetry/Stat.hs index 81e3687b3..8fab1ea3f 100644 --- a/src/Semantic/Stat.hs +++ b/src/Semantic/Telemetry/Stat.hs @@ -1,4 +1,4 @@ -module Semantic.Stat +module Semantic.Telemetry.Stat ( -- Primary API for creating stats. increment @@ -12,7 +12,6 @@ module Semantic.Stat , Stat -- Client -, defaultStatsClient , statsClient , StatsClient(..) , closeStatClient @@ -105,32 +104,6 @@ data StatsClient , statsClientUDPPort :: String } --- | Create a default stats client. This function consults two optional --- environment variables for the stats URI (default: 127.0.0.1:28125). --- * STATS_ADDR - String URI to send stats to in the form of `host:port`. --- * DOGSTATSD_HOST - String hostname which will override the above host. --- Generally used on kubes pods. -defaultStatsClient :: MonadIO io => io StatsClient -defaultStatsClient = liftIO $ do - addr <- lookupEnv "STATS_ADDR" - let (host', port) = parseAddr (fmap ("statsd://" <>) addr) - - -- When running in Kubes, DOGSTATSD_HOST is set with the dogstatsd host. - kubesHost <- lookupEnv "DOGSTATSD_HOST" - let host = fromMaybe host' kubesHost - - statsClient host port "semantic" - where - defaultHost = "127.0.0.1" - defaultPort = "28125" - parseAddr a | Just s <- a - , Just (Just (URIAuth _ host port)) <- uriAuthority <$> parseURI s - = (parseHost host, parsePort port) - | otherwise = (defaultHost, defaultPort) - parseHost s = if null s then defaultHost else s - parsePort s = if null s then defaultPort else dropWhile (':' ==) s - - -- | Create a StatsClient at the specified host and port with a namespace prefix. statsClient :: MonadIO io => String -> String -> String -> io StatsClient statsClient host port statsClientNamespace = liftIO $ do From 78d7ccd43b5c2455b23a74deb9e8193676d8cfb5 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:38:44 -0700 Subject: [PATCH 03/46] OK to expose this --- src/Semantic/Telemetry/AsyncQueue.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Semantic/Telemetry/AsyncQueue.hs b/src/Semantic/Telemetry/AsyncQueue.hs index 220c169e8..f484665cb 100644 --- a/src/Semantic/Telemetry/AsyncQueue.hs +++ b/src/Semantic/Telemetry/AsyncQueue.hs @@ -2,7 +2,7 @@ module Semantic.Telemetry.AsyncQueue ( AsyncQueue(..) , newAsyncQueue --- , newAsyncQueue' +, newAsyncQueue' , writeAsyncQueue , closeAsyncQueue ) @@ -25,7 +25,6 @@ data AsyncQueue a extra , asyncQueueExtra :: extra -- ^ Any exta data the queue needs to use. } - -- | Create a new AsyncQueue with the given capacity using the defaultSink. newAsyncQueue :: Int -> (extra -> a -> IO ()) -> extra -> IO (AsyncQueue a extra) newAsyncQueue i = newAsyncQueue' i . defaultSink From bff74e55d19a5f86c8501c5af1b70d0ab35467e7 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:39:01 -0700 Subject: [PATCH 04/46] Attempt to have buildVersion in it's own file --- semantic.cabal | 1 + src/Semantic/Version.hs | 13 +++++++++++++ 2 files changed, 14 insertions(+) create mode 100644 src/Semantic/Version.hs diff --git a/semantic.cabal b/semantic.cabal index 5959d5d37..da71a7e4b 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -165,6 +165,7 @@ library , Semantic.Task , Semantic.Telemetry , Semantic.Util + , Semantic.Version -- Serialization , Serializing.DOT , Serializing.Format diff --git a/src/Semantic/Version.hs b/src/Semantic/Version.hs new file mode 100644 index 000000000..391910ce3 --- /dev/null +++ b/src/Semantic/Version.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fforce-recomp #-} -- So that gitHash is correct. +{-# LANGUAGE TemplateHaskell #-} +module Semantic.Version where + +import Data.Version (showVersion) +import Development.GitRev +import qualified Paths_semantic as Library (version) + +buildSHA :: String +buildSHA = $(gitHash) + +buildVersion :: String +buildVersion = showVersion Library.version From a1949ae3228d285a8206870e881f8397f39fb92f Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:39:13 -0700 Subject: [PATCH 05/46] Re-order --- semantic.cabal | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/semantic.cabal b/semantic.cabal index da71a7e4b..afab26033 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -157,13 +157,13 @@ library , Semantic.Graph , Semantic.IO , Semantic.Parse - , Semantic.Telemetry.Log - , Semantic.Telemetry.AsyncQueue - , Semantic.Telemetry.Haystack - , Semantic.Telemetry.Stat , Semantic.Resolution , Semantic.Task , Semantic.Telemetry + , Semantic.Telemetry.AsyncQueue + , Semantic.Telemetry.Haystack + , Semantic.Telemetry.Log + , Semantic.Telemetry.Stat , Semantic.Util , Semantic.Version -- Serialization From 40ec08ad007d37422d463191ea6e0d0de0aa6ebd Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:39:35 -0700 Subject: [PATCH 06/46] Expose tags, clean imports --- src/Semantic/Telemetry/Stat.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Semantic/Telemetry/Stat.hs b/src/Semantic/Telemetry/Stat.hs index 8fab1ea3f..3c42e42a6 100644 --- a/src/Semantic/Telemetry/Stat.hs +++ b/src/Semantic/Telemetry/Stat.hs @@ -10,6 +10,7 @@ module Semantic.Telemetry.Stat , histogram , set , Stat +, Tags -- Client , statsClient @@ -31,10 +32,8 @@ import qualified Data.Time.Clock.POSIX as Time (getCurrentTime) import Network.Socket (Socket (..), SocketType (..), addrAddress, addrFamily, close, connect, defaultProtocol, getAddrInfo, socket) import Network.Socket.ByteString -import Network.URI import Numeric import Prologue -import System.Environment import System.IO.Error -- | A named piece of data you wish to record a specific 'Metric' for. From 3ac9d5efeb4bee003b12c76e2a36f9817e56420f Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:39:49 -0700 Subject: [PATCH 07/46] Don't need this --- src/Semantic/Telemetry.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index 3144bf472..37aba9f55 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -45,9 +45,6 @@ type LogQueue = AsyncQueue Message LogOptions type StatQueue = AsyncQueue Stat StatsClient type HaystackQueue = AsyncQueue ErrorReport HaystackClient --- data TelemetryQueues = TelemetryQueues LogQueue StatQueue HaystackQueue - - -- | Queue a message to be logged. queueLogMessage :: MonadIO io => LogQueue -> Level -> String -> [(String, String)] -> io () queueLogMessage q@AsyncQueue{..} level message pairs From 3c34a590081e0bb8c99196b6ffcb4e48a60a536e Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:39:56 -0700 Subject: [PATCH 08/46] Remove imports --- src/Semantic/Telemetry.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index 37aba9f55..333c1068d 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -38,7 +38,6 @@ import Semantic.Telemetry.Haystack import Semantic.Telemetry.Log import Semantic.Telemetry.Stat as Stat import qualified Data.Time.Clock.POSIX as Time (getCurrentTime) -import qualified Data.Time.Format as Time import qualified Data.Time.LocalTime as LocalTime type LogQueue = AsyncQueue Message LogOptions From 470d911f981b275fc3e6accb8409a5ad185d82d5 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:40:09 -0700 Subject: [PATCH 09/46] Try out extra helpers like statCount --- src/Semantic/Telemetry.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index 333c1068d..ddef7840a 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -24,6 +24,7 @@ module Semantic.Telemetry -- Eff interface , writeLog , writeStat +, statCount , time , Telemetry , runTelemetry @@ -70,6 +71,9 @@ writeLog level message pairs = send (WriteLog level message pairs) writeStat :: Member Telemetry effs => Stat -> Eff effs () writeStat stat = send (WriteStat stat) +statCount :: Member Telemetry effs => String -> Int -> Tags -> Eff effs () +statCount n i = send . WriteStat . count n i + -- | A task which measures and stats the timing of another task. time :: (Member IO effs, Member Telemetry effs) => String -> [(String, String)] -> Eff effs output -> Eff effs output time statName tags task = do From 427d1dc0817f1a9001dc7e10ee19c74ea5a73d15 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:40:16 -0700 Subject: [PATCH 10/46] Expose rest of Stat api --- src/Semantic/Telemetry.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index ddef7840a..60f23a65e 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -8,7 +8,14 @@ module Semantic.Telemetry , queueErrorReport , queueStat +, Stat.increment +, Stat.decrement , Stat.count +, Stat.gauge +, Stat.timing +, Stat.withTiming +, Stat.histogram +, Stat.set , statsClient , StatsClient From 0e630d8da3b81e507195c849c6687e1bc00d6f3c Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:40:51 -0700 Subject: [PATCH 11/46] Don't keep hostname in here - external concern --- src/Semantic/Telemetry/Haystack.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Semantic/Telemetry/Haystack.hs b/src/Semantic/Telemetry/Haystack.hs index 4686ddcff..af1c2d52f 100644 --- a/src/Semantic/Telemetry/Haystack.hs +++ b/src/Semantic/Telemetry/Haystack.hs @@ -22,14 +22,13 @@ data HaystackClient = HaystackClient { haystackClientRequest :: Request , haystackClientManager :: Manager - , haystackClientHostName :: String , haystackClientAppName :: String } | NullHaystackClient -- ^ Doesn't report needles, good for testing or when the 'HAYSTACK_URL' env var isn't set. -- Create a Haystack HTTP client. -haystackClient :: Maybe String -> ManagerSettings -> String -> String -> IO HaystackClient -haystackClient maybeURL managerSettings hostName appName +haystackClient :: Maybe String -> ManagerSettings -> String -> IO HaystackClient +haystackClient maybeURL managerSettings appName | Just url <- maybeURL = do manager <- newManager managerSettings request' <- parseRequest url @@ -37,7 +36,7 @@ haystackClient maybeURL managerSettings hostName appName { method = "POST" , requestHeaders = ("Content-Type", "application/json; charset=utf-8") : requestHeaders request' } - pure $ HaystackClient request manager hostName appName + pure $ HaystackClient request manager appName | otherwise = pure NullHaystackClient -- Report an error to Haystack over HTTP (blocking). @@ -49,7 +48,6 @@ reportError sha logger HaystackClient{..} ErrorReport{..} = do logger summary errorReportContext let payload = object $ [ "app" .= haystackClientAppName - , "host" .= haystackClientHostName , "sha" .= sha , "message" .= summary , "class" .= summary From b07bfd810e62eaa1be381680e277db49f409af63 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:41:08 -0700 Subject: [PATCH 12/46] Logger function so we don't depend on a specific logger --- src/Semantic/Telemetry/Haystack.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Telemetry/Haystack.hs b/src/Semantic/Telemetry/Haystack.hs index af1c2d52f..2ac49e79c 100644 --- a/src/Semantic/Telemetry/Haystack.hs +++ b/src/Semantic/Telemetry/Haystack.hs @@ -26,6 +26,9 @@ data HaystackClient } | NullHaystackClient -- ^ Doesn't report needles, good for testing or when the 'HAYSTACK_URL' env var isn't set. +-- | Function to log if there are errors reporting to haystack. +type ErrorLogger io = String -> [(String, String)] -> io () + -- Create a Haystack HTTP client. haystackClient :: Maybe String -> ManagerSettings -> String -> IO HaystackClient haystackClient maybeURL managerSettings appName @@ -40,9 +43,9 @@ haystackClient maybeURL managerSettings appName | otherwise = pure NullHaystackClient -- Report an error to Haystack over HTTP (blocking). -reportError :: MonadIO io => String -> (String -> [(String, String)] -> io ()) -> HaystackClient -> ErrorReport -> io () -reportError _ logger NullHaystackClient ErrorReport{..} = let msg = takeWhile (/= '\n') (displayException errorReportException) in logger msg errorReportContext -reportError sha logger HaystackClient{..} ErrorReport{..} = do +reportError :: MonadIO io => ErrorLogger io -> HaystackClient -> ErrorReport -> io () +reportError logger NullHaystackClient ErrorReport{..} = let msg = takeWhile (/= '\n') (displayException errorReportException) in logger msg errorReportContext +reportError logger HaystackClient{..} ErrorReport{..} = do let fullMsg = displayException errorReportException let summary = takeWhile (/= '\n') fullMsg logger summary errorReportContext From cea7a4a880b50424c3aa2588616e7838a9f0cb0c Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:41:18 -0700 Subject: [PATCH 13/46] Let external callers log sha --- src/Semantic/Telemetry/Haystack.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Semantic/Telemetry/Haystack.hs b/src/Semantic/Telemetry/Haystack.hs index 2ac49e79c..de4130683 100644 --- a/src/Semantic/Telemetry/Haystack.hs +++ b/src/Semantic/Telemetry/Haystack.hs @@ -51,7 +51,6 @@ reportError logger HaystackClient{..} ErrorReport{..} = do logger summary errorReportContext let payload = object $ [ "app" .= haystackClientAppName - , "sha" .= sha , "message" .= summary , "class" .= summary , "backtrace" .= fullMsg From 5ad2b6476918f6142e72e77eae0742534e89f4d1 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:41:32 -0700 Subject: [PATCH 14/46] Try out the new statCount API --- src/Semantic/Diff.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index c36d23b57..d5f65e276 100644 --- a/src/Semantic/Diff.hs +++ b/src/Semantic/Diff.hs @@ -46,7 +46,7 @@ withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> WrapTask (wi where diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member IO effs, Member Task effs, Member Telemetry effs) => BlobPair -> Join These (Term syntax (Record fields)) -> Eff effs (Diff syntax (Record fields) (Record fields)) diffTerms blobs terms = time "diff" languageTag $ do diff <- diff (runJoin terms) - diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag) + diff <$ statCount "diff.nodes" (bilength diff) languageTag where languageTag = languageTagForBlobPair blobs withParsedBlobPair :: (Member (Distribute WrappedTask) effs, Member (Exc SomeException) effs) From 797099946317d14aa1979712a06ce080330a8580 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:42:04 -0700 Subject: [PATCH 15/46] Continue to refine config API --- src/Semantic/CLI.hs | 11 +++---- src/Semantic/Config.hs | 55 +++++++++++++++++++++++------------ src/Semantic/Task.hs | 18 ++++-------- src/Semantic/Telemetry.hs | 2 +- src/Semantic/Telemetry/Log.hs | 12 ++++---- 5 files changed, 52 insertions(+), 46 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index f19f690aa..a949eb77f 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -1,5 +1,4 @@ -{-# OPTIONS_GHC -fforce-recomp #-} -- So that gitHash is correct. -{-# LANGUAGE ApplicativeDo, RankNTypes, TemplateHaskell #-} +{-# LANGUAGE ApplicativeDo, RankNTypes #-} module Semantic.CLI ( main -- Testing @@ -11,10 +10,7 @@ import Data.Language (ensureLanguage) import Data.List (intercalate) import Data.List.Split (splitWhen) import Data.Project -import Data.Version (showVersion) -import Development.GitRev import Options.Applicative hiding (style) -import qualified Paths_semantic as Library (version) import Prologue import Rendering.Renderer import qualified Semantic.AST as AST @@ -25,6 +21,7 @@ import Semantic.IO as IO import qualified Semantic.Parse as Parse import qualified Semantic.Task as Task import qualified Semantic.Telemetry.Log as Log +import Semantic.Version import Serializing.Format hiding (Options) import Text.Read @@ -38,9 +35,9 @@ arguments :: ParserInfo (Options, Task.TaskEff ()) arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsParser)) description where version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program") - versionString = "semantic version " <> showVersion Library.version <> " (" <> $(gitHash) <> ")" + versionString = "semantic version " <> buildVersion <> " (" <> buildSHA <> ")" description = fullDesc <> header "semantic -- Parse and diff semantically" - + optionsParser = do logLevel <- options [ ("error", Just Log.Error) , ("warning", Just Log.Warning) , ("info", Just Log.Info) , ("debug", Just Log.Debug) , ("none", Nothing)] (long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.") diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index 2999849c3..c3652e7fa 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -1,19 +1,23 @@ +{-# OPTIONS_GHC -fforce-recomp #-} -- So that gitHash is correct. +{-# LANGUAGE TemplateHaskell #-} module Semantic.Config where -import Control.Exception -import Network.BSD -import Network.HTTP.Client.TLS -import Network.URI -import Prologue -import Semantic.Telemetry -import Semantic.Telemetry.AsyncQueue -import qualified Semantic.Telemetry.Stat as Stat +import Control.Exception +import Network.BSD +import Network.HTTP.Client.TLS +import Network.URI +import Prologue +import Semantic.Env +import Semantic.Telemetry +import Semantic.Telemetry.AsyncQueue +import qualified Semantic.Telemetry.Haystack as Haystack import qualified Semantic.Telemetry.Log as Log -import Semantic.Env -import System.Environment -import System.IO (hIsTerminalDevice, stderr) -import System.Posix.Process -import System.Posix.Types +import qualified Semantic.Telemetry.Stat as Stat +import Semantic.Version +import System.Environment +import System.IO (hIsTerminalDevice, stderr) +import System.Posix.Process +import System.Posix.Types data Config = Config @@ -65,13 +69,17 @@ defaultConfig' options@Options{..} = do , configMaxTelemetyQueueSize = size , configIsTerminal = isTerminal , configLogPrintSource = isTerminal - , configLogFormatter = logfmtFormatter + , configLogFormatter = if isTerminal then terminalFormatter else logfmtFormatter , configOptions = options } + +defaultHaystackFromConfig :: Config -> Haystack.ErrorLogger IO -> IO HaystackQueue +defaultHaystackFromConfig c@Config{..} logError = haystackClientFromConfig c >>= newAsyncQueue configMaxTelemetyQueueSize (Haystack.reportError logError) + haystackClientFromConfig :: Config -> IO HaystackClient -haystackClientFromConfig Config{..} = haystackClient configHaystackURL tlsManagerSettings configHostName configAppName +haystackClientFromConfig Config{..} = haystackClient configHaystackURL tlsManagerSettings configAppName withLogger :: Config -> (LogQueue -> IO c) -> IO c @@ -79,12 +87,21 @@ withLogger c = bracket (defaultLoggerFromConfig c) closeAsyncQueue defaultLoggerFromConfig :: Config -> IO LogQueue defaultLoggerFromConfig Config{..} = - newAsyncQueue configMaxTelemetyQueueSize Log.writeLogMessage LogOptions{ - optionsLevel = optionsLogLevel configOptions - , optionsFormatter = configLogFormatter - , optionsLogContext = [("app", configAppName), ("process_id", show configProcessID)] <> [("request_id", x) | x <- toList (optionsRequestID configOptions) ] + newAsyncQueue configMaxTelemetyQueueSize Log.writeLogMessage LogOptions { + logOptionsLevel = optionsLogLevel configOptions + , logOptionsFormatter = configLogFormatter + , logOptionsContext = + [ ("app", configAppName) + , ("pid", show configProcessID) + , ("hostname", configHostName) + , ("sha", buildSHA) + ] <> [("request_id", x) | x <- toList (optionsRequestID configOptions) ] } +withStatter :: Config -> (StatQueue -> IO c) -> IO c +withStatter c = bracket (defaultStatterFromConfig c) $ \statter -> do + closeAsyncQueue statter + Stat.closeStatClient (asyncQueueExtra statter) defaultStatterFromConfig :: Config -> IO StatQueue defaultStatterFromConfig c@Config{..} = statsClientFromConfig c >>= newAsyncQueue configMaxTelemetyQueueSize Stat.sendStat diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 2628e3225..aed9c5959 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -73,14 +73,11 @@ import Prologue hiding (MonadError (..), project) import Semantic.Config import Semantic.Distribute import qualified Semantic.IO as IO --- import Semantic.Log --- import Semantic.Queue import Semantic.Resolution -import Semantic.Telemetry.Stat as Stat import Semantic.Telemetry +import Semantic.Telemetry.Stat as Stat import Serializing.Format hiding (Options) import System.Exit (die) -import System.IO (stderr) -- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap' type TaskEff = Eff '[Distribute WrappedTask @@ -129,21 +126,16 @@ serialize format = send . Serialize format runTask :: TaskEff a -> IO a runTask = runTaskWithOptions defaultOptions --- | Execute a 'TaskEff' with the passed 'Config', yielding its result value in 'IO'. +-- | Execute a 'TaskEff' with the passed 'Options', yielding its result value in 'IO'. runTaskWithOptions :: Options -> TaskEff a -> IO a runTaskWithOptions opts task = do config <- defaultConfig' opts - statter <- defaultStatterFromConfig config - -- logger <- defaultLoggerFromConfig c - result <- withLogger config $ \logger -> - runTaskWithConfig config logger statter task - - -- closeQueue statter - -- closeStatClient (asyncQueueExtra statter) - -- closeQueue logger + withStatter config $ \statter -> + runTaskWithConfig config logger statter task either (die . displayException) pure result +-- | Execute a 'TaskEff' yielding its result value in 'IO'. runTaskWithConfig :: Config -> LogQueue -> StatQueue -> TaskEff a -> IO (Either SomeException a) runTaskWithConfig options logger statter task = do (result, stat) <- withTiming "run" [] $ do diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index 60f23a65e..4d93b8de7 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -55,7 +55,7 @@ type HaystackQueue = AsyncQueue ErrorReport HaystackClient -- | Queue a message to be logged. queueLogMessage :: MonadIO io => LogQueue -> Level -> String -> [(String, String)] -> io () queueLogMessage q@AsyncQueue{..} level message pairs - | Just logLevel <- optionsLevel asyncQueueExtra + | Just logLevel <- logOptionsLevel asyncQueueExtra , level <= logLevel = liftIO Time.getCurrentTime >>= liftIO . LocalTime.utcToLocalZonedTime >>= liftIO . writeAsyncQueue q . Message level message pairs | otherwise = pure () diff --git a/src/Semantic/Telemetry/Log.hs b/src/Semantic/Telemetry/Log.hs index 7ad10bbd8..8a116e017 100644 --- a/src/Semantic/Telemetry/Log.hs +++ b/src/Semantic/Telemetry/Log.hs @@ -27,14 +27,14 @@ data Level -- | Options for controlling logging data LogOptions = LogOptions - { optionsLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging. - , optionsFormatter :: LogFormatter -- ^ Log formatter to use. - , optionsLogContext :: [(String, String)] + { logOptionsLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging. + , logOptionsFormatter :: LogFormatter -- ^ Log formatter to use. + , logOptionsContext :: [(String, String)] } -- | Write a log a message to stderr. writeLogMessage :: MonadIO io => LogOptions -> Message -> io () -writeLogMessage options@LogOptions{..} = liftIO . hPutStr stderr . optionsFormatter options +writeLogMessage options@LogOptions{..} = liftIO . hPutStr stderr . logOptionsFormatter options -- | Format log messaging using "logfmt". -- @@ -49,7 +49,7 @@ logfmtFormatter LogOptions{..} (Message level message pairs time) = ( kv "time" (showTime time) : kv "msg" (shows message) : kv "level" (shows level) - : (uncurry kv . second shows <$> (pairs <> optionsLogContext))) + : (uncurry kv . second shows <$> (pairs <> logOptionsContext))) . showChar '\n' $ "" where kv k v = showString k . showChar '=' . v @@ -65,7 +65,7 @@ terminalFormatter LogOptions{..} (Message level message pairs time) = showChar '[' . showTime time . showString "] " . showLevel level . showChar ' ' . showString (printf "%-20s " message) - . showPairs pairs + . showPairs (pairs <> logOptionsContext) . showChar '\n' $ "" where colourize = True From 73bdcbe23ae8c6bbe5515afa5eb70f7b32e9d785 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:55:29 -0700 Subject: [PATCH 16/46] Not needed anymore --- src/Semantic/Config.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index c3652e7fa..8901dd6a8 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fforce-recomp #-} -- So that gitHash is correct. -{-# LANGUAGE TemplateHaskell #-} module Semantic.Config where import Control.Exception From f1ffdec3f726b27d538f3a9f609196f93d0db3d6 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:55:52 -0700 Subject: [PATCH 17/46] Move tree-sitter parsing timeout to a config setting --- src/Semantic/Config.hs | 23 +++++++++++++---------- src/Semantic/Task.hs | 8 +++----- 2 files changed, 16 insertions(+), 15 deletions(-) diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index 8901dd6a8..3050b70c5 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -4,6 +4,7 @@ import Control.Exception import Network.BSD import Network.HTTP.Client.TLS import Network.URI +import Parsing.TreeSitter (Timeout (..)) import Prologue import Semantic.Env import Semantic.Telemetry @@ -19,18 +20,19 @@ import System.Posix.Types 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 - , configStatsAddr :: StatsAddr -- ^ Address of statsd/datadog + { 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 + , configStatsAddr :: StatsAddr -- ^ Address of statsd/datadog - , configMaxTelemetyQueueSize :: Int -- ^ Max size of telemetry queues before messages are dropped. - , 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). + , configTreeSitterParseTimeout :: Timeout -- ^ Timeout in milliseconds before canceling tree-sitter parsing + , configMaxTelemetyQueueSize :: Int -- ^ Max size of telemetry queues before messages are dropped. + , 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). - , configOptions :: Options -- ^ Options configurable via command line arguments. + , configOptions :: Options -- ^ Options configurable via command line arguments. } -- Options configurable via command line arguments. @@ -64,6 +66,7 @@ defaultConfig' options@Options{..} = do , configHaystackURL = haystackURL , configStatsAddr = statsAddr + , configTreeSitterParseTimeout = Milliseconds 10000 -- 10 seconds , configMaxTelemetyQueueSize = size , configIsTerminal = isTerminal , configLogPrintSource = isTerminal diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index aed9c5959..520bd6bd3 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -186,15 +186,13 @@ data ParserCancelled = ParserTimedOut deriving (Show, Typeable) instance Exception ParserCancelled -defaultTimeout :: Timeout -defaultTimeout = Milliseconds 5000 - -- | Parse a 'Blob' in 'IO'. runParser :: (Member (Exc SomeException) effs, Member IO effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs) => Blob -> Parser term -> Eff effs term runParser blob@Blob{..} parser = case parser of ASTParser language -> - time "parse.tree_sitter_ast_parse" languageTag $ - parseToAST defaultTimeout language blob + time "parse.tree_sitter_ast_parse" languageTag $ do + config <- ask + parseToAST (configTreeSitterParseTimeout config) language blob >>= maybeM (throwError (SomeException ParserTimedOut)) AssignmentParser parser assignment -> do From d4e5c791193c76ffe29907786959a84e410b2fc5 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:58:58 -0700 Subject: [PATCH 18/46] Allow setting from the environment --- src/Semantic/Config.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index 3050b70c5..1b9071e4c 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -59,6 +59,7 @@ defaultConfig' options@Options{..} = do haystackURL <- lookupEnv "HAYSTACK_URL" statsAddr <- lookupStatsAddr size <- envLookupInt 1000 "MAX_TELEMETRY_QUEUE_SIZE" + parseTimeout <- envLookupInt 10000 "TREE_SITTER_PARSE_TIMEOUT" -- Default is 10 seconds pure Config { configAppName = "semantic" , configHostName = hostName @@ -66,7 +67,7 @@ defaultConfig' options@Options{..} = do , configHaystackURL = haystackURL , configStatsAddr = statsAddr - , configTreeSitterParseTimeout = Milliseconds 10000 -- 10 seconds + , configTreeSitterParseTimeout = Milliseconds parseTimeout , configMaxTelemetyQueueSize = size , configIsTerminal = isTerminal , configLogPrintSource = isTerminal From 9b45928227072256c89608dee108007e3ff5dd12 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 17:03:15 -0700 Subject: [PATCH 19/46] Fix up test/spec --- test/Semantic/Stat/Spec.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/test/Semantic/Stat/Spec.hs b/test/Semantic/Stat/Spec.hs index f1a5fea7a..20b9d7243 100644 --- a/test/Semantic/Stat/Spec.hs +++ b/test/Semantic/Stat/Spec.hs @@ -3,7 +3,8 @@ module Semantic.Stat.Spec (spec) where import Control.Exception import Network.Socket hiding (recv) import Network.Socket.ByteString -import Semantic.Stat +import Semantic.Telemetry.Stat +import Semantic.Config import System.Environment import SpecHelpers @@ -80,3 +81,7 @@ spec = do sendStat client { statsClientUDPSocket = clientSoc } (increment "app.metric" []) info <- recv serverSoc 1024 info `shouldBe` "semantic.app.metric:1|c" + +-- Defaults are all drive by defaultConfig. +defaultStatsClient :: IO StatsClient +defaultStatsClient = defaultConfig >>= \Config{..} -> statsClient (addrHost configStatsAddr) (addrPort configStatsAddr) configAppName From cff0e073aeaf8d6e099f97fb4c8fac6fe5fac839 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 17:48:22 -0700 Subject: [PATCH 20/46] Comment typo --- test/Semantic/Stat/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Semantic/Stat/Spec.hs b/test/Semantic/Stat/Spec.hs index 20b9d7243..903608ef8 100644 --- a/test/Semantic/Stat/Spec.hs +++ b/test/Semantic/Stat/Spec.hs @@ -82,6 +82,6 @@ spec = do info <- recv serverSoc 1024 info `shouldBe` "semantic.app.metric:1|c" --- Defaults are all drive by defaultConfig. +-- Defaults are all driven by defaultConfig. defaultStatsClient :: IO StatsClient defaultStatsClient = defaultConfig >>= \Config{..} -> statsClient (addrHost configStatsAddr) (addrPort configStatsAddr) configAppName From 96e26ce735103d2e0e046dcab5b2cc8e1bb792c2 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Thu, 14 Jun 2018 17:28:07 +1000 Subject: [PATCH 21/46] change arrays and tuples to hold addresses rather than unboxed values --- src/Control/Abstract/Value.hs | 6 +++--- src/Data/Abstract/Type.hs | 8 +++++--- src/Data/Abstract/Value.hs | 10 +++++----- src/Data/Syntax/Declaration.hs | 2 +- src/Data/Syntax/Expression.hs | 2 +- src/Data/Syntax/Literal.hs | 4 ++-- 6 files changed, 17 insertions(+), 15 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 96d6fb515..cee127661 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -112,10 +112,10 @@ class (AbstractFunction address value effects, AbstractIntro value) => AbstractV -> (value -> value -> Evaluator address value effects value) -- | Construct an N-ary tuple of multiple (possibly-disjoint) values - tuple :: [value] -> Evaluator address value effects value + tuple :: [address] -> Evaluator address value effects value -- | Construct an array of zero or more values. - array :: [value] -> Evaluator address value effects value + array :: [address] -> Evaluator address value effects value -- | Extract the contents of a key-value pair as a tuple. asPair :: value -> Evaluator address value effects (value, value) @@ -127,7 +127,7 @@ class (AbstractFunction address value effects, AbstractIntro value) => AbstractV ifthenelse :: value -> Evaluator address value effects a -> Evaluator address value effects a -> Evaluator address value effects a -- | @index x i@ computes @x[i]@, with zero-indexing. - index :: value -> value -> Evaluator address value effects value + index :: value -> value -> Evaluator address value effects address -- | Build a class value from a name and environment. klass :: Name -- ^ The new class's identifier diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index cecff696f..751ce71e9 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -150,9 +150,10 @@ instance ( Member (Allocator address Type) effects => AbstractValue address Type effects where array fields = do var <- fresh - Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fields + fieldTypes <- traverse deref fields + Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes - tuple = pure . zeroOrMoreProduct + tuple fields = zeroOrMoreProduct <$> traverse deref fields klass _ _ _ = pure Object namespace _ _ = pure Unit @@ -168,7 +169,8 @@ instance ( Member (Allocator address Type) effects index arr sub = do _ <- unify sub Int field <- fresh - Var field <$ unify (Array (Var field)) arr + _ <- unify (Array (Var field)) arr + box (Var field) ifthenelse cond if' else' = unify cond Bool *> (if' <|> else') diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 4217aa586..b33d32bdc 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -22,8 +22,8 @@ data Value address body | Float (Number.Number Scientific) | String Text | Symbol Text - | Tuple [Value address body] - | Array [Value address body] + | Tuple [address] + | Array [address] | Class Name (Environment address) | Namespace Name (Environment address) | KVPair (Value address body) (Value address body) @@ -146,12 +146,12 @@ instance ( Coercible body (Eff effects) index = go where tryIdx list ii - | ii > genericLength list = throwValueError (BoundsError list ii) + | ii > genericLength list = box =<< throwValueError (BoundsError list ii) | otherwise = pure (genericIndex list ii) go arr idx | (Array arr, Integer (Number.Integer i)) <- (arr, idx) = tryIdx arr i | (Tuple tup, Integer (Number.Integer i)) <- (arr, idx) = tryIdx tup i - | otherwise = throwValueError (IndexError arr idx) + | otherwise = box =<< throwValueError (IndexError arr idx) liftNumeric f arg | Integer (Number.Integer i) <- arg = pure . integer $ f i @@ -236,7 +236,7 @@ data ValueError address body resume where -- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching. ArithmeticError :: ArithException -> ValueError address body (Value address body) -- Out-of-bounds error - BoundsError :: [Value address body] -> Prelude.Integer -> ValueError address body (Value address body) + BoundsError :: [address] -> Prelude.Integer -> ValueError address body (Value address body) instance Eq address => Eq1 (ValueError address body) where diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index ed418a7ff..13218198a 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -101,7 +101,7 @@ instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable VariableDeclaration where eval (VariableDeclaration []) = rvalBox unit - eval (VariableDeclaration decs) = rvalBox =<< tuple =<< traverse subtermValue decs + eval (VariableDeclaration decs) = rvalBox =<< tuple =<< traverse subtermAddress decs instance Declarations a => Declarations (VariableDeclaration a) where declaredName (VariableDeclaration vars) = case vars of diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index c92a4885c..4e3049414 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -215,7 +215,7 @@ instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec -- TODO: Finish Eval instance for Subscript -- TODO return a special LvalSubscript instance here instance Evaluatable Subscript where - eval (Subscript l [r]) = rvalBox =<< join (index <$> subtermValue l <*> subtermValue r) + eval (Subscript l [r]) = Rval <$> join (index <$> subtermValue l <*> subtermValue r) eval (Subscript _ _) = rvalBox =<< throwResumable (Unspecialized "Eval unspecialized for subscript with slices") eval (Member _ _) = rvalBox =<< throwResumable (Unspecialized "Eval unspecialized for member access") diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 51afb1ab2..1c51423d8 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -169,7 +169,7 @@ instance Ord1 Array where liftCompare = genericLiftCompare instance Show1 Array where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Array where - eval (Array a) = rvalBox =<< (array =<< traverse subtermValue a) + eval (Array a) = rvalBox =<< array =<< traverse subtermAddress a newtype Hash a = Hash { hashElements :: [a] } deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) @@ -200,7 +200,7 @@ instance Ord1 Tuple where liftCompare = genericLiftCompare instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Tuple where - eval (Tuple cs) = rvalBox =<< tuple =<< traverse subtermValue cs + eval (Tuple cs) = rvalBox =<< tuple =<< traverse subtermAddress cs newtype Set a = Set { setElements :: [a] } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable) From 139bd660cb60df8cc13541ffa9cabfa59e47ab0d Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Thu, 14 Jun 2018 09:23:46 -0700 Subject: [PATCH 22/46] Back to full interface --- src/Semantic/Diff.hs | 2 +- src/Semantic/Telemetry.hs | 4 ---- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index d5f65e276..c36d23b57 100644 --- a/src/Semantic/Diff.hs +++ b/src/Semantic/Diff.hs @@ -46,7 +46,7 @@ withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> WrapTask (wi where diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member IO effs, Member Task effs, Member Telemetry effs) => BlobPair -> Join These (Term syntax (Record fields)) -> Eff effs (Diff syntax (Record fields) (Record fields)) diffTerms blobs terms = time "diff" languageTag $ do diff <- diff (runJoin terms) - diff <$ statCount "diff.nodes" (bilength diff) languageTag + diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag) where languageTag = languageTagForBlobPair blobs withParsedBlobPair :: (Member (Distribute WrappedTask) effs, Member (Exc SomeException) effs) diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index 4d93b8de7..c05657e29 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -31,7 +31,6 @@ module Semantic.Telemetry -- Eff interface , writeLog , writeStat -, statCount , time , Telemetry , runTelemetry @@ -78,9 +77,6 @@ writeLog level message pairs = send (WriteLog level message pairs) writeStat :: Member Telemetry effs => Stat -> Eff effs () writeStat stat = send (WriteStat stat) -statCount :: Member Telemetry effs => String -> Int -> Tags -> Eff effs () -statCount n i = send . WriteStat . count n i - -- | A task which measures and stats the timing of another task. time :: (Member IO effs, Member Telemetry effs) => String -> [(String, String)] -> Eff effs output -> Eff effs output time statName tags task = do From 1ce115349079d21724c4d6f2971b28666971a0f2 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Thu, 14 Jun 2018 09:23:59 -0700 Subject: [PATCH 23/46] Extra docs and minor formatting cleanup --- src/Semantic/CLI.hs | 2 +- src/Semantic/Config.hs | 10 +++++----- src/Semantic/Telemetry.hs | 8 +++++++- src/Semantic/Telemetry/Haystack.hs | 9 ++++----- src/Semantic/Version.hs | 10 ++++++---- 5 files changed, 23 insertions(+), 16 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index a949eb77f..a62521022 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -37,7 +37,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program") versionString = "semantic version " <> buildVersion <> " (" <> buildSHA <> ")" description = fullDesc <> header "semantic -- Parse and diff semantically" - + optionsParser = do logLevel <- options [ ("error", Just Log.Error) , ("warning", Just Log.Warning) , ("info", Just Log.Info) , ("debug", Just Log.Debug) , ("none", Nothing)] (long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.") diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index 1b9071e4c..166120377 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -20,14 +20,14 @@ import System.Posix.Types data Config = Config - { configAppName :: String -- ^ Application name (semantic) + { 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 - , configStatsAddr :: StatsAddr -- ^ Address of statsd/datadog + , configStatsAddr :: StatsAddr -- ^ Address of statsd/datadog (default: "127.0.0.1:28125") - , configTreeSitterParseTimeout :: Timeout -- ^ Timeout in milliseconds before canceling tree-sitter parsing - , configMaxTelemetyQueueSize :: Int -- ^ Max size of telemetry queues before messages are dropped. + , configTreeSitterParseTimeout :: Timeout -- ^ Timeout in milliseconds before canceling tree-sitter parsing (default: 10000). + , 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). @@ -77,7 +77,7 @@ defaultConfig' options@Options{..} = do } -defaultHaystackFromConfig :: Config -> Haystack.ErrorLogger IO -> IO HaystackQueue +defaultHaystackFromConfig :: Config -> Haystack.ErrorLogger -> IO HaystackQueue defaultHaystackFromConfig c@Config{..} logError = haystackClientFromConfig c >>= newAsyncQueue configMaxTelemetyQueueSize (Haystack.reportError logError) haystackClientFromConfig :: Config -> IO HaystackClient diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index c05657e29..3bd609e52 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-} module Semantic.Telemetry ( + -- Async telemetry interface LogQueue , StatQueue , HaystackQueue @@ -8,6 +9,7 @@ module Semantic.Telemetry , queueErrorReport , queueStat +-- Create stats , Stat.increment , Stat.decrement , Stat.count @@ -16,19 +18,23 @@ module Semantic.Telemetry , Stat.withTiming , Stat.histogram , Stat.set + +-- Statsd client , statsClient , StatsClient +-- Haystack client , haystackClient , HaystackClient +-- Logging options and formatters , Level(..) , LogOptions(..) , logfmtFormatter , terminalFormatter , LogFormatter --- Eff interface +-- Eff interface for telemetry , writeLog , writeStat , time diff --git a/src/Semantic/Telemetry/Haystack.hs b/src/Semantic/Telemetry/Haystack.hs index de4130683..86706f636 100644 --- a/src/Semantic/Telemetry/Haystack.hs +++ b/src/Semantic/Telemetry/Haystack.hs @@ -1,7 +1,6 @@ module Semantic.Telemetry.Haystack where import Control.Exception -import Control.Monad.IO.Class import Crypto.Hash import Data.Aeson hiding (Error) import qualified Data.ByteString.Char8 as BC @@ -23,11 +22,11 @@ data HaystackClient { haystackClientRequest :: Request , haystackClientManager :: Manager , haystackClientAppName :: String - } + } -- ^ Standard HTTP client for Haystack | NullHaystackClient -- ^ Doesn't report needles, good for testing or when the 'HAYSTACK_URL' env var isn't set. -- | Function to log if there are errors reporting to haystack. -type ErrorLogger io = String -> [(String, String)] -> io () +type ErrorLogger = String -> [(String, String)] -> IO () -- Create a Haystack HTTP client. haystackClient :: Maybe String -> ManagerSettings -> String -> IO HaystackClient @@ -43,7 +42,7 @@ haystackClient maybeURL managerSettings appName | otherwise = pure NullHaystackClient -- Report an error to Haystack over HTTP (blocking). -reportError :: MonadIO io => ErrorLogger io -> HaystackClient -> ErrorReport -> io () +reportError :: ErrorLogger -> HaystackClient -> ErrorReport -> IO () reportError logger NullHaystackClient ErrorReport{..} = let msg = takeWhile (/= '\n') (displayException errorReportException) in logger msg errorReportContext reportError logger HaystackClient{..} ErrorReport{..} = do let fullMsg = displayException errorReportException @@ -58,7 +57,7 @@ reportError logger HaystackClient{..} ErrorReport{..} = do ] <> foldr (\(k, v) acc -> Text.pack k .= v : acc) [] errorReportContext let request = haystackClientRequest { requestBody = RequestBodyLBS (encode payload) } - response <- liftIO . tryIOError $ httpLbs request haystackClientManager + response <- tryIOError $ httpLbs request haystackClientManager case response of Left e -> logger ("Failed to report error to haystack: " <> displayException e) [] Right response -> do diff --git a/src/Semantic/Version.hs b/src/Semantic/Version.hs index 391910ce3..0a836d905 100644 --- a/src/Semantic/Version.hs +++ b/src/Semantic/Version.hs @@ -2,12 +2,14 @@ {-# LANGUAGE TemplateHaskell #-} module Semantic.Version where -import Data.Version (showVersion) -import Development.GitRev -import qualified Paths_semantic as Library (version) +import Data.Version (showVersion) +import Development.GitRev +import Paths_semantic (version) +-- The SHA1 hash of this build of semantic. buildSHA :: String buildSHA = $(gitHash) +-- The version string of this build of semantic. buildVersion :: String -buildVersion = showVersion Library.version +buildVersion = showVersion version From 7c8a64c9fe7a917a4b64640b1471a8d661889788 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Jun 2018 14:38:45 -0400 Subject: [PATCH 24/46] Define a toTerm combinator. Co-Authored-By: Rick Winfrey Co-Authored-By: Ayman Nadeem --- src/Assigning/Assignment.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Assigning/Assignment.hs b/src/Assigning/Assignment.hs index ec8ea863a..70efa4e75 100644 --- a/src/Assigning/Assignment.hs +++ b/src/Assigning/Assignment.hs @@ -63,6 +63,7 @@ module Assigning.Assignment ( Assignment , Location -- Combinators +, toTerm , Alternative(..) , MonadError(..) , MonadFail(..) @@ -110,6 +111,12 @@ import Data.Text.Encoding (decodeUtf8') import Text.Parser.Combinators as Parsers hiding (choice) import TreeSitter.Language +toTerm :: Element syntax syntaxes + => Assignment ast grammar (syntax (Term (Sum syntaxes) (Record Location))) + -> Assignment ast grammar (Term (Sum syntaxes) (Record Location)) +toTerm syntax = termIn <$> location <*> (inject <$> syntax) + + -- | Assignment from an AST with some set of 'symbol's onto some other value. -- -- This is essentially a parser. From ea0575b0b3c92e702971b0641f563535ea48d128 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Jun 2018 14:39:12 -0400 Subject: [PATCH 25/46] Define a leafNode combinator. Co-Authored-By: Rick Winfrey Co-Authored-By: Ayman Nadeem --- src/Assigning/Assignment.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Assigning/Assignment.hs b/src/Assigning/Assignment.hs index 70efa4e75..2f3ec3f6a 100644 --- a/src/Assigning/Assignment.hs +++ b/src/Assigning/Assignment.hs @@ -63,6 +63,7 @@ module Assigning.Assignment ( Assignment , Location -- Combinators +, leafNode , toTerm , Alternative(..) , MonadError(..) @@ -111,6 +112,9 @@ import Data.Text.Encoding (decodeUtf8') import Text.Parser.Combinators as Parsers hiding (choice) import TreeSitter.Language +leafNode :: (Enum grammar, Ix grammar) => grammar -> Assignment ast grammar Text +leafNode sym = symbol sym *> source + toTerm :: Element syntax syntaxes => Assignment ast grammar (syntax (Term (Sum syntaxes) (Record Location))) -> Assignment ast grammar (Term (Sum syntaxes) (Record Location)) From 470a99df3b13d302552d6abb427f7cb17a11e4bd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Jun 2018 14:39:42 -0400 Subject: [PATCH 26/46] Define a branchNode combinator. Co-Authored-By: Rick Winfrey Co-Authored-By: Ayman Nadeem --- src/Assigning/Assignment.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Assigning/Assignment.hs b/src/Assigning/Assignment.hs index 2f3ec3f6a..6fe9eb873 100644 --- a/src/Assigning/Assignment.hs +++ b/src/Assigning/Assignment.hs @@ -63,6 +63,7 @@ module Assigning.Assignment ( Assignment , Location -- Combinators +, branchNode , leafNode , toTerm , Alternative(..) @@ -112,6 +113,9 @@ import Data.Text.Encoding (decodeUtf8') import Text.Parser.Combinators as Parsers hiding (choice) import TreeSitter.Language +branchNode :: (Enum grammar, Ix grammar) => grammar -> Assignment ast grammar a -> Assignment ast grammar a +branchNode sym child = symbol sym *> children child + leafNode :: (Enum grammar, Ix grammar) => grammar -> Assignment ast grammar Text leafNode sym = symbol sym *> source From 177be87acc2528354b9daf616b996ec521ff1efa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Jun 2018 14:40:53 -0400 Subject: [PATCH 27/46] Redefine boolean using toTerm/branchNode/leafNode. Co-Authored-By: Rick Winfrey Co-Authored-By: Ayman Nadeem --- src/Language/Java/Assignment.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/Java/Assignment.hs b/src/Language/Java/Assignment.hs index ae08fd7fc..736b9cd49 100644 --- a/src/Language/Java/Assignment.hs +++ b/src/Language/Java/Assignment.hs @@ -215,9 +215,9 @@ variableDeclaratorId = symbol VariableDeclaratorId *> children identifier -- Literals boolean :: Assignment -boolean = makeTerm <$> symbol BooleanLiteral <*> children - (token Grammar.True $> Literal.true - <|> token Grammar.False $> Literal.false) +boolean = toTerm (branchNode BooleanLiteral + ( leafNode Grammar.True $> Literal.true + <|> leafNode Grammar.False $> Literal.false)) null' :: Assignment null' = makeTerm <$> symbol NullLiteral <*> (Literal.Null <$ source) From a29c0dd9be612d58bb5e34a6c3d532618ab4195e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Jun 2018 14:41:46 -0400 Subject: [PATCH 28/46] Redefine module' using toTerm/branchNode. Co-Authored-By: Rick Winfrey Co-Authored-By: Ayman Nadeem --- src/Language/Java/Assignment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Java/Assignment.hs b/src/Language/Java/Assignment.hs index 736b9cd49..e75935aa1 100644 --- a/src/Language/Java/Assignment.hs +++ b/src/Language/Java/Assignment.hs @@ -288,7 +288,7 @@ explicitConstructorInvocation = makeTerm <$> symbol ExplicitConstructorInvocatio callFunction a Nothing = ([], a) module' :: Assignment -module' = makeTerm <$> symbol ModuleDeclaration <*> children (Java.Syntax.Module <$> expression <*> many expression) +module' = toTerm (branchNode ModuleDeclaration (Java.Syntax.Module <$> expression <*> many expression)) import' :: Assignment import' = makeTerm <$> symbol ImportDeclaration <*> children (Java.Syntax.Import <$> someTerm (expression <|> asterisk)) From 4206f1c183fb5162a07ce3ff62ae3b032b867b65 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Jun 2018 14:42:15 -0400 Subject: [PATCH 29/46] :fire: the HasCallStack constraint. Co-Authored-By: Rick Winfrey Co-Authored-By: Ayman Nadeem --- src/Language/Java/Assignment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Java/Assignment.hs b/src/Language/Java/Assignment.hs index e75935aa1..62683569e 100644 --- a/src/Language/Java/Assignment.hs +++ b/src/Language/Java/Assignment.hs @@ -103,7 +103,7 @@ type Syntax = ] type Term = Term.Term (Sum Syntax) (Record Location) -type Assignment = HasCallStack => Assignment.Assignment [] Grammar Term +type Assignment = Assignment.Assignment [] Grammar Term -- | Assignment from AST in Java's grammar onto a program in Java's syntax. assignment :: Assignment From be464d49e239465b5ef4cb445d54ac23a3f73e46 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Jun 2018 14:46:18 -0400 Subject: [PATCH 30/46] Rename a bunch of parameters. Co-Authored-By: Rick Winfrey Co-Authored-By: Ayman Nadeem --- src/Data/Syntax.hs | 68 +++++++++++++++++++++++----------------------- 1 file changed, 34 insertions(+), 34 deletions(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index b5e0cbec7..a340a1038 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -26,81 +26,81 @@ import Data.Char (toLower) -- Combinators -- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children. -makeTerm :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => a -> f (Term (Sum fs) a) -> Term (Sum fs) a -makeTerm a = makeTerm' a . inject +makeTerm :: (HasCallStack, Element syntax syntaxes, Semigroup ann, Apply Foldable syntaxes) => ann -> syntax (Term (Sum syntaxes) ann) -> Term (Sum syntaxes) ann +makeTerm ann = makeTerm' ann . inject -- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children. -makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a -makeTerm' a f = termIn (sconcat (a :| (termAnnotation <$> toList f))) f +makeTerm' :: (HasCallStack, Semigroup ann, Foldable syntax) => ann -> syntax (Term syntax ann) -> Term syntax ann +makeTerm' ann syntax = termIn (sconcat (ann :| (termAnnotation <$> toList syntax))) syntax -- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children. Removes extra structure if term is a list of a single item. -makeTerm'' :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs, Foldable f) => a -> f (Term (Sum fs) a) -> Term (Sum fs) a -makeTerm'' a children = case toList children of +makeTerm'' :: (HasCallStack, Element syntax syntaxes, Semigroup ann, Apply Foldable syntaxes, Foldable syntax) => ann -> syntax (Term (Sum syntaxes) ann) -> Term (Sum syntaxes) ann +makeTerm'' ann children = case toList children of [x] -> x - _ -> makeTerm' a (inject children) + _ -> makeTerm' ann (inject children) -- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation. -makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => f (Term (Sum fs) a) -> Term (Sum fs) a +makeTerm1 :: (HasCallStack, Element syntax syntaxes, Semigroup ann, Apply Foldable syntaxes) => syntax (Term (Sum syntaxes) ann) -> Term (Sum syntaxes) ann makeTerm1 = makeTerm1' . inject --- | Lift a non-empty union into a term, appending all subterms’.annotations to make the new term’s annotation. -makeTerm1' :: (HasCallStack, Semigroup a, Foldable f) => f (Term f a) -> Term f a -makeTerm1' f = case toList f of - a : _ -> makeTerm' (termAnnotation a) f +-- | Lift a non-empty union into a term, appending all subterms’ annotations to make the new term’s annotation. +makeTerm1' :: (HasCallStack, Semigroup ann, Foldable syntax) => syntax (Term syntax ann) -> Term syntax ann +makeTerm1' syntax = case toList syntax of + a : _ -> makeTerm' (termAnnotation a) syntax _ -> error "makeTerm1': empty structure" -- | Construct an empty term at the current position. -emptyTerm :: (HasCallStack, Empty :< fs, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Sum fs) (Record Location)) +emptyTerm :: (HasCallStack, Empty :< syntaxes, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location)) emptyTerm = makeTerm . startLocation <$> Assignment.location <*> pure Empty where startLocation ann = Range (start (getField ann)) (start (getField ann)) :. Span (spanStart (getField ann)) (spanStart (getField ann)) :. Nil -- | Catch assignment errors into an error term. -handleError :: (HasCallStack, Error :< fs, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Sum fs) (Record Location)) -> Assignment.Assignment ast grammar (Term (Sum fs) (Record Location)) +handleError :: (HasCallStack, Error :< syntaxes, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location)) -> Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location)) handleError = flip catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source) -- | Catch parse errors into an error term. -parseError :: (HasCallStack, Error :< fs, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Sum fs) (Record Location)) +parseError :: (HasCallStack, Error :< syntaxes, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location)) parseError = makeTerm <$> Assignment.token maxBound <*> pure (Error (ErrorStack (getCallStack (freezeCallStack callStack))) [] (Just "ParseError") []) -- | Match context terms before a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term. -contextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs) - => m (Term (Sum fs) a) - -> m (Term (Sum fs) a) - -> m (Term (Sum fs) a) +contextualize :: (HasCallStack, Context :< syntaxes, Alternative m, Semigroup ann, Apply Foldable syntaxes) + => m (Term (Sum syntaxes) ann) + -> m (Term (Sum syntaxes) ann) + -> m (Term (Sum syntaxes) ann) contextualize context rule = make <$> Assignment.manyThrough context rule where make (cs, node) = case nonEmpty cs of Just cs -> makeTerm1 (Context cs node) _ -> node -- | Match context terms after a subject term and before a delimiter, returning the delimiter paired with a Context term if any context terms matched, or the subject term otherwise. -postContextualizeThrough :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs) - => m (Term (Sum fs) a) - -> m (Term (Sum fs) a) - -> m b - -> m (Term (Sum fs) a, b) +postContextualizeThrough :: (HasCallStack, Context :< syntaxes, Alternative m, Semigroup ann, Apply Foldable syntaxes) + => m (Term (Sum syntaxes) ann) + -> m (Term (Sum syntaxes) ann) + -> m delimiter + -> m (Term (Sum syntaxes) ann, delimiter) postContextualizeThrough context rule end = make <$> rule <*> Assignment.manyThrough context end where make node (cs, end) = case nonEmpty cs of Just cs -> (makeTerm1 (Context cs node), end) _ -> (node, end) -- | Match context terms after a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term. -postContextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs) - => m (Term (Sum fs) a) - -> m (Term (Sum fs) a) - -> m (Term (Sum fs) a) +postContextualize :: (HasCallStack, Context :< syntaxes, Alternative m, Semigroup ann, Apply Foldable syntaxes) + => m (Term (Sum syntaxes) ann) + -> m (Term (Sum syntaxes) ann) + -> m (Term (Sum syntaxes) ann) postContextualize context rule = make <$> rule <*> many context where make node cs = case nonEmpty cs of Just cs -> makeTerm1 (Context cs node) _ -> node -- | Match infix terms separated by any of a list of operators, with optional context terms following each operand. -infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack, Apply Foldable fs) - => m (Term (Sum fs) a) - -> m (Term (Sum fs) a) - -> m (Term (Sum fs) a) - -> [m (Term (Sum fs) a -> Term (Sum fs) a -> Sum fs (Term (Sum fs) a))] - -> m (Sum fs (Term (Sum fs) a)) +infixContext :: (Context :< syntaxes, Assignment.Parsing m, Semigroup ann, HasCallStack, Apply Foldable syntaxes) + => m (Term (Sum syntaxes) ann) + -> m (Term (Sum syntaxes) ann) + -> m (Term (Sum syntaxes) ann) + -> [m (Term (Sum syntaxes) ann -> Term (Sum syntaxes) ann -> Sum syntaxes (Term (Sum syntaxes) ann))] + -> m (Sum syntaxes (Term (Sum syntaxes) ann)) infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right instance (Apply Message1 fs, Generate Message1 fs fs, Generate Named1 fs fs) => Message1 (Sum fs) where From 480549dd46bd6869c2a786aebbf3aa078454c10a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Jun 2018 14:51:48 -0400 Subject: [PATCH 31/46] :memo: branchNode. --- src/Assigning/Assignment.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Assigning/Assignment.hs b/src/Assigning/Assignment.hs index 6fe9eb873..f9a15f699 100644 --- a/src/Assigning/Assignment.hs +++ b/src/Assigning/Assignment.hs @@ -113,6 +113,7 @@ import Data.Text.Encoding (decodeUtf8') import Text.Parser.Combinators as Parsers hiding (choice) import TreeSitter.Language +-- | Match a branch node, matching its children with the supplied 'Assignment' & returning the result. branchNode :: (Enum grammar, Ix grammar) => grammar -> Assignment ast grammar a -> Assignment ast grammar a branchNode sym child = symbol sym *> children child From 3ef04bb17c7e8ae8fe247275541f8b9380b27824 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Jun 2018 14:51:55 -0400 Subject: [PATCH 32/46] :memo: leafNode. --- src/Assigning/Assignment.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Assigning/Assignment.hs b/src/Assigning/Assignment.hs index f9a15f699..0755dd31f 100644 --- a/src/Assigning/Assignment.hs +++ b/src/Assigning/Assignment.hs @@ -117,6 +117,7 @@ import TreeSitter.Language branchNode :: (Enum grammar, Ix grammar) => grammar -> Assignment ast grammar a -> Assignment ast grammar a branchNode sym child = symbol sym *> children child +-- | Match a leaf node, returning the corresponding 'Text'. leafNode :: (Enum grammar, Ix grammar) => grammar -> Assignment ast grammar Text leafNode sym = symbol sym *> source From 11d887fdd2649a395f0b86517048c4e08ccd0f2e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Jun 2018 14:53:14 -0400 Subject: [PATCH 33/46] :memo: toTerm. --- src/Assigning/Assignment.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Assigning/Assignment.hs b/src/Assigning/Assignment.hs index 0755dd31f..a431d2533 100644 --- a/src/Assigning/Assignment.hs +++ b/src/Assigning/Assignment.hs @@ -121,6 +121,7 @@ branchNode sym child = symbol sym *> children child leafNode :: (Enum grammar, Ix grammar) => grammar -> Assignment ast grammar Text leafNode sym = symbol sym *> source +-- | Wrap an 'Assignment' producing @syntax@ up into an 'Assignment' producing 'Term's. toTerm :: Element syntax syntaxes => Assignment ast grammar (syntax (Term (Sum syntaxes) (Record Location))) -> Assignment ast grammar (Term (Sum syntaxes) (Record Location)) From 89359de71d513993205630dae3af76c9cd07be88 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Fri, 15 Jun 2018 11:52:11 +1000 Subject: [PATCH 34/46] return original address rather than boxing a copy --- src/Data/Syntax/Declaration.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 13218198a..73ee2bf4d 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -163,11 +163,12 @@ instance Evaluatable Class where eval Class{..} = do name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm classIdentifier) supers <- traverse subtermValue classSuperclasses - (v, addr) <- letrec name $ do + (_, addr) <- letrec name $ do void $ subtermValue classBody classEnv <- Env.head <$> getEnv klass name supers classEnv - rvalBox =<< (v <$ bind name addr) + bind name addr + pure (Rval addr) -- | A decorator in Python data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a } @@ -246,7 +247,8 @@ instance Evaluatable TypeAlias where v <- subtermValue typeAliasKind addr <- lookupOrAlloc name assign addr v - rvalBox =<< (v <$ bind name addr) + bind name addr + pure (Rval addr) instance Declarations a => Declarations (TypeAlias a) where declaredName TypeAlias{..} = declaredName typeAliasIdentifier From b00423b043bbb53ab0b1d1624292e4ed20e78181 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Fri, 15 Jun 2018 11:57:42 +1000 Subject: [PATCH 35/46] pass through original address in If and Let --- src/Data/Syntax/Statement.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index a1275b494..6f9df5a16 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -37,7 +37,7 @@ instance Show1 If where liftShowsPrec = genericLiftShowsPrec instance Evaluatable If where eval (If cond if' else') = do bool <- subtermValue cond - rvalBox =<< ifthenelse bool (subtermValue if') (subtermValue else') + Rval <$> ifthenelse bool (subtermAddress if') (subtermAddress else') -- | Else statement. The else condition is any term, that upon successful completion, continues evaluation to the elseBody, e.g. `for ... else` in Python. data Else a = Else { elseCondition :: !a, elseBody :: !a } @@ -100,7 +100,7 @@ instance Evaluatable Let where eval Let{..} = do name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm letVariable) addr <- snd <$> letrec name (subtermValue letValue) - rvalBox =<< locally (bind name addr *> subtermValue letBody) + Rval <$> locally (bind name addr *> subtermAddress letBody) -- Assignment From 430a4e1cfaf9181aad3a99dd87bef5b936202e21 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Jun 2018 11:05:19 -0400 Subject: [PATCH 36/46] :fire: emptyEnv. --- src/Data/Abstract/Environment.hs | 10 +++------- src/Data/Abstract/Evaluatable.hs | 8 ++++---- src/Data/Abstract/Type.hs | 5 +++-- src/Data/Abstract/Value.hs | 7 ++++--- src/Language/Go/Syntax.hs | 5 +++-- src/Language/PHP/Syntax.hs | 3 ++- src/Language/Python/Syntax.hs | 7 ++++--- src/Language/Ruby/Syntax.hs | 5 +++-- src/Language/TypeScript/Syntax.hs | 7 ++++--- src/Semantic/Graph.hs | 2 +- test/Analysis/TypeScript/Spec.hs | 2 +- 11 files changed, 32 insertions(+), 29 deletions(-) diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 17b98108b..45164e07c 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -3,7 +3,6 @@ module Data.Abstract.Environment , addresses , delete , head - , emptyEnv , mergeEnvs , mergeNewer , insert @@ -29,7 +28,7 @@ import Prologue -- $setup -- >>> import Data.Abstract.Address --- >>> let bright = push (insert (name "foo") (Precise 0) emptyEnv) +-- >>> let bright = push (insert (name "foo") (Precise 0) lowerBound) -- >>> let shadowed = insert (name "foo") (Precise 1) bright -- | A LIFO stack of maps of names to addresses, representing a lexically-scoped evaluation environment. @@ -42,16 +41,13 @@ mergeEnvs :: Environment address -> Environment address -> Environment address mergeEnvs (Environment (a :| as)) (Environment (b :| bs)) = Environment ((<>) a b :| alignWith (mergeThese (<>)) as bs) -emptyEnv :: Environment address -emptyEnv = Environment (lowerBound :| []) - -- | Make and enter a new empty scope in the given environment. push :: Environment address -> Environment address push (Environment (a :| as)) = Environment (mempty :| a : as) -- | Remove the frontmost scope. pop :: Environment address -> Environment address -pop (Environment (_ :| [])) = emptyEnv +pop (Environment (_ :| [])) = lowerBound pop (Environment (_ :| a : as)) = Environment (a :| as) -- | Drop all scopes save for the frontmost one. @@ -125,7 +121,7 @@ addresses :: Ord address => Environment address -> Live address addresses = fromAddresses . map snd . pairs -instance Lower (Environment address) where lowerBound = emptyEnv +instance Lower (Environment address) where lowerBound = Environment (lowerBound :| []) instance Show address => Show (Environment address) where showsPrec d = showsUnaryWith showsPrec "Environment" d . pairs diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index ab2718b3b..a9fcfa051 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -118,15 +118,15 @@ evaluatePackageWith analyzeModule analyzeTerm package evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' (address, Environment address) evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do addr <- box unit -- TODO don't *always* allocate - use maybeM instead - (ptr, env) <- fromMaybe (addr, emptyEnv) <$> require m + (ptr, env) <- fromMaybe (addr, lowerBound) <$> require m bindAll env maybe (pure ptr) ((`call` []) <=< deref <=< variable) sym - evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule emptyEnv)) $ do - (_, builtinsEnv) <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins *> box unit)) + evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule lowerBound)) $ do + (_, builtinsEnv) <- runInModule lowerBound moduleInfoFromCallStack (TermEvaluator (defineBuiltins *> box unit)) second (mergeEnvs builtinsEnv) <$> evalModule builtinsEnv prelude - withPrelude Nothing f = f emptyEnv + withPrelude Nothing f = f lowerBound withPrelude (Just prelude) f = do (_, preludeEnv) <- evalPrelude prelude f preludeEnv diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 23567d219..24f4a8d5f 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -10,6 +10,7 @@ module Data.Abstract.Type import Control.Abstract import Data.Abstract.Environment as Env import Data.Semigroup.Foldable (foldMap1) +import Data.Semilattice.Lower import Prologue hiding (TypeError) type TName = Int @@ -126,7 +127,7 @@ instance ( Member (Allocator address Type) effects addr <- alloc name tvar <- Var <$> fresh assign addr tvar - bimap (Env.insert name addr) (tvar :) <$> rest) (pure (emptyEnv, [])) names + bimap (Env.insert name addr) (tvar :) <$> rest) (pure (lowerBound, [])) names (zeroOrMoreProduct tvars :->) <$> (deref =<< locally (bindAll env *> body `catchReturn` \ (Return ptr) -> pure ptr)) call op params = do @@ -158,7 +159,7 @@ instance ( Member (Allocator address Type) effects klass _ _ _ = pure Object namespace _ _ = pure Unit - scopedEnvironment _ = pure (Just emptyEnv) + scopedEnvironment _ = pure (Just lowerBound) asString t = unify t String $> "" asPair t = do diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index b8f899932..fe891c086 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -2,7 +2,7 @@ module Data.Abstract.Value where import Control.Abstract -import Data.Abstract.Environment (Environment, emptyEnv, mergeEnvs) +import Data.Abstract.Environment (Environment, mergeEnvs) import qualified Data.Abstract.Environment as Env import Data.Abstract.Name import qualified Data.Abstract.Number as Number @@ -10,6 +10,7 @@ import Data.Coerce import Data.List (genericIndex, genericLength) import Data.Scientific (Scientific) import Data.Scientific.Exts +import Data.Semilattice.Lower import qualified Data.Set as Set import Prologue @@ -120,12 +121,12 @@ instance ( Coercible body (Eff effects) klass n [] env = pure $ Class n env klass n supers env = do - product <- foldl mergeEnvs emptyEnv . catMaybes <$> traverse scopedEnvironment supers + product <- foldl mergeEnvs lowerBound . catMaybes <$> traverse scopedEnvironment supers pure $ Class n (mergeEnvs product env) namespace n env = do maybeAddr <- lookupEnv n - env' <- maybe (pure emptyEnv) (asNamespaceEnv <=< deref) maybeAddr + env' <- maybe (pure lowerBound) (asNamespaceEnv <=< deref) maybeAddr pure (Namespace n (Env.mergeNewer env' env)) where asNamespaceEnv v | Namespace _ env' <- v = pure env' diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index 220c82c58..0d7c9ff09 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -7,6 +7,7 @@ import qualified Data.Abstract.Package as Package import Data.Abstract.Path import Data.Aeson import Data.JSON.Fields +import Data.Semilattice.Lower import qualified Data.Text as T import Diffing.Algorithm import Prologue @@ -66,7 +67,7 @@ instance Evaluatable Import where paths <- resolveGoImport importPath for_ paths $ \path -> do traceResolve (unPath importPath) path - importedEnv <- maybe emptyEnv snd <$> require path + importedEnv <- maybe lowerBound snd <$> require path bindAll importedEnv rvalBox unit @@ -88,7 +89,7 @@ instance Evaluatable QualifiedImport where void $ letrec' alias $ \addr -> do for_ paths $ \p -> do traceResolve (unPath importPath) p - importedEnv <- maybe emptyEnv snd <$> require p + importedEnv <- maybe lowerBound snd <$> require p bindAll importedEnv makeNamespace alias addr Nothing rvalBox unit diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index e5b29aa00..bb184f7c4 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -7,6 +7,7 @@ import Data.Abstract.Path import qualified Data.Text as T import Data.JSON.Fields import qualified Data.Language as Language +import Data.Semilattice.Lower import Diffing.Algorithm import Prologue hiding (Text) @@ -62,7 +63,7 @@ include pathTerm f = do path <- resolvePHPName name traceResolve name path unitPtr <- box unit -- TODO don't always allocate, use maybeM - (v, importedEnv) <- fromMaybe (unitPtr, emptyEnv) <$> f path + (v, importedEnv) <- fromMaybe (unitPtr, lowerBound) <$> f path bindAll importedEnv pure (Rval v) diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index fd60361cf..2a877ba11 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -10,6 +10,7 @@ import Data.JSON.Fields import qualified Data.Language as Language import qualified Data.List.NonEmpty as NonEmpty import Data.Mergeable +import Data.Semilattice.Lower import qualified Data.Text as T import Diffing.Algorithm import GHC.Generics @@ -113,7 +114,7 @@ instance Evaluatable Import where -- Last module path is the one we want to import let path = NonEmpty.last modulePaths - importedEnv <- maybe emptyEnv snd <$> require path + importedEnv <- maybe lowerBound snd <$> require path bindAll (select importedEnv) rvalBox unit where @@ -130,7 +131,7 @@ evalQualifiedImport :: ( AbstractValue address value effects ) => Name -> ModulePath -> Evaluator address value effects value evalQualifiedImport name path = letrec' name $ \addr -> do - importedEnv <- maybe emptyEnv snd <$> require path + importedEnv <- maybe lowerBound snd <$> require path bindAll importedEnv unit <$ makeNamespace name addr Nothing @@ -174,7 +175,7 @@ instance Evaluatable QualifiedAliasedImport where alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm) rvalBox =<< letrec' alias (\addr -> do let path = NonEmpty.last modulePaths - importedEnv <- maybe emptyEnv snd <$> require path + importedEnv <- maybe lowerBound snd <$> require path bindAll importedEnv unit <$ makeNamespace alias addr Nothing) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index f2e2aab20..21c709f68 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -8,6 +8,7 @@ import Data.Abstract.Path import qualified Data.Text as T import Data.JSON.Fields import qualified Data.Language as Language +import Data.Semilattice.Lower import Diffing.Algorithm import Prologue import System.FilePath.Posix @@ -80,7 +81,7 @@ doRequire :: ( AbstractValue address value effects doRequire path = do result <- join <$> lookupModule path case result of - Nothing -> (,) (boolean True) . maybe emptyEnv snd <$> load path + Nothing -> (,) (boolean True) . maybe lowerBound snd <$> load path Just (_, env) -> pure (boolean False, env) @@ -112,7 +113,7 @@ doLoad :: ( AbstractValue address value effects doLoad path shouldWrap = do path' <- resolveRubyPath path traceResolve path path' - importedEnv <- maybe emptyEnv snd <$> load path' + importedEnv <- maybe lowerBound snd <$> load path' unless shouldWrap $ bindAll importedEnv pure (boolean Prelude.True) -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 1f479eee7..f76e1a46e 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -10,6 +10,7 @@ import Data.Aeson import Data.JSON.Fields import qualified Data.Language as Language import qualified Data.Map as Map +import Data.Semilattice.Lower import qualified Data.Text as T import Diffing.Algorithm import Prologue @@ -139,7 +140,7 @@ evalRequire :: ( AbstractValue address value effects -> Name -> Evaluator address value effects value evalRequire modulePath alias = letrec' alias $ \addr -> do - importedEnv <- maybe emptyEnv snd <$> require modulePath + importedEnv <- maybe lowerBound snd <$> require modulePath bindAll importedEnv unit <$ makeNamespace alias addr Nothing @@ -154,7 +155,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Import where eval (Import symbols importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - importedEnv <- maybe emptyEnv snd <$> require modulePath + importedEnv <- maybe lowerBound snd <$> require modulePath bindAll (renamed importedEnv) rvalBox unit where @@ -230,7 +231,7 @@ instance Show1 QualifiedExportFrom where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedExportFrom where eval (QualifiedExportFrom importPath exportSymbols) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - importedEnv <- maybe emptyEnv snd <$> require modulePath + importedEnv <- maybe lowerBound snd <$> require modulePath -- Look up addresses in importedEnv and insert the aliases with addresses into the exports. for_ exportSymbols $ \(name, alias) -> do let address = Env.lookup name importedEnv diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index f9ebee5ac..47fda0872 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -162,7 +162,7 @@ resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err NumericError{} -> pure hole Numeric2Error{} -> pure hole ComparisonError{} -> pure hole - NamespaceError{} -> pure emptyEnv + NamespaceError{} -> pure lowerBound BitwiseError{} -> pure hole Bitwise2Error{} -> pure hole KeyValueError{} -> pure (hole, hole) diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index acb871251..d1f09dbb1 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -27,7 +27,7 @@ spec = parallel $ do it "side effect only imports" $ do ((res, _), _) <- evaluate "main2.ts" - fmap snd <$> res `shouldBe` Right [emptyEnv] + fmap snd <$> res `shouldBe` Right [lowerBound] it "fails exporting symbols not defined in the module" $ do ((res, _), _) <- evaluate "bad-export.ts" From 54ea58fd79551e1ea2a98309d20ecf3cabd55dba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Jun 2018 11:06:26 -0400 Subject: [PATCH 37/46] Move the proto3 packages down. --- semantic.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/semantic.cabal b/semantic.cabal index 86110c8db..f00c8f1ae 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -217,10 +217,10 @@ library , text >= 1.2.1.3 , these , time - , proto3-suite - , proto3-wire , unix , unordered-containers + , proto3-suite + , proto3-wire , haskell-tree-sitter , tree-sitter-go , tree-sitter-haskell From 33064d0dbc2bfd9043580706bff81a8bbd234c0e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Jun 2018 11:36:58 -0400 Subject: [PATCH 38/46] Add semilattices as a submodule. --- .gitmodules | 3 +++ vendor/semilattices | 1 + 2 files changed, 4 insertions(+) create mode 160000 vendor/semilattices diff --git a/.gitmodules b/.gitmodules index 859c01cba..011108b59 100644 --- a/.gitmodules +++ b/.gitmodules @@ -22,3 +22,6 @@ [submodule "vendor/proto3-suite"] path = vendor/proto3-suite url = https://github.com/joshvera/proto3-suite +[submodule "vendor/semilattices"] + path = vendor/semilattices + url = https://github.com/robrix/semilattices.git diff --git a/vendor/semilattices b/vendor/semilattices new file mode 160000 index 000000000..cad77016f --- /dev/null +++ b/vendor/semilattices @@ -0,0 +1 @@ +Subproject commit cad77016f533f9078c6e42aea33405ec7900497c From bf06d928c99bbb296378e45a14ed97a13977bd7f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Jun 2018 11:37:49 -0400 Subject: [PATCH 39/46] Replace Data.Semilattice.Lower with semilattices. --- semantic.cabal | 2 +- src/Data/Semilattice/Lower.hs | 47 ----------------------------------- 2 files changed, 1 insertion(+), 48 deletions(-) delete mode 100644 src/Data/Semilattice/Lower.hs diff --git a/semantic.cabal b/semantic.cabal index f00c8f1ae..41f8d1b04 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -86,7 +86,6 @@ library , Data.Range , Data.Record , Data.Semigroup.App - , Data.Semilattice.Lower , Data.Scientific.Exts , Data.Source , Data.Span @@ -211,6 +210,7 @@ library , reducers , scientific , semigroupoids + , semilattices , split , stm-chans , template-haskell diff --git a/src/Data/Semilattice/Lower.hs b/src/Data/Semilattice/Lower.hs deleted file mode 100644 index 87101aafd..000000000 --- a/src/Data/Semilattice/Lower.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -module Data.Semilattice.Lower -( Lower (..) -) where - -import Data.IntMap as IntMap -import Data.IntSet as IntSet -import Data.Map as Map -import Data.Monoid as Monoid -import Data.Set as Set - -class Lower s where - -- | The greatest lower bound of @s@. - -- - -- Laws: - -- - -- If @s@ is 'Bounded', we require 'lowerBound' and 'minBound' to agree: - -- - -- > lowerBound = minBound - -- - -- If @s@ is a 'Join' semilattice, 'lowerBound' must be the identity of '(\/)': - -- - -- > lowerBound \/ a = a - -- - -- If @s@ is 'Ord'ered, 'lowerBound' must be at least as small as every terminating value: - -- - -- > compare lowerBound a /= GT - lowerBound :: s - default lowerBound :: Bounded s => s - lowerBound = minBound - -instance Lower b => Lower (a -> b) where lowerBound = const lowerBound - -instance Lower (Maybe a) where lowerBound = Nothing -instance Lower [a] where lowerBound = [] - -instance (Lower a, Lower b) => Lower (a, b) where lowerBound = (lowerBound, lowerBound) - - --- Data.Monoid -instance Lower (Last a) where lowerBound = mempty - --- containers -instance Lower (IntMap a) where lowerBound = IntMap.empty -instance Lower IntSet where lowerBound = IntSet.empty -instance Lower (Map k a) where lowerBound = Map.empty -instance Lower (Set a) where lowerBound = Set.empty From da19e87b8062e94067275b92cf58f5a4be18a678 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Jun 2018 11:40:26 -0400 Subject: [PATCH 40/46] Depend on semilattices in the tests. --- semantic.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/semantic.cabal b/semantic.cabal index 41f8d1b04..62d658875 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -320,6 +320,7 @@ test-suite test , proto3-suite , proto3-wire , recursion-schemes >= 4.1 + , semilattices , semantic , text >= 1.2.1.3 , these From ccbd8801553f72a95acd95bffe59bc7a74716988 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Jun 2018 11:41:15 -0400 Subject: [PATCH 41/46] Re-export Lower in Prologue. --- src/Analysis/Abstract/Caching.hs | 1 - src/Analysis/Abstract/Collecting.hs | 1 - src/Analysis/Abstract/Dead.hs | 1 - src/Analysis/Abstract/Evaluating.hs | 2 +- src/Control/Abstract/Environment.hs | 1 - src/Control/Abstract/Primitive.hs | 1 - src/Control/Abstract/Value.hs | 2 -- src/Data/Abstract/Address.hs | 1 - src/Data/Abstract/Cache.hs | 1 - src/Data/Abstract/Environment.hs | 1 - src/Data/Abstract/Evaluatable.hs | 1 - src/Data/Abstract/Exports.hs | 1 - src/Data/Abstract/Heap.hs | 1 - src/Data/Abstract/Live.hs | 1 - src/Data/Abstract/ModuleTable.hs | 1 - src/Data/Abstract/Type.hs | 1 - src/Data/Abstract/Value.hs | 1 - src/Data/Graph.hs | 1 - src/Data/Map/Monoidal.hs | 1 - src/Data/Range.hs | 1 - src/Data/Record.hs | 1 - src/Data/Span.hs | 1 - src/Language/Go/Syntax.hs | 1 - src/Language/PHP/Syntax.hs | 1 - src/Language/Python/Syntax.hs | 1 - src/Language/Ruby/Syntax.hs | 1 - src/Language/TypeScript/Syntax.hs | 1 - src/Prologue.hs | 1 + 28 files changed, 2 insertions(+), 28 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 97133344e..00485ade9 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -9,7 +9,6 @@ import Control.Abstract import Data.Abstract.Cache import Data.Abstract.Module import Data.Abstract.Ref -import Data.Semilattice.Lower import Prologue -- | Look up the set of values for a given configuration in the in-cache. diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 2d8202cdc..f8300d287 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -5,7 +5,6 @@ module Analysis.Abstract.Collecting ) where import Control.Abstract -import Data.Semilattice.Lower import Prologue -- | An analysis performing GC after every instruction. diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 3528e4ad5..6a8f0e360 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -9,7 +9,6 @@ module Analysis.Abstract.Dead import Control.Abstract import Data.Abstract.Module import Data.Semigroup.Reducer as Reducer -import Data.Semilattice.Lower import Data.Set (delete) import Prologue diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index e5db191ca..6da064c3b 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -5,7 +5,7 @@ module Analysis.Abstract.Evaluating ) where import Control.Abstract -import Data.Semilattice.Lower +import Prologue -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. data EvaluatingState address value = EvaluatingState diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 597610fb7..8179e730a 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -23,7 +23,6 @@ import Data.Abstract.Environment (Environment) import qualified Data.Abstract.Environment as Env import Data.Abstract.Exports as Exports import Data.Abstract.Name -import Data.Semilattice.Lower import Prologue -- | Retrieve the environment. diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 5221ae7c6..a624c2e78 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -6,7 +6,6 @@ import Control.Abstract.Evaluator import Control.Abstract.Heap import Control.Abstract.Value import Data.Abstract.Name -import Data.Semilattice.Lower import Data.Text (pack, unpack) import Prologue diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 8dfdf0801..082e35db8 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -25,8 +25,6 @@ import Data.Abstract.Name import Data.Abstract.Number as Number import Data.Abstract.Ref import Data.Scientific (Scientific) -import Data.Semilattice.Lower -import Prelude import Prologue hiding (TypeError) -- | This datum is passed into liftComparison to handle the fact that Ruby and PHP diff --git a/src/Data/Abstract/Address.hs b/src/Data/Abstract/Address.hs index d5eb863ff..cb87676fb 100644 --- a/src/Data/Abstract/Address.hs +++ b/src/Data/Abstract/Address.hs @@ -6,7 +6,6 @@ import Data.Abstract.Name import Data.Abstract.Package (PackageInfo) import Data.Monoid (Last(..)) import Data.Semigroup.Reducer -import Data.Semilattice.Lower import Data.Set as Set import Prologue diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index 0112f7cd9..413340276 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -5,7 +5,6 @@ import Data.Abstract.Configuration import Data.Abstract.Heap import Data.Abstract.Ref import Data.Map.Monoidal as Monoidal -import Data.Semilattice.Lower import Prologue -- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's. diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 45164e07c..6ee68346f 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -22,7 +22,6 @@ import Data.Abstract.Name import Data.Align import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map -import Data.Semilattice.Lower import Prelude hiding (head, lookup) import Prologue diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index a9fcfa051..d32f93e93 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -34,7 +34,6 @@ import Data.Scientific (Scientific) import Data.Semigroup.App import Data.Semigroup.Foldable import Data.Semigroup.Reducer hiding (unit) -import Data.Semilattice.Lower import Data.Sum import Data.Term import Prologue diff --git a/src/Data/Abstract/Exports.hs b/src/Data/Abstract/Exports.hs index f3df8174d..e1ce863c3 100644 --- a/src/Data/Abstract/Exports.hs +++ b/src/Data/Abstract/Exports.hs @@ -10,7 +10,6 @@ module Data.Abstract.Exports import Data.Abstract.Environment (Environment, unpairs) import Data.Abstract.Name import qualified Data.Map as Map -import Data.Semilattice.Lower import Prelude hiding (null) import Prologue hiding (null) diff --git a/src/Data/Abstract/Heap.hs b/src/Data/Abstract/Heap.hs index 1b4aea41d..6fbd7cc19 100644 --- a/src/Data/Abstract/Heap.hs +++ b/src/Data/Abstract/Heap.hs @@ -4,7 +4,6 @@ module Data.Abstract.Heap where import Data.Abstract.Live import qualified Data.Map.Monoidal as Monoidal import Data.Semigroup.Reducer -import Data.Semilattice.Lower import Prologue -- | A map of addresses onto cells holding their values. diff --git a/src/Data/Abstract/Live.hs b/src/Data/Abstract/Live.hs index e521e9caf..af922f17f 100644 --- a/src/Data/Abstract/Live.hs +++ b/src/Data/Abstract/Live.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-} module Data.Abstract.Live where -import Data.Semilattice.Lower import Data.Set as Set import Prologue diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index 94744d81b..1522ad635 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -15,7 +15,6 @@ module Data.Abstract.ModuleTable import Data.Abstract.Module import qualified Data.Map as Map import Data.Semigroup -import Data.Semilattice.Lower import GHC.Generics (Generic1) import Prelude hiding (lookup) import Prologue diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 24f4a8d5f..c311a8c5c 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -10,7 +10,6 @@ module Data.Abstract.Type import Control.Abstract import Data.Abstract.Environment as Env import Data.Semigroup.Foldable (foldMap1) -import Data.Semilattice.Lower import Prologue hiding (TypeError) type TName = Int diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index fe891c086..b14021db7 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -10,7 +10,6 @@ import Data.Coerce import Data.List (genericIndex, genericLength) import Data.Scientific (Scientific) import Data.Scientific.Exts -import Data.Semilattice.Lower import qualified Data.Set as Set import Prologue diff --git a/src/Data/Graph.hs b/src/Data/Graph.hs index 59466ee19..f8e6e263d 100644 --- a/src/Data/Graph.hs +++ b/src/Data/Graph.hs @@ -11,7 +11,6 @@ module Data.Graph import qualified Algebra.Graph as G import qualified Algebra.Graph.Class as Class import Data.Aeson -import Data.Semilattice.Lower import Prologue -- | An algebraic graph with 'Ord', 'Semigroup', and 'Monoid' instances. diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index 20d3cb1b0..34192cb2b 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -14,7 +14,6 @@ module Data.Map.Monoidal import Data.Aeson (ToJSON) import qualified Data.Map as Map import Data.Semigroup.Reducer as Reducer -import Data.Semilattice.Lower import Prelude hiding (lookup) import Prologue hiding (Map) diff --git a/src/Data/Range.hs b/src/Data/Range.hs index 51f9048f4..bd5a8b7ac 100644 --- a/src/Data/Range.hs +++ b/src/Data/Range.hs @@ -9,7 +9,6 @@ module Data.Range import Data.Aeson import Data.JSON.Fields -import Data.Semilattice.Lower import Prologue -- | A half-open interval of integers, defined by start & end indices. diff --git a/src/Data/Record.hs b/src/Data/Record.hs index 9a5d72b62..2e2f98af7 100644 --- a/src/Data/Record.hs +++ b/src/Data/Record.hs @@ -4,7 +4,6 @@ module Data.Record where import Data.Aeson import Data.JSON.Fields import Data.Kind -import Data.Semilattice.Lower import Prologue -- | A type-safe, extensible record structure. diff --git a/src/Data/Span.hs b/src/Data/Span.hs index 1f805060d..6e7c0bdf1 100644 --- a/src/Data/Span.hs +++ b/src/Data/Span.hs @@ -16,7 +16,6 @@ import Proto3.Wire.Decode as Decode import Proto3.Wire.Encode as Encode import qualified Data.Aeson as A import Data.JSON.Fields -import Data.Semilattice.Lower import GHC.Stack import Prologue diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index 0d7c9ff09..de0378bf3 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -7,7 +7,6 @@ import qualified Data.Abstract.Package as Package import Data.Abstract.Path import Data.Aeson import Data.JSON.Fields -import Data.Semilattice.Lower import qualified Data.Text as T import Diffing.Algorithm import Prologue diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index bb184f7c4..254e91223 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -7,7 +7,6 @@ import Data.Abstract.Path import qualified Data.Text as T import Data.JSON.Fields import qualified Data.Language as Language -import Data.Semilattice.Lower import Diffing.Algorithm import Prologue hiding (Text) diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 2a877ba11..b968fb218 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -10,7 +10,6 @@ import Data.JSON.Fields import qualified Data.Language as Language import qualified Data.List.NonEmpty as NonEmpty import Data.Mergeable -import Data.Semilattice.Lower import qualified Data.Text as T import Diffing.Algorithm import GHC.Generics diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 21c709f68..821eb026f 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -8,7 +8,6 @@ import Data.Abstract.Path import qualified Data.Text as T import Data.JSON.Fields import qualified Data.Language as Language -import Data.Semilattice.Lower import Diffing.Algorithm import Prologue import System.FilePath.Posix diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index f76e1a46e..c218876e1 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -10,7 +10,6 @@ import Data.Aeson import Data.JSON.Fields import qualified Data.Language as Language import qualified Data.Map as Map -import Data.Semilattice.Lower import qualified Data.Text as T import Diffing.Algorithm import Prologue diff --git a/src/Prologue.hs b/src/Prologue.hs index 3e8397b2d..4021a8e18 100644 --- a/src/Prologue.hs +++ b/src/Prologue.hs @@ -20,6 +20,7 @@ import Data.Map as X (Map) import Data.Maybe as X import Data.Monoid (Alt (..)) import Data.Sequence as X (Seq) +import Data.Semilattice.Lower as X (Lower(..)) import Data.Set as X (Set) import Data.Sum as X (Sum, Element, Elements, (:<), (:<:), Apply (..), inject) import Data.Text as X (Text) From 792cdcc5e297c56c85748c264ab48132986b9920 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Jun 2018 11:41:38 -0400 Subject: [PATCH 42/46] Re-export Lower from SpecHelpers. --- test/Control/Abstract/Evaluator/Spec.hs | 1 - test/SpecHelpers.hs | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index b94060d49..a0f21fa8c 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -13,7 +13,6 @@ import Data.Abstract.Value as Value import Data.Algebra import Data.Bifunctor (first) import Data.Functor.Const -import Data.Semilattice.Lower import Data.Sum import SpecHelpers hiding (reassociate) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 05690c5a5..d1d2d6702 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -37,6 +37,7 @@ import Data.Language as X import Data.List.NonEmpty as X (NonEmpty(..)) import Data.Range as X import Data.Record as X +import Data.Semilattice.Lower as X import Data.Source as X import Data.Span as X import Data.Sum From 033a748ed74f75e760b6639debe35e9a9e600673 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 15 Jun 2018 09:56:46 -0700 Subject: [PATCH 43/46] Telemetry interface handles details of creating/closing async queues --- src/Semantic/Config.hs | 58 +++++++++++++++------------------- src/Semantic/Task.hs | 16 ++++------ src/Semantic/Telemetry.hs | 54 ++++++++++++++++++++++++++----- src/Semantic/Telemetry/Stat.hs | 17 +++++++--- 4 files changed, 91 insertions(+), 54 deletions(-) diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index 166120377..841c9c622 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -43,7 +43,7 @@ data Options , optionsFailOnWarning :: Bool -- ^ Should semantic fail fast on assignment warnings (for testing) } -data StatsAddr = StatsAddr { addrHost :: String, addrPort :: String } +data StatsAddr = StatsAddr { addrHost :: Stat.Host, addrPort :: Stat.Port } defaultOptions :: Options defaultOptions = Options (Just Warning) Nothing False @@ -76,40 +76,34 @@ defaultConfig' options@Options{..} = do , configOptions = options } +withTelemetry :: Config -> (TelemetryQueues -> IO c) -> IO c +withTelemetry config action = + withLoggerFromConfig config $ \logger -> + withHaystackFromConfig config (queueLogMessage logger Error) $ \haystack -> + withStatterFromConfig config $ \statter -> + action (TelemetryQueues logger statter haystack) -defaultHaystackFromConfig :: Config -> Haystack.ErrorLogger -> IO HaystackQueue -defaultHaystackFromConfig c@Config{..} logError = haystackClientFromConfig c >>= newAsyncQueue configMaxTelemetyQueueSize (Haystack.reportError logError) +withLoggerFromConfig :: Config -> (LogQueue -> IO c) -> IO c +withLoggerFromConfig Config{..} = withLogger opts configMaxTelemetyQueueSize + where opts = LogOptions { + logOptionsLevel = optionsLogLevel configOptions + , logOptionsFormatter = configLogFormatter + , logOptionsContext = + [ ("app", configAppName) + , ("pid", show configProcessID) + , ("hostname", configHostName) + , ("sha", buildSHA) + ] <> [("request_id", x) | x <- toList (optionsRequestID configOptions) ] + } -haystackClientFromConfig :: Config -> IO HaystackClient -haystackClientFromConfig Config{..} = haystackClient configHaystackURL tlsManagerSettings configAppName +withHaystackFromConfig :: Config -> Haystack.ErrorLogger -> (HaystackQueue -> IO c) -> IO c +withHaystackFromConfig Config{..} errorLogger = + withHaystack configHaystackURL tlsManagerSettings configAppName errorLogger configMaxTelemetyQueueSize - -withLogger :: Config -> (LogQueue -> IO c) -> IO c -withLogger c = bracket (defaultLoggerFromConfig c) closeAsyncQueue - -defaultLoggerFromConfig :: Config -> IO LogQueue -defaultLoggerFromConfig Config{..} = - newAsyncQueue configMaxTelemetyQueueSize Log.writeLogMessage LogOptions { - logOptionsLevel = optionsLogLevel configOptions - , logOptionsFormatter = configLogFormatter - , logOptionsContext = - [ ("app", configAppName) - , ("pid", show configProcessID) - , ("hostname", configHostName) - , ("sha", buildSHA) - ] <> [("request_id", x) | x <- toList (optionsRequestID configOptions) ] - } - -withStatter :: Config -> (StatQueue -> IO c) -> IO c -withStatter c = bracket (defaultStatterFromConfig c) $ \statter -> do - closeAsyncQueue statter - Stat.closeStatClient (asyncQueueExtra statter) - -defaultStatterFromConfig :: Config -> IO StatQueue -defaultStatterFromConfig c@Config{..} = statsClientFromConfig c >>= newAsyncQueue configMaxTelemetyQueueSize Stat.sendStat - -statsClientFromConfig :: Config -> IO StatsClient -statsClientFromConfig Config{..} = statsClient (addrHost configStatsAddr) (addrPort configStatsAddr) configAppName +withStatterFromConfig :: Config -> (StatQueue -> IO c) -> IO c +withStatterFromConfig Config{..} = withStatter host port configAppName configMaxTelemetyQueueSize + where host = addrHost configStatsAddr + port = addrPort configStatsAddr lookupStatsAddr :: IO StatsAddr lookupStatsAddr = do diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 520bd6bd3..f59fda15f 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -75,7 +75,6 @@ import Semantic.Distribute import qualified Semantic.IO as IO import Semantic.Resolution import Semantic.Telemetry -import Semantic.Telemetry.Stat as Stat import Serializing.Format hiding (Options) import System.Exit (die) @@ -130,9 +129,8 @@ runTask = runTaskWithOptions defaultOptions runTaskWithOptions :: Options -> TaskEff a -> IO a runTaskWithOptions opts task = do config <- defaultConfig' opts - result <- withLogger config $ \logger -> - withStatter config $ \statter -> - runTaskWithConfig config logger statter task + result <- withTelemetry config $ \(TelemetryQueues logger statter _) -> + runTaskWithConfig config logger statter task either (die . displayException) pure result -- | Execute a 'TaskEff' yielding its result value in 'IO'. @@ -197,26 +195,26 @@ runParser blob@Blob{..} parser = case parser of AssignmentParser parser assignment -> do ast <- runParser blob parser `catchError` \ (SomeException err) -> do - writeStat (Stat.increment "parse.parse_failures" languageTag) + writeStat (increment "parse.parse_failures" languageTag) writeLog Error "failed parsing" (("task", "parse") : blobFields) throwError (toException err) config <- ask time "parse.assign" languageTag $ case Assignment.assign blobSource assignment ast of Left err -> do - writeStat (Stat.increment "parse.assign_errors" languageTag) + writeStat (increment "parse.assign_errors" languageTag) logError config Error blob err (("task", "assign") : blobFields) throwError (toException err) Right term -> do for_ (errors term) $ \ err -> case Error.errorActual err of Just "ParseError" -> do - writeStat (Stat.increment "parse.parse_errors" languageTag) + writeStat (increment "parse.parse_errors" languageTag) logError config Warning blob err (("task", "parse") : blobFields) _ -> do - writeStat (Stat.increment "parse.assign_warnings" languageTag) + writeStat (increment "parse.assign_warnings" languageTag) logError config Warning blob err (("task", "assign") : blobFields) when (optionsFailOnWarning (configOptions config)) $ throwError (toException err) - writeStat (Stat.count "parse.nodes" (length term) languageTag) + writeStat (count "parse.nodes" (length term) languageTag) pure term MarkdownParser -> time "parse.cmark_parse" languageTag $ diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index 3bd609e52..cf67db6b7 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -2,9 +2,13 @@ module Semantic.Telemetry ( -- Async telemetry interface - LogQueue + withLogger +, withHaystack +, withStatter +, LogQueue , StatQueue , HaystackQueue +, TelemetryQueues(..) , queueLogMessage , queueErrorReport , queueStat @@ -43,20 +47,54 @@ module Semantic.Telemetry , ignoreTelemetry ) where -import Control.Exception -import Control.Monad.Effect -import Control.Monad.IO.Class -import Semantic.Telemetry.AsyncQueue -import Semantic.Telemetry.Haystack -import Semantic.Telemetry.Log -import Semantic.Telemetry.Stat as Stat +import Control.Exception +import Control.Monad.Effect +import Control.Monad.IO.Class import qualified Data.Time.Clock.POSIX as Time (getCurrentTime) import qualified Data.Time.LocalTime as LocalTime +import Network.HTTP.Client +import Semantic.Telemetry.AsyncQueue +import Semantic.Telemetry.Haystack +import Semantic.Telemetry.Log +import Semantic.Telemetry.Stat as Stat type LogQueue = AsyncQueue Message LogOptions type StatQueue = AsyncQueue Stat StatsClient type HaystackQueue = AsyncQueue ErrorReport HaystackClient +data TelemetryQueues + = TelemetryQueues + { telemetryLogger :: LogQueue + , telemetryStatter :: StatQueue + , telemetryHaystack :: HaystackQueue + } + +-- | Execute an action in IO with access to a logger (async log queue). +withLogger :: LogOptions -- ^ Log options + -> Int -- ^ Max stats queue size before dropping stats + -> (LogQueue -> IO c) -- ^ Action in IO + -> IO c +withLogger options size = bracket setup closeAsyncQueue + where setup = newAsyncQueue size writeLogMessage options + +-- | Execute an action in IO with access to haystack (async error reporting queue). +withHaystack :: Maybe String -> ManagerSettings -> String -> ErrorLogger -> Int -> (HaystackQueue -> IO c) -> IO c +withHaystack url settings appName errorLogger size = bracket setup closeAsyncQueue + where setup = haystackClient url settings appName >>= newAsyncQueue size (reportError errorLogger) + +-- | Execute an action in IO with access to a statter (async stat queue). +-- Handles the bracketed setup and teardown of the underlying 'AsyncQueue' and +-- 'StatsClient'. +withStatter :: Host -- ^ Statsd host + -> Port -- ^ Statsd port + -> Namespace -- ^ Namespace prefix for stats + -> Int -- ^ Max stats queue size before dropping stats + -> (StatQueue -> IO c) -- ^ Action in IO + -> IO c +withStatter host port ns size = bracket setup teardown + where setup = statsClient host port ns >>= newAsyncQueue size sendStat + teardown statter = closeAsyncQueue statter >> Stat.closeStatClient (asyncQueueExtra statter) + -- | Queue a message to be logged. queueLogMessage :: MonadIO io => LogQueue -> Level -> String -> [(String, String)] -> io () queueLogMessage q@AsyncQueue{..} level message pairs diff --git a/src/Semantic/Telemetry/Stat.hs b/src/Semantic/Telemetry/Stat.hs index 3c42e42a6..1bb313a14 100644 --- a/src/Semantic/Telemetry/Stat.hs +++ b/src/Semantic/Telemetry/Stat.hs @@ -11,6 +11,9 @@ module Semantic.Telemetry.Stat , set , Stat , Tags +, Host +, Port +, Namespace -- Client , statsClient @@ -99,17 +102,21 @@ data StatsClient = StatsClient { statsClientUDPSocket :: Socket , statsClientNamespace :: String - , statsClientUDPHost :: String - , statsClientUDPPort :: String + , statsClientUDPHost :: Host + , statsClientUDPPort :: Port } +type Host = String +type Port = String +type Namespace = String + -- | Create a StatsClient at the specified host and port with a namespace prefix. -statsClient :: MonadIO io => String -> String -> String -> io StatsClient -statsClient host port statsClientNamespace = liftIO $ do +statsClient :: MonadIO io => Host -> Port -> Namespace -> io StatsClient +statsClient host port ns = liftIO $ do (addr:_) <- getAddrInfo Nothing (Just host) (Just port) sock <- socket (addrFamily addr) Datagram defaultProtocol connect sock (addrAddress addr) - pure (StatsClient sock statsClientNamespace host port) + pure (StatsClient sock ns host port) -- | Close the client's underlying socket. closeStatClient :: MonadIO io => StatsClient -> io () From 21e3f691100afacd4e1b46f672a442a7dba78916 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 15 Jun 2018 10:17:02 -0700 Subject: [PATCH 44/46] Just one defaultConfig --- src/Semantic/Config.hs | 7 ++----- src/Semantic/Task.hs | 2 +- test/Semantic/Stat/Spec.hs | 2 +- 3 files changed, 4 insertions(+), 7 deletions(-) diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index 841c9c622..f59695121 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -48,11 +48,8 @@ data StatsAddr = StatsAddr { addrHost :: Stat.Host, addrPort :: Stat.Port } defaultOptions :: Options defaultOptions = Options (Just Warning) Nothing False -defaultConfig :: IO Config -defaultConfig = defaultConfig' defaultOptions - -defaultConfig' :: Options -> IO Config -defaultConfig' options@Options{..} = do +defaultConfig :: Options -> IO Config +defaultConfig options@Options{..} = do pid <- getProcessID hostName <- getHostName isTerminal <- hIsTerminalDevice stderr diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index f59fda15f..7b17a303a 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -128,7 +128,7 @@ runTask = runTaskWithOptions defaultOptions -- | Execute a 'TaskEff' with the passed 'Options', yielding its result value in 'IO'. runTaskWithOptions :: Options -> TaskEff a -> IO a runTaskWithOptions opts task = do - config <- defaultConfig' opts + config <- defaultConfig opts result <- withTelemetry config $ \(TelemetryQueues logger statter _) -> runTaskWithConfig config logger statter task either (die . displayException) pure result diff --git a/test/Semantic/Stat/Spec.hs b/test/Semantic/Stat/Spec.hs index 903608ef8..649ae6f3d 100644 --- a/test/Semantic/Stat/Spec.hs +++ b/test/Semantic/Stat/Spec.hs @@ -84,4 +84,4 @@ spec = do -- Defaults are all driven by defaultConfig. defaultStatsClient :: IO StatsClient -defaultStatsClient = defaultConfig >>= \Config{..} -> statsClient (addrHost configStatsAddr) (addrPort configStatsAddr) configAppName +defaultStatsClient = defaultConfig defaultOptions >>= \Config{..} -> statsClient (addrHost configStatsAddr) (addrPort configStatsAddr) configAppName From 23390f7789a235d1551432969bce6002d269ee0c Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 15 Jun 2018 10:31:51 -0700 Subject: [PATCH 45/46] Refactor Stats addr --- src/Semantic/Config.hs | 19 +++++++++---------- test/Semantic/Stat/Spec.hs | 2 +- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index f59695121..0f5f9f231 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -24,7 +24,8 @@ data Config , configHostName :: String -- ^ HostName from getHostName , configProcessID :: ProcessID -- ^ ProcessID from getProcessID , configHaystackURL :: Maybe String -- ^ URL of Haystack (with creds) from environment - , configStatsAddr :: StatsAddr -- ^ Address of statsd/datadog (default: "127.0.0.1:28125") + , configStatsHost :: Stat.Host -- ^ Host of statsd/datadog (default: "127.0.0.1") + , configStatsPort :: Stat.Port -- ^ Port of statsd/datadog (default: "28125") , configTreeSitterParseTimeout :: Timeout -- ^ Timeout in milliseconds before canceling tree-sitter parsing (default: 10000). , configMaxTelemetyQueueSize :: Int -- ^ Max size of telemetry queues before messages are dropped (default: 1000). @@ -43,8 +44,6 @@ data Options , optionsFailOnWarning :: Bool -- ^ Should semantic fail fast on assignment warnings (for testing) } -data StatsAddr = StatsAddr { addrHost :: Stat.Host, addrPort :: Stat.Port } - defaultOptions :: Options defaultOptions = Options (Just Warning) Nothing False @@ -54,7 +53,7 @@ defaultConfig options@Options{..} = do hostName <- getHostName isTerminal <- hIsTerminalDevice stderr haystackURL <- lookupEnv "HAYSTACK_URL" - statsAddr <- lookupStatsAddr + (statsHost, statsPort) <- lookupStatsAddr size <- envLookupInt 1000 "MAX_TELEMETRY_QUEUE_SIZE" parseTimeout <- envLookupInt 10000 "TREE_SITTER_PARSE_TIMEOUT" -- Default is 10 seconds pure Config @@ -62,7 +61,8 @@ defaultConfig options@Options{..} = do , configHostName = hostName , configProcessID = pid , configHaystackURL = haystackURL - , configStatsAddr = statsAddr + , configStatsHost = statsHost + , configStatsPort = statsPort , configTreeSitterParseTimeout = Milliseconds parseTimeout , configMaxTelemetyQueueSize = size @@ -98,11 +98,10 @@ withHaystackFromConfig Config{..} errorLogger = withHaystack configHaystackURL tlsManagerSettings configAppName errorLogger configMaxTelemetyQueueSize withStatterFromConfig :: Config -> (StatQueue -> IO c) -> IO c -withStatterFromConfig Config{..} = withStatter host port configAppName configMaxTelemetyQueueSize - where host = addrHost configStatsAddr - port = addrPort configStatsAddr +withStatterFromConfig Config{..} = + withStatter configStatsHost configStatsPort configAppName configMaxTelemetyQueueSize -lookupStatsAddr :: IO StatsAddr +lookupStatsAddr :: IO (Stat.Host, Stat.Port) lookupStatsAddr = do addr <- lookupEnv "STATS_ADDR" let (host', port) = parseAddr (fmap ("statsd://" <>) addr) @@ -111,7 +110,7 @@ lookupStatsAddr = do kubesHost <- lookupEnv "DOGSTATSD_HOST" let host = fromMaybe host' kubesHost - pure (StatsAddr host port) + pure (host, port) where defaultHost = "127.0.0.1" defaultPort = "28125" diff --git a/test/Semantic/Stat/Spec.hs b/test/Semantic/Stat/Spec.hs index 649ae6f3d..47d9bfd0d 100644 --- a/test/Semantic/Stat/Spec.hs +++ b/test/Semantic/Stat/Spec.hs @@ -84,4 +84,4 @@ spec = do -- Defaults are all driven by defaultConfig. defaultStatsClient :: IO StatsClient -defaultStatsClient = defaultConfig defaultOptions >>= \Config{..} -> statsClient (addrHost configStatsAddr) (addrPort configStatsAddr) configAppName +defaultStatsClient = defaultConfig defaultOptions >>= \Config{..} -> statsClient configStatsHost configStatsPort configAppName From 3657c0e524e3312795d3f3fec67268972638217b Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 15 Jun 2018 10:34:49 -0700 Subject: [PATCH 46/46] Remove imports --- src/Semantic/Config.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index 0f5f9f231..2ba260cc2 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -1,6 +1,5 @@ module Semantic.Config where -import Control.Exception import Network.BSD import Network.HTTP.Client.TLS import Network.URI @@ -8,9 +7,7 @@ import Parsing.TreeSitter (Timeout (..)) import Prologue import Semantic.Env import Semantic.Telemetry -import Semantic.Telemetry.AsyncQueue import qualified Semantic.Telemetry.Haystack as Haystack -import qualified Semantic.Telemetry.Log as Log import qualified Semantic.Telemetry.Stat as Stat import Semantic.Version import System.Environment