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

.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

semantic.cabal

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

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.

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.

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
 

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

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.

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
 

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

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
 

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.

src/Data/Abstract/Environment.hs

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

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

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)
 

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.

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
 

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

src/Data/Abstract/Type.hs

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

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

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.

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)
 

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.

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.

src/Data/Semilattice/Lower.hs

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

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
 

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

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

src/Language/Go/Syntax.hs

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

src/Language/PHP/Syntax.hs

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

src/Language/Python/Syntax.hs

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

src/Language/Ruby/Syntax.hs

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

src/Language/TypeScript/Syntax.hs

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

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)

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

src/Semantic/Config.hs

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

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
 

src/Semantic/Graph.hs

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

src/Semantic/Log.hs

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

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,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 $

src/Semantic/Telemetry.hs

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

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

src/Semantic/Telemetry/Haystack.hs

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

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
+  { 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"

src/Semantic/Telemetry/Stat.hs

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

src/Semantic/Version.hs

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

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"

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)
 

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

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

vendor/semilattices

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