github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-29 01:42:43 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into grpc-trees

Browse Source
This commit is contained in:
Timothy Clem 2018-06-15 14:33:18 -07:00
commit 92c1394098
55 changed files with 501 additions and 461 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

@ -86,7 +86,6 @@ library
, Data.Range
, Data.Record
, Data.Semigroup.App
, Data.Semilattice.Lower
, Data.Scientific.Exts
, Data.Source
, Data.Span
@ -155,16 +154,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
@ -211,16 +211,17 @@ library
, reducers
, scientific
, semigroupoids
, semilattices
, split
, stm-chans
, template-haskell
, text >= 1.2.1.3
, these
, time
, proto3-suite
, proto3-wire
, unix
, unordered-containers
, proto3-suite
, proto3-wire
, haskell-tree-sitter
, tree-sitter-go
, tree-sitter-haskell
@ -320,6 +321,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

18
src/Assigning/Assignment.hs
View File

@ -63,6 +63,9 @@ module Assigning.Assignment
( Assignment
, Location
-- Combinators
, branchNode
, leafNode
, toTerm
, Alternative(..)
, MonadError(..)
, MonadFail(..)
@ -110,6 +113,21 @@ import Data.Text.Encoding (decodeUtf8')
import Text.Parser.Combinators as Parsers hiding (choice)
import TreeSitter.Language
-- | Match a branch node, matching its children with the supplied 'Assignment' & returning the result.
branchNode :: (Enum grammar, Ix grammar) => grammar -> Assignment ast grammar a -> Assignment ast grammar a
branchNode sym child = symbol sym *> children child
-- | Match a leaf node, returning the corresponding 'Text'.
leafNode :: (Enum grammar, Ix grammar) => grammar -> Assignment ast grammar Text
leafNode sym = symbol sym *> source
-- | Wrap an 'Assignment' producing @syntax@ up into an 'Assignment' producing 'Term's.
toTerm :: Element syntax syntaxes
=> Assignment ast grammar (syntax (Term (Sum syntaxes) (Record Location)))
-> Assignment ast grammar (Term (Sum syntaxes) (Record Location))
toTerm syntax = termIn <$> location <*> (inject <$> syntax)
-- | Assignment from an AST with some set of 'symbol's onto some other value.
--
-- This is essentially a parser.

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

12
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
@ -73,9 +71,6 @@ class Show value => AbstractIntro value where
-- | Construct a rational value.
rational :: Rational -> value
-- | Construct an N-ary tuple of multiple (possibly-disjoint) values
multiple :: [value] -> value
-- | Construct a key-value pair for use in a hash.
kvPair :: value -> value -> value
@ -114,8 +109,11 @@ class (AbstractFunction address value effects, AbstractIntro value) => AbstractV
liftBitwise2 :: (forall a . (Integral a, Bits a) => a -> a -> a)
-> (value -> value -> Evaluator address value effects value)
-- | Construct an N-ary tuple of multiple (possibly-disjoint) values
tuple :: [address] -> Evaluator address value effects value
-- | Construct an array of zero or more values.
array :: [value] -> Evaluator address value effects value
array :: [address] -> Evaluator address value effects value
-- | Extract the contents of a key-value pair as a tuple.
asPair :: value -> Evaluator address value effects (value, value)
@ -127,7 +125,7 @@ class (AbstractFunction address value effects, AbstractIntro value) => AbstractV
ifthenelse :: value -> Evaluator address value effects a -> Evaluator address value effects a -> Evaluator address value effects a
-- | @index x i@ computes @x[i]@, with zero-indexing.
index :: value -> value -> Evaluator address value effects value
index :: value -> value -> Evaluator address value effects address
-- | Build a class value from a name and environment.
klass :: Name -- ^ The new class's identifier

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

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

@ -108,7 +108,6 @@ instance AbstractIntro Type where
float _ = Float
symbol _ = Symbol
rational _ = Rational
multiple = zeroOrMoreProduct
hash = Hash
kvPair k v = k :* v
@ -127,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
@ -151,12 +150,15 @@ instance ( Member (Allocator address Type) effects
=> AbstractValue address Type effects where
array fields = do
var <- fresh
Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fields
fieldTypes <- traverse deref fields
Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes
tuple fields = zeroOrMoreProduct <$> traverse deref fields
klass _ _ _ = pure Object
namespace _ _ = pure Unit
scopedEnvironment _ = pure (Just emptyEnv)
scopedEnvironment _ = pure (Just lowerBound)
asString t = unify t String $> ""
asPair t = do
@ -167,7 +169,8 @@ instance ( Member (Allocator address Type) effects
index arr sub = do
_ <- unify sub Int
field <- fresh
Var field <$ unify (Array (Var field)) arr
_ <- unify (Array (Var field)) arr
box (Var field)
ifthenelse cond if' else' = unify cond Bool *> (if' <|> else')

21
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
@ -22,8 +22,8 @@ data Value address body
| Float (Number.Number Scientific)
| String Text
| Symbol Text
| Tuple [Value address body]
| Array [Value address body]
| Tuple [address]
| Array [address]
| Class Name (Environment address)
| Namespace Name (Environment address)
| KVPair (Value address body) (Value address body)
@ -92,8 +92,6 @@ instance Show address => AbstractIntro (Value address body) where
symbol = Symbol
rational = Rational . Number.Ratio
multiple = Tuple
kvPair = KVPair
hash = Hash . map (uncurry KVPair)
@ -117,16 +115,17 @@ instance ( Coercible body (Eff effects)
| KVPair k v <- val = pure (k, v)
| otherwise = throwValueError $ KeyValueError val
array = pure . Array
tuple = pure . Tuple
array = pure . Array
klass n [] env = pure $ Class n env
klass n supers env = do
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'
@ -147,12 +146,12 @@ instance ( Coercible body (Eff effects)
index = go where
tryIdx list ii
| ii > genericLength list = throwValueError (BoundsError list ii)
| ii > genericLength list = box =<< throwValueError (BoundsError list ii)
| otherwise = pure (genericIndex list ii)
go arr idx
| (Array arr, Integer (Number.Integer i)) <- (arr, idx) = tryIdx arr i
| (Tuple tup, Integer (Number.Integer i)) <- (arr, idx) = tryIdx tup i
| otherwise = throwValueError (IndexError arr idx)
| otherwise = box =<< throwValueError (IndexError arr idx)
liftNumeric f arg
| Integer (Number.Integer i) <- arg = pure . integer $ f i
@ -237,7 +236,7 @@ data ValueError address body resume where
-- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching.
ArithmeticError :: ArithException -> ValueError address body (Value address body)
-- Out-of-bounds error
BoundsError :: [Value address body] -> Prelude.Integer -> ValueError address body (Value address body)
BoundsError :: [address] -> Prelude.Integer -> ValueError address body (Value address body)
instance Eq address => Eq1 (ValueError address body) where

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

68
src/Data/Syntax.hs
View File

@ -27,81 +27,81 @@ import Data.Char (toLower)
-- Combinators
-- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children.
makeTerm :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => a -> f (Term (Sum fs) a) -> Term (Sum fs) a
makeTerm a = makeTerm' a . inject
makeTerm :: (HasCallStack, Element syntax syntaxes, Semigroup ann, Apply Foldable syntaxes) => ann -> syntax (Term (Sum syntaxes) ann) -> Term (Sum syntaxes) ann
makeTerm ann = makeTerm' ann . inject
-- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children.
makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a
makeTerm' a f = termIn (sconcat (a :| (termAnnotation <$> toList f))) f
makeTerm' :: (HasCallStack, Semigroup ann, Foldable syntax) => ann -> syntax (Term syntax ann) -> Term syntax ann
makeTerm' ann syntax = termIn (sconcat (ann :| (termAnnotation <$> toList syntax))) syntax
-- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children. Removes extra structure if term is a list of a single item.
makeTerm'' :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs, Foldable f) => a -> f (Term (Sum fs) a) -> Term (Sum fs) a
makeTerm'' a children = case toList children of
makeTerm'' :: (HasCallStack, Element syntax syntaxes, Semigroup ann, Apply Foldable syntaxes, Foldable syntax) => ann -> syntax (Term (Sum syntaxes) ann) -> Term (Sum syntaxes) ann
makeTerm'' ann children = case toList children of
[x] -> x
_ -> makeTerm' a (inject children)
_ -> makeTerm' ann (inject children)
-- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation.
makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => f (Term (Sum fs) a) -> Term (Sum fs) a
makeTerm1 :: (HasCallStack, Element syntax syntaxes, Semigroup ann, Apply Foldable syntaxes) => syntax (Term (Sum syntaxes) ann) -> Term (Sum syntaxes) ann
makeTerm1 = makeTerm1' . inject
-- | Lift a non-empty union into a term, appending all subterms’.annotations to make the new term’s annotation.
makeTerm1' :: (HasCallStack, Semigroup a, Foldable f) => f (Term f a) -> Term f a
makeTerm1' f = case toList f of
a : _ -> makeTerm' (termAnnotation a) f
-- | Lift a non-empty union into a term, appending all subterms’ annotations to make the new term’s annotation.
makeTerm1' :: (HasCallStack, Semigroup ann, Foldable syntax) => syntax (Term syntax ann) -> Term syntax ann
makeTerm1' syntax = case toList syntax of
a : _ -> makeTerm' (termAnnotation a) syntax
_ -> error "makeTerm1': empty structure"
-- | Construct an empty term at the current position.
emptyTerm :: (HasCallStack, Empty :< fs, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Sum fs) (Record Location))
emptyTerm :: (HasCallStack, Empty :< syntaxes, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location))
emptyTerm = makeTerm . startLocation <$> Assignment.location <*> pure Empty
where startLocation ann = Range (start (getField ann)) (start (getField ann)) :. Span (spanStart (getField ann)) (spanStart (getField ann)) :. Nil
-- | Catch assignment errors into an error term.
handleError :: (HasCallStack, Error :< fs, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Sum fs) (Record Location)) -> Assignment.Assignment ast grammar (Term (Sum fs) (Record Location))
handleError :: (HasCallStack, Error :< syntaxes, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location)) -> Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location))
handleError = flip catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source)
-- | Catch parse errors into an error term.
parseError :: (HasCallStack, Error :< fs, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Sum fs) (Record Location))
parseError :: (HasCallStack, Error :< syntaxes, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location))
parseError = makeTerm <$> Assignment.token maxBound <*> pure (Error (ErrorStack $ errorSite <$> getCallStack (freezeCallStack callStack)) [] (Just "ParseError") [])
-- | Match context terms before a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.
contextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
=> m (Term (Sum fs) a)
-> m (Term (Sum fs) a)
-> m (Term (Sum fs) a)
contextualize :: (HasCallStack, Context :< syntaxes, Alternative m, Semigroup ann, Apply Foldable syntaxes)
=> m (Term (Sum syntaxes) ann)
-> m (Term (Sum syntaxes) ann)
-> m (Term (Sum syntaxes) ann)
contextualize context rule = make <$> Assignment.manyThrough context rule
where make (cs, node) = case nonEmpty cs of
Just cs -> makeTerm1 (Context cs node)
_ -> node
-- | Match context terms after a subject term and before a delimiter, returning the delimiter paired with a Context term if any context terms matched, or the subject term otherwise.
postContextualizeThrough :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
=> m (Term (Sum fs) a)
-> m (Term (Sum fs) a)
-> m b
-> m (Term (Sum fs) a, b)
postContextualizeThrough :: (HasCallStack, Context :< syntaxes, Alternative m, Semigroup ann, Apply Foldable syntaxes)
=> m (Term (Sum syntaxes) ann)
-> m (Term (Sum syntaxes) ann)
-> m delimiter
-> m (Term (Sum syntaxes) ann, delimiter)
postContextualizeThrough context rule end = make <$> rule <*> Assignment.manyThrough context end
where make node (cs, end) = case nonEmpty cs of
Just cs -> (makeTerm1 (Context cs node), end)
_ -> (node, end)
-- | Match context terms after a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.
postContextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
=> m (Term (Sum fs) a)
-> m (Term (Sum fs) a)
-> m (Term (Sum fs) a)
postContextualize :: (HasCallStack, Context :< syntaxes, Alternative m, Semigroup ann, Apply Foldable syntaxes)
=> m (Term (Sum syntaxes) ann)
-> m (Term (Sum syntaxes) ann)
-> m (Term (Sum syntaxes) ann)
postContextualize context rule = make <$> rule <*> many context
where make node cs = case nonEmpty cs of
Just cs -> makeTerm1 (Context cs node)
_ -> node
-- | Match infix terms separated by any of a list of operators, with optional context terms following each operand.
infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack, Apply Foldable fs)
=> m (Term (Sum fs) a)
-> m (Term (Sum fs) a)
-> m (Term (Sum fs) a)
-> [m (Term (Sum fs) a -> Term (Sum fs) a -> Sum fs (Term (Sum fs) a))]
-> m (Sum fs (Term (Sum fs) a))
infixContext :: (Context :< syntaxes, Assignment.Parsing m, Semigroup ann, HasCallStack, Apply Foldable syntaxes)
=> m (Term (Sum syntaxes) ann)
-> m (Term (Sum syntaxes) ann)
-> m (Term (Sum syntaxes) ann)
-> [m (Term (Sum syntaxes) ann -> Term (Sum syntaxes) ann -> Sum syntaxes (Term (Sum syntaxes) ann))]
-> m (Sum syntaxes (Term (Sum syntaxes) ann))
infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right
instance (Apply Message1 fs, Generate Message1 fs fs, Generate Named1 fs fs) => Message1 (Sum fs) where

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

