Merge branch 'master' into no-really-php-namespaces

.gitmodules

@@ -13,18 +13,9 @@
 [submodule "vendor/effects"]
 	path = vendor/effects
 	url = https://github.com/joshvera/effects.git
-[submodule "languages/c/vendor/tree-sitter-c"]
-	path = languages/c/vendor/tree-sitter-c
-	url = https://github.com/tree-sitter/tree-sitter-c.git
-[submodule "languages/javascript/vendor/tree-sitter-javascript"]
-	path = languages/javascript/vendor/tree-sitter-javascript
-	url = https://github.com/tree-sitter/tree-sitter-javascript.git
 [submodule "vendor/haskell-tree-sitter"]
 	path = vendor/haskell-tree-sitter
 	url = https://github.com/tree-sitter/haskell-tree-sitter.git
 [submodule "vendor/freer-cofreer"]
 	path = vendor/freer-cofreer
 	url = https://github.com/robrix/freer-cofreer.git
-[submodule "vendor/ghc-mod"]
-	path = vendor/ghc-mod
-	url = https://github.com/joshvera/ghc-mod

.stylish-haskell.yaml

@@ -225,6 +225,8 @@ language_extensions:
   - FlexibleContexts
   - FlexibleInstances
   - MultiParamTypeClasses
+  - StandaloneDeriving
+  - DataKinds
   - OverloadedStrings
   - RecordWildCards
   - StrictData

semantic.cabal

@@ -182,14 +182,17 @@ library
                      , tree-sitter-ruby
                      , tree-sitter-typescript
   default-language:    Haskell2010
-  default-extensions:  DeriveFoldable
+  default-extensions:  DataKinds
+                     , DeriveFoldable
                      , DeriveFunctor
                      , DeriveGeneric
                      , DeriveTraversable
                      , FlexibleContexts
                      , FlexibleInstances
+                     , MultiParamTypeClasses
                      , OverloadedStrings
                      , RecordWildCards
+                     , StandaloneDeriving
                      , StrictData
   ghc-options:         -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -O -j
   ghc-prof-options:    -fprof-auto
@@ -258,7 +261,15 @@ test-suite test
                      , these
   ghc-options:       -threaded -rtsopts -with-rtsopts=-N -j
   default-language:    Haskell2010
-  default-extensions:  DeriveFunctor, DeriveGeneric, FlexibleContexts, FlexibleInstances, OverloadedStrings, RecordWildCards
+  default-extensions:  DataKinds
+                     , DeriveFunctor
+                     , DeriveGeneric
+                     , FlexibleContexts
+                     , FlexibleInstances
+                     , MultiParamTypeClasses
+                     , OverloadedStrings
+                     , RecordWildCards
+                     , StandaloneDeriving
 
 test-suite doctests
   type:                exitcode-stdio-1.0

src/Analysis/Abstract/Caching.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.Abstract.Caching
 ( type Caching
 ) where
@@ -13,7 +13,7 @@ import Prologue
 -- | The effects necessary for caching analyses.
 type CachingEffects term value effects
   = Fresh                        -- For 'MonadFresh'.
- ': NonDetEff                    -- For 'Alternative' and 'MonadNonDet'.
+ ': NonDet                       -- For 'Alternative' and 'MonadNonDet'.
  ': Reader (CacheFor term value) -- The in-cache used as an oracle while converging on a result.
  ': State  (CacheFor term value) -- The out-cache used to record results in each iteration of convergence.
  ': effects

src/Analysis/Abstract/Collecting.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.Abstract.Collecting
 ( type Collecting
 ) where

src/Analysis/Abstract/Dead.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-}
 module Analysis.Abstract.Dead
 ( type DeadCode
 ) where

src/Analysis/Abstract/Evaluating.hs

@@ -9,9 +9,7 @@ module Analysis.Abstract.Evaluating
 
 import Control.Abstract.Evaluator
 import Control.Monad.Effect
