Merge branch 'master' into telemetry-and-config

.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

@@ -86,7 +86,6 @@ library
                      , Data.Range
                      , Data.Record
                      , Data.Semigroup.App
-                     , Data.Semilattice.Lower
                      , Data.Scientific.Exts
                      , Data.Source
                      , Data.Span
@@ -212,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
@@ -321,6 +321,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/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/Graph.hs

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

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