@ -101,7 +101,7 @@ instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable VariableDeclaration where
eval (VariableDeclaration []) = rvalBox unit
eval (VariableDeclaration decs) = rvalBox =<< (multiple <$> traverse subtermValue decs)
eval (VariableDeclaration decs) = rvalBox =<< tuple =<< traverse subtermAddress decs
instance Declarations a => Declarations (VariableDeclaration a) where
declaredName (VariableDeclaration vars) = case vars of
@ -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

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

@ -215,7 +215,7 @@ instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
-- TODO: Finish Eval instance for Subscript
-- TODO return a special LvalSubscript instance here
instance Evaluatable Subscript where
eval (Subscript l [r]) = rvalBox =<< join (index <$> subtermValue l <*> subtermValue r)
eval (Subscript l [r]) = Rval <$> join (index <$> subtermValue l <*> subtermValue r)
eval (Subscript _ _) = rvalBox =<< throwResumable (Unspecialized "Eval unspecialized for subscript with slices")
eval (Member _ _) = rvalBox =<< throwResumable (Unspecialized "Eval unspecialized for member access")

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

@ -169,7 +169,7 @@ instance Ord1 Array where liftCompare = genericLiftCompare
instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Array where
eval (Array a) = rvalBox =<< (array =<< traverse subtermValue a)
eval (Array a) = rvalBox =<< array =<< traverse subtermAddress a
newtype Hash a = Hash { hashElements :: [a] }
deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1)
@ -200,7 +200,7 @@ instance Ord1 Tuple where liftCompare = genericLiftCompare
instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Tuple where
eval (Tuple cs) = rvalBox =<< (multiple <$> traverse subtermValue cs)
eval (Tuple cs) = rvalBox =<< tuple =<< traverse subtermAddress cs
newtype Set a = Set { setElements :: [a] }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)

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