-import Control.Monad.Effect.Fail
+import Control.Monad.Effect.Resumable
-import Control.Monad.Effect.Reader
-import Control.Monad.Effect.State
 import Data.Abstract.Configuration
 import qualified Data.Abstract.Environment as Env
 import Data.Abstract.Environment (Environment)
@@ -25,7 +23,7 @@ import qualified Data.IntMap as IntMap
 import Data.Language
 import Data.List.Split (splitWhen)
 import Prelude hiding (fail)
-import Prologue
+import Prologue hiding (throwError)
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.Map as Map
 import System.FilePath.Posix
@@ -118,12 +116,13 @@ newtype Evaluating term value effects a = Evaluating (Eff effects a)
 
 deriving instance Member Fail      effects => MonadFail   (Evaluating term value effects)
 deriving instance Member Fresh     effects => MonadFresh  (Evaluating term value effects)
-deriving instance Member NonDetEff effects => Alternative (Evaluating term value effects)
+deriving instance Member NonDet    effects => Alternative (Evaluating term value effects)
-deriving instance Member NonDetEff effects => MonadNonDet (Evaluating term value effects)
+deriving instance Member NonDet    effects => MonadNonDet (Evaluating term value effects)
 
 -- | Effects necessary for evaluating (whether concrete or abstract).
 type EvaluatingEffects term value
-  = '[ Fail                                        -- Failure with an error message
+  = '[ Resumable Prelude.String value
+     , Fail                                        -- Failure with an error message
      , State  (EnvironmentFor value)               -- Environments (both local and global)
      , State  (HeapFor value)                      -- The heap
      , Reader (ModuleTable [term])                 -- Cache of unevaluated modules
@@ -132,6 +131,10 @@ type EvaluatingEffects term value
      , State  (IntMap.IntMap term)                 -- For jumps
      ]
 
+
+instance Members '[Resumable Prelude.String value] effects => MonadThrow Prelude.String value (Evaluating term value effects) where
+   throwException = raise . throwError
+
 instance Members '[Fail, State (IntMap.IntMap term)] effects => MonadControl term (Evaluating term value effects) where
   label term = do
     m <- raise get
