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

Merge remote-tracking branch 'origin/master' into import-graph-mk2

Browse Source
This commit is contained in:
Patrick Thomson 2018-06-15 19:30:50 -04:00
commit 659500551c
50 changed files with 422 additions and 402 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitmodules vendored
View File

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

16
semantic.cabal
View File

@ -88,7 +88,6 @@ library
, Data.Range
, Data.Record
, Data.Semigroup.App
, Data.Semilattice.Lower
, Data.Scientific.Exts
, Data.Source
, Data.Span
@ -156,16 +155,17 @@ library
, Semantic.Distribute
, Semantic.Env
, Semantic.Graph
, Semantic.Haystack
, Semantic.IO
, Semantic.Log
, Semantic.Parse
, Semantic.Queue
, Semantic.Resolution
, Semantic.Stat
, Semantic.Task
, Semantic.Telemetry
, Semantic.Telemetry.AsyncQueue
, Semantic.Telemetry.Haystack
, Semantic.Telemetry.Log
, Semantic.Telemetry.Stat
, Semantic.Util
, Semantic.Version
-- Serialization
, Serializing.DOT
, Serializing.Format
@ -208,18 +208,19 @@ library
, parallel
, parsers
, pretty-show
, proto3-suite
, proto3-wire
, recursion-schemes
, reducers
, scientific
, semigroupoids
, semilattices
, split
, stm-chans
, template-haskell
, text >= 1.2.1.3
, these
, time
, proto3-suite
, proto3-wire
, unix
, unordered-containers
, vector
@ -322,6 +323,7 @@ test-suite test
, proto3-suite
, proto3-wire
, recursion-schemes >= 4.1
, semilattices
, semantic
, text >= 1.2.1.3
, these

1
src/Analysis/Abstract/Caching.hs
View File

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

1
src/Analysis/Abstract/Collecting.hs
View File

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

1
src/Analysis/Abstract/Dead.hs
View File

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

2
src/Analysis/Abstract/Evaluating.hs
View File

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

1
src/Control/Abstract/Environment.hs
View File

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

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

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

2
src/Control/Abstract/Value.hs
View File

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

1
src/Data/Abstract/Address.hs
View File

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

1
src/Data/Abstract/Cache.hs
View File

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

11
src/Data/Abstract/Environment.hs
View File

@ -3,7 +3,6 @@ module Data.Abstract.Environment
, addresses
, delete
, head
, emptyEnv
, mergeEnvs
, mergeNewer
, insert
@ -23,13 +22,12 @@ 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
-- $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 +40,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 +120,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

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

@ -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
@ -118,15 +117,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

1
src/Data/Abstract/Exports.hs
View File

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

1
src/Data/Abstract/Heap.hs
View File

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

1
src/Data/Abstract/Live.hs
View File

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

1
src/Data/Abstract/ModuleTable.hs
View File

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

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

@ -126,7 +126,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 +158,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

6
src/Data/Abstract/Value.hs
View File

@ -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
@ -120,12 +120,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'

1
src/Data/Graph.hs
View File

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

1
src/Data/Map/Monoidal.hs
View File

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

1
src/Data/Range.hs
View File

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

1
src/Data/Record.hs
View File

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

47
src/Data/Semilattice/Lower.hs
View File

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

1
src/Data/Span.hs
View File

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

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

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

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

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

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

@ -66,7 +66,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 +88,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

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

@ -62,7 +62,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)

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

@ -113,7 +113,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 +130,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 +174,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)

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

@ -80,7 +80,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 +112,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

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

@ -139,7 +139,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 +154,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 +230,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

1
src/Prologue.hs
View File

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

21
src/Semantic/CLI.hs
View File

@ -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
@ -7,24 +6,23 @@ module Semantic.CLI
, Parse.runParse
) where
import Data.Project
import Data.Language (ensureLanguage)
import Data.List (intercalate)
import Data.List.Split (splitWhen)
import Data.Version (showVersion)
import Development.GitRev
import Data.Project
import Options.Applicative hiding (style)
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 Semantic.Version
import Serializing.Format hiding (Options)
import Text.Read
main :: IO ()
@ -33,20 +31,19 @@ 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")
versionString = "semantic version " <> showVersion Library.version <> " (" <> $(gitHash) <> ")"
versionString = "semantic version " <> buildVersion <> " (" <> buildSHA <> ")"
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)

114
src/Semantic/Config.hs
View File