10
src/Language/Java/Assignment.hs
View File

@ -103,7 +103,7 @@ type Syntax =
]
type Term = Term.Term (Sum Syntax) (Record Location)
type Assignment = HasCallStack => Assignment.Assignment [] Grammar Term
type Assignment = Assignment.Assignment [] Grammar Term
-- | Assignment from AST in Java's grammar onto a program in Java's syntax.
assignment :: Assignment
@ -215,9 +215,9 @@ variableDeclaratorId = symbol VariableDeclaratorId *> children identifier
-- Literals
boolean :: Assignment
boolean = makeTerm <$> symbol BooleanLiteral <*> children
(token Grammar.True $> Literal.true
<|> token Grammar.False $> Literal.false)
boolean = toTerm (branchNode BooleanLiteral
( leafNode Grammar.True $> Literal.true
<|> leafNode Grammar.False $> Literal.false))
null' :: Assignment
null' = makeTerm <$> symbol NullLiteral <*> (Literal.Null <$ source)
@ -288,7 +288,7 @@ explicitConstructorInvocation = makeTerm <$> symbol ExplicitConstructorInvocatio
callFunction a Nothing = ([], a)
module' :: Assignment
module' = makeTerm <$> symbol ModuleDeclaration <*> children (Java.Syntax.Module <$> expression <*> many expression)
module' = toTerm (branchNode ModuleDeclaration (Java.Syntax.Module <$> expression <*> many expression))
import' :: Assignment
import' = makeTerm <$> symbol ImportDeclaration <*> children (Java.Syntax.Import <$> someTerm (expression <|> asterisk))

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

@ -162,7 +162,7 @@ resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err
NumericError{} -> pure hole
Numeric2Error{} -> pure hole
ComparisonError{} -> pure hole
NamespaceError{} -> pure emptyEnv
NamespaceError{} -> pure lowerBound
BitwiseError{} -> pure hole
Bitwise2Error{} -> pure hole
KeyValueError{} -> pure (hole, hole)

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