@@ -180,4 +183,4 @@ instance ( Evaluatable (Base term)
          => MonadAnalysis term value (Evaluating term value effects) where
   type RequiredEffects term value (Evaluating term value effects) = EvaluatingEffects term value
 
-  analyzeTerm = eval
+  analyzeTerm term = resumeException @value (eval term) (\yield exc -> string (BC.pack exc) >>= yield)

src/Analysis/Abstract/Tracing.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.Abstract.Tracing
 ( type Tracing
 ) where

src/Analysis/ConstructorName.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.ConstructorName
 ( ConstructorName(..)
 , ConstructorLabel(..)

src/Analysis/Declaration.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, MultiParamTypeClasses, TypeOperators, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
+{-# LANGUAGE TypeOperators, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
 module Analysis.Declaration
 ( Declaration(..)
 , HasDeclaration

src/Analysis/IdentifierName.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.IdentifierName
 ( IdentifierName(..)
 , IdentifierLabel(..)
@@ -8,10 +8,10 @@ module Analysis.IdentifierName
 import           Data.Abstract.FreeVariables
 import           Data.Aeson
 import           Data.JSON.Fields
+import qualified Data.Syntax
 import           Data.Term
 import           Data.Text.Encoding (decodeUtf8)
 import           Prologue
-import qualified Data.Syntax
 
 -- | Compute a 'IdentifierLabel' label for a 'Term'.
 identifierLabel :: IdentifierName syntax => TermF syntax a b -> Maybe IdentifierLabel

src/Analysis/ModuleDef.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
 module Analysis.ModuleDef
 ( ModuleDef(..)
 , HasModuleDef

src/Control/Abstract/Analysis.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, MultiParamTypeClasses, TypeFamilies #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For runAnalysis
 module Control.Abstract.Analysis
 ( MonadAnalysis(..)

src/Control/Abstract/Evaluator.hs

@@ -13,6 +13,7 @@ module Control.Abstract.Evaluator
   , MonadModuleTable(..)
   , modifyModuleTable
   , MonadControl(..)
+  , MonadThrow(..)
 ) where
 
 import Data.Abstract.Address
@@ -147,3 +148,6 @@ class Monad m => MonadControl term m where
   label :: term -> m Label
   -- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated in e.g. a 'MonadAnalysis' instance).
   goto :: Label -> m term
+
+class Monad m => MonadThrow exc v m | m -> exc where
+  throwException :: exc -> m v

src/Control/Effect.hs

@@ -1,13 +1,13 @@
-{-# LANGUAGE DataKinds, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies, TypeOperators, UndecidableInstances, ScopedTypeVariables #-}
 module Control.Effect where
 
-import qualified Control.Monad.Effect as Effect
+import Control.Monad.Effect as Effect
 import Control.Monad.Effect.Fail
-import Control.Monad.Effect.Internal
+import Control.Monad.Effect.NonDet
-import Control.Monad.Effect.NonDetEff
 import Control.Monad.Effect.Reader
 import Control.Monad.Effect.State
 import Control.Monad.Effect.Writer
+import Control.Monad.Effect.Resumable
 import Data.Semigroup.Reducer
 import Prologue
 
@@ -58,12 +58,18 @@ instance Monoid w => RunEffect (Writer w) a where
   type Result (Writer w) a = (a, w)
   runEffect = runWriter
 
--- | 'NonDetEff' effects are interpreted into a nondeterministic set of result values.
+-- | 'NonDet' effects are interpreted into a nondeterministic set of result values.
-instance Ord a => RunEffect NonDetEff a where
+instance Ord a => RunEffect NonDet a where
-  type Result NonDetEff a = Set a
+  type Result NonDet a = Set a
-  runEffect = relay (pure . unit) (\ m k -> case m of
+  runEffect = runNonDet unit
-    MZero -> pure mempty
+
-    MPlus -> mappend <$> k True <*> k False)
+-- | 'Resumable' effects are interpreted into 'Either' s.t. failures are in 'Left' and successful results are in 'Right'.
+instance RunEffect (Resumable exc v) a where
+  type Result (Resumable exc v) a = Either exc a
+  runEffect = runError
+
+resumeException :: forall v m exc e a. (Effectful m, Resumable exc v :< e) => m e a -> ((v -> m e a) -> exc -> m e a) -> m e a
+resumeException m handle = raise (resumeError (lower m) (\yield -> lower . handle (raise . yield)))
 
 
 -- | Types wrapping 'Eff' actions.

src/Control/Effect/NonDet.hs

@@ -1,11 +1,11 @@
 {-# LANGUAGE TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Control.Effect.NonDet
 ( MonadNonDet(..)
-, NonDetEff
+, NonDet
 ) where
 
 import Control.Monad.Effect.Internal
-import Control.Monad.Effect.NonDetEff
+import Control.Monad.Effect.NonDet as NonDet
 import Prologue
 
 -- | 'Monad's offering local isolation of nondeterminism effects.
@@ -16,8 +16,6 @@ class (Alternative m, Monad m) => MonadNonDet m where
          -> m a      -- ^ The computation to run locally-nondeterministically.
          -> m b      -- ^ A _deterministic_ computation producing the 'Monoid'al accumulation of the _locally-nondeterministic_ result values.
 
--- | Effect stacks containing 'NonDetEff' offer a 'MonadNonDet' instance which implements 'gather' by interpreting the requests for nondeterminism locally, without removing 'NonDetEff' from the stack—i.e. the _capacity_ for nondeterminism is still present in the effect stack, but any local nondeterminism has been applied.
+-- | Effect stacks containing 'NonDet' offer a 'MonadNonDet' instance which implements 'gather' by interpreting the requests for nondeterminism locally, without removing 'NonDet' from the stack—i.e. the _capacity_ for nondeterminism is still present in the effect stack, but any local nondeterminism has been applied.
-instance (NonDetEff :< fs) => MonadNonDet (Eff fs) where
+instance (NonDet :< fs) => MonadNonDet (Eff fs) where
-  gather f = interpose (pure . f) (\ m k -> case m of
+  gather = NonDet.gather
-    MZero -> pure mempty
-    MPlus -> mappend <$> k True <*> k False)

src/Data/Abstract/Evaluatable.hs

@@ -18,7 +18,6 @@ import Data.Proxy
 import Data.Semigroup.Foldable
 import Data.Semigroup.App
 import Data.Term
-import Prelude hiding (fail)
 import Prologue
 
 
@@ -29,10 +28,11 @@ class Evaluatable constr where
           , MonadAnalysis term value m
           , MonadValue value m
           , Show (LocationFor value)
+          , MonadThrow Prelude.String value m
           )
        => SubtermAlgebra constr term (m value)
-  default eval :: (MonadFail m, Show1 constr) => SubtermAlgebra constr term (m value)
+  default eval :: (MonadThrow Prelude.String value m, Show1 constr) => SubtermAlgebra constr term (m value)
-  eval expr = fail $ "Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""
+  eval expr = throwException $ "Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""
 
 -- | If we can evaluate any syntax which can occur in a 'Union', we can evaluate the 'Union'.
 instance Apply Evaluatable fs => Evaluatable (Union fs) where

src/Data/Term.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, MultiParamTypeClasses, RankNTypes, TypeFamilies, TypeOperators #-}
+{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators #-}
 module Data.Term
 ( Term(..)
 , termIn

src/Prologue.hs

@@ -10,34 +10,23 @@ module Prologue
 import Data.Bifunctor.Join as X
 import Data.Bits as X
 import Data.ByteString as X (ByteString)
-import Data.Functor.Both as X (Both, runBothWith, both)
+import Data.Functor.Both as X (Both, both, runBothWith)
 import Data.IntMap as X (IntMap)
 import Data.IntSet as X (IntSet)
 import Data.Ix as X (Ix (..))
+import Data.List.NonEmpty as X (NonEmpty (..), nonEmpty, some1)
 import Data.Map as X (Map)
-import Data.Monoid (Alt(..))
 import Data.Maybe as X
+import Data.Monoid (Alt (..))
 import Data.Sequence as X (Seq)
 import Data.Set as X (Set)
 import Data.Text as X (Text)
 import Data.These as X
 import Data.Union as X
-import Data.List.NonEmpty as X (
-    NonEmpty(..)
-  , nonEmpty
-  , some1
-  )
 
 import Debug.Trace as X
 
-import Control.Exception as X hiding (
+import Control.Exception as X hiding (Handler (..), assert, evaluate, throw, throwIO, throwTo)
-    evaluate
-  , throw
-  , throwIO
-  , throwTo
-  , assert
-  , Handler(..)
-  )
 
 -- Typeclasses
 import Control.Applicative as X
@@ -51,23 +40,18 @@ import Data.Bifoldable as X
 import Data.Bifunctor as X (Bifunctor (..))
 import Data.Bitraversable as X
 import Data.Foldable as X hiding (product, sum)
-import Data.Functor as X (($>), void)
 import Data.Function as X (fix, on, (&))
+import Data.Functor as X (void, ($>))
 import Data.Functor.Classes as X
 import Data.Functor.Classes.Generic as X
-import Data.Functor.Foldable as X (Base, Recursive(..), Corecursive(..))
+import Data.Functor.Foldable as X (Base, Corecursive (..), Recursive (..))
+import Data.Hashable as X (Hashable, hash, hashUsing, hashWithSalt)
 import Data.Mergeable as X (Mergeable)
-import Data.Monoid as X (Monoid(..), First(..), Last(..))
+import Data.Monoid as X (First (..), Last (..), Monoid (..))
 import Data.Proxy as X (Proxy (..))
 import Data.Semigroup as X (Semigroup (..))
 import Data.Traversable as X
 import Data.Typeable as X (Typeable)
-import Data.Hashable as X (
-    Hashable
-  , hash
-  , hashWithSalt
-  , hashUsing
-  )
 
 -- Generics
 import GHC.Generics as X hiding (moduleName)

src/Rendering/Imports.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Rendering.Imports
 ( renderToImports
 , ImportSummary(..)

src/Rendering/Symbol.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Rendering.Symbol
 ( renderSymbolTerms
 , renderToSymbols

test/Analysis/Go/Spec.hs

@@ -3,6 +3,7 @@ module Analysis.Go.Spec (spec) where
 
 import Data.Abstract.Value
 import Data.Map
+import Data.Either
 
 import SpecHelpers
 

test/Analysis/Python/Spec.hs

@@ -36,11 +36,11 @@ spec = parallel $ do
 
     it "subclasses" $ do
       res <- evaluate' "subclass.py"
-      fst res `shouldBe` Right (injValue (String "\"bar\""))
+      join (fst res) `shouldBe` Right (injValue (String "\"bar\""))
 
     it "handles multiple inheritance left-to-right" $ do
       res <- evaluate' "multiple_inheritance.py"
-      fst res `shouldBe` Right (injValue (String "\"foo!\""))
+      join (fst res) `shouldBe` Right (injValue (String "\"foo!\""))
 
   where
     addr = Address . Precise

test/Analysis/Ruby/Spec.hs

@@ -28,7 +28,7 @@ spec = parallel $ do
 
     it "subclass" $ do
       res <- evaluate' "subclass.rb"
-      fst res `shouldBe` Right (injValue (String "\"<bar>\""))
+      join (fst res) `shouldBe` Right (injValue (String "\"<bar>\""))
 
   where
     addr = Address . Precise

test/Data/Functor/Listable.hs

@@ -156,7 +156,7 @@ instance Listable1 f => Listable2 (FreeF f) where
 instance (Listable1 f, Listable a) => Listable1 (FreeF f a) where
   liftTiers = liftTiers2 tiers
 
-instance (Functor f, Listable1 f) => Listable1 (Free.Free f) where
+instance Listable1 f => Listable1 (Free.Free f) where
   liftTiers pureTiers = go
     where go = liftCons1 (liftTiers2 pureTiers go) free
           free (FreeF.Free f) = Free.Free f

test/Doctests.hs

@@ -12,13 +12,16 @@ main = do
 
 extensions :: [String]
 extensions =
-  [ "DeriveFoldable"
+  [ "DataKinds"
+  , "DeriveFoldable"
   , "DeriveFunctor"
   , "DeriveGeneric"
   , "DeriveTraversable"
   , "FlexibleContexts"
   , "FlexibleInstances"
+  , "MultiParamTypeClasses"
   , "OverloadedStrings"
   , "RecordWildCards"
+  , "StandaloneDeriving"
   , "StrictData"
   ]

test/SpecHelpers.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, GADTs, ScopedTypeVariables, TypeFamilies, TypeOperators, TypeApplications #-}
+{-# LANGUAGE GADTs, ScopedTypeVariables, TypeFamilies, TypeOperators, TypeApplications #-}
 module SpecHelpers (
   module X
 , diffFilePaths
@@ -34,6 +34,7 @@ import Data.Functor.Both as X (Both, runBothWith, both)
 import Data.Maybe as X
 import Data.Monoid as X (Monoid(..), First(..), Last(..))
 import Data.Semigroup as X (Semigroup(..))
+import Control.Monad as X
 
 import Test.Hspec as X (Spec, SpecWith, context, describe, it, xit, parallel, pendingWith, around, runIO)
 import Test.Hspec.Expectations.Pretty as X

vendor/effects

@@ -1 +1 @@
-Subproject commit 6aaaa39f18f38628a91d3ffd155c7f4099131d9e
+Subproject commit 7d4525db7b6a12c0a34da5f70a97db137c144c60

vendor/ghc-mod

@@ -1 +0,0 @@
-Subproject commit 7fb380dae0ae877a24ac8258fcd193cd6256a171