@ -1,58 +1,104 @@
module Semantic.Config where
import Network.BSD
import Network.HTTP.Client.TLS
import Network.URI
import Prologue
import Semantic.Haystack
import Semantic.Log
import Semantic.Stat
import System.Environment
import System.IO (stderr)
import System.Posix.Process
import System.Posix.Types
import Network.BSD
import Network.HTTP.Client.TLS
import Network.URI
import Parsing.TreeSitter (Timeout (..))
import Prologue
import Semantic.Env
import Semantic.Telemetry
import qualified Semantic.Telemetry.Haystack as Haystack
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
{ 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
, 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).
, 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.
}
data StatsAddr = StatsAddr { addrHost :: String, addrPort :: String }
-- 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)
}
defaultConfig :: IO Config
defaultConfig = do
defaultOptions :: Options
defaultOptions = Options (Just Warning) Nothing False
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
(statsHost, statsPort) <- 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
, configProcessID = pid
, configHaystackURL = haystackURL
, configStatsAddr = statsAddr
, configLogOptions = logOptions
, configStatsHost = statsHost
, configStatsPort = statsPort
, configTreeSitterParseTimeout = Milliseconds parseTimeout
, configMaxTelemetyQueueSize = size
, configIsTerminal = isTerminal
, configLogPrintSource = isTerminal
, configLogFormatter = if isTerminal then terminalFormatter else logfmtFormatter
, configOptions = options
}
defaultHaystackClient :: IO HaystackClient
defaultHaystackClient = defaultConfig >>= haystackClientFromConfig
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)
haystackClientFromConfig :: Config -> IO HaystackClient
haystackClientFromConfig Config{..} = haystackClient configHaystackURL tlsManagerSettings configHostName configAppName
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) ]
}
defaultStatsClient :: IO StatsClient
defaultStatsClient = defaultConfig >>= statsClientFromConfig
withHaystackFromConfig :: Config -> Haystack.ErrorLogger -> (HaystackQueue -> IO c) -> IO c
withHaystackFromConfig Config{..} errorLogger =
withHaystack configHaystackURL tlsManagerSettings configAppName errorLogger configMaxTelemetyQueueSize
statsClientFromConfig :: Config -> IO StatsClient
statsClientFromConfig Config{..} = statsClient (addrHost configStatsAddr) (addrPort configStatsAddr) configAppName
withStatterFromConfig :: Config -> (StatQueue -> IO c) -> IO c
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)
@ -61,7 +107,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"

2
src/Semantic/Diff.hs
View File

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

2
src/Semantic/Graph.hs
View File

@ -164,7 +164,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)

117
src/Semantic/Log.hs
View File

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

72
src/Semantic/Task.hs
View File

@ -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,23 +70,20 @@ 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.Resolution
import Semantic.Log
import Semantic.Queue
import Semantic.Stat as Stat
import Semantic.Telemetry
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
, Task
, Resolution
, IO.Files
, Reader Options
, Reader Config
, Trace
, Telemetry
, Exc SomeException
@ -131,21 +127,15 @@ runTask = runTaskWithOptions defaultOptions
-- | Execute a 'TaskEff' with the passed 'Options', 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
result <- runTaskWithOptions' options logger statter task
closeQueue statter
closeStatClient (asyncQueueExtra statter)
closeQueue logger
runTaskWithOptions opts task = do
config <- defaultConfig opts
result <- withTelemetry config $ \(TelemetryQueues logger statter _) ->
runTaskWithConfig config logger statter task
either (die . displayException) pure result
runTaskWithOptions' :: Options -> LogQueue -> AsyncQueue Stat StatsClient -> TaskEff a -> IO (Either SomeException a)
runTaskWithOptions' options logger statter task = do
-- | 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
let run :: TaskEff a -> IO (Either SomeException a)
run = runM . runError
@ -157,7 +147,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 +164,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,51 +172,49 @@ 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)
instance Exception ParserCancelled
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 $
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
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)
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)
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)
logError options Warning blob err (("task", "parse") : blobFields)
writeStat (increment "parse.parse_errors" languageTag)
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)
writeStat (Stat.count "parse.nodes" (length term) languageTag)
writeStat (increment "parse.assign_warnings" languageTag)
logError config Warning blob err (("task", "assign") : blobFields)
when (optionsFailOnWarning (configOptions config)) $ throwError (toException err)
writeStat (count "parse.nodes" (length term) languageTag)
pure term
MarkdownParser ->
time "parse.cmark_parse" languageTag $

115
src/Semantic/Telemetry.hs
View File

@ -1,6 +1,45 @@
{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
module Semantic.Telemetry
( writeLog
(
-- Async telemetry interface
withLogger
, withHaystack
, withStatter
, LogQueue
, StatQueue
, HaystackQueue
, TelemetryQueues(..)
, queueLogMessage
, queueErrorReport
, queueStat
-- Create stats
, Stat.increment
, Stat.decrement
, Stat.count
, Stat.gauge
, Stat.timing
, 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 for telemetry
, writeLog
, writeStat
, time
, Telemetry
@ -8,11 +47,71 @@ module Semantic.Telemetry
, ignoreTelemetry
) where
import Control.Monad.Effect
import Control.Monad.IO.Class
import Semantic.Log
import Semantic.Queue
import Semantic.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
| Just logLevel <- logOptionsLevel 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 +134,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.

43
src/Semantic/Queue.hs → src/Semantic/Telemetry/AsyncQueue.hs
View File

@ -1,10 +1,10 @@
module Semantic.Queue
module Semantic.Telemetry.AsyncQueue
(
AsyncQueue(..)
, newQueue
, newQueue'
, queue
, closeQueue
, newAsyncQueue
, newAsyncQueue'
, writeAsyncQueue
, closeAsyncQueue
)
where
@ -20,36 +20,35 @@ 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

35
src/Semantic/Haystack.hs → src/Semantic/Telemetry/Haystack.hs
View File

@ -1,7 +1,6 @@
module Semantic.Haystack where
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
@ -10,8 +9,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
@ -24,18 +21,16 @@ data HaystackClient
= HaystackClient
{ haystackClientRequest :: Request
, haystackClientManager :: Manager
, haystackClientHostName :: String
, 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.
-- 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
-- | Function to log if there are errors reporting to haystack.
type ErrorLogger = String -> [(String, String)] -> IO ()
-- 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
@ -43,20 +38,18 @@ 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).
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 sha logger HaystackClient{..} ErrorReport{..} = do
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
let summary = takeWhile (/= '\n') fullMsg
queueLogMessage logger Error summary errorReportContext
logger summary errorReportContext
let payload = object $
[ "app" .= haystackClientAppName
, "host" .= haystackClientHostName
, "sha" .= sha
, "message" .= summary
, "class" .= summary
, "backtrace" .= fullMsg
@ -64,13 +57,13 @@ reportError sha 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 -> 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

78
src/Semantic/Telemetry/Log.hs Normal file
View File

@ -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
{ 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 . logOptionsFormatter 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 <> logOptionsContext)))
. 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 <> logOptionsContext)
. 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"

47
src/Semantic/Stat.hs → src/Semantic/Telemetry/Stat.hs
View File

@ -1,4 +1,4 @@
module Semantic.Stat
module Semantic.Telemetry.Stat
(
-- Primary API for creating stats.
increment
@ -10,9 +10,12 @@ module Semantic.Stat
, histogram
, set
, Stat
, Tags
, Host
, Port
, Namespace
-- Client
, defaultStatsClient
, statsClient
, StatsClient(..)
, closeStatClient
@ -32,10 +35,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.
@ -101,43 +102,21 @@ data StatsClient
= StatsClient
{ statsClientUDPSocket :: Socket
, statsClientNamespace :: String
, statsClientUDPHost :: String
, statsClientUDPPort :: String
, statsClientUDPHost :: Host
, statsClientUDPPort :: Port
}
-- | 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
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 ()

15
src/Semantic/Version.hs Normal file
View File

@ -0,0 +1,15 @@
{-# OPTIONS_GHC -fforce-recomp #-} -- So that gitHash is correct.
{-# LANGUAGE TemplateHaskell #-}
module Semantic.Version where
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 version

2
test/Analysis/TypeScript/Spec.hs
View File

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

1
test/Control/Abstract/Evaluator/Spec.hs
View File

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

7
test/Semantic/Stat/Spec.hs
View File

@ -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 driven by defaultConfig.
defaultStatsClient :: IO StatsClient
defaultStatsClient = defaultConfig defaultOptions >>= \Config{..} -> statsClient configStatsHost configStatsPort configAppName

1
test/SpecHelpers.hs
View File

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

1
vendor/semilattices vendored Submodule

@ -0,0 +1 @@
Subproject commit cad77016f533f9078c6e42aea33405ec7900497c