Merge remote-tracking branch 'origin/master' into java-assignment

.ghci

@@ -27,7 +27,7 @@ assignmentExample lang = case lang of
   "Java" -> mk "java" "java"
   "PHP" -> mk "php" "php"
   _ -> mk "" ""
-  where mk fileExtension parser = putStrLn ("example: fmap (() <$) . runTask . parse " ++ parser ++ "Parser =<< Semantic.Util.file \"example." ++ fileExtension ++ "\"") >> return ("import Parsing.Parser\nimport Semantic.Task\nimport Semantic.Util")
+  where mk fileExtension parser = putStrLn ("example: fmap (() <$) . runTask . parse " ++ parser ++ "Parser =<< Semantic.Util.blob \"example." ++ fileExtension ++ "\"") >> return ("import Parsing.Parser\nimport Semantic.Task\nimport Semantic.Util")
 :}
 :undef assignment
 :def assignment assignmentExample

.gitignore

@@ -10,14 +10,16 @@ dist-newstyle
 .ghc.environment.*
 
 tmp/
-
 bin/
 
+/test/fixtures/*/examples
+
 *.hp
 *.prof
 *.pyc
 
-test.rb
+/test.*
+/*.html
 
 .bundle/
 .licenses/vendor/gems

.gitmodules

@@ -1,12 +1,3 @@
-[submodule "test/repos/jquery"]
-	path = test/repos/jquery
-	url = https://github.com/jquery/jquery
-[submodule "test/repos/js-test"]
-	path = test/repos/js-test
-	url = https://github.com/rewinfrey/js-test.git
-[submodule "test/repos/backbone"]
-	path = test/repos/backbone
-	url = https://github.com/jashkenas/backbone
 [submodule "vendor/hspec-expectations-pretty-diff"]
 	path = vendor/hspec-expectations-pretty-diff
 	url = https://github.com/rewinfrey/hspec-expectations-pretty-diff

script/generate-example

@@ -35,17 +35,23 @@ generate_example () {
   diffFileAB="${fileA%%.*}.diffA-B.txt"
   diffFileBA="${fileB%%.*}.diffB-A.txt"
 
-  status $parseFileA
+  if [ -e "$fileA" ]; then
-  "$(dirname "$0")/run" semantic parse --sexpression $fileA > $parseFileA
+    status $parseFileA
+    "$(dirname "$0")/run" semantic parse --sexpression $fileA > $parseFileA
+  fi
 
-  status $parseFileB
+  if [ -e "$fileB" ]; then
-  "$(dirname "$0")/run" semantic parse --sexpression $fileB > $parseFileB
+    status $parseFileB
+    "$(dirname "$0")/run" semantic parse --sexpression $fileB > $parseFileB
+  fi
 
-  status $diffFileAB
+  if [ -e "$fileA" -a -e "$fileB" ]; then
-  "$(dirname "$0")/run" semantic diff --sexpression $fileA $fileB > $diffFileAB
+    status $diffFileAB
+    "$(dirname "$0")/run" semantic diff --sexpression $fileA $fileB > $diffFileAB
 
-  status $diffFileBA
+    status $diffFileBA
-  "$(dirname "$0")/run" semantic diff --sexpression $fileB $fileA > $diffFileBA
+    "$(dirname "$0")/run" semantic diff --sexpression $fileB $fileA > $diffFileBA
+  fi
 }
 
 if [[ -d $1 ]]; then

semantic.cabal

@@ -15,16 +15,19 @@ library
   hs-source-dirs:      src
   exposed-modules:
                      -- Analyses & term annotations
-                       Analysis.Abstract.BadVariables
+                       Analysis.Abstract.BadAddresses
-                       Analysis.Abstract.BadValues
+                     , Analysis.Abstract.BadSyntax
-                       Analysis.Abstract.BadModuleResolutions
+                     , Analysis.Abstract.BadModuleResolutions
+                     , Analysis.Abstract.BadVariables
+                     , Analysis.Abstract.BadValues
                      , Analysis.Abstract.Caching
                      , Analysis.Abstract.Collecting
                      , Analysis.Abstract.Dead
+                     , Analysis.Abstract.Erroring
                      , Analysis.Abstract.Evaluating
                      , Analysis.Abstract.ImportGraph
-                     , Analysis.Abstract.Quiet
                      , Analysis.Abstract.Tracing
+                     , Analysis.Abstract.TypeChecking
                      , Analysis.CallGraph
                      , Analysis.ConstructorName
                      , Analysis.CyclomaticComplexity
@@ -43,12 +46,11 @@ library
                      , Control.Abstract.Value
                      -- Control flow
                      , Control.Effect
-                     -- Effects used for program analysis
-                     , Control.Effect.Fresh
                      -- Datatypes for abstract interpretation
                      , Data.Abstract.Address
                      , Data.Abstract.Cache
                      , Data.Abstract.Configuration
+                     , Data.Abstract.Declarations
                      , Data.Abstract.Environment
                      , Data.Abstract.Evaluatable
                      , Data.Abstract.Exports
@@ -71,6 +73,7 @@ library
                      , Data.Blob
                      , Data.Diff
                      , Data.Error
+                     , Data.File
                      , Data.Functor.Both
                      , Data.Functor.Classes.Generic
                      , Data.JSON.Fields
@@ -82,6 +85,7 @@ library
                      , Data.Range
                      , Data.Record
                      , Data.Semigroup.App
+                     , Data.Semilattice.Lower
                      , Data.Scientific.Exts
                      , Data.Source
                      , Data.Span
@@ -90,6 +94,7 @@ library
                      , Data.Syntax
                      , Data.Syntax.Comment
                      , Data.Syntax.Declaration
+                     , Data.Syntax.Directive
                      , Data.Syntax.Expression
                      , Data.Syntax.Literal
                      , Data.Syntax.Statement
@@ -143,6 +148,7 @@ library
                      , Semantic.CLI
                      , Semantic.Diff
                      , Semantic.Distribute
+                     , Semantic.Graph
                      , Semantic.IO
                      , Semantic.Log
                      , Semantic.Parse
@@ -165,6 +171,7 @@ library
                      , cmark-gfm
                      , containers
                      , directory
+                     , directory-tree
                      , effects
                      , filepath
                      , free
@@ -240,6 +247,7 @@ test-suite test
                      , Analysis.Ruby.Spec
                      , Analysis.TypeScript.Spec
                      , Data.Diff.Spec
+                     , Data.Abstract.Path.Spec
                      , Data.Functor.Classes.Generic.Spec
                      , Data.Functor.Listable
                      , Data.Mergeable.Spec

src/Analysis/Abstract/BadAddresses.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
+module Analysis.Abstract.BadAddresses where
+
+import Control.Abstract.Analysis
+import Data.Abstract.Address
+import Prologue
+
+newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses { runBadAddresses :: m effects a }
+  deriving (Alternative, Applicative, Functor, Effectful, Monad)
+
+deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadAddresses m)
+deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadAddresses m)
+
+instance ( Interpreter m effects
+         , MonadEvaluator location term value effects m
+         , AbstractHole value
+         , Monoid (Cell location value)
+         , Show location
+         )
+      => Interpreter (BadAddresses m) (Resumable (AddressError location value) ': effects) where
+  type Result (BadAddresses m) (Resumable (AddressError location value) ': effects) result = Result m effects result
+  interpret
+    = interpret
+    . runBadAddresses
+    . raiseHandler (relay pure (\ (Resumable err) yield -> traceM ("AddressError:" <> show err) *> case err of
+      UnallocatedAddress _   -> yield mempty
+      UninitializedAddress _ -> yield hole))

src/Analysis/Abstract/BadModuleResolutions.hs

@@ -1,32 +1,25 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
 module Analysis.Abstract.BadModuleResolutions where
 
 import Control.Abstract.Analysis
 import Data.Abstract.Evaluatable
-import Analysis.Abstract.Evaluating
 import Prologue
 
-newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions (m effects a)
+newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions { runBadModuleResolutions :: m effects a }
-  deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
+  deriving (Alternative, Applicative, Functor, Effectful, Monad)
 
-deriving instance MonadControl term (m effects)                    => MonadControl term (BadModuleResolutions m effects)
+deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadModuleResolutions m)
-deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (BadModuleResolutions m effects)
+deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadModuleResolutions m)
-deriving instance MonadHeap location value (m effects)             => MonadHeap location value (BadModuleResolutions m effects)
-deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadModuleResolutions m effects)
-deriving instance MonadEvaluator location term value (m effects)   => MonadEvaluator location term value (BadModuleResolutions m effects)
 
-instance ( Effectful m
+instance ( Interpreter m effects
-         , Member (Resumable (ResolutionError value)) effects
+         , MonadEvaluator location term value effects m
-         , Member (State (EvaluatingState location term value)) effects
-         , Member (State [Name]) effects
-         , MonadAnalysis location term value (m effects)
-         , MonadValue location value (BadModuleResolutions m effects)
          )
-      => MonadAnalysis location term value (BadModuleResolutions m effects) where
+      => Interpreter (BadModuleResolutions m) (Resumable (ResolutionError value) ': effects) where
-  type Effects location term value (BadModuleResolutions m effects) = State [Name] ': Effects location term value (m effects)
+  type Result (BadModuleResolutions m) (Resumable (ResolutionError value) ': effects) result = Result m effects result
-
+  interpret
-  analyzeTerm eval term = resumeException @(ResolutionError value) (liftAnalyze analyzeTerm eval term) (
+    = interpret
-        \yield error -> case error of
+    . runBadModuleResolutions
-          (RubyError nameToResolve) -> yield nameToResolve)
+    . raiseHandler (relay pure (\ (Resumable err) yield -> traceM ("ResolutionError:" <> show err) *> case err of
-
+      NotFoundError nameToResolve _ _ -> yield  nameToResolve
-  analyzeModule = liftAnalyze analyzeModule
+      GoImportError pathToResolve     -> yield [pathToResolve]))

src/Analysis/Abstract/BadSyntax.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
+module Analysis.Abstract.BadSyntax
+( BadSyntax
+) where
+
+import Control.Abstract.Analysis
+import Data.Abstract.Evaluatable
+import Prologue
+
+-- | An analysis which resumes exceptions instead of failing.
+--
+--   Use it by composing it onto an analysis:
+--
+--   > interpret @(BadSyntax (Evaluating term value)) (…)
+--
+--   Note that exceptions thrown by other analyses may not be caught if 'BadSyntax' doesn’t know about them, i.e. if they’re not part of the generic 'MonadValue', 'MonadAddressable', etc. machinery.
+newtype BadSyntax m (effects :: [* -> *]) a = BadSyntax { runBadSyntax :: m effects a }
+  deriving (Alternative, Applicative, Functor, Effectful, Monad)
+
+deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadSyntax m)
+deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadSyntax m)
+
+instance ( Interpreter m effects
+         , MonadEvaluator location term value effects m
+         , AbstractHole value
+         )
+      => Interpreter (BadSyntax m) (Resumable (Unspecialized value) ': effects) where
+  type Result (BadSyntax m) (Resumable (Unspecialized value) ': effects) result = Result m effects result
+  interpret
+    = interpret
+    . runBadSyntax
+    . raiseHandler (relay pure (\ (Resumable err@(Unspecialized _)) yield -> traceM ("Unspecialized:" <> show err) *> yield hole))

src/Analysis/Abstract/BadValues.hs

@@ -1,42 +1,38 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.Abstract.BadValues where
 
 import Control.Abstract.Analysis
-import Data.Abstract.Evaluatable
+import Data.Abstract.Value (ValueError(..))
-import Analysis.Abstract.Evaluating
-import Data.Abstract.Environment as Env
-import Prologue
 import Data.ByteString.Char8 (pack)
+import Prologue
 
-newtype BadValues m (effects :: [* -> *]) a = BadValues (m effects a)
+newtype BadValues m (effects :: [* -> *]) a = BadValues { runBadValues :: m effects a }
-  deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
+  deriving (Alternative, Applicative, Functor, Effectful, Monad)
 
-deriving instance MonadControl term (m effects)                    => MonadControl term (BadValues m effects)
+deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadValues m)
-deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (BadValues m effects)
+deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadValues m)
-deriving instance MonadHeap location value (m effects)             => MonadHeap location value (BadValues m effects)
-deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadValues m effects)
-deriving instance MonadEvaluator location term value (m effects)   => MonadEvaluator location term value (BadValues m effects)
 
-instance ( Effectful m
+instance ( Interpreter m effects
-         , Member (Resumable (ValueError location value)) effects
+         , MonadEvaluator location term value effects m
-         , Member (State (EvaluatingState location term value)) effects
+         , AbstractHole value
-         , Member (State [Name]) effects
+         , Show value
-         , MonadAnalysis location term value (m effects)
-         , MonadValue location value (BadValues m effects)
          )
-      => MonadAnalysis location term value (BadValues m effects) where
+      => Interpreter (BadValues m) (Resumable (ValueError location value) ': effects) where
-  type Effects location term value (BadValues m effects) = State [Name] ': Effects location term value (m effects)
+  type Result (BadValues m) (Resumable (ValueError location value) ': effects) result = Result m effects result
-
+  interpret
-  analyzeTerm eval term = resumeException @(ValueError location value) (liftAnalyze analyzeTerm eval term) (
+    = interpret
-        \yield error -> case error of
+    . runBadValues
-          (ScopedEnvironmentError _) -> do
+    . raiseHandler (relay pure (\ (Resumable err) yield -> traceM ("ValueError" <> show err) *> case err of
-            env <- getEnv
+      CallError val     -> yield val
-            yield (Env.push env)
+      StringError val   -> yield (pack (show val))
-          (CallError val) -> yield val
+      BoolError{}       -> yield True
-          (StringError val) -> yield (pack $ show val)
+      BoundsError{}     -> yield hole
-          BoolError{} -> yield True
+      IndexError{}      -> yield hole
-          Numeric2Error{} -> unit >>= yield
+      NumericError{}    -> yield hole
-          NamespaceError{} -> getEnv >>= yield
+      Numeric2Error{}   -> yield hole
-          )
+      ComparisonError{} -> yield hole
-
+      NamespaceError{}  -> lower @m getEnv >>= yield
-  analyzeModule = liftAnalyze analyzeModule
+      BitwiseError{}    -> yield hole
+      Bitwise2Error{}   -> yield hole
+      KeyValueError{}   -> yield (hole, hole)
+      ArithmeticError{} -> yield hole))

src/Analysis/Abstract/BadVariables.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
 module Analysis.Abstract.BadVariables
 ( BadVariables
 ) where
@@ -8,27 +9,30 @@ import Data.Abstract.Evaluatable
 import Prologue
 
 -- An analysis that resumes from evaluation errors and records the list of unresolved free variables.
-newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a)
+newtype BadVariables m (effects :: [* -> *]) a = BadVariables { runBadVariables :: m effects a }
-  deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
+  deriving (Alternative, Applicative, Functor, Effectful, Monad)
 
-deriving instance MonadControl term (m effects)                    => MonadControl term (BadVariables m effects)
+deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadVariables m)
-deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (BadVariables m effects)
+deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadVariables m)
-deriving instance MonadHeap location value (m effects)             => MonadHeap location value (BadVariables m effects)
-deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadVariables m effects)
-deriving instance MonadEvaluator location term value (m effects)   => MonadEvaluator location term value (BadVariables m effects)
 
-instance ( Effectful m
+instance ( Interpreter m effects
-         , Member (Resumable (EvalError value)) effects
+         , MonadEvaluator location term value effects m
-         , Member (State [Name]) effects
+         , AbstractHole value
-         , MonadAnalysis location term value (m effects)
+         , Show value
-         , MonadValue location value (BadVariables m effects)
          )
-      => MonadAnalysis location term value (BadVariables m effects) where
+      => Interpreter (BadVariables m) (Resumable (EvalError value) ': State [Name] ': effects) where
-  type Effects location term value (BadVariables m effects) = State [Name] ': Effects location term value (m effects)
+  type Result (BadVariables m) (Resumable (EvalError value) ': State [Name] ': effects) result = Result m effects (result, [Name])
-
+  interpret
-  analyzeTerm eval term = resumeException @(EvalError value) (liftAnalyze analyzeTerm eval term) (
+    = interpret
-        \yield err -> case err of
+    . runBadVariables
-          (FreeVariableError name) -> raise (modify' (name :)) >> unit >>= yield
+    . raiseHandler
-          (FreeVariablesError names) -> raise (modify' (names <>)) >> yield (last names) )
+      ( flip runState []
-
+      . relay pure (\ (Resumable err) yield -> traceM ("EvalError" <> show err) *> case err of
-  analyzeModule = liftAnalyze analyzeModule
+        EnvironmentLookupError{}     -> yield hole
+        DefaultExportError{}     -> yield ()
+        ExportError{}            -> yield ()
+        IntegerFormatError{}     -> yield 0
+        FloatFormatError{}       -> yield 0
+        RationalFormatError{}    -> yield 0
+        FreeVariableError name   -> modify' (name :) *> yield hole
+        FreeVariablesError names -> modify' (names <>) *> yield (fromMaybeLast "unknown" names)))

src/Analysis/Abstract/Caching.hs

@@ -1,59 +1,52 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
 module Analysis.Abstract.Caching
 ( Caching
 ) where
 
 import Control.Abstract.Analysis
+import Control.Monad.Effect hiding (interpret)
 import Data.Abstract.Address
 import Data.Abstract.Cache
 import Data.Abstract.Configuration
 import Data.Abstract.Heap
+import Data.Abstract.Live
 import Data.Abstract.Module
 import Prologue
 
--- | The effects necessary for caching analyses.
-type CachingEffects location term value effects
-  = NonDet                             -- For 'Alternative' and 'gather'.
- ': Reader (Cache location term value) -- The in-cache used as an oracle while converging on a result.
- ': State  (Cache location term value) -- The out-cache used to record results in each iteration of convergence.
- ': effects
-
 -- | A (coinductively-)cached analysis suitable for guaranteeing termination of (suitably finitized) analyses over recursive programs.
-newtype Caching m (effects :: [* -> *]) a = Caching (m effects a)
+newtype Caching m (effects :: [* -> *]) a = Caching { runCaching :: m effects a }
-  deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
+  deriving (Alternative, Applicative, Functor, Effectful, Monad)
 
-deriving instance MonadControl term (m effects)                    => MonadControl term (Caching m effects)
+deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Caching m)
-deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (Caching m effects)
-deriving instance MonadHeap location value (m effects)             => MonadHeap location value (Caching m effects)
-deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Caching m effects)
-deriving instance MonadEvaluator location term value (m effects)   => MonadEvaluator location term value (Caching m effects)
 
 -- | Functionality used to perform caching analysis. This is not exported, and exists primarily for organizational reasons.
-class MonadEvaluator location term value m => MonadCaching location term value m where
+class MonadEvaluator location term value effects m => MonadCaching location term value effects m where
   -- | Look up the set of values for a given configuration in the in-cache.
-  consultOracle :: Configuration location term value -> m (Set (value, Heap location value))
+  consultOracle :: Configuration location term value -> m effects (Set (value, Heap location value))
   -- | Run an action with the given in-cache.
-  withOracle :: Cache location term value -> m a -> m a
+  withOracle :: Cache location term value -> m effects a -> m effects a
 
   -- | Look up the set of values for a given configuration in the out-cache.
-  lookupCache :: Configuration location term value -> m (Maybe (Set (value, Heap location value)))
+  lookupCache :: Configuration location term value -> m effects (Maybe (Set (value, Heap location value)))
   -- | Run an action, caching its result and 'Heap' under the given configuration.
-  caching :: Configuration location term value -> Set (value, Heap location value) -> m value -> m value
+  caching :: Configuration location term value -> Set (value, Heap location value) -> m effects value -> m effects value
 
   -- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
-  isolateCache :: m a -> m (Cache location term value)
+  isolateCache :: m effects a -> m effects (Cache location term value)
 
 instance ( Effectful m
-         , Members (CachingEffects location term value '[]) effects
+         , Member (Reader (Cache location term value)) effects
-         , MonadEvaluator location term value (m effects)
+         , Member (State  (Cache location term value)) effects
+         , MonadEvaluator location term value effects m
          , Ord (Cell location value)
          , Ord location
          , Ord term
          , Ord value
          )
-         => MonadCaching location term value (Caching m effects) where
+         => MonadCaching location term value effects (Caching m) where
   consultOracle configuration = raise (fromMaybe mempty . cacheLookup configuration <$> ask)
-  withOracle cache = raise . local (const cache) . lower
+  withOracle cache = raiseHandler (local (const cache))
 
   lookupCache configuration = raise (cacheLookup configuration <$> get)
   caching configuration values action = do
@@ -68,18 +61,18 @@ instance ( Effectful m
 instance ( Alternative (m effects)
          , Corecursive term
          , Effectful m
-         , Members (CachingEffects location term value '[]) effects
+         , Member Fresh effects
-         , MonadAnalysis location term value (m effects)
+         , Member NonDet effects
-         , MonadFresh (m effects)
+         , Member (Reader (Cache location term value)) effects
+         , Member (Reader (Live location value)) effects
+         , Member (State  (Cache location term value)) effects
+         , MonadAnalysis location term value effects m
          , Ord (Cell location value)
          , Ord location
          , Ord term
          , Ord value
          )
-      => MonadAnalysis location term value (Caching m effects) where
+      => MonadAnalysis location term value effects (Caching m) where
-  -- We require the 'CachingEffects' in addition to the underlying analysis’ 'Effects'.
-  type Effects location term value (Caching m effects) = CachingEffects location term value (Effects location term value (m effects))
-
   -- Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
   analyzeTerm recur e = do
     c <- getConfiguration (embedSubterm e)
@@ -96,15 +89,18 @@ instance ( Alternative (m effects)
     cache <- converge (\ prevCache -> isolateCache $ do
       putHeap (configurationHeap c)
       -- We need to reset fresh generation so that this invocation converges.
-      reset 0
+      reset 0 $
       -- This is subtle: though the calling context supports nondeterminism, we want
       -- to corral all the nondeterminism that happens in this @eval@ invocation, so
       -- that it doesn't "leak" to the calling context and diverge (otherwise this
       -- would never complete). We don’t need to use the values, so we 'gather' the
       -- nondeterministic values into @()@.
-      withOracle prevCache (raise (gather (const ()) (lower (liftAnalyze analyzeModule recur m))))) mempty
+        withOracle prevCache (raise (gather (const ()) (lower (liftAnalyze analyzeModule recur m))))) mempty
     maybe empty scatter (cacheLookup c cache)
 
+reset :: (Effectful m, Member Fresh effects) => Int -> m effects a -> m effects a
+reset start = raiseHandler (interposeState start (const pure) (\ counter Fresh yield -> (yield $! succ counter) counter))
+
 -- | Iterate a monadic action starting from some initial seed until the results converge.
 --
 --   This applies the Kleene fixed-point theorem to finitize a monotone action. cf https://en.wikipedia.org/wiki/Kleene_fixed-point_theorem
@@ -121,5 +117,23 @@ converge f = loop
             loop x'
 
 -- | Nondeterministically write each of a collection of stores & return their associated results.
-scatter :: (Alternative m, Foldable t, MonadEvaluator location term value m) => t (a, Heap location value) -> m a
+scatter :: (Alternative (m effects), Foldable t, MonadEvaluator location term value effects m) => t (a, Heap location value) -> m effects a
 scatter = foldMapA (\ (value, heap') -> putHeap heap' $> value)
+
+
+instance ( Interpreter m effects
+         , MonadEvaluator location term value effects m
+         , Ord (Cell location value)
+         , Ord location
+         , Ord term
+         , Ord value
+         )
+      => Interpreter (Caching m) (NonDet ': Reader (Cache location term value) ': State (Cache location term value) ': effects) where
+  type Result (Caching m) (NonDet ': Reader (Cache location term value) ': State (Cache location term value) ': effects) result = Result m effects ([result], Cache location term value)
+  interpret
+    = interpret
+    . runCaching
+    . raiseHandler
+      ( flip runState mempty
+      . flip runReader mempty
+      . makeChoiceA @[])

src/Analysis/Abstract/Collecting.hs

@@ -1,43 +1,31 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
 module Analysis.Abstract.Collecting
 ( Collecting
+, Retaining
 ) where
 
 import Control.Abstract.Analysis
 import Data.Abstract.Address
-import Data.Abstract.Configuration
 import Data.Abstract.Heap
 import Data.Abstract.Live
 import Prologue
 
-newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a)
+-- | An analysis performing GC after every instruction.
-  deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
+newtype Collecting m (effects :: [* -> *]) a = Collecting { runCollecting :: m effects a }
+  deriving (Alternative, Applicative, Effectful, Functor, Monad)
 
-deriving instance MonadControl term (m effects)                    => MonadControl term (Collecting m effects)
+deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Collecting m)
-deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (Collecting m effects)
-deriving instance MonadHeap location value (m effects)             => MonadHeap location value (Collecting m effects)
-deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Collecting m effects)
-
-instance ( Effectful m
-         , Member (Reader (Live location value)) effects
-         , MonadEvaluator location term value (m effects)
-         )
-      => MonadEvaluator location term value (Collecting m effects) where
-  getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap
 
 
 instance ( Effectful m
          , Foldable (Cell location)
          , Member (Reader (Live location value)) effects
-         , MonadAnalysis location term value (m effects)
+         , MonadAnalysis location term value effects m
          , Ord location
          , ValueRoots location value
          )
-      => MonadAnalysis location term value (Collecting m effects) where
+      => MonadAnalysis location term value effects (Collecting m) where
-  type Effects location term value (Collecting m effects)
-    = Reader (Live location value)
-   ': Effects location term value (m effects)
-
   -- Small-step evaluation which garbage-collects any non-rooted addresses after evaluating each term.
   analyzeTerm recur term = do
     roots <- askRoots
@@ -48,15 +36,6 @@ instance ( Effectful m
   analyzeModule = liftAnalyze analyzeModule
 
 
--- | Retrieve the local 'Live' set.
-askRoots :: (Effectful m, Member (Reader (Live location value)) effects) => m effects (Live location value)
-askRoots = raise ask
-
--- | Run a computation with the given 'Live' set added to the local root set.
--- extraRoots :: (Effectful m, Member (Reader (Live location value)) effects, Ord location) => Live location value -> m effects a -> m effects a
--- extraRoots roots = raise . local (<> roots) . lower
-
-
 -- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
 gc :: ( Ord location
       , Foldable (Cell location)
@@ -81,3 +60,28 @@ reachable roots heap = go mempty roots
           Just (a, as) -> go (liveInsert a seen) (case heapLookupAll a heap of
             Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen
             _           -> seen)
+
+
+instance ( Interpreter m effects
+         , MonadEvaluator location term value effects m
+         , Ord location
+         )
+      => Interpreter (Collecting m) (Reader (Live location value) ': effects) where
+  type Result (Collecting m) (Reader (Live location value) ': effects) result = Result m effects result
+  interpret = interpret . runCollecting . raiseHandler (`runReader` mempty)
+
+
+-- | An analysis providing a 'Live' set, but never performing GC.
+newtype Retaining m (effects :: [* -> *]) a = Retaining { runRetaining :: m effects a }
+  deriving (Alternative, Applicative, Effectful, Functor, Monad)
+
+deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Retaining m)
+deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (Retaining m)
+
+instance ( Interpreter m effects
+         , MonadEvaluator location term value effects m
+         , Ord location
+         )
+      => Interpreter (Retaining m) (Reader (Live location value) ': effects) where
+  type Result (Retaining m) (Reader (Live location value) ': effects) result = Result m effects result
+  interpret = interpret . runRetaining . raiseHandler (`runReader` mempty)

src/Analysis/Abstract/Dead.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
 module Analysis.Abstract.Dead
 ( DeadCode
 ) where
@@ -10,14 +11,10 @@ import Data.Set (delete)
 import Prologue
 
 -- | An analysis tracking dead (unreachable) code.
-newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a)
+newtype DeadCode m (effects :: [* -> *]) a = DeadCode { runDeadCode :: m effects a }
-  deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
+  deriving (Alternative, Applicative, Functor, Effectful, Monad)
 
-deriving instance MonadControl term (m effects)                    => MonadControl term (DeadCode m effects)
+deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (DeadCode m)
-deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (DeadCode m effects)
-deriving instance MonadHeap location value (m effects)             => MonadHeap location value (DeadCode m effects)
-deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (DeadCode m effects)
-deriving instance MonadEvaluator location term value (m effects)   => MonadEvaluator location term value (DeadCode m effects)
 
 -- | A set of “dead” (unreachable) terms.
 newtype Dead term = Dead { unDead :: Set term }
@@ -42,13 +39,11 @@ instance ( Corecursive term
          , Effectful m
          , Foldable (Base term)
          , Member (State (Dead term)) effects
-         , MonadAnalysis location term value (m effects)
+         , MonadAnalysis location term value effects m
          , Ord term
          , Recursive term
          )
-      => MonadAnalysis location term value (DeadCode m effects) where
+      => MonadAnalysis location term value effects (DeadCode m) where
-  type Effects location term value (DeadCode m effects) = State (Dead term) ': Effects location term value (m effects)
-
   analyzeTerm recur term = do
     revive (embedSubterm term)
     liftAnalyze analyzeTerm recur term
@@ -56,3 +51,11 @@ instance ( Corecursive term
   analyzeModule recur m = do
     killAll (subterms (subterm (moduleBody m)))
     liftAnalyze analyzeModule recur m
+
+instance ( Interpreter m effects
+         , MonadEvaluator location term value effects m
+         , Ord term
+         )
+      => Interpreter (DeadCode m) (State (Dead term) ': effects) where
+  type Result (DeadCode m) (State (Dead term) ': effects) result = Result m effects (result, Dead term)
+  interpret = interpret . runDeadCode . raiseHandler (`runState` mempty)

src/Analysis/Abstract/Erroring.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+module Analysis.Abstract.Erroring
+( Erroring
+) where
+
+import Control.Abstract.Analysis
+import Prologue
+
+-- | An analysis that fails on errors.
+newtype Erroring (exc :: * -> *) m (effects :: [* -> *]) a = Erroring { runErroring :: m effects a }
+  deriving (Alternative, Applicative, Effectful, Functor, Monad)
+
+deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Erroring exc m)
+deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (Erroring exc m)
+
+instance Interpreter               m                    effects
+      => Interpreter (Erroring exc m) (Resumable exc ': effects) where
+  type Result (Erroring exc m) (Resumable exc ': effects) result = Result m effects (Either (SomeExc exc) result)
+  interpret = interpret . runErroring . raiseHandler runError

src/Analysis/Abstract/Evaluating.hs

@@ -1,162 +1,77 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies, UndecidableInstances, ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}
 module Analysis.Abstract.Evaluating
 ( Evaluating
-, EvaluatingState(..)
 ) where
 
-import           Control.Abstract.Analysis
+import Control.Abstract.Analysis
-import           Control.Monad.Effect
+import qualified Control.Monad.Effect as Eff
-import           Data.Abstract.Address
+import Data.Abstract.Environment
-import           Data.Abstract.Configuration
+import Data.Abstract.Module
-import           Data.Abstract.Environment as Env
+import Data.Abstract.ModuleTable
-import           Data.Abstract.Evaluatable
+import Data.Abstract.Origin
-import           Data.Abstract.Exports
+import Data.Semilattice.Lower
-import           Data.Abstract.Heap
+import Prologue
-import           Data.Abstract.Module
-import           Data.Abstract.ModuleTable
-import           Data.Abstract.Origin
-import qualified Data.IntMap as IntMap
-import           Lens.Micro
-import           Prelude hiding (fail)
-import           Prologue
 
 -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@.
-newtype Evaluating location term value effects a = Evaluating (Eff effects a)
+newtype Evaluating location term value effects a = Evaluating { runEvaluating :: Eff effects a }
   deriving (Applicative, Functor, Effectful, Monad)
 
-deriving instance Member Fail   effects => MonadFail   (Evaluating location term value effects)
-deriving instance Member Fresh  effects => MonadFresh  (Evaluating location term value effects)
 deriving instance Member NonDet effects => Alternative (Evaluating location term value effects)
 
 -- | Effects necessary for evaluating (whether concrete or abstract).
 type EvaluatingEffects location term value
-  = '[ Resumable (EvalError value)
+  = '[ EvalClosure term value
-     , Resumable (ResolutionError value)
+     , EvalModule term value
-     , Resumable (LoadError term value)
+     , Return value
-     , Resumable (ValueError location value)
+     , LoopControl value
-     , Resumable (Unspecialized value)
+     , Fail                                        -- Failure with an error message
-     , Fail                                         -- Failure with an error message
+     , Fresh                                       -- For allocating new addresses and/or type variables.
-     , Fresh                                        -- For allocating new addresses and/or type variables.
+     , Reader (SomeOrigin term)                    -- The current term’s origin.
-     , Reader (SomeOrigin term)                     -- The current term’s origin.
+     , Reader (ModuleTable [Module term])          -- Cache of unevaluated modules
-     , Reader (ModuleTable [Module term])           -- Cache of unevaluated modules
+     , Reader (Environment location value)         -- Default environment used as a fallback in lookupEnv
-     , Reader (Environment location value)          -- Default environment used as a fallback in lookupEnv
+     , State  (EvaluatorState location term value) -- Environment, heap, modules, exports, and jumps.
-     , State  (EvaluatingState location term value) -- Environment, heap, modules, exports, and jumps.
      ]
 
-data EvaluatingState location term value = EvaluatingState
+instance ( Member (Reader (Environment location value)) effects
-  { environment :: Environment location value
+         , Member (Reader (ModuleTable [Module term])) effects
-  , heap        :: Heap location value
+         , Member (Reader (SomeOrigin term)) effects
-  , modules     :: ModuleTable (Environment location value, value)
+         , Member (State (EvaluatorState location term value)) effects
-  , exports     :: Exports location value
+         )
-  , jumps       :: IntMap.IntMap term
+      => MonadEvaluator location term value effects (Evaluating location term value)
-  , origin      :: SomeOrigin term
-  }
-
-deriving instance (Eq (Cell location value), Eq location, Eq term, Eq value, Eq (Base term ())) => Eq (EvaluatingState location term value)
-deriving instance (Ord (Cell location value), Ord location, Ord term, Ord value, Ord (Base term ())) => Ord (EvaluatingState location term value)
-deriving instance (Show (Cell location value), Show location, Show term, Show value, Show (Base term ())) => Show (EvaluatingState location term value)
-
-instance (Ord location, Semigroup (Cell location value)) => Semigroup (EvaluatingState location term value) where
-  EvaluatingState e1 h1 m1 x1 j1 o1 <> EvaluatingState e2 h2 m2 x2 j2 o2 = EvaluatingState (e1 <> e2) (h1 <> h2) (m1 <> m2) (x1 <> x2) (j1 <> j2) (o1 <> o2)
-
-instance (Ord location, Semigroup (Cell location value)) => Monoid (EvaluatingState location term value) where
-  mempty = EvaluatingState mempty mempty mempty mempty mempty mempty
-  mappend = (<>)
-
-_environment :: Lens' (EvaluatingState location term value) (Environment location value)
-_environment = lens environment (\ s e -> s {environment = e})
-
-_heap :: Lens' (EvaluatingState location term value) (Heap location value)
-_heap = lens heap (\ s h -> s {heap = h})
-
-_modules :: Lens' (EvaluatingState location term value) (ModuleTable (Environment location value, value))
-_modules = lens modules (\ s m -> s {modules = m})
-
-_exports :: Lens' (EvaluatingState location term value) (Exports location value)
-_exports = lens exports (\ s e -> s {exports = e})
-
-_jumps :: Lens' (EvaluatingState location term value) (IntMap.IntMap term)
-_jumps = lens jumps (\ s j -> s {jumps = j})
-
-_origin :: Lens' (EvaluatingState location term value) (SomeOrigin term)
-_origin = lens origin (\ s o -> s {origin = o})
-
-
-(.=) :: Member (State (EvaluatingState location term value)) effects => ASetter (EvaluatingState location term value) (EvaluatingState location term value) a b -> b -> Evaluating location term value effects ()
-lens .= val = raise (modify' (lens .~ val))
-
-view :: Member (State (EvaluatingState location term value)) effects => Getting a (EvaluatingState location term value) a -> Evaluating location term value effects a
-view lens = raise (gets (^. lens))
-
-localEvaluatingState :: Member (State (EvaluatingState location term value)) effects => Lens' (EvaluatingState location term value) prj -> (prj -> prj) -> Evaluating location term value effects a -> Evaluating location term value effects a
-localEvaluatingState lens f action = do
-  original <- view lens
-  lens .= f original
-  v <- action
-  v <$ lens .= original
-
-
-instance Members '[Fail, State (EvaluatingState location term value)] effects => MonadControl term (Evaluating location term value effects) where
-  label term = do
-    m <- view _jumps
-    let i = IntMap.size m
-    _jumps .= IntMap.insert i term m
-    pure i
-
-  goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure
-
-instance Members '[ State (EvaluatingState location term value)
-                  , Reader (Environment location value)
-                  ] effects
-      => MonadEnvironment location value (Evaluating location term value effects) where
-  getEnv = view _environment
-  putEnv = (_environment .=)
-  withEnv s = localEvaluatingState _environment (const s)
-
-  defaultEnvironment = raise ask
-  withDefaultEnvironment e = raise . local (const e) . lower
-
-  getExports = view _exports
-  putExports = (_exports .=)
-  withExports s = localEvaluatingState _exports (const s)
-
-  localEnv f a = do
-    modifyEnv (f . Env.push)
-    result <- a
-    result <$ modifyEnv Env.pop
-
-instance Member (State (EvaluatingState location term value)) effects
-      => MonadHeap location value (Evaluating location term value effects) where
-  getHeap = view _heap
-  putHeap = (_heap .=)
-
-instance Members '[ Reader (ModuleTable [Module term])
-                  , State (EvaluatingState location term value)
-                  , Reader (SomeOrigin term)
-                  , Fail
-                  ] effects
-      => MonadModuleTable location term value (Evaluating location term value effects) where
-  getModuleTable = view _modules
-  putModuleTable = (_modules .=)
-
-  askModuleTable = raise ask
-  localModuleTable f a = raise (local f (lower a))
-
-  currentModule = do
-    o <- raise ask
-    maybeFail "unable to get currentModule" $ withSomeOrigin (originModule @term) o
-
-instance Members (EvaluatingEffects location term value) effects
-      => MonadEvaluator location term value (Evaluating location term value effects) where
-  getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap
 
 instance ( Corecursive term
-         , Members (EvaluatingEffects location term value) effects
+         , Member (Reader (Environment location value)) effects
+         , Member (Reader (ModuleTable [Module term])) effects
+         , Member (Reader (SomeOrigin term)) effects
+         , Member (State (EvaluatorState location term value)) effects
          , Recursive term
          )
-      => MonadAnalysis location term value (Evaluating location term value effects) where
+      => MonadAnalysis location term value effects (Evaluating location term value) where
-  type Effects location term value (Evaluating location term value effects) = EvaluatingEffects location term value
-
   analyzeTerm eval term = pushOrigin (termOrigin (embedSubterm term)) (eval term)
 
   analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (eval m)
+
+
+instance (AbstractHole value, Show term, Show value) => Interpreter (Evaluating location term value) (EvaluatingEffects location term value) where
+  type Result (Evaluating location term value) (EvaluatingEffects location term value) result
+    = ( Either String result
+      , EvaluatorState location term value)
+  interpret
+    = interpret
+    . runEvaluating
+    . raiseHandler
+      ( flip runState  lowerBound -- State (EvaluatorState location term value)
+      . flip runReader lowerBound -- Reader (Environment location value)
+      . flip runReader lowerBound -- Reader (ModuleTable [Module term])
+      . flip runReader lowerBound -- Reader (SomeOrigin term)
+      . flip runFresh' 0
+      . runFail
+      -- NB: We should never have a 'Return', 'Break', or 'Continue' at this point in execution; the scope being returned from/broken from/continued should have intercepted the effect. This handler will therefore only be invoked if we issue a 'Return', 'Break', or 'Continue' outside of such a scope, and unfortunately if this happens it will handle it by resuming the scope being returned from. While it would be _slightly_ more correct to instead exit with the value being returned, we aren’t able to do that here since 'Interpreter'’s type is parametric in the value being returned—we don’t know that we’re returning a @value@ (because we very well may not be). On the balance, I felt the strange behaviour in error cases is worth the improved behaviour in the common case—we get to lose a layer of 'Either' in the result for each.
+      -- In general, it’s expected that none of the following effects will remain by the time 'interpret' is called—they should have been handled by local 'interpose's—but if they do, we’ll at least trace.
+      . Eff.interpret (\ control -> case control of
+        Break value -> traceM ("Evaluating.interpret: resuming uncaught break with " <> show value) $> value
+        Continue    -> traceM "Evaluating.interpret: resuming uncaught continue with hole" $> hole)
+      . Eff.interpret (\ (Return value) -> traceM ("Evaluating.interpret: resuming uncaught return with " <> show value) $> value)
+      . Eff.interpret (\ (EvalModule m) -> traceM ("Evaluating.interpret: resuming uncaught EvalModule of " <> show m <> " with hole") $> hole)
+      . Eff.interpret (\ (EvalClosure term) -> traceM ("Evaluating.interpret: resuming uncaught EvalClosure of " <> show term <> " with hole") $> hole))
+      -- TODO: Replace 'traceM's with e.g. 'Telemetry'.

src/Analysis/Abstract/ImportGraph.hs

@@ -1,5 +1,4 @@
-{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving,
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
-             TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.Abstract.ImportGraph
 ( ImportGraph(..)
 , renderImportGraph
@@ -17,9 +16,13 @@ import           Data.Abstract.Located
 import           Data.Abstract.Module hiding (Module)
 import           Data.Abstract.Origin hiding (Module, Package)
 import           Data.Abstract.Package hiding (Package)
+import           Data.Aeson hiding (Result)
 import qualified Data.ByteString.Char8 as BC
+import           Data.ByteString.Lazy (toStrict)
+import           Data.Output
 import qualified Data.Syntax as Syntax
 import           Data.Term
+import           Data.Text.Encoding as T
 import           Prologue hiding (empty, packageName)
 
 -- | The graph of function variableDefinitions to symbols used in a given program.
@@ -50,35 +53,28 @@ style = (defaultStyle vertexName)
         edgeAttributes Variable{} Module{}   = [ "color" := "blue" ]
         edgeAttributes _          _          = []
 
-newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a)
+newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing { runImportGraphing :: m effects a }
-  deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
+  deriving (Alternative, Applicative, Functor, Effectful, Monad)
 
-deriving instance MonadControl term (m effects)                    => MonadControl term (ImportGraphing m effects)
+deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (ImportGraphing m)
-deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (ImportGraphing m effects)
-deriving instance MonadHeap location value (m effects)             => MonadHeap location value (ImportGraphing m effects)
-deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (ImportGraphing m effects)
-deriving instance MonadEvaluator location term value (m effects)   => MonadEvaluator location term value (ImportGraphing m effects)
 
 
 instance ( Effectful m
-         , Member (Reader (SomeOrigin term)) effects
+         , Member (Resumable (LoadError term)) effects
-         , Member (Resumable (LoadError term value)) effects
          , Member (State ImportGraph) effects
          , Member Syntax.Identifier syntax
-         , MonadAnalysis (Located location term) term value (m effects)
+         , MonadAnalysis (Located location term) term value effects m
          , term ~ Term (Union syntax) ann
          )
-      => MonadAnalysis (Located location term) term value (ImportGraphing m effects) where
+      => MonadAnalysis (Located location term) term value effects (ImportGraphing m) where
-  type Effects (Located location term) term value (ImportGraphing m effects) = State ImportGraph ': Effects (Located location term) term value (m effects)
-
   analyzeTerm eval term@(In _ syntax) = do
     case prj syntax of
       Just (Syntax.Identifier name) -> do
         moduleInclusion (Variable (unName name))
         variableDefinition name
       _ -> pure ()
-    resumeException
+    resume
-      @(LoadError term value)
+      @(LoadError term)
       (liftAnalyze analyzeTerm eval term)
       (\yield (LoadError name) -> moduleInclusion (Module (BC.pack name)) >> yield [])
 
@@ -96,10 +92,8 @@ moduleGraph = maybe empty (vertex . Module . BC.pack . modulePath) . withSomeOri
 
 -- | Add an edge from the current package to the passed vertex.
 packageInclusion :: forall m location term value effects
-                 .  ( Effectful m
+                 .  ( Member (State ImportGraph) effects
-                    , Member (Reader (SomeOrigin term)) effects
+                    , MonadEvaluator location term value effects m
-                    , Member (State ImportGraph) effects
-                    , MonadEvaluator location term value (m effects)
                     )
                  => Vertex
                  -> ImportGraphing m effects ()
@@ -109,10 +103,8 @@ packageInclusion v = do
 
 -- | Add an edge from the current module to the passed vertex.
 moduleInclusion :: forall m location term value effects
-                .  ( Effectful m
+                .  ( Member (State ImportGraph) effects
-                   , Member (Reader (SomeOrigin term)) effects
+                   , MonadEvaluator location term value effects m
-                   , Member (State ImportGraph) effects
-                   , MonadEvaluator location term value (m effects)
                    )
                 => Vertex
                 -> ImportGraphing m effects ()
@@ -121,10 +113,11 @@ moduleInclusion v = do
   appendGraph (moduleGraph @term o `connect` vertex v)
 
 -- | Add an edge from the passed variable name to the module it originated within.
-variableDefinition :: ( Effectful m
+variableDefinition :: ( Member (State ImportGraph) effects
-              , Member (State ImportGraph) effects
+                      , MonadEvaluator (Located location term) term value effects m
-              , MonadEvaluator (Located location term) term value (m effects)
+                      )
-              ) => Name -> ImportGraphing m effects ()
+                   => Name
+                   -> ImportGraphing m effects ()
 variableDefinition name = do
   graph <- maybe empty (moduleGraph . origin . unAddress) <$> lookupEnv name
   appendGraph (vertex (Variable (unName name)) `connect` graph)
@@ -151,3 +144,29 @@ instance Ord ImportGraph where
   compare (ImportGraph (G.Overlay _  _))  _                               = LT
   compare _                               (ImportGraph (G.Overlay _ _))   = GT
   compare (ImportGraph (G.Connect a1 a2)) (ImportGraph (G.Connect b1 b2)) = (compare `on` ImportGraph) a1 b1 <> (compare `on` ImportGraph) a2 b2
+
+instance Output ImportGraph where
+  toOutput = toStrict . (<> "\n") . encode
+
+instance ToJSON ImportGraph where
+  toJSON ImportGraph{..} = object [ "vertices" .= vertices, "edges" .= edges ]
+    where
+      vertices = toJSON (G.vertexList unImportGraph)
+      edges = fmap (\(a, b) -> object [ "source" .= vertexToText a, "target" .= vertexToText b ]) (G.edgeList unImportGraph)
+
+instance ToJSON Vertex where
+  toJSON v = object [ "name" .= vertexToText v, "type" .= vertexToType v ]
+
+vertexToText :: Vertex -> Text
+vertexToText = decodeUtf8 . vertexName
+
+vertexToType :: Vertex -> Text
+vertexToType Package{}  = "package"
+vertexToType Module{}   = "module"
+vertexToType Variable{} = "variable"
+
+
+instance Interpreter m effects
+      => Interpreter (ImportGraphing m) (State ImportGraph ': effects) where
+  type Result (ImportGraphing m) (State ImportGraph ': effects) result = Result m effects (result, ImportGraph)
+  interpret = interpret . runImportGraphing . raiseHandler (`runState` mempty)

src/Analysis/Abstract/Quiet.hs

@@ -1,36 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-}
-module Analysis.Abstract.Quiet
-( Quietly
-) where
-
-import Control.Abstract.Analysis
-import Data.Abstract.Evaluatable
-import Prologue
-
--- | An analysis which resumes exceptions instead of failing.
---
---   Use it by composing it onto an analysis:
---
---   > runAnalysis @(Quietly (Evaluating term value)) (…)
---
---   Note that exceptions thrown by other analyses may not be caught if 'Quietly' doesn’t know about them, i.e. if they’re not part of the generic 'MonadValue', 'MonadAddressable', etc. machinery.
-newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a)
-  deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
-
-deriving instance MonadControl term (m effects)                    => MonadControl term (Quietly m effects)
-deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (Quietly m effects)
-deriving instance MonadHeap location value (m effects)             => MonadHeap location value (Quietly m effects)
-deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Quietly m effects)
-deriving instance MonadEvaluator location term value (m effects)   => MonadEvaluator location term value (Quietly m effects)
-
-instance ( Effectful m
-         , Member (Resumable (Unspecialized value)) effects
-         , MonadAnalysis location term value (m effects)
-         , MonadValue location value (Quietly m effects)
-         )
-      => MonadAnalysis location term value (Quietly m effects) where
-  type Effects location term value (Quietly m effects) = Effects location term value (m effects)
-
-  analyzeTerm eval term = resumeException @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield (Unspecialized _) -> unit >>= yield)
-
-  analyzeModule = liftAnalyze analyzeModule

src/Analysis/Abstract/Tracing.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
 module Analysis.Abstract.Tracing
 ( Tracing
 ) where
@@ -6,6 +7,7 @@ module Analysis.Abstract.Tracing
 import Control.Abstract.Analysis
 import Control.Monad.Effect.Writer
 import Data.Abstract.Configuration
+import Data.Abstract.Live
 import Data.Semigroup.Reducer as Reducer
 import Data.Union
 import Prologue
@@ -13,28 +15,31 @@ import Prologue
 -- | Trace analysis.
 --
 --   Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
-newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a)
+newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing { runTracing :: m effects a }
-  deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
+  deriving (Alternative, Applicative, Functor, Effectful, Monad)
 
-deriving instance MonadControl term (m effects)                    => MonadControl term (Tracing trace m effects)
+deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Tracing trace m)
-deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (Tracing trace m effects)
-deriving instance MonadHeap location value (m effects)             => MonadHeap location value (Tracing trace m effects)
-deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Tracing trace m effects)
-deriving instance MonadEvaluator location term value (m effects)   => MonadEvaluator location term value (Tracing trace m effects)
 
 instance ( Corecursive term
          , Effectful m
+         , Member (Reader (Live location value)) effects
          , Member (Writer (trace (Configuration location term value))) effects
-         , MonadAnalysis location term value (m effects)
+         , MonadAnalysis location term value effects m
          , Ord location
          , Reducer (Configuration location term value) (trace (Configuration location term value))
          )
-      => MonadAnalysis location term value (Tracing trace m effects) where
+      => MonadAnalysis location term value effects (Tracing trace m) where
-  type Effects location term value (Tracing trace m effects) = Writer (trace (Configuration location term value)) ': Effects location term value (m effects)
-
   analyzeTerm recur term = do
     config <- getConfiguration (embedSubterm term)
     raise (tell @(trace (Configuration location term value)) (Reducer.unit config))
     liftAnalyze analyzeTerm recur term
 
   analyzeModule = liftAnalyze analyzeModule
+
+instance ( Interpreter m effects
+         , MonadEvaluator location term value effects m
+         , Monoid (trace (Configuration location term value))
+         )
+      => Interpreter (Tracing trace m) (Writer (trace (Configuration location term value)) ': effects) where
+  type Result (Tracing trace m) (Writer (trace (Configuration location term value)) ': effects) result = Result m effects (result, trace (Configuration location term value))
+  interpret = interpret . runTracing . raiseHandler runWriter

src/Analysis/Abstract/TypeChecking.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+
+module Analysis.Abstract.TypeChecking
+( TypeChecking
+) where
+
+import Control.Abstract.Analysis
+import Data.Abstract.Type
+import Prologue hiding (TypeError)
+
+newtype TypeChecking m (effects :: [* -> *]) a = TypeChecking { runTypeChecking :: m effects a }
+  deriving (Alternative, Applicative, Functor, Effectful, Monad)
+
+deriving instance MonadEvaluator location term Type effects m => MonadEvaluator location term Type effects (TypeChecking m)
+deriving instance MonadAnalysis location term Type effects m => MonadAnalysis location term Type effects (TypeChecking m)
+
+instance Interpreter m effects
+      => Interpreter (TypeChecking m) (Resumable TypeError ': effects) where
+  type Result (TypeChecking m) (Resumable TypeError ': effects) result = Result m effects (Either (SomeExc TypeError) result)
+  interpret
+    = interpret
+    . runTypeChecking
+    -- TODO: We should handle TypeError by yielding both sides of the exception,
+    -- but something is mysteriously busted in the innards of typechecking,
+    -- so doing that just yields an empty list in the result type, which isn't
+    -- extraordinarily helpful. Better for now to just die with an error and
+    -- tackle this issue in a separate PR.
+    . raiseHandler runError

src/Assigning/Assignment.hs

@@ -77,6 +77,8 @@ module Assigning.Assignment
 , while
 , until
 , manyThrough
+, getRubyLocals
+, putRubyLocals
 -- Results
 , Error(..)
 , errorCallStack
@@ -121,6 +123,8 @@ data AssignmentF ast grammar a where
   Alt :: [a] -> AssignmentF ast grammar a
   Label :: Assignment ast grammar a -> String -> AssignmentF ast grammar a
   Fail :: String -> AssignmentF ast grammar a
+  GetRubyLocals :: AssignmentF ast grammar [ByteString]
+  PutRubyLocals :: [ByteString] -> AssignmentF ast grammar ()
 
 data Tracing f a where
   Tracing :: { tracingCallSite :: Maybe (String, SrcLoc), runTracing :: f a } -> Tracing f a
@@ -140,6 +144,13 @@ tracing f = case getCallStack callStack of
 location :: HasCallStack => Assignment ast grammar (Record Location)
 location = tracing Location `Then` return
 
+getRubyLocals :: HasCallStack => Assignment ast grammar [ByteString]
+getRubyLocals = tracing GetRubyLocals `Then` return
+
+putRubyLocals :: (HasCallStack, Enum grammar, Eq1 ast, Ix grammar) => [ByteString] -> Assignment ast grammar ()
+putRubyLocals l = (tracing (PutRubyLocals l) `Then` return)
+              <|> (tracing End `Then` return)
+
 -- | Zero-width production of the current node.
 currentNode :: HasCallStack => Assignment ast grammar (TermF ast (Node grammar) ())
 currentNode = tracing CurrentNode `Then` return
@@ -239,6 +250,8 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
         run yield t initialState = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes)
           where atNode (Term (In node f)) = case runTracing t of
                   Location -> yield (nodeLocation node) state
+                  GetRubyLocals -> yield stateRubyLocals state
+                  PutRubyLocals l -> yield () (state { stateRubyLocals = l })
                   CurrentNode -> yield (In node (() <$ f)) state
                   Source -> yield (Source.sourceBytes (Source.slice (nodeByteRange node) source)) (advanceState state)
                   Children child -> do
@@ -277,7 +290,7 @@ skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . n
 -- | Advances the state past the current (head) node (if any), dropping it off stateNodes, and updating stateOffset & statePos to its end; or else returns the state unchanged.
 advanceState :: State ast grammar -> State ast grammar
 advanceState state@State{..}
-  | Term (In Node{..} _) : rest <- stateNodes = State (end nodeByteRange) (spanEnd nodeSpan) stateCallSites rest
+  | Term (In Node{..} _) : rest <- stateNodes = State (end nodeByteRange) (spanEnd nodeSpan) stateCallSites rest stateRubyLocals
   | otherwise = state
 
 -- | State kept while running 'Assignment's.
@@ -286,13 +299,14 @@ data State ast grammar = State
   , statePos :: {-# UNPACK #-} !Pos  -- ^ The (1-indexed) line/column position in the Source thus far reached.
   , stateCallSites :: ![(String, SrcLoc)] -- ^ The symbols & source locations of the calls thus far.
   , stateNodes :: ![AST ast grammar]      -- ^ The remaining nodes to assign. Note that 'children' rules recur into subterms, and thus this does not necessarily reflect all of the terms remaining to be assigned in the overall algorithm, only those “in scope.”
+  , stateRubyLocals :: ![ByteString]      -- Special state necessary for the Ruby assignment. When we refactor Assignment to use effects we should pull this out into Language.Ruby.Assignment
   }
 
 deriving instance (Eq grammar, Eq1 ast) => Eq (State ast grammar)
 deriving instance (Show grammar, Show1 ast) => Show (State ast grammar)
 
 makeState :: [AST ast grammar] -> State ast grammar
-makeState = State 0 (Pos 1 1) []
+makeState ns = State 0 (Pos 1 1) [] ns []
 
 
 -- Instances
@@ -374,6 +388,8 @@ instance (Enum grammar, Ix grammar, Show grammar, Show1 ast) => Show1 (Assignmen
     Alt as -> showsUnaryWith (const sl) "Alt" d (toList as)
     Label child string -> showsBinaryWith (liftShowsPrec sp sl) showsPrec "Label" d child string
     Fail s -> showsUnaryWith showsPrec "Fail" d s
+    GetRubyLocals -> showString "GetRubyLocals"
+    PutRubyLocals _ -> showString "PutRubyLocals _"
     where showChild = liftShowsPrec sp sl
           showChildren = liftShowList sp sl
 

src/Control/Abstract/Addressable.hs

@@ -1,39 +1,39 @@
-{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
+{-# LANGUAGE GADTs, UndecidableInstances #-}
 module Control.Abstract.Addressable where
 
 import Control.Abstract.Evaluator
 import Control.Applicative
-import Control.Effect.Fresh
+import Control.Effect
+import Control.Monad.Effect.Fresh
+import Control.Monad.Effect.Resumable as Eff
 import Data.Abstract.Address
 import Data.Abstract.Environment (insert)
 import Data.Abstract.FreeVariables
 import Data.Semigroup.Reducer
-import Prelude hiding (fail)
 import Prologue
 
 -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap.
-class (MonadFresh m, Ord location) => MonadAddressable location m where
+class (Effectful m, Member Fresh effects, Monad (m effects), Ord location) => MonadAddressable location effects m where
-  derefCell :: Address location value -> Cell location value -> m value
+  derefCell :: Address location value -> Cell location value -> m effects (Maybe value)
 
-  allocLoc :: Name -> m location
+  allocLoc :: Name -> m effects location
 
 -- | Look up or allocate an address for a 'Name'.
-lookupOrAlloc :: ( MonadAddressable location m
+lookupOrAlloc :: ( MonadAddressable location effects m
-                 , MonadEnvironment location value m
+                 , MonadEvaluator location term value effects m
                  )
               => Name
-              -> m (Address location value)
+              -> m effects (Address location value)
 lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure
 
 
-letrec :: ( MonadAddressable location m
+letrec :: ( MonadAddressable location effects m
-          , MonadEnvironment location value m
+          , MonadEvaluator location term value effects m
-          , MonadHeap location value m
           , Reducer value (Cell location value)
           )
        => Name
-       -> m value
+       -> m effects value
-       -> m (value, Address location value)
+       -> m effects (value, Address location value)
 letrec name body = do
   addr <- lookupOrAlloc name
   v <- localEnv (insert name addr) body
@@ -41,12 +41,12 @@ letrec name body = do
   pure (v, addr)
 
 -- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
-letrec' :: ( MonadAddressable location m
+letrec' :: ( MonadAddressable location effects m
-           , MonadEnvironment location value m
+           , MonadEvaluator location term value effects m
            )
         => Name
-        -> (Address location value -> m value)
+        -> (Address location value -> m effects value)
-        -> m value
+        -> m effects value
 letrec' name body = do
   addr <- lookupOrAlloc name
   v <- localEnv id (body addr)
@@ -55,22 +55,39 @@ letrec' name body = do
 -- Instances
 
 -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
-instance (MonadFail m, MonadFresh m) => MonadAddressable Precise m where
+instance (Effectful m, Member Fresh effects, Monad (m effects)) => MonadAddressable Precise effects m where
-  derefCell addr = maybeM (uninitializedAddress addr) . unLatest
+  derefCell _ = pure . unLatest
-  allocLoc _ = Precise <$> fresh
+  allocLoc _ = Precise <$> raise fresh
 
 -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
-instance (Alternative m, MonadFresh m) => MonadAddressable Monovariant m where
+instance (Alternative (m effects), Effectful m, Member Fresh effects, Monad (m effects)) => MonadAddressable Monovariant effects m where
-  derefCell _ = foldMapA pure
+  derefCell _ cell | null cell = pure Nothing
+                   | otherwise = Just <$> foldMapA pure cell
   allocLoc = pure . Monovariant
 
 -- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized.
-deref :: (MonadFail m, MonadAddressable location m, MonadHeap location value m, Show location) => Address location value -> m value
+deref :: (Member (Resumable (AddressError location value)) effects, MonadAddressable location effects m, MonadEvaluator location term value effects m) => Address location value -> m effects value
-deref addr = lookupHeap addr >>= maybe (uninitializedAddress addr) (derefCell addr)
+deref addr = do
+  cell <- lookupHeap addr >>= maybeM (throwAddressError (UnallocatedAddress addr))
+  derefed <- derefCell addr cell
+  maybeM (throwAddressError (UninitializedAddress addr)) derefed
 
-alloc :: MonadAddressable location m => Name -> m (Address location value)
+alloc :: MonadAddressable location effects m => Name -> m effects (Address location value)
 alloc = fmap Address . allocLoc
 
--- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced).
+data AddressError location value resume where
-uninitializedAddress :: (MonadFail m, Show location) => Address location value -> m a
+  UnallocatedAddress :: Address location value -> AddressError location value (Cell location value)
-uninitializedAddress addr = fail $ "uninitialized address: " <> show addr
+  UninitializedAddress :: Address location value -> AddressError location value value
+
+deriving instance Eq location => Eq (AddressError location value resume)
+deriving instance Show location => Show (AddressError location value resume)
+instance Show location => Show1 (AddressError location value) where
+  liftShowsPrec _ _ = showsPrec
+instance Eq location => Eq1 (AddressError location value) where
+  liftEq _ (UninitializedAddress a) (UninitializedAddress b) = a == b
+  liftEq _ (UnallocatedAddress a)   (UnallocatedAddress b)   = a == b
+  liftEq _ _                        _                        = False
+
+
+throwAddressError :: (Effectful m, Member (Resumable (AddressError location value)) effects) => AddressError location value resume -> m effects resume
+throwAddressError = raise . Eff.throwError

src/Control/Abstract/Analysis.hs

@@ -1,22 +1,17 @@
-{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-}
+{-# LANGUAGE KindSignatures #-}
-{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For runAnalysis
 module Control.Abstract.Analysis
 ( MonadAnalysis(..)
 , liftAnalyze
-, runAnalysis
-, SomeAnalysis(..)
-, runSomeAnalysis
 , module X
-, Subterm(..)
-, SubtermAlgebra
 ) where
 
 import Control.Abstract.Addressable as X
 import Control.Abstract.Evaluator as X
 import Control.Abstract.Value as X
 import Control.Effect as X
-import Control.Effect.Fresh as X
 import Control.Monad.Effect.Fail as X
+import Control.Monad.Effect.Fresh as X
+import Control.Monad.Effect.Internal as X (Eff, relay)
 import Control.Monad.Effect.NonDet as X
 import Control.Monad.Effect.Reader as X
 import Control.Monad.Effect.State as X
@@ -29,21 +24,14 @@ import Prologue
 -- | A 'Monad' in which one can evaluate some specific term type to some specific value type.
 --
 --   This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses.
-class MonadEvaluator location term value m => MonadAnalysis location term value m where
+class MonadEvaluator location term value effects m => MonadAnalysis location term value effects m where
-  -- | The effects necessary to run the analysis. Analyses which are composed on top of (wrap) other analyses should include the inner analyses 'Effects' in their own list.
-  type family Effects location term value m :: [* -> *]
-
   -- | Analyze a term using the semantics of the current analysis.
-  analyzeTerm :: (Base term (Subterm term (outer value)) -> m value)
+  analyzeTerm :: (Base term (Subterm term (outer value)) -> m effects value)
-              -> (Base term (Subterm term (outer value)) -> m value)
+              -> (Base term (Subterm term (outer value)) -> m effects value)
 
   -- | Analyze a module using the semantics of the current analysis. This should generally only be called by 'evaluateModule' and by definitions of 'analyzeModule' in instances for composite analyses.
-  analyzeModule :: (Module (Subterm term (outer value)) -> m value)
+  analyzeModule :: (Module (Subterm term (outer value)) -> m effects value)
-                -> (Module (Subterm term (outer value)) -> m value)
+                -> (Module (Subterm term (outer value)) -> m effects value)
-
-  -- | Isolate the given action with an empty global environment and exports.
-  isolate :: m a -> m a
-  isolate = withEnv mempty . withExports mempty
 
 
 -- | Lift a 'SubtermAlgebra' for an underlying analysis into a containing analysis. Use this when defining an analysis which can be composed onto other analyses to ensure that a call to 'analyzeTerm' occurs in the inner analysis and not the outer one.
@@ -51,31 +39,3 @@ liftAnalyze :: Coercible (  m effects value) (t m (effects :: [* -> *]) value)
             => ((base (Subterm term (outer value)) ->   m effects value) -> (base (Subterm term (outer value)) ->   m effects value))
             -> ((base (Subterm term (outer value)) -> t m effects value) -> (base (Subterm term (outer value)) -> t m effects value))
 liftAnalyze analyze recur term = coerce (analyze (coerceWith (sym Coercion) . recur) term)
-
-
--- | Run an analysis, performing its effects and returning the result alongside any state.
---
---   This enables us to refer to the analysis type as e.g. @Analysis1 (Analysis2 Evaluating) Term Value@ without explicitly mentioning its effects (which are inferred to be simply its 'Effects').
-runAnalysis :: ( Effectful m
-               , Effects location term value (m effects) ~ effects
-               , MonadAnalysis location term value (m effects)
-               , RunEffects effects a
-               )
-            => m effects a
-            -> Final effects a
-runAnalysis = X.run
-
-
--- | An abstraction over analyses.
-data SomeAnalysis m result where
-  SomeAnalysis :: ( Effectful m
-                  , effects ~ Effects location term value (m effects)
-                  , MonadAnalysis location term value (m effects)
-                  , RunEffects effects a
-                  )
-               => m effects a
-               -> SomeAnalysis m (Final effects a)
-
--- | Run an abstracted analysis.
-runSomeAnalysis :: SomeAnalysis m result -> result
-runSomeAnalysis (SomeAnalysis a) = X.run a

src/Control/Abstract/Evaluator.hs

@@ -1,34 +1,90 @@
-{-# LANGUAGE ConstrainedClassMethods, DataKinds, FunctionalDependencies, RankNTypes, TypeFamilies, UndecidableInstances #-}
+{-# LANGUAGE ConstrainedClassMethods, FunctionalDependencies, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-}
 module Control.Abstract.Evaluator
-  ( MonadEvaluator(..)
+  ( MonadEvaluator
-  , MonadEnvironment(..)
+  -- * State
+  , EvaluatorState(..)
+  -- * Environment
+  , getEnv
+  , putEnv
   , modifyEnv
+  , withEnv
+  , defaultEnvironment
+  , withDefaultEnvironment
+  , fullEnvironment
+  , localEnv
+  , localize
+  , lookupEnv
+  , lookupWith
+  -- * Exports
+  , getExports
+  , putExports
   , modifyExports
   , addExport
-  , fullEnvironment
+  , withExports
-  , MonadHeap(..)
+  , isolate
+  -- * Heap
+  , getHeap
+  , putHeap
   , modifyHeap
-  , localize
   , lookupHeap
   , assign
-  , MonadModuleTable(..)
+  -- * Roots
+  , askRoots
+  , extraRoots
+  -- * Configuration
+  , getConfiguration
+  -- * Module tables
+  , getModuleTable
+  , putModuleTable
   , modifyModuleTable
-  , MonadControl(..)
+  , askModuleTable
-  , MonadThrow(..)
+  , localModuleTable
+  , getLoadStack
+  , putLoadStack
+  , modifyLoadStack
+  , currentModule
+  , currentPackage
+  -- * Control
+  , label
+  , goto
+  -- * Effects
+  , EvalClosure(..)
+  , evaluateClosureBody
+  , EvalModule(..)
+  , evaluateModule
+  , Return(..)
+  , earlyReturn
+  , catchReturn
+  , LoopControl(..)
+  , throwBreak
+  , throwContinue
+  , catchLoopControl
+  -- * Origin
+  , pushOrigin
   ) where
 
 import Control.Effect
-import Control.Monad.Effect.Resumable
+import qualified Control.Monad.Effect as Eff
+import Control.Monad.Effect.Fail
+import Control.Monad.Effect.Reader
+import Control.Monad.Effect.State
 import Data.Abstract.Address
 import Data.Abstract.Configuration
 import Data.Abstract.Environment as Env
 import Data.Abstract.Exports as Export
 import Data.Abstract.FreeVariables
 import Data.Abstract.Heap
+import Data.Abstract.Live
 import Data.Abstract.Module
 import Data.Abstract.ModuleTable
+import Data.Abstract.Package
+import Data.Abstract.Origin
+import qualified Data.IntMap as IntMap
 import Data.Semigroup.Reducer
-import Prologue hiding (throwError)
+import Data.Semilattice.Lower
+import Lens.Micro
+import Prelude hiding (fail)
+import Prologue
 
 -- | A 'Monad' providing the basic essentials for evaluation.
 --
@@ -36,140 +92,336 @@ import Prologue hiding (throwError)
 --   - environments binding names to addresses
 --   - a heap mapping addresses to (possibly sets of) values
 --   - tables of modules available for import
-class ( MonadControl term m
+class ( Effectful m
-      , MonadEnvironment location value m
+      , Member (Reader (Environment location value)) effects
-      , MonadFail m
+      , Member (Reader (ModuleTable [Module term])) effects
-      , MonadModuleTable location term value m
+      , Member (Reader (SomeOrigin term)) effects
-      , MonadHeap location value m
+      , Member (State (EvaluatorState location term value)) effects
+      , Monad (m effects)
       )
-      => MonadEvaluator location term value m | m -> location, m -> term, m -> value where
+   => MonadEvaluator location term value effects m | m effects -> location term value
-  -- | Get the current 'Configuration' with a passed-in term.
-  getConfiguration :: Ord location => term -> m (Configuration location term value)
 
--- | A 'Monad' abstracting local and global environments.
-class Monad m => MonadEnvironment location value m | m -> value, m -> location where
-  -- | Retrieve the environment.
-  getEnv :: m (Environment location value)
-  -- | Set the environment.
-  putEnv :: Environment location value -> m ()
-  -- | Sets the environment for the lifetime of the given action.
-  withEnv :: Environment location value -> m a -> m a
 
-  -- | Retrieve the default environment.
+-- State
-  defaultEnvironment :: m (Environment location value)
 
-  -- | Set the default environment for the lifetime of an action.
+data EvaluatorState location term value = EvaluatorState
-  --   Usually only invoked in a top-level evaluation function.
+  { environment :: Environment location value
-  withDefaultEnvironment :: Environment location value -> m a -> m a
+  , heap        :: Heap location value
+  , modules     :: ModuleTable (Environment location value, value)
+  , loadStack   :: LoadStack
+  , exports     :: Exports location value
+  , jumps       :: IntMap.IntMap (SomeOrigin term, term)
+  }
 
-  -- | Get the global export state.
+deriving instance (Eq (Cell location value), Eq location, Eq term, Eq value, Eq (Base term ())) => Eq (EvaluatorState location term value)
-  getExports :: m (Exports location value)
+deriving instance (Ord (Cell location value), Ord location, Ord term, Ord value, Ord (Base term ())) => Ord (EvaluatorState location term value)
-  -- | Set the global export state.
+deriving instance (Show (Cell location value), Show location, Show term, Show value, Show (Base term ())) => Show (EvaluatorState location term value)
-  putExports :: Exports location value -> m ()
-  -- | Sets the global export state for the lifetime of the given action.
-  withExports :: Exports location value -> m a -> m a
 
-  -- | Run an action with a locally-modified environment.
+instance Lower (EvaluatorState location term value) where
-  localEnv :: (Environment location value -> Environment location value) -> m a -> m a
+  lowerBound = EvaluatorState lowerBound lowerBound lowerBound lowerBound lowerBound lowerBound
 
-  -- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
-  lookupEnv :: Name -> m (Maybe (Address location value))
-  lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)
 
-  -- | Look up a 'Name' in the environment, running an action with the resolved address (if any).
+-- Lenses
-  lookupWith :: (Address location value -> m a) -> Name -> m (Maybe a)
-  lookupWith with name = do
-    addr <- lookupEnv name
-    maybe (pure Nothing) (fmap Just . with) addr
 
--- | Run a computation in a new local environment.
+_environment :: Lens' (EvaluatorState location term value) (Environment location value)
-localize :: MonadEnvironment location value m => m a -> m a
+_environment = lens environment (\ s e -> s {environment = e})
-localize = localEnv id
+
+_heap :: Lens' (EvaluatorState location term value) (Heap location value)
+_heap = lens heap (\ s h -> s {heap = h})
+
+_modules :: Lens' (EvaluatorState location term value) (ModuleTable (Environment location value, value))
+_modules = lens modules (\ s m -> s {modules = m})
+
+_loadStack :: Lens' (EvaluatorState location term value) LoadStack
+_loadStack = lens loadStack (\ s l -> s {loadStack = l})
+
+_exports :: Lens' (EvaluatorState location term value) (Exports location value)
+_exports = lens exports (\ s e -> s {exports = e})
+
+_jumps :: Lens' (EvaluatorState location term value) (IntMap.IntMap (SomeOrigin term, term))
+_jumps = lens jumps (\ s j -> s {jumps = j})
+
+
+(.=) :: MonadEvaluator location term value effects m => ASetter (EvaluatorState location term value) (EvaluatorState location term value) a b -> b -> m effects ()
+lens .= val = raise (modify' (lens .~ val))
+
+view :: MonadEvaluator location term value effects m => Getting a (EvaluatorState location term value) a -> m effects a
+view lens = raise (gets (^. lens))
+
+localEvaluatorState :: MonadEvaluator location term value effects m => Lens' (EvaluatorState location term value) prj -> (prj -> prj) -> m effects a -> m effects a
+localEvaluatorState lens f action = do
+  original <- view lens
+  lens .= f original
+  v <- action
+  v <$ lens .= original
+
+
+-- Environment
+
+-- | Retrieve the environment.
+getEnv :: MonadEvaluator location term value effects m => m effects (Environment location value)
+getEnv = view _environment
+
+-- | Set the environment.
+putEnv :: MonadEvaluator location term value effects m => Environment location value -> m effects ()
+putEnv = (_environment .=)
 
 -- | Update the global environment.
-modifyEnv :: MonadEnvironment location value m => (Environment location value -> Environment location value) -> m ()
+modifyEnv :: MonadEvaluator location term value effects m => (Environment location value -> Environment location value) -> m effects ()
 modifyEnv f = do
   env <- getEnv
   putEnv $! f env
 
+-- | Sets the environment for the lifetime of the given action.
+withEnv :: MonadEvaluator location term value effects m => Environment location value -> m effects a -> m effects a
+withEnv s = localEvaluatorState _environment (const s)
+
+
+-- | Retrieve the default environment.
+defaultEnvironment :: MonadEvaluator location term value effects m => m effects (Environment location value)
+defaultEnvironment = raise ask
+
+-- | Set the default environment for the lifetime of an action.
+--   Usually only invoked in a top-level evaluation function.
+withDefaultEnvironment :: MonadEvaluator location term value effects m => Environment location value -> m effects a -> m effects a
+withDefaultEnvironment e = raiseHandler (local (const e))
+
+-- | Obtain an environment that is the composition of the current and default environments.
+--   Useful for debugging.
+fullEnvironment :: MonadEvaluator location term value effects m => m effects (Environment location value)
+fullEnvironment = mergeEnvs <$> getEnv <*> defaultEnvironment
+
+-- | Run an action with a locally-modified environment.
+localEnv :: MonadEvaluator location term value effects m => (Environment location value -> Environment location value) -> m effects a -> m effects a
+localEnv f a = do
+  modifyEnv (f . Env.push)
+  result <- a
+  result <$ modifyEnv Env.pop
+
+-- | Run a computation in a new local environment.
+localize :: MonadEvaluator location term value effects m => m effects a -> m effects a
+localize = localEnv id
+
+-- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
+lookupEnv :: MonadEvaluator location term value effects m => Name -> m effects (Maybe (Address location value))
+lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)
+
+-- | Look up a 'Name' in the environment, running an action with the resolved address (if any).
+lookupWith :: MonadEvaluator location term value effects m => (Address location value -> m effects a) -> Name -> m effects (Maybe a)
+lookupWith with name = do
+  addr <- lookupEnv name
+  maybe (pure Nothing) (fmap Just . with) addr
+
+
+-- Exports
+
+-- | Get the global export state.
+getExports :: MonadEvaluator location term value effects m => m effects (Exports location value)
+getExports = view _exports
+
+-- | Set the global export state.
+putExports :: MonadEvaluator location term value effects m => Exports location value -> m effects ()
+putExports = (_exports .=)
+
 -- | Update the global export state.
-modifyExports :: MonadEnvironment location value m => (Exports location value -> Exports location value) -> m ()
+modifyExports :: MonadEvaluator location term value effects m => (Exports location value -> Exports location value) -> m effects ()
 modifyExports f = do
   exports <- getExports
   putExports $! f exports
 
 -- | Add an export to the global export state.
-addExport :: MonadEnvironment location value m => Name -> Name -> Maybe (Address location value) -> m ()
+addExport :: MonadEvaluator location term value effects m => Name -> Name -> Maybe (Address location value) -> m effects ()
 addExport name alias = modifyExports . Export.insert name alias
 
--- | Obtain an environment that is the composition of the current and default environments.
+-- | Sets the global export state for the lifetime of the given action.
---   Useful for debugging.
+withExports :: MonadEvaluator location term value effects m => Exports location value -> m effects a -> m effects a
-fullEnvironment :: MonadEnvironment location value m => m (Environment location value)
+withExports s = localEvaluatorState _exports (const s)
-fullEnvironment = mappend <$> getEnv <*> defaultEnvironment
 
--- | A 'Monad' abstracting a heap of values.
+-- | Isolate the given action with an empty global environment and exports.
-class Monad m => MonadHeap location value m | m -> value, m -> location where
+isolate :: MonadEvaluator location term value effects m => m effects a -> m effects a
-  -- | Retrieve the heap.
+isolate = withEnv lowerBound . withExports lowerBound
-  getHeap :: m (Heap location value)
+
-  -- | Set the heap.
+
-  putHeap :: Heap location value -> m ()
+-- Heap
+
+-- | Retrieve the heap.
+getHeap :: MonadEvaluator location term value effects m => m effects (Heap location value)
+getHeap = view _heap
+
+-- | Set the heap.
+putHeap :: MonadEvaluator location term value effects m => Heap location value -> m effects ()
+putHeap = (_heap .=)
 
 -- | Update the heap.
-modifyHeap :: MonadHeap location value m => (Heap location value -> Heap location value) -> m ()
+modifyHeap :: MonadEvaluator location term value effects m => (Heap location value -> Heap location value) -> m effects ()
 modifyHeap f = do
   s <- getHeap
   putHeap $! f s
 
 -- | Look up the cell for the given 'Address' in the 'Heap'.
-lookupHeap :: (MonadHeap location value m, Ord location) => Address location value -> m (Maybe (Cell location value))
+lookupHeap :: (MonadEvaluator location term value effects m, Ord location) => Address location value -> m effects (Maybe (Cell location value))
 lookupHeap = flip fmap getHeap . heapLookup
 
 -- | Write a value to the given 'Address' in the 'Store'.
 assign :: ( Ord location
-          , MonadHeap location value m
+          , MonadEvaluator location term value effects m
           , Reducer value (Cell location value)
           )
        => Address location value
        -> value
-       -> m ()
+       -> m effects ()
 assign address = modifyHeap . heapInsert address
 
 
--- | A 'Monad' abstracting tables of modules available for import.
+-- Roots
-class Monad m => MonadModuleTable location term value m | m -> location, m -> term, m -> value where
-  -- | Retrieve the table of evaluated modules.
-  getModuleTable :: m (ModuleTable (Environment location value, value))
-  -- | Set the table of evaluated modules.
-  putModuleTable :: ModuleTable (Environment location value, value) -> m ()
 
-  -- | Retrieve the table of unevaluated modules.
+-- | Retrieve the local 'Live' set.
-  askModuleTable :: m (ModuleTable [Module term])
+askRoots :: (Effectful m, Member (Reader (Live location value)) effects) => m effects (Live location value)
-  -- | Run an action with a locally-modified table of unevaluated modules.
+askRoots = raise ask
-  localModuleTable :: (ModuleTable [Module term] -> ModuleTable [Module term]) -> m a -> m a
 
-  -- | Get the currently evaluating 'ModuleInfo'.
+-- | Run a computation with the given 'Live' set added to the local root set.
-  currentModule :: m ModuleInfo
+extraRoots :: (Effectful m, Member (Reader (Live location value)) effects, Ord location) => Live location value -> m effects a -> m effects a
+extraRoots roots = raiseHandler (local (<> roots))
+
+
+-- Configuration
+
+-- | Get the current 'Configuration' with a passed-in term.
+getConfiguration :: (Member (Reader (Live location value)) effects, MonadEvaluator location term value effects m) => term -> m effects (Configuration location term value)
+getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap
+
+
+-- Module table
+
+-- | Retrieve the table of evaluated modules.
+getModuleTable :: MonadEvaluator location term value effects m => m effects (ModuleTable (Environment location value, value))
+getModuleTable = view _modules
+
+-- | Set the table of evaluated modules.
+putModuleTable :: MonadEvaluator location term value effects m => ModuleTable (Environment location value, value) -> m effects ()
+putModuleTable = (_modules .=)
 
 -- | Update the evaluated module table.
-modifyModuleTable :: MonadModuleTable location term value m => (ModuleTable (Environment location value, value) -> ModuleTable (Environment location value, value)) -> m ()
+modifyModuleTable :: MonadEvaluator location term value effects m => (ModuleTable (Environment location value, value) -> ModuleTable (Environment location value, value)) -> m effects ()
 modifyModuleTable f = do
   table <- getModuleTable
   putModuleTable $! f table
 
 
--- | A 'Monad' abstracting jumps in imperative control.
+-- | Retrieve the table of unevaluated modules.
-class Monad m => MonadControl term m where
+askModuleTable :: MonadEvaluator location term value effects m => m effects (ModuleTable [Module term])
-  -- | Allocate a 'Label' for the given @term@.
+askModuleTable = raise ask
-  --
+
-  --   Labels must be allocated before being jumped to with 'goto', but are suitable for nonlocal jumps; thus, they can be used to implement coroutines, exception handling, call with current continuation, and other esoteric control mechanisms.
+-- | Run an action with a locally-modified table of unevaluated modules.
-  label :: term -> m Label
+localModuleTable :: MonadEvaluator location term value effects m => (ModuleTable [Module term] -> ModuleTable [Module term]) -> m effects a -> m effects a
-  -- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated in e.g. a 'MonadAnalysis' instance).
+localModuleTable f = raiseHandler (local f)
-  goto :: Label -> m term
 
 
--- | 'Monad's which can throw exceptions of type @exc v@ which can be resumed with a value of type @v@.
+-- | Retrieve the module load stack
-class Monad m => MonadThrow exc m where
+getLoadStack :: MonadEvaluator location term value effects m => m effects LoadStack
-  throwException :: exc v -> m v
+getLoadStack = view _loadStack
 
-instance (Effectful m, Members '[Resumable exc] effects, Monad (m effects)) => MonadThrow exc (m effects) where
+-- | Set the module load stack
-  throwException = raise . throwError
+putLoadStack :: MonadEvaluator location term value effects m => LoadStack -> m effects ()
+putLoadStack = (_loadStack .=)
+
+-- | Update the module load stack.
+modifyLoadStack :: MonadEvaluator location term value effects m => (LoadStack -> LoadStack) -> m effects ()
+modifyLoadStack f = do
+  stack <- getLoadStack
+  putLoadStack $! f stack
+
+
+-- | Get the currently evaluating 'ModuleInfo'.
+currentModule :: forall location term value effects m . (Member Fail effects, MonadEvaluator location term value effects m) => m effects ModuleInfo
+currentModule = do
+  o <- raise ask
+  maybeM (raise (fail "unable to get currentModule")) $ withSomeOrigin (originModule @term) o
+
+-- | Get the currently evaluating 'PackageInfo'.
+currentPackage :: forall location term value effects m . (Member Fail effects, MonadEvaluator location term value effects m) => m effects PackageInfo
+currentPackage = do
+  o <- raise ask
+  maybeM (raise (fail "unable to get currentPackage")) $ withSomeOrigin (originPackage @term) o
+
+
+-- Control
+
+-- | Allocate a 'Label' for the given @term@.
+--
+--   Labels must be allocated before being jumped to with 'goto', but are suitable for nonlocal jumps; thus, they can be used to implement coroutines, exception handling, call with current continuation, and other esoteric control mechanisms.
+label :: MonadEvaluator location term value effects m => term -> m effects Label
+label term = do
+  m <- view _jumps
+  origin <- raise ask
+  let i = IntMap.size m
+  _jumps .= IntMap.insert i (origin, term) m
+  pure i
+
+-- | “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 :: (Recursive term, Member Fail effects, MonadEvaluator location term value effects m) => Label -> (term -> m effects a) -> m effects a
+goto label comp = do
+  maybeTerm <- IntMap.lookup label <$> view _jumps
+  case maybeTerm of
+    Just (origin, term) -> pushOrigin (origin <> termOrigin term) (comp term)
+    Nothing -> raise (fail ("unknown label: " <> show label))
+
+
+-- Effects
+
+-- | An effect to evaluate a closure’s body.
+data EvalClosure term value resume where
+  EvalClosure :: term -> EvalClosure term value value
+
+evaluateClosureBody :: (Effectful m, Member (EvalClosure term value) effects) => term -> m effects value
+evaluateClosureBody = raise . Eff.send . EvalClosure
+
+
+-- | An effect to evaluate a module.
+data EvalModule term value resume where
+  EvalModule :: Module term -> EvalModule term value value
+
+evaluateModule :: (Effectful m, Member (EvalModule term value) effects) => Module term -> m effects value
+evaluateModule = raise . Eff.send . EvalModule
+
+
+-- | An effect for explicitly returning out of a function/method body.
+data Return value resume where
+  Return :: value -> Return value value
+
+deriving instance Eq value => Eq (Return value a)
+deriving instance Show value => Show (Return value a)
+
+earlyReturn :: (Effectful m, Member (Return value) effects) => value -> m effects value
+earlyReturn = raise . Eff.send . Return
+
+catchReturn :: (Effectful m, Member (Return value) effects) => m effects a -> (forall x . Return value x -> m effects a) -> m effects a
+catchReturn action handler = raiseHandler (Eff.interpose pure (\ ret _ -> lower (handler ret))) action
+
+
+-- | Effects for control flow around loops (breaking and continuing).
+data LoopControl value resume where
+  Break :: value -> LoopControl value value
+  Continue :: LoopControl value value
+
+deriving instance Eq value => Eq (LoopControl value a)
+deriving instance Show value => Show (LoopControl value a)
+
+throwBreak :: (Effectful m, Member (LoopControl value) effects) => value -> m effects value
+throwBreak = raise . Eff.send . Break
+
+throwContinue :: (Effectful m, Member (LoopControl value) effects) => m effects value
+throwContinue = raise (Eff.send Continue)
+
+catchLoopControl :: (Effectful m, Member (LoopControl value) effects) => m effects a -> (forall x . LoopControl value x -> m effects a) -> m effects a
+catchLoopControl action handler = raiseHandler (Eff.interpose pure (\ control _ -> lower (handler control))) action
+
+
+-- | Push a 'SomeOrigin' onto the stack. This should be used to contextualize execution with information about the originating term, module, or package.
+pushOrigin :: ( Effectful m
+              , Member (Reader (SomeOrigin term)) effects
+              )
+           => SomeOrigin term
+           -> m effects a
+           -> m effects a
+pushOrigin o = raiseHandler (local (<> o))

src/Control/Abstract/Value.hs

@@ -1,13 +1,13 @@
-{-# LANGUAGE FunctionalDependencies, GADTs, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE FunctionalDependencies, GADTs, KindSignatures, Rank2Types #-}
 module Control.Abstract.Value
 ( MonadValue(..)
+, AbstractHole(..)
 , Comparator(..)
 , while
 , doWhile
 , forLoop
 , makeNamespace
 , ValueRoots(..)
-, ValueError(..)
 ) where
 
 import Control.Abstract.Evaluator
@@ -18,6 +18,7 @@ import Data.Abstract.Live (Live)
 import Data.Abstract.Number as Number
 import Data.Scientific (Scientific)
 import Data.Semigroup.Reducer hiding (unit)
+import Data.Semilattice.Lower
 import Prelude
 import Prologue hiding (TypeError)
 
@@ -31,153 +32,162 @@ data Comparator
   = Concrete (forall a . Ord a => a -> a -> Bool)
   | Generalized
 
+class AbstractHole value where
+  hole :: value
+
 -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc).
 --
 --   This allows us to abstract the choice of whether to evaluate under binders for different value types.
-class (Monad m, Show value) => MonadValue location value m | m value -> location where
+class (Monad (m effects), Show value) => MonadValue location value (effects :: [* -> *]) m | m effects value -> location where
   -- | Construct an abstract unit value.
   --   TODO: This might be the same as the empty tuple for some value types
-  unit :: m value
+  unit :: m effects value
 
   -- | Construct an abstract integral value.
-  integer :: Prelude.Integer -> m value
+  integer :: Prelude.Integer -> m effects value
 
   -- | Lift a unary operator over a 'Num' to a function on 'value's.
   liftNumeric  :: (forall a . Num a => a -> a)
-               -> (value -> m value)
+               -> (value -> m effects value)
 
   -- | Lift a pair of binary operators to a function on 'value's.
   --   You usually pass the same operator as both arguments, except in the cases where
   --   Haskell provides different functions for integral and fractional operations, such
   --   as division, exponentiation, and modulus.
   liftNumeric2 :: (forall a b. Number a -> Number b -> SomeNumber)
-               -> (value -> value -> m value)
+               -> (value -> value -> m effects value)
 
   -- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values.
-  liftComparison :: Comparator -> (value -> value -> m value)
+  liftComparison :: Comparator -> (value -> value -> m effects value)
 
   -- | Lift a unary bitwise operator to values. This is usually 'complement'.
   liftBitwise :: (forall a . Bits a => a -> a)
-              -> (value -> m value)
+              -> (value -> m effects value)
 
   -- | Lift a binary bitwise operator to values. The Integral constraint is
   --   necessary to satisfy implementation details of Haskell left/right shift,
   --   but it's fine, since these are only ever operating on integral values.
   liftBitwise2 :: (forall a . (Integral a, Bits a) => a -> a -> a)
-               -> (value -> value -> m value)
+               -> (value -> value -> m effects value)
 
   -- | Construct an abstract boolean value.
-  boolean :: Bool -> m value
+  boolean :: Bool -> m effects value
 
   -- | Construct an abstract string value.
-  string :: ByteString -> m value
+  string :: ByteString -> m effects value
 
   -- | Construct a self-evaluating symbol value.
   --   TODO: Should these be interned in some table to provide stronger uniqueness guarantees?
-  symbol :: ByteString -> m value
+  symbol :: ByteString -> m effects value
 
   -- | Construct a floating-point value.
-  float :: Scientific -> m value
+  float :: Scientific -> m effects value
 
   -- | Construct a rational value.
-  rational :: Prelude.Rational -> m value
+  rational :: Prelude.Rational -> m effects value
 
   -- | Construct an N-ary tuple of multiple (possibly-disjoint) values
-  multiple :: [value] -> m value
+  multiple :: [value] -> m effects value
 
   -- | Construct an array of zero or more values.
-  array :: [value] -> m value
+  array :: [value] -> m effects value
 
   -- | Construct a key-value pair for use in a hash.
-  kvPair :: value -> value -> m value
+  kvPair :: value -> value -> m effects value
 
   -- | Extract the contents of a key-value pair as a tuple.
-  asPair :: value -> m (value, value)
+  asPair :: value -> m effects (value, value)
 
   -- | Construct a hash out of pairs.
-  hash :: [(value, value)] -> m value
+  hash :: [(value, value)] -> m effects value
 
   -- | Extract a 'ByteString' from a given value.
-  asString :: value -> m ByteString
+  asString :: value -> m effects ByteString
 
   -- | Eliminate boolean values. TODO: s/boolean/truthy
-  ifthenelse :: value -> m value -> m value -> m value
+  ifthenelse :: value -> m effects value -> m effects value -> m effects value
 
   -- | Extract a 'Bool' from a given value.
-  asBool :: value -> m Bool
+  asBool :: value -> m effects Bool
 
   -- | Construct the nil/null datatype.
-  null :: m value
+  null :: m effects value
+
+  -- | @index x i@ computes @x[i]@, with zero-indexing.
+  index :: value -> value -> m effects value
+
+  -- | Determine whether the given datum is a 'Hole'.
+  isHole :: value -> m effects Bool
 
   -- | Build a class value from a name and environment.
   klass :: Name                       -- ^ The new class's identifier
         -> [value]                    -- ^ A list of superclasses
         -> Environment location value -- ^ The environment to capture
-        -> m value
+        -> m effects value
 
   -- | Build a namespace value from a name and environment stack
   --
   -- Namespaces model closures with monoidal environments.
   namespace :: Name                       -- ^ The namespace's identifier
             -> Environment location value -- ^ The environment to mappend
-            -> m value
+            -> m effects value
 
   -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
-  scopedEnvironment :: value -> m (Environment location value)
+  scopedEnvironment :: value -> m effects (Maybe (Environment location value))
 
   -- | Evaluate an abstraction (a binder like a lambda or method definition).
-  lambda :: (FreeVariables term, MonadControl term m) => [Name] -> Subterm term (m value) -> m value
+  lambda :: (FreeVariables term, MonadEvaluator location term value effects m) => [Name] -> Subterm term (m effects value) -> m effects value
   -- | Evaluate an application (like a function call).
-  call :: value -> [m value] -> m value
+  call :: value -> [m effects value] -> m effects value
 
   -- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion.
   --
   --   The function argument takes an action which recurs through the loop.
-  loop :: (m value -> m value) -> m value
+  loop :: (m effects value -> m effects value) -> m effects value
 
 
 -- | Attempt to extract a 'Prelude.Bool' from a given value.
-forLoop :: (MonadEnvironment location value m, MonadValue location value m)
+forLoop :: (MonadEvaluator location term value effects m, MonadValue location value effects m)
-        => m value -- ^ Initial statement
+        => m effects value -- ^ Initial statement
-        -> m value -- ^ Condition
+        -> m effects value -- ^ Condition
-        -> m value -- ^ Increment/stepper
+        -> m effects value -- ^ Increment/stepper
-        -> m value -- ^ Body
+        -> m effects value -- ^ Body
-        -> m value
+        -> m effects value
 forLoop initial cond step body =
   localize (initial *> while cond (body *> step))
 
 -- | The fundamental looping primitive, built on top of ifthenelse.
-while :: MonadValue location value m
+while :: MonadValue location value effects m
-      => m value
+      => m effects value
-      -> m value
+      -> m effects value
-      -> m value
+      -> m effects value
 while cond body = loop $ \ continue -> do
   this <- cond
   ifthenelse this (body *> continue) unit
 
 -- | Do-while loop, built on top of while.
-doWhile :: MonadValue location value m
+doWhile :: MonadValue location value effects m
-        => m value
+        => m effects value
-        -> m value
+        -> m effects value
-        -> m value
+        -> m effects value
 doWhile body cond = loop $ \ continue -> body *> do
   this <- cond
   ifthenelse this continue unit
 
-makeNamespace :: ( MonadValue location value m
+makeNamespace :: ( MonadValue location value effects m
-                 , MonadEnvironment location value m
+                 , MonadEvaluator location term value effects m
-                 , MonadHeap location value m
                  , Ord location
                  , Reducer value (Cell location value)
                  )
               => Name
               -> Address location value
-              -> [value]
+              -> Maybe value
-              -> m value
+              -> m effects value
-makeNamespace name addr supers = do
+makeNamespace name addr super = do
-  superEnv <- mconcat <$> traverse scopedEnvironment supers
+  superEnv <- maybe (pure (Just lowerBound)) scopedEnvironment super
+  let env' = fromMaybe lowerBound superEnv
   namespaceEnv <- Env.head <$> getEnv
-  v <- namespace name (Env.mergeNewer superEnv namespaceEnv)
+  v <- namespace name (Env.mergeNewer env' namespaceEnv)
   v <$ assign addr v
 
 
@@ -185,26 +195,3 @@ makeNamespace name addr supers = do
 class ValueRoots location value where
   -- | Compute the set of addresses rooted by a given value.
   valueRoots :: value -> Live location value
-
-
--- The type of exceptions that can be thrown when constructing values in `MonadValue`.
-data ValueError location value resume where
-  StringError            :: value          -> ValueError location value ByteString
-  NamespaceError         :: Prelude.String -> ValueError location value (Environment location value)
-  ScopedEnvironmentError :: Prelude.String -> ValueError location value (Environment location value)
-  CallError              :: value          -> ValueError location value value
-  BoolError              :: value          -> ValueError location value Bool
-  Numeric2Error          :: value          -> value -> ValueError location value value
-
-instance Eq value => Eq1 (ValueError location value) where
-  liftEq _ (StringError a) (StringError b)                       = a == b
-  liftEq _ (NamespaceError a) (NamespaceError b)                 = a == b
-  liftEq _ (ScopedEnvironmentError a) (ScopedEnvironmentError b) = a == b
-  liftEq _ (CallError a) (CallError b)                           = a == b
-  liftEq _ (BoolError a) (BoolError c)                           = a == c
-  liftEq _ (Numeric2Error a b) (Numeric2Error c d)               = (a == c) && (b == d)
-  liftEq _ _             _                                       = False
-
-deriving instance (Show value) => Show (ValueError location value resume)
-instance (Show value) => Show1 (ValueError location value) where
-  liftShowsPrec _ _ = showsPrec

src/Control/Effect.hs

@@ -1,92 +1,26 @@
-{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE FunctionalDependencies, RankNTypes, TypeFamilies, TypeOperators #-}
 module Control.Effect
-( Control.Effect.run
+( Effectful(..)
-, RunEffects(..)
+, raiseHandler
-, RunEffect(..)
+, Interpreter(..)
-, Effectful(..)
+, throwResumable
-, resumeException
+, resume
-, mergeEither
 ) where
 
-import Control.Monad.Effect as Effect
+import Control.Monad.Effect           as Effect
-import Control.Monad.Effect.Fail
+import Control.Monad.Effect.Resumable as Resumable
-import Control.Monad.Effect.NonDet
-import Control.Monad.Effect.Reader
-import Control.Monad.Effect.Resumable
-import Control.Monad.Effect.State
-import Control.Monad.Effect.Writer
-import Data.Semigroup.Reducer
-import Prologue
 
--- | Run an 'Effectful' computation to completion, interpreting each effect with some sensible defaults, and return the 'Final' result.
+throwResumable :: (Member (Resumable exc) effects, Effectful m) => exc v -> m effects v
-run :: (Effectful m, RunEffects effects a) => m effects a -> Final effects a
+throwResumable = raise . throwError
-run = runEffects . lower
 
--- | A typeclass to run a computation to completion, interpreting each effect with some sensible defaults.
+resume :: (Member (Resumable exc) e, Effectful m) => m e a -> (forall v . (v -> m e a) -> exc v -> m e a) -> m e a
-class RunEffects fs a where
+resume m handle = raise (resumeError (lower m) (\yield -> lower . handle (raise . yield)))
-  -- | The final result type of the computation, factoring in the results of any effects, e.g. pairing 'State' results with the final state, wrapping 'Fail' results in 'Either', etc.
-  type Final fs a
-  runEffects :: Eff fs a -> Final fs a
-
-instance (RunEffect f a, RunEffects fs (Result f a)) => RunEffects (f ': fs) a where
-  type Final (f ': fs) a = Final fs (Result f a)
-  runEffects = runEffects . runEffect
-
-instance RunEffects '[] a where
-  type Final '[] a = a
-  runEffects = Effect.run
-
-
--- | A typeclass to interpret a single effect with some sensible defaults (defined per-effect).
-class RunEffect f a where
-  -- | The incremental result of an effect w.r.t. the parameter value, factoring in the interpretation of the effect.
-  type Result f a
-  type instance Result f a = a
-
-  -- | Interpret the topmost effect in a computation with some sensible defaults (defined per-effect), and return the incremental 'Result'.
-  runEffect :: Eff (f ': fs) a -> Eff fs (Result f a)
-
--- | 'State' effects with 'Monoid'al states are interpreted starting from the 'mempty' state value into a pair of result value and final state.
-instance Monoid b => RunEffect (State b) a where
-  type Result (State b) a = (a, b)
-  runEffect = flip runState mempty
-
--- | 'Reader' effects with 'Monoid'al environments are interpreted starting from the 'mempty' environment value.
-instance Monoid b => RunEffect (Reader b) a where
-  runEffect = flip runReader mempty
-
--- | 'Fail' effects are interpreted into 'Either' s.t. failures are in 'Left' and successful results are in 'Right'.
-instance RunEffect Fail a where
-  type Result Fail a = Either String a
-  runEffect = runFail
-
--- | 'Writer' effects are interpreted into a pair of result value and final log.
-instance Monoid w => RunEffect (Writer w) a where
-  type Result (Writer w) a = (a, w)
-  runEffect = runWriter
-
--- | 'NonDet' effects are interpreted into a nondeterministic set of result values.
-instance Ord a => RunEffect NonDet a where
-  type Result NonDet a = Set a
-  runEffect = runNonDet unit
-
--- | 'Resumable' effects are interpreted into 'Either' s.t. failures are in 'Left' and successful results are in 'Right'.
-instance RunEffect (Resumable exc) a where
-  type Result (Resumable exc) a = Either (SomeExc exc) a
-  runEffect = runError
-
-resumeException :: (Resumable exc :< e, Effectful m) => m e a -> (forall v . (v -> m e a) -> exc v -> m e a) -> m e a
-resumeException m handle = raise (resumeError (lower m) (\yield -> lower . handle (raise . yield)))
-
--- | Reassociate 'Either's, combining errors into 'Left' values and successes in a single level of 'Right'.
-mergeEither :: Either a (Either b c) -> Either (Either a b) c
-mergeEither = either (Left . Left) (either (Left . Right) Right)
 
 
 -- | Types wrapping 'Eff' actions.
 --
 --   Most instances of 'Effectful' will be derived using @-XGeneralizedNewtypeDeriving@, with these ultimately bottoming out on the instance for 'Eff' (for which 'raise' and 'lower' are simply the identity). Because of this, types can be nested arbitrarily deeply and still call 'raise'/'lower' just once to get at the (ultimately) underlying 'Eff'.
-class Effectful (m :: [* -> *] -> * -> *) where
+class Effectful m where
   -- | Raise an action in 'Eff' into an action in @m@.
   raise :: Eff effects a -> m effects a
   -- | Lower an action in @m@ into an action in 'Eff'.
@@ -95,3 +29,18 @@ class Effectful (m :: [* -> *] -> * -> *) where
 instance Effectful Eff where
   raise = id
   lower = id
+
+raiseHandler :: Effectful m => (Eff effectsA a -> Eff effectsB b) -> m effectsA a -> m effectsB b
+raiseHandler handler = raise . handler . lower
+
+
+-- | Interpreters determine and interpret a list of effects, optionally taking extra arguments.
+--
+--   Instances will generally be defined recursively in terms of underlying interpreters, bottoming out with the instance for 'Eff' which uses 'Effect.run' to produce a final value.
+class Effectful m => Interpreter m effects | m -> effects where
+  type Result m effects result
+  type instance Result m effects result = result
+  interpret :: m effects result -> Result m effects result
+
+instance Interpreter Eff '[] where
+  interpret = Effect.run

src/Control/Effect/Fresh.hs

@@ -1,31 +0,0 @@
-{-# LANGUAGE GADTs, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
-module Control.Effect.Fresh where
-
-import Control.Effect
-import Control.Monad.Effect.Internal
-
--- | An effect offering a (resettable) sequence of always-incrementing, and therefore “fresh,” type variables.
-data Fresh a where
-  -- | Request a reset of the sequence of variable names.
-  Reset :: Int -> Fresh ()
-  -- | Request a fresh variable name.
-  Fresh :: Fresh Int
-
--- | 'Monad's offering a (resettable) sequence of guaranteed-fresh type variables.
-class Monad m => MonadFresh m where
-  -- | Get a fresh variable name, guaranteed unused (since the last 'reset').
-  fresh :: m Int
-
-  -- | Reset the sequence of variable names. Useful to avoid complicated alpha-equivalence comparisons when iteratively recomputing the results of an analysis til convergence.
-  reset :: Int -> m ()
-
-instance (Fresh :< fs) => MonadFresh (Eff fs) where
-  fresh = send Fresh
-  reset = send . Reset
-
-
--- | 'Fresh' effects are interpreted starting from 0, incrementing the current name with each request for a fresh name, and overwriting the counter on reset.
-instance RunEffect Fresh a where
-  runEffect = relayState (0 :: Int) (const pure) (\ s action k -> case action of
-    Fresh -> k (succ s) s
-    Reset s' -> k s' ())

src/Data/Abstract/Declarations.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Data.Abstract.Declarations  where
+
+import Data.Abstract.FreeVariables
+import Data.Term
+import Prologue
+
+class Declarations syntax where
+  declaredName :: syntax -> Maybe Name
+  declaredName = const Nothing
+
+class Declarations1 syntax where
+  -- | Lift a function mapping each element to its set of free variables through a containing structure, collecting the results into a single set.
+  liftDeclaredName :: (a -> [Name]) -> syntax a -> Maybe Name
+  liftDeclaredName _ _ = Nothing
+
+instance Declarations t => Declarations (Subterm t a) where
+  declaredName = declaredName . subterm
+
+instance (FreeVariables1 syntax, Declarations1 syntax, Functor syntax) => Declarations (Term syntax ann) where
+  declaredName = liftDeclaredName freeVariables . termOut
+
+instance (Apply Declarations1 fs) => Declarations1 (Union fs) where
+  liftDeclaredName f = apply (Proxy :: Proxy Declarations1) (liftDeclaredName f)
+
+instance Declarations1 []

src/Data/Abstract/Environment.hs

@@ -5,12 +5,15 @@ module Data.Abstract.Environment
   , bind
   , delete
   , head
+  , emptyEnv
+  , mergeEnvs
   , mergeNewer
   , insert
   , lookup
   , names
   , overwrite
   , pairs
+  , unpairs
   , pop
   , push
   , roots
@@ -22,13 +25,13 @@ import           Data.Abstract.FreeVariables
 import           Data.Abstract.Live
 import           Data.Align
 import qualified Data.Map as Map
-import           Data.Semigroup.Reducer
+import           Data.Semilattice.Lower
 import           GHC.Exts (IsList (..))
 import           Prologue
 import qualified Data.List.NonEmpty as NonEmpty
 
 -- $setup
--- >>> let bright = push (insert (name "foo") (Address (Precise 0)) mempty)
+-- >>> let bright = push (insert (name "foo") (Address (Precise 0)) emptyEnv)
 -- >>> let shadowed = insert (name "foo") (Address (Precise 1)) bright
 
 -- | A LIFO stack of maps of names to addresses, representing a lexically-scoped evaluation environment.
@@ -49,18 +52,12 @@ instance IsList (Environment l a) where
   fromList xs                   = Environment (Map.fromList xs :| [])
   toList (Environment (x :| _)) = Map.toList x
 
--- TODO: property-check me
+mergeEnvs :: Environment l a -> Environment l a -> Environment l a
-instance Semigroup (Environment l a) where
+mergeEnvs (Environment (a :| as)) (Environment (b :| bs)) =
-  Environment (a :| as) <> Environment (b :| bs) =
+  Environment ((<>) a b :| alignWith (mergeThese (<>)) as bs)
-    Environment ((a <> b) :| alignWith (mergeThese (<>)) as bs)
 
-instance Reducer (Name, Address l a) (Environment l a) where
+emptyEnv :: Environment l a
-  unit a = Environment (unit a :| [])
+emptyEnv = Environment (lowerBound :| [])
-
--- | This instance is possibly unlawful. If this breaks, you get to keep both pieces.
-instance Monoid (Environment l a) where
-  mappend = (<>)
-  mempty  = Environment (mempty :| [])
 
 -- | Make and enter a new empty scope in the given environment.
 push :: Environment l a -> Environment l a
@@ -68,7 +65,7 @@ push (Environment (a :| as)) = Environment (mempty :| a : as)
 
 -- | Remove the frontmost scope.
 pop :: Environment l a -> Environment l a
-pop (Environment (_ :| []))     = mempty
+pop (Environment (_ :| []))     = emptyEnv
 pop (Environment (_ :| a : as)) = Environment (a :| as)
 
 -- | Drop all scopes save for the frontmost one.
@@ -92,6 +89,9 @@ mergeNewer (Environment a) (Environment b) =
 pairs :: Environment l a -> [(Name, Address l a)]
 pairs = Map.toList . fold . unEnvironment
 
+unpairs :: [(Name, Address l a)] -> Environment l a
+unpairs = fromList
+
 -- | Lookup a 'Name' in the environment.
 --
 -- >>> lookup (name "foo") shadowed
@@ -115,19 +115,19 @@ trim (Environment (a :| as)) = Environment (a :| filtered)
   where filtered = filter (not . Map.null) as
 
 bind :: Foldable t => t Name -> Environment l a -> Environment l a
-bind names env = foldMap envForName names
+bind names env = fromList (mapMaybe lookupName (Prologue.toList names))
-  where envForName name = maybe mempty (curry unit name) (lookup name env)
+  where
+    lookupName name = (,) name <$> lookup name env
 
 -- | Get all bound 'Name's in an environment.
 names :: Environment l a -> [Name]
 names = fmap fst . pairs
 
--- | Overwrite a set of key-value bindings in the provided environment.
+-- | Lookup and alias name-value bindings from an environment.
 overwrite :: [(Name, Name)] -> Environment l a -> Environment l a
-overwrite pairs env = foldMap go pairs where
+overwrite pairs env = fromList $ mapMaybe lookupAndAlias pairs
-  go (k, v) = case lookup k env of
+  where
-    Nothing   -> mempty
+    lookupAndAlias (oldName, newName) = (,) newName <$> lookup oldName env
-    Just addr -> unit (v, addr)
 
 -- | Retrieve the 'Live' set of addresses to which the given free variable names are bound.
 --
@@ -137,3 +137,6 @@ roots env = foldMap (maybe mempty liveSingleton . flip lookup env)
 
 addresses :: Ord l => Environment l a -> Live l a
 addresses = Live . fromList . fmap snd . pairs
+
+
+instance Lower (Environment location value) where lowerBound = emptyEnv

src/Data/Abstract/Evaluatable.hs

@@ -1,80 +1,92 @@
-{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
 module Data.Abstract.Evaluatable
 ( module X
 , MonadEvaluatable
 , Evaluatable(..)
 , Unspecialized(..)
-, LoadError(..)
 , EvalError(..)
+, LoadError(..)
 , ResolutionError(..)
 , variable
-, evaluateTerm
+, evaluateInScopedEnv
-, evaluateModule
-, evaluateModules
 , evaluatePackage
 , evaluatePackageBody
-, throwLoadError
 , throwEvalError
-, throwValueError
 , resolve
+, traceResolve
 , listModulesInDir
 , require
 , load
-, pushOrigin
 ) where
 
 import           Control.Abstract.Addressable as X
-import           Control.Abstract.Analysis as X
+import           Control.Abstract.Analysis as X hiding (LoopControl(..), Return(..))
+import           Control.Abstract.Analysis (LoopControl, Return(..))
+import           Control.Monad.Effect as Eff
 import           Data.Abstract.Address
+import           Data.Abstract.Declarations as X
 import           Data.Abstract.Environment as X
 import qualified Data.Abstract.Exports as Exports
 import           Data.Abstract.FreeVariables as X
 import           Data.Abstract.Module
 import           Data.Abstract.ModuleTable as ModuleTable
-import           Data.Abstract.Origin (SomeOrigin, packageOrigin)
+import           Data.Abstract.Origin (packageOrigin)
 import           Data.Abstract.Package as Package
+import           Data.Language
+import           Data.Scientific (Scientific)
 import           Data.Semigroup.App
 import           Data.Semigroup.Foldable
 import           Data.Semigroup.Reducer hiding (unit)
 import           Data.Term
 import           Prologue
 
-type MonadEvaluatable location term value m =
+type MonadEvaluatable location term value effects m =
-  ( Evaluatable (Base term)
+  ( Declarations term
+  , Evaluatable (Base term)
   , FreeVariables term
-  , MonadAddressable location m
+  , Member (EvalClosure term value) effects
-  , MonadAnalysis location term value m
+  , Member (EvalModule term value) effects
-  , MonadThrow (Unspecialized value) m
+  , Member Fail effects
-  , MonadThrow (ValueError location value) m
+  , Member (LoopControl value) effects
-  , MonadThrow (LoadError term value) m
+  , Member (Resumable (Unspecialized value)) effects
-  , MonadThrow (EvalError value) m
+  , Member (Resumable (LoadError term)) effects
-  , MonadThrow (ResolutionError value) m
+  , Member (Resumable (EvalError value)) effects
-  , MonadValue location value m
+  , Member (Resumable (ResolutionError value)) effects
+  , Member (Resumable (AddressError location value)) effects
+  , Member (Return value) effects
+  , MonadAddressable location effects m
+  , MonadEvaluator location term value effects m
+  , MonadValue location value effects m
   , Recursive term
   , Reducer value (Cell location value)
-  , Show location
   )
 
 -- | An error thrown when we can't resolve a module from a qualified name.
 data ResolutionError value resume where
-  RubyError :: String -> ResolutionError value ModulePath
+  NotFoundError :: String   -- ^ The path that was not found.
+                -> [String] -- ^ List of paths searched that shows where semantic looked for this module.
+                -> Language -- ^ Language.
+                -> ResolutionError value ModulePath
+
+  GoImportError :: FilePath -> ResolutionError value [ModulePath]
 
 deriving instance Eq (ResolutionError a b)
 deriving instance Show (ResolutionError a b)
-instance Show1 (ResolutionError value) where
+instance Show1 (ResolutionError value) where liftShowsPrec _ _ = showsPrec
-  liftShowsPrec _ _ = showsPrec
 instance Eq1 (ResolutionError value) where
-  liftEq _ (RubyError a) (RubyError b) = a == b
+  liftEq _ (NotFoundError a _ l1) (NotFoundError b _ l2) = a == b && l1 == l2
+  liftEq _ (GoImportError a) (GoImportError b) = a == b
+  liftEq _ _ _ = False
 
 -- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name.
-data LoadError term value resume where
+data LoadError term resume where
-  LoadError :: ModulePath -> LoadError term value [Module term]
+  LoadError :: ModulePath -> LoadError term [Module term]
 
-deriving instance Eq (LoadError term a b)
+deriving instance Eq (LoadError term resume)
-deriving instance Show (LoadError term a b)
+deriving instance Show (LoadError term resume)
-instance Show1 (LoadError term value) where
+instance Show1 (LoadError term) where
   liftShowsPrec _ _ = showsPrec
-instance Eq1 (LoadError term a) where
+instance Eq1 (LoadError term) where
   liftEq _ (LoadError a) (LoadError b) = a == b
 
 -- | The type of error thrown when failing to evaluate a term.
@@ -82,29 +94,54 @@ data EvalError value resume where
   -- Indicates we weren't able to dereference a name from the evaluated environment.
   FreeVariableError :: Name -> EvalError value value
   FreeVariablesError :: [Name] -> EvalError value Name
+  -- Indicates that our evaluator wasn't able to make sense of these literals.
+  IntegerFormatError  :: ByteString -> EvalError value Integer
+  FloatFormatError    :: ByteString -> EvalError value Scientific
+  RationalFormatError :: ByteString -> EvalError value Rational
+  DefaultExportError  :: EvalError value ()
+  ExportError         :: ModulePath -> Name -> EvalError value ()
+  EnvironmentLookupError :: value -> EvalError value value
+
+-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
+--   Throws an 'EnvironmentLookupError' if @scopedEnvTerm@ does not have an environment.
+evaluateInScopedEnv :: MonadEvaluatable location term value effects m
+                    => m effects value
+                    -> m effects value
+                    -> m effects value
+evaluateInScopedEnv scopedEnvTerm term = do
+  value <- scopedEnvTerm
+  scopedEnv <- scopedEnvironment value
+  maybe (throwEvalError (EnvironmentLookupError value)) (flip localEnv term . mergeEnvs) scopedEnv
 
 -- | Look up and dereference the given 'Name', throwing an exception for free variables.
-variable :: MonadEvaluatable location term value m => Name -> m value
+variable :: ( Member (Resumable (AddressError location value)) effects
-variable name = lookupWith deref name >>= maybeM (throwException (FreeVariableError name))
+            , Member (Resumable (EvalError value)) effects
+            , MonadAddressable location effects m
+            , MonadEvaluator location term value effects m
+            )
+         => Name
+         -> m effects value
+variable name = lookupWith deref name >>= maybeM (throwResumable (FreeVariableError name))
 
-deriving instance Eq (EvalError a b)
+deriving instance Eq a => Eq (EvalError a b)
-deriving instance Show (EvalError a b)
+deriving instance Show a => Show (EvalError a b)
-instance Show1 (EvalError value) where
+instance Show value => Show1 (EvalError value) where
   liftShowsPrec _ _ = showsPrec
-instance Eq1 (EvalError term) where
+instance Eq term => Eq1 (EvalError term) where
-  liftEq _ (FreeVariableError a) (FreeVariableError b) = a == b
+  liftEq _ (FreeVariableError a) (FreeVariableError b)     = a == b
-  liftEq _ (FreeVariablesError a) (FreeVariablesError b) = a == b
+  liftEq _ (FreeVariablesError a) (FreeVariablesError b)   = a == b
-  liftEq _ _ _ = False
+  liftEq _ DefaultExportError DefaultExportError           = True
+  liftEq _ (ExportError a b) (ExportError c d)             = (a == c) && (b == d)
+  liftEq _ (IntegerFormatError a) (IntegerFormatError b)   = a == b
+  liftEq _ (FloatFormatError a) (FloatFormatError b)       = a == b
+  liftEq _ (RationalFormatError a) (RationalFormatError b) = a == b
+  liftEq _ (EnvironmentLookupError a) (EnvironmentLookupError b) = a == b
+  liftEq _ _ _                                             = False
 
 
-throwValueError :: MonadEvaluatable location term value m => ValueError location value resume -> m resume
+throwEvalError :: (Member (Resumable (EvalError value)) effects, MonadEvaluator location term value effects m) => EvalError value resume -> m effects resume
-throwValueError = throwException
+throwEvalError = throwResumable
 
-throwLoadError :: MonadEvaluatable location term value m => LoadError term value resume -> m resume
-throwLoadError = throwException
-
-throwEvalError :: MonadEvaluatable location term value m => EvalError value resume -> m resume
-throwEvalError = throwException
 
 data Unspecialized a b where
   Unspecialized :: { getUnspecialized :: Prelude.String } -> Unspecialized value value
@@ -119,10 +156,10 @@ instance Show1 (Unspecialized a) where
 
 -- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics.
 class Evaluatable constr where
-  eval :: MonadEvaluatable location term value m
+  eval :: MonadEvaluatable location term value effects m
-       => SubtermAlgebra constr term (m value)
+       => SubtermAlgebra constr term (m effects value)
-  default eval :: (MonadThrow (Unspecialized value) m, Show1 constr) => SubtermAlgebra constr term (m value)
+  default eval :: (MonadEvaluatable location term value effects m, Show1 constr) => SubtermAlgebra constr term (m effects value)
-  eval expr = throwException (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
+  eval expr = throwResumable (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
 
 
 -- Instances
@@ -145,48 +182,87 @@ instance Evaluatable [] where
   eval = maybe unit (runApp . foldMap1 (App . subtermValue)) . nonEmpty
 
 -- Resolve a list of module paths to a possible module table entry.
-resolve :: MonadEvaluatable location term value m
+resolve :: MonadEvaluatable location term value effects m
         => [FilePath]
-        -> m (Maybe ModulePath)
+        -> m effects (Maybe ModulePath)
 resolve names = do
   tbl <- askModuleTable
   pure $ find (`ModuleTable.member` tbl) names
 
-listModulesInDir :: MonadEvaluatable location term value m
+traceResolve :: (Show a, Show b) => a -> b -> c -> c
+traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
+
+listModulesInDir :: MonadEvaluatable location term value effects m
         => FilePath
-        -> m [ModulePath]
+        -> m effects [ModulePath]
 listModulesInDir dir = ModuleTable.modulePathsInDir dir <$> askModuleTable
 
 -- | Require/import another module by name and return it's environment and value.
 --
 -- Looks up the term's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module.
-require :: MonadEvaluatable location term value m
+require :: ( Member (EvalModule term value) effects
+           , Member (Resumable (LoadError term)) effects
+           , MonadEvaluator location term value effects m
+           , MonadValue location value effects m
+           )
         => ModulePath
-        -> m (Environment location value, value)
+        -> m effects (Environment location value, value)
-require name = getModuleTable >>= maybeM (load name) . ModuleTable.lookup name
+require = requireWith evaluateModule
+
+requireWith :: ( Member (Resumable (LoadError term)) effects
+               , MonadEvaluator location term value effects m
+               , MonadValue location value effects m
+               )
+            => (Module term -> m effects value)
+            -> ModulePath
+            -> m effects (Environment location value, value)
+requireWith with name = getModuleTable >>= maybeM (loadWith with name) . ModuleTable.lookup name
 
 -- | Load another module by name and return it's environment and value.
 --
 -- Always loads/evaluates.
-load :: MonadEvaluatable location term value m
+load :: ( Member (EvalModule term value) effects
+        , Member (Resumable (LoadError term)) effects
+        , MonadEvaluator location term value effects m
+        , MonadValue location value effects m
+        )
      => ModulePath
-     -> m (Environment location value, value)
+     -> m effects (Environment location value, value)
-load name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= evalAndCache
+load = loadWith evaluateModule
-  where
-    notFound = throwLoadError (LoadError name)
 
-    evalAndCache []     = (,) mempty <$> unit
+loadWith :: ( Member (Resumable (LoadError term)) effects
+            , MonadEvaluator location term value effects m
+            , MonadValue location value effects m
+            )
+         => (Module term -> m effects value)
+         -> ModulePath
+         -> m effects (Environment location value, value)
+loadWith with name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= evalAndCache
+  where
+    notFound = throwResumable (LoadError name)
+
+    evalAndCache []     = (,) emptyEnv <$> unit
     evalAndCache [x]    = evalAndCache' x
     evalAndCache (x:xs) = do
       (env, _) <- evalAndCache' x
       (env', v') <- evalAndCache xs
-      pure (env <> env', v')
+      pure (mergeEnvs env env', v')
 
     evalAndCache' x = do
-      v <- evaluateModule x
+      let mPath = modulePath (moduleInfo x)
-      env <- filterEnv <$> getExports <*> getEnv
+      LoadStack{..} <- getLoadStack
-      modifyModuleTable (ModuleTable.insert name (env, v))
+      if mPath `elem` unLoadStack
-      pure (env, v)
+        then do -- Circular load, don't keep evaluating.
+          v <- trace ("load (skip evaluating, circular load): " <> show mPath) unit
+          pure (emptyEnv, v)
+        else do
+          modifyLoadStack (loadStackPush mPath)
+          v <- trace ("load (evaluating): " <> show mPath) $ with x
+          modifyLoadStack loadStackPop
+          traceM ("load done:" <> show mPath)
+          env <- filterEnv <$> getExports <*> getEnv
+          modifyModuleTable (ModuleTable.insert name (env, v))
+          pure (env, v)
 
     -- TODO: If the set of exports is empty because no exports have been
     -- defined, do we export all terms, or no terms? This behavior varies across
@@ -194,53 +270,46 @@ load name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= eva
     filterEnv :: Exports.Exports l a -> Environment l a -> Environment l a
     filterEnv ports env
       | Exports.null ports = env
-      | otherwise = Exports.toEnvironment ports <> overwrite (Exports.aliases ports) env
+      | otherwise = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env
 
 
--- | Evaluate a term to a value using the semantics of the current analysis.
+-- | Evaluate a (root-level) term to a value using the semantics of the current analysis.
---
+evalModule :: forall location term value effects m
---   This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'.
+           .  ( MonadAnalysis location term value effects m
-evaluateTerm :: MonadEvaluatable location term value m
+              , MonadEvaluatable location term value effects m
-             => term
+              )
-             -> m value
+           => Module term
-evaluateTerm = foldSubterms (analyzeTerm eval)
+           -> m effects value
-
+evalModule m = raiseHandler
--- | Evaluate a (root-level) term to a value using the semantics of the current analysis. This should be used to evaluate single-term programs, or (via 'evaluateModules') the entry point of multi-term programs.
+  (interpose @(EvalModule term value) pure (\ (EvalModule m) yield -> lower @m (evalModule m) >>= yield))
-evaluateModule :: MonadEvaluatable location term value m
+  (analyzeModule (subtermValue . moduleBody) (fmap (Subterm <*> evalTerm) m))
-               => Module term
+  where evalTerm term = catchReturn @m @value
-               -> m value
+          (raiseHandler
-evaluateModule m = analyzeModule (subtermValue . moduleBody) (fmap (Subterm <*> evaluateTerm) m)
+            (interpose @(EvalClosure term value) pure (\ (EvalClosure term) yield -> lower (evalTerm term) >>= yield))
-
+            (foldSubterms (analyzeTerm eval) term))
--- | Evaluate with a list of modules in scope, taking the head module as the entry point.
+          (\ (Return value) -> pure value)
-evaluateModules :: MonadEvaluatable location term value m
-                => [Module term]
-                -> m value
-evaluateModules = fmap Prelude.head . evaluatePackageBody . Package.fromModules
 
 -- | Evaluate a given package.
-evaluatePackage :: ( Effectful m
+evaluatePackage :: ( MonadAnalysis location term value effects m
-                   , Member (Reader (SomeOrigin term)) effects
+                   , MonadEvaluatable location term value effects m
-                   , MonadEvaluatable location term value (m effects)
                    )
                 => Package term
                 -> m effects [value]
 evaluatePackage p = pushOrigin (packageOrigin p) (evaluatePackageBody (packageBody p))
 
 -- | Evaluate a given package body (module table and entry points).
-evaluatePackageBody :: MonadEvaluatable location term value m
+evaluatePackageBody :: ( MonadAnalysis location term value effects m
+                       , MonadEvaluatable location term value effects m
+                       )
                     => PackageBody term
-                    -> m [value]
+                    -> m effects [value]
-evaluatePackageBody body = localModuleTable (<> packageModules body)
+evaluatePackageBody body = withPrelude (packagePrelude body) $
-  (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints body)))
+  localModuleTable (<> packageModules body) (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints body)))
-  where evaluateEntryPoint (m, sym) = do
+  where
-          (_, v) <- require m
+    evaluateEntryPoint (m, sym) = do
-          maybe (pure v) ((`call` []) <=< variable) sym
+      (_, v) <- requireWith evalModule m
-
+      maybe (pure v) ((`call` []) <=< variable) sym
--- | Push a 'SomeOrigin' onto the stack. This should be used to contextualize execution with information about the originating term, module, or package.
+    withPrelude Nothing a = a
-pushOrigin :: ( Effectful m
+    withPrelude (Just prelude) a = do
-              , Member (Reader (SomeOrigin term)) effects
+      preludeEnv <- evalModule prelude *> getEnv
-              )
+      withDefaultEnvironment preludeEnv a
-           => SomeOrigin term
-           -> m effects a
-           -> m effects a
-pushOrigin o = raise . local (<> o) . lower

src/Data/Abstract/Exports.hs

@@ -10,22 +10,23 @@ module Data.Abstract.Exports
 import Prelude hiding (null)
 import Prologue hiding (null)
 import Data.Abstract.Address
-import Data.Abstract.Environment (Environment)
+import Data.Abstract.Environment (Environment, unpairs)
 import Data.Abstract.FreeVariables
 import qualified Data.Map as Map
-import Data.Semigroup.Reducer
+import Data.Semilattice.Lower
 
 -- | A map of export names to an alias & address tuple.
 newtype Exports l a = Exports { unExports :: Map.Map Name (Name, Maybe (Address l a)) }
-  deriving (Eq, Foldable, Functor, Generic1, Monoid, Ord, Semigroup, Show, Traversable)
+  deriving (Eq, Foldable, Functor, Generic1, Lower, Monoid, Ord, Semigroup, Show, Traversable)
 
 null :: Exports l a -> Bool
 null = Map.null . unExports
 
 toEnvironment :: Exports l a -> Environment l a
-toEnvironment = Map.foldMapWithKey buildEnv . unExports where
+toEnvironment exports = unpairs (mapMaybe collectExport (toList (unExports exports)))
-  buildEnv _ (_, Nothing) = mempty
+  where
-  buildEnv _ (n, Just a)  = unit (n, a)
+    collectExport (_, Nothing) = Nothing
+    collectExport (n, Just a)  = Just (n, a)
 
 insert :: Name -> Name -> Maybe (Address l a) -> Exports l a -> Exports l a
 insert name alias address = Exports . Map.insert name (alias, address) . unExports

src/Data/Abstract/FreeVariables.hs

@@ -45,6 +45,9 @@ freeVariable term = case freeVariables term of
   [n] -> Right n
   xs -> Left xs
 
+instance (FreeVariables t) => FreeVariables (Subterm t a) where
+  freeVariables = freeVariables . subterm
+
 instance (FreeVariables1 syntax, Functor syntax) => FreeVariables (Term syntax ann) where
   freeVariables = cata (liftFreeVariables id)
 

src/Data/Abstract/Heap.hs

@@ -5,11 +5,12 @@ import Data.Abstract.Address
 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.
 newtype Heap l a = Heap { unHeap :: Monoidal.Map l (Cell l a) }
-  deriving (Generic1)
+  deriving (Generic1, Lower)
 
 deriving instance (Eq l, Eq (Cell l a)) => Eq (Heap l a)
 deriving instance (Ord l, Ord (Cell l a)) => Ord (Heap l a)

src/Data/Abstract/Located.hs

@@ -19,10 +19,10 @@ instance (Location location, Ord (Base term ())) => Location (Located location t
 
 instance ( Effectful m
          , Member (Reader (SomeOrigin term)) effects
-         , MonadAddressable location (m effects)
+         , MonadAddressable location effects m
          , Ord (Base term ())
          )
-      => MonadAddressable (Located location term) (m effects) where
+      => MonadAddressable (Located location term) effects m where
   derefCell (Address (Located loc _)) = derefCell (Address loc)
 
   allocLoc name = Located <$> allocLoc name <*> raise ask

src/Data/Abstract/Module.hs

@@ -11,7 +11,7 @@ import System.FilePath.Posix
 
 type ModulePath = FilePath
 
-data ModuleInfo = ModuleInfo { modulePath :: FilePath, moduleRoot :: FilePath }
+newtype ModuleInfo = ModuleInfo { modulePath :: FilePath }
   deriving (Eq, Ord, Show)
 
 data Module term = Module { moduleInfo :: ModuleInfo, moduleBody :: term }
@@ -27,7 +27,5 @@ moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the mo
               -> term           -- ^ The @term@ representing the body of the module.
               -> Module term    -- ^ A 'Module' named appropriate for the 'Blob', holding the @term@, and constructed relative to the root 'FilePath', if any.
 moduleForBlob rootDir Blob{..} = Module info
-  where
+  where root = fromMaybe (takeDirectory blobPath) rootDir
-    root = fromMaybe (takeDirectory blobPath) rootDir
+        info = ModuleInfo (makeRelative root blobPath)
-    modulePath = maybe takeFileName makeRelative rootDir
-    info = ModuleInfo (modulePath blobPath) root

src/Data/Abstract/ModuleTable.hs

@@ -7,20 +7,25 @@ module Data.Abstract.ModuleTable
 , member
 , modulePathsInDir
 , insert
+, keys
 , fromModules
 , toPairs
+, LoadStack (..)
+, loadStackPush
+, loadStackPop
 ) where
 
 import Data.Abstract.Module
 import qualified Data.Map as Map
 import Data.Semigroup
+import Data.Semilattice.Lower
 import Prologue
 import System.FilePath.Posix
 import GHC.Generics (Generic1)
 import Prelude hiding (lookup)
 
 newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModulePath a }
-  deriving (Eq, Foldable, Functor, Generic1, Monoid, Ord, Semigroup, Show, Traversable)
+  deriving (Eq, Foldable, Functor, Generic1, Lower, Monoid, Ord, Semigroup, Show, Traversable)
 
 singleton :: ModulePath -> a -> ModuleTable a
 singleton name = ModuleTable . Map.singleton name
@@ -37,11 +42,25 @@ member k = Map.member k . unModuleTable
 insert :: ModulePath -> a -> ModuleTable a -> ModuleTable a
 insert k v = ModuleTable . Map.insert k v . unModuleTable
 
+keys :: ModuleTable a -> [ModulePath]
+keys = Map.keys . unModuleTable
 
 -- | Construct a 'ModuleTable' from a list of 'Module's.
 fromModules :: [Module term] -> ModuleTable [Module term]
-fromModules modules = let x = ModuleTable (Map.fromListWith (<>) (map toEntry modules)) in traceShow x x
+fromModules modules = ModuleTable (Map.fromListWith (<>) (map toEntry modules))
   where toEntry m = (modulePath (moduleInfo m), [m])
 
 toPairs :: ModuleTable a -> [(ModulePath, a)]
 toPairs = Map.toList . unModuleTable
+
+
+-- | Stack of module paths used to help break circular loads/imports.
+newtype LoadStack = LoadStack { unLoadStack :: [ModulePath] }
+  deriving (Eq, Lower, Monoid, Ord, Semigroup, Show)
+
+loadStackPush :: ModulePath -> LoadStack -> LoadStack
+loadStackPush x LoadStack{..} = LoadStack (x : unLoadStack)
+
+loadStackPop :: LoadStack -> LoadStack
+loadStackPop (LoadStack []) = LoadStack []
+loadStackPop (LoadStack (_:xs)) = LoadStack xs

src/Data/Abstract/Number.hs

@@ -6,6 +6,7 @@ module Data.Abstract.Number
     , liftReal
     , liftIntegralFrac
     , liftedExponent
+    , liftedFloorDiv
     ) where
 
 import Data.Scientific
@@ -96,3 +97,8 @@ liftedExponent (Integer i) (Integer j) = whole (i ^ j)
 liftedExponent (Ratio i) (Integer j)   = ratio (i ^^ j)
 liftedExponent i j                     = decim (fromFloatDigits (munge i ** munge j))
   where munge = (toRealFloat . toScientific) :: Number a -> Double
+
+liftedFloorDiv :: Number a -> Number b -> SomeNumber
+liftedFloorDiv (Integer i) (Integer j) = whole (i `div` j)
+liftedFloorDiv i j                     = decim (fromIntegral @Prelude.Integer (floor (fromFloatDigits (munge i / munge j))))
+  where munge = (toRealFloat . toScientific) :: Number a -> Double

src/Data/Abstract/Origin.hs

@@ -3,6 +3,7 @@ module Data.Abstract.Origin where
 
 import qualified Data.Abstract.Module as M
 import qualified Data.Abstract.Package as P
+import Data.Semilattice.Lower
 import Prologue
 
 -- | An 'Origin' encapsulates the location at which a name is bound or allocated.
@@ -52,6 +53,9 @@ liftCompareOrigins c (Term m1 t1)   (Term m2 t2)   = liftCompareOrigins c m1 m2
 instance Ord (Base term ()) => Ord (Origin term ty) where
   compare = liftCompareOrigins compare
 
+instance Lower (Origin term ty) where lowerBound = Unknown
+
+
 -- | An existential abstraction over 'Origin's of different types.
 data SomeOrigin term where
   SomeOrigin :: Origin term ty -> SomeOrigin term
@@ -98,3 +102,5 @@ instance Semigroup (SomeOrigin term) where
 instance Monoid (SomeOrigin term) where
   mempty = SomeOrigin Unknown
   mappend = (<>)
+
+instance Lower (SomeOrigin term) where lowerBound = SomeOrigin lowerBound

src/Data/Abstract/Package.hs

@@ -1,8 +1,10 @@
+{-# LANGUAGE TupleSections #-}
 module Data.Abstract.Package where
 
 import Data.Abstract.FreeVariables
 import Data.Abstract.Module
 import Data.Abstract.ModuleTable as ModuleTable
+import qualified Data.Map as Map
 
 type PackageName = Name
 
@@ -18,6 +20,7 @@ newtype Version = Version { versionString :: String }
 
 data PackageBody term = PackageBody
   { packageModules     :: ModuleTable [Module term]
+  , packagePrelude     :: Maybe (Module term)
   , packageEntryPoints :: ModuleTable (Maybe Name)
   }
   deriving (Eq, Functor, Ord, Show)
@@ -30,11 +33,8 @@ data Package term = Package
   }
   deriving (Eq, Functor, Ord, Show)
 
-fromModules :: [Module term] -> PackageBody term
+fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> Int -> [Module term] -> Package term
-fromModules []     = PackageBody mempty mempty
+fromModules name version prelude entryPoints modules =
-fromModules (m:ms) = fromModulesWithEntryPoint (m : ms) (modulePath (moduleInfo m))
+  Package (PackageInfo name version) (PackageBody (ModuleTable.fromModules modules) prelude entryPoints')
-
+  where
-fromModulesWithEntryPoint :: [Module term] -> FilePath -> PackageBody term
+    entryPoints' = ModuleTable . Map.fromList $ (,Nothing) . modulePath . moduleInfo <$> if entryPoints == 0 then modules else take entryPoints modules
-fromModulesWithEntryPoint ms path = PackageBody (ModuleTable.fromModules ms) entryPoints
-  where entryPoints = ModuleTable.singleton path Nothing
-

src/Data/Abstract/Path.hs

@@ -3,17 +3,24 @@ module Data.Abstract.Path where
 import Prologue
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString as B
+import System.FilePath.Posix
 
-splitOnPathSeparator :: ByteString -> [ByteString]
+-- | Join two paths a and b. Handles walking up relative directories in b. e.g.
-splitOnPathSeparator = BC.split '/'
+--
+--     joinPaths "a/b" "../c" == "a/c"
+--     joinPaths "a/b" "./c" == "a/b/c"
+--
+-- Walking beyond the beginning of a just stops when you get to the root of a.
+joinPaths :: FilePath -> FilePath -> FilePath
+joinPaths a b = let bs = splitPath (normalise b)
+                    n = length (filter (== "../") bs)
+                in normalise $ walkup n a </> joinPath (drop n bs)
+  where
+    walkup 0 str = str
+    walkup n str = walkup (pred n) (takeDirectory str)
 
 stripQuotes :: ByteString -> ByteString
 stripQuotes = B.filter (`B.notElem` "\'\"")
 
 dropRelativePrefix :: ByteString -> ByteString
 dropRelativePrefix = BC.dropWhile (== '/') . BC.dropWhile (== '.')
-
-dropExtension :: ByteString -> ByteString
-dropExtension path = case BC.split '.' path of
-  [] -> path
-  xs -> BC.intercalate "." (Prelude.init xs)

src/Data/Abstract/Type.hs

@@ -1,13 +1,18 @@
-{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
+{-# LANGUAGE GADTs, TypeFamilies, UndecidableInstances #-}
-module Data.Abstract.Type where
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the MonadValue instance, which requires MonadEvaluator to resolve its functional dependency.
+module Data.Abstract.Type
+  ( Type (..)
+  , TypeError (..)
+  , unify
+  ) where
 
 import Control.Abstract.Analysis
 import Data.Abstract.Address
 import Data.Abstract.Environment as Env
 import Data.Align (alignWith)
 import Data.Semigroup.Reducer (Reducer)
-import Prelude hiding (fail)
+import Prelude
-import Prologue
+import Prologue hiding (TypeError)
 
 type TName = Int
 
@@ -27,13 +32,33 @@ data Type
   | Hash [(Type, Type)] -- ^ Heterogenous key-value maps.
   | Object              -- ^ Objects. Once we have some notion of inheritance we'll need to store a superclass.
   | Null                -- ^ The null type. Unlike 'Unit', this unifies with any other type.
+  | Hole                -- ^ The hole type.
   deriving (Eq, Ord, Show)
 
 -- TODO: À la carte representation of types.
 
+data TypeError resume where
+  NumOpError       :: Type -> Type -> TypeError Type
+  BitOpError       :: Type -> Type -> TypeError Type
+  UnificationError :: Type -> Type -> TypeError Type
+  SubscriptError   :: Type -> Type -> TypeError Type
+
+deriving instance Show (TypeError resume)
+
+instance Show1 TypeError where
+  liftShowsPrec _ _ _ (NumOpError l r)       = showString "NumOpError " . shows [l, r]
+  liftShowsPrec _ _ _ (BitOpError l r)       = showString "BitOpError " . shows [l, r]
+  liftShowsPrec _ _ _ (UnificationError l r) = showString "UnificationError " . shows [l, r]
+  liftShowsPrec _ _ _ (SubscriptError l r)   = showString "SubscriptError " . shows [l, r]
+
+instance Eq1 TypeError where
+  liftEq _ (BitOpError a b) (BitOpError c d)             = a == c && b == d
+  liftEq _ (NumOpError a b) (NumOpError c d)             = a == c && b == d
+  liftEq _ (UnificationError a b) (UnificationError c d) = a == c && b == d
+  liftEq _ _ _                                           = False
 
 -- | Unify two 'Type's.
-unify :: MonadFail m => Type -> Type -> m Type
+unify :: (Effectful m, Applicative (m effects), Member (Resumable TypeError) effects) => Type -> Type -> m effects Type
 unify (a1 :-> b1) (a2 :-> b2) = (:->) <$> unify a1 a2 <*> unify b1 b2
 unify a Null = pure a
 unify Null b = pure b
@@ -43,31 +68,32 @@ unify a (Var _) = pure a
 unify (Product as) (Product bs) = Product <$> sequenceA (alignWith (these pure pure unify) as bs)
 unify t1 t2
   | t1 == t2  = pure t2
-  | otherwise = fail ("cannot unify " ++ show t1 ++ " with " ++ show t2)
+  | otherwise = throwResumable (UnificationError t1 t2)
-
 
 instance Ord location => ValueRoots location Type where
   valueRoots _ = mempty
 
 
+instance AbstractHole Type where
+  hole = Hole
+
 -- | Discard the value arguments (if any), constructing a 'Type' instead.
-instance ( Alternative m
+instance ( Alternative (m effects)
-         , MonadAddressable location m
+         , Member Fresh effects
-         , MonadEnvironment location Type m
+         , Member (Resumable TypeError) effects
-         , MonadFail m
+         , MonadAddressable location effects m
-         , MonadFresh m
+         , MonadEvaluator location term Type effects m
-         , MonadHeap location Type m
          , Reducer Type (Cell location Type)
          )
-      => MonadValue location Type m where
+      => MonadValue location Type effects m where
   lambda names (Subterm _ body) = do
     (env, tvars) <- foldr (\ name rest -> do
       a <- alloc name
-      tvar <- Var <$> fresh
+      tvar <- Var <$> raise fresh
       assign a tvar
       (env, tvars) <- rest
-      pure (Env.insert name a env, tvar : tvars)) (pure mempty) names
+      pure (Env.insert name a env, tvar : tvars)) (pure (emptyEnv, [])) names
-    ret <- localEnv (mappend env) body
+    ret <- localEnv (mergeEnvs env) body
     pure (Product tvars :-> ret)
 
   unit       = pure Unit
@@ -87,28 +113,37 @@ instance ( Alternative m
   klass _ _ _   = pure Object
   namespace _ _ = pure Unit
 
-  scopedEnvironment _ = pure mempty
+  scopedEnvironment _ = pure (Just emptyEnv)
 
-  asString _ = fail "Must evaluate to Value to use asString"
+  asString t = unify t String $> ""
-  asPair _   = fail "Must evaluate to Value to use asPair"
+  asPair t   = do
-  asBool _ = fail "Must evaluate to Value to use asBool"
+    t1 <- raise fresh
+    t2 <- raise fresh
+    unify t (Product [Var t1, Var t2]) $> (Var t1, Var t2)
+  asBool t   = unify t Bool *> (pure True <|> pure False)
+
+  isHole ty = pure (ty == Hole)
+
+  index (Array (mem:_)) Int   = pure mem
+  index (Product (mem:_)) Int = pure mem
+  index a b                   = throwResumable (SubscriptError a b)
 
   ifthenelse cond if' else' = unify cond Bool *> (if' <|> else')
 
-  liftNumeric _ Float = pure Float
+  liftNumeric _ Float      = pure Float
   liftNumeric _ Int        = pure Int
-  liftNumeric _ _          = fail "Invalid type in unary numeric operation"
+  liftNumeric _ t          = throwResumable (NumOpError t Hole)
 
   liftNumeric2 _ left right = case (left, right) of
     (Float, Int) -> pure Float
     (Int, Float) -> pure Float
-    _                 -> unify left right
+    _            -> unify left right
 
   liftBitwise _ Int = pure Int
-  liftBitwise _ t   = fail ("Invalid type passed to unary bitwise operation: " <> show t)
+  liftBitwise _ t   = throwResumable (BitOpError t Hole)
 
   liftBitwise2 _ Int Int = pure Int
-  liftBitwise2 _ t1 t2   = fail ("Invalid types passed to binary bitwise operation: " <> show (t1, t2))
+  liftBitwise2 _ t1 t2   = throwResumable (BitOpError t1 t2)
 
   liftComparison (Concrete _) left right = case (left, right) of
     (Float, Int) ->                     pure Bool
@@ -120,9 +155,12 @@ instance ( Alternative m
     _                 -> unify left right $> Bool
 
   call op params = do
-    tvar <- fresh
+    tvar <- raise fresh
     paramTypes <- sequenceA params
-    _ :-> ret <- op `unify` (Product paramTypes :-> Var tvar)
+    let needed = Product paramTypes :-> Var tvar
-    pure ret
+    unified <- op `unify` needed
+    case unified of
+      _ :-> ret -> pure ret
+      gotten    -> throwResumable (UnificationError needed gotten)
 
   loop f = f empty

src/Data/Abstract/Value.hs

@@ -1,15 +1,24 @@
-{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, UndecidableInstances, ScopedTypeVariables #-}
+{-# LANGUAGE GADTs, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Data.Abstract.Value where
 
-import Control.Abstract.Analysis
+import Control.Abstract.Addressable
-import Data.Abstract.Environment (Environment)
+import Control.Abstract.Evaluator
+import Control.Abstract.Value
+import Control.Effect
+import Control.Monad.Effect.Fail
+import Control.Monad.Effect.Resumable
+import Data.Abstract.Address
+import Data.Abstract.Environment (Environment, emptyEnv, mergeEnvs)
 import qualified Data.Abstract.Environment as Env
-import Data.Abstract.Evaluatable
+import Data.Abstract.FreeVariables
 import qualified Data.Abstract.Number as Number
+import Data.List (genericIndex, genericLength)
 import Data.Scientific (Scientific)
+import Data.Scientific.Exts
+import Data.Semigroup.Reducer
 import qualified Data.Set as Set
 import Prologue hiding (TypeError)
-import Prelude hiding (Float, Integer, String, Rational, fail)
+import Prelude hiding (Float, Integer, String, Rational)
 import qualified Prelude
 
 type ValueConstructors location
@@ -28,6 +37,7 @@ type ValueConstructors location
     , Symbol
     , Tuple
     , Unit
+    , Hole
     ]
 
 -- | Open union of primitive values that terms can be evaluated to.
@@ -67,6 +77,13 @@ instance Eq1 Unit where liftEq = genericLiftEq
 instance Ord1 Unit where liftCompare = genericLiftCompare
 instance Show1 Unit where liftShowsPrec = genericLiftShowsPrec
 
+data Hole value = Hole
+  deriving (Eq, Generic1, Ord, Show)
+
+instance Eq1 Hole where liftEq = genericLiftEq
+instance Ord1 Hole where liftCompare = genericLiftCompare
+instance Show1 Hole where liftShowsPrec = genericLiftShowsPrec
+
 -- | Boolean values.
 newtype Boolean value = Boolean Prelude.Bool
   deriving (Eq, Generic1, Ord, Show)
@@ -189,8 +206,24 @@ instance Ord location => ValueRoots location (Value location) where
     | otherwise                            = mempty
 
 
+instance AbstractHole (Value location) where
+  hole = injValue Hole
+
 -- | Construct a 'Value' wrapping the value arguments (if any).
-instance forall location term m. (Monad m, MonadEvaluatable location term (Value location) m) => MonadValue location (Value location) m where
+instance ( Member (EvalClosure term (Value location)) effects
+         , Member Fail effects
+         , Member (LoopControl (Value location)) effects
+         , Member (Resumable (AddressError location (Value location))) effects
+         , Member (Resumable (ValueError location (Value location))) effects
+         , Member (Return (Value location)) effects
+         , Monad (m effects)
+         , MonadAddressable location effects m
+         , MonadEvaluator location term (Value location) effects m
+         , Recursive term
+         , Reducer (Value location) (Cell location (Value location))
+         , Show location
+         )
+      => MonadValue location (Value location) effects m where
   unit     = pure . injValue $ Unit
   integer  = pure . injValue . Integer . Number.Integer
   boolean  = pure . injValue . Boolean
@@ -206,66 +239,83 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value
 
   null     = pure . injValue $ Null
 
-  asPair k
+  asPair val
-    | Just (KVPair k v) <- prjValue k = pure (k, v)
+    | Just (KVPair k v) <- prjValue val = pure (k, v)
-    | otherwise = fail ("expected key-value pair, got " <> show k)
+    | otherwise = throwResumable @(ValueError location (Value location)) $ KeyValueError val
 
   hash = pure . injValue . Hash . fmap (injValue . uncurry KVPair)
 
   klass n [] env = pure . injValue $ Class n env
   klass n supers env = do
-    product <- mconcat <$> traverse scopedEnvironment supers
+    product <- foldl mergeEnvs emptyEnv . catMaybes <$> traverse scopedEnvironment supers
-    pure . injValue $ Class n (Env.push product <> env)
+    pure . injValue $ Class n (mergeEnvs product env)
 
   namespace n env = do
     maybeAddr <- lookupEnv n
-    env' <- maybe (pure mempty) (asNamespaceEnv <=< deref) maybeAddr
+    env' <- maybe (pure emptyEnv) (asNamespaceEnv <=< deref) maybeAddr
     pure (injValue (Namespace n (Env.mergeNewer env' env)))
     where asNamespaceEnv v
             | Just (Namespace _ env') <- prjValue v = pure env'
-            | otherwise                             = throwException $ NamespaceError ("expected " <> show v <> " to be a namespace")
+            | otherwise                             = throwResumable $ NamespaceError ("expected " <> show v <> " to be a namespace")
 
   scopedEnvironment o
-    | Just (Class _ env) <- prjValue o = pure env
+    | Just (Class _ env) <- prjValue o = pure (Just env)
-    | Just (Namespace _ env) <- prjValue o = pure env
+    | Just (Namespace _ env) <- prjValue o = pure (Just env)
-    | otherwise = throwException $ ScopedEnvironmentError ("object type passed to scopedEnvironment doesn't have an environment: " <> show o)
+    | otherwise = pure Nothing
 
   asString v
     | Just (String n) <- prjValue v = pure n
-    | otherwise                     = throwException @(ValueError location (Value location)) $ StringError v
+    | otherwise                     = throwResumable @(ValueError location (Value location)) $ StringError v
 
   ifthenelse cond if' else' = do
-    bool <- asBool cond
+    isHole <- isHole cond
-    if bool then if' else else'
+    if isHole then
+      pure hole
+    else do
+      bool <- asBool cond
+      if bool then if' else else'
 
   asBool val
     | Just (Boolean b) <- prjValue val = pure b
-    | otherwise = throwException @(ValueError location (Value location)) $ BoolError val
+    | otherwise = throwResumable @(ValueError location (Value location)) $ BoolError val
 
+  isHole val = pure (prjValue val == Just Hole)
+
+  index = go where
+    tryIdx list ii
+      | ii > genericLength list = throwValueError (BoundsError list ii)
+      | otherwise               = pure (genericIndex list ii)
+    go arr idx
+      | (Just (Array arr, Integer (Number.Integer i))) <- prjPair (arr, idx) = tryIdx arr i
+      | (Just (Tuple tup, Integer (Number.Integer i))) <- prjPair (arr, idx) = tryIdx tup i
+      | otherwise = throwValueError (IndexError arr idx)
 
   liftNumeric f arg
     | Just (Integer (Number.Integer i)) <- prjValue arg = integer $ f i
-    | Just (Float (Number.Decimal d))          <- prjValue arg = float   $ f d
+    | Just (Float (Number.Decimal d))   <- prjValue arg = float   $ f d
-    | Just (Rational (Number.Ratio r))         <- prjValue arg = rational $ f r
+    | Just (Rational (Number.Ratio r))  <- prjValue arg = rational $ f r
-    | otherwise = fail ("Invalid operand to liftNumeric: " <> show arg)
+    | otherwise = throwValueError (NumericError arg)
 
   liftNumeric2 f left right
-    | Just (Integer  i, Integer j)  <- prjPair pair = f i j & specialize
+    | Just (Integer  i, Integer j)  <- prjPair pair = tentative f i j & specialize
-    | Just (Integer  i, Rational j) <- prjPair pair = f i j & specialize
+    | Just (Integer  i, Rational j) <- prjPair pair = tentative f i j & specialize
-    | Just (Integer  i, Float j)    <- prjPair pair = f i j & specialize
+    | Just (Integer  i, Float j)    <- prjPair pair = tentative f i j & specialize
-    | Just (Rational i, Integer j)  <- prjPair pair = f i j & specialize
+    | Just (Rational i, Integer j)  <- prjPair pair = tentative f i j & specialize
-    | Just (Rational i, Rational j) <- prjPair pair = f i j & specialize
+    | Just (Rational i, Rational j) <- prjPair pair = tentative f i j & specialize
-    | Just (Rational i, Float j)    <- prjPair pair = f i j & specialize
+    | Just (Rational i, Float j)    <- prjPair pair = tentative f i j & specialize
-    | Just (Float    i, Integer j)  <- prjPair pair = f i j & specialize
+    | Just (Float    i, Integer j)  <- prjPair pair = tentative f i j & specialize
-    | Just (Float    i, Rational j) <- prjPair pair = f i j & specialize
+    | Just (Float    i, Rational j) <- prjPair pair = tentative f i j & specialize
-    | Just (Float    i, Float j)    <- prjPair pair = f i j & specialize
+    | Just (Float    i, Float j)    <- prjPair pair = tentative f i j & specialize
     | otherwise = throwValueError (Numeric2Error left right)
       where
+        tentative x i j = attemptUnsafeArithmetic (x i j)
+
         -- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
-        specialize :: MonadValue location value m => Number.SomeNumber -> m value
+        specialize :: Either ArithException Number.SomeNumber -> m effects (Value location)
-        specialize (Number.SomeNumber (Number.Integer i)) = integer i
+        specialize (Left exc) = throwValueError (ArithmeticError exc)
-        specialize (Number.SomeNumber (Number.Ratio r))          = rational r
+        specialize (Right (Number.SomeNumber (Number.Integer i))) = integer i
-        specialize (Number.SomeNumber (Number.Decimal d))        = float d
+        specialize (Right (Number.SomeNumber (Number.Ratio r)))   = rational r
+        specialize (Right (Number.SomeNumber (Number.Decimal d))) = float d
         pair = (left, right)
 
   liftComparison comparator left right
@@ -276,11 +326,11 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value
     | Just (String  i,                  String  j)                  <- prjPair pair = go i j
     | Just (Boolean i,                  Boolean j)                  <- prjPair pair = go i j
     | Just (Unit,                       Unit)                       <- prjPair pair = boolean True
-    | otherwise = fail ("Type error: invalid arguments to liftComparison: " <> show pair)
+    | otherwise = throwValueError (ComparisonError left right)
       where
         -- Explicit type signature is necessary here because we're passing all sorts of things
         -- to these comparison functions.
-        go :: (Ord a, MonadValue location value m) => a -> a -> m value
+        go :: Ord a => a -> a -> m effects (Value location)
         go l r = case comparator of
           Concrete f  -> boolean (f l r)
           Generalized -> integer (orderingToInt (compare l r))
@@ -294,11 +344,11 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value
 
   liftBitwise operator target
     | Just (Integer (Number.Integer i)) <- prjValue target = integer $ operator i
-    | otherwise = fail ("Type error: invalid unary bitwise operation on " <> show target)
+    | otherwise = throwValueError (BitwiseError target)
 
   liftBitwise2 operator left right
     | Just (Integer (Number.Integer i), Integer (Number.Integer j)) <- prjPair pair = integer $ operator i j
-    | otherwise = fail ("Type error: invalid binary bitwise operation on " <> show pair)
+    | otherwise = throwValueError (Bitwise2Error left right)
       where pair = (left, right)
 
   lambda names (Subterm body _) = do
@@ -308,12 +358,61 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value
   call op params = do
     case prjValue op of
       Just (Closure names label env) -> do
-        bindings <- foldr (\ (name, param) rest -> do
+        -- Evaluate the bindings and the body within a `goto` in order to
-          v <- param
+        -- charge their origins to the closure's origin.
-          a <- alloc name
+        goto label $ \body -> do
-          assign a v
+          bindings <- foldr (\ (name, param) rest -> do
-          Env.insert name a <$> rest) (pure env) (zip names params)
+            v <- param
-        localEnv (mappend bindings) (goto label >>= evaluateTerm)
+            a <- alloc name
-      Nothing -> throwException @(ValueError location (Value location)) (CallError op)
+            assign a v
+            Env.insert name a <$> rest) (pure env) (zip names params)
+          localEnv (mergeEnvs bindings) (evalClosure body)
+      Nothing -> throwValueError (CallError op)
+    where
+      evalClosure term = catchReturn @m @(Value location) (evaluateClosureBody term) (\ (Return value) -> pure value)
 
-  loop = fix
+  loop x = catchLoopControl @m @(Value location) (fix x) (\ control -> case control of
+    Break value -> pure value
+    Continue    -> loop x)
+
+
+-- | The type of exceptions that can be thrown when constructing values in 'Value'’s 'MonadValue' instance.
+data ValueError location value resume where
+  StringError            :: value          -> ValueError location value ByteString
+  BoolError              :: value          -> ValueError location value Bool
+  IndexError             :: value -> value -> ValueError location value value
+  NamespaceError         :: Prelude.String -> ValueError location value (Environment location value)
+  CallError              :: value          -> ValueError location value value
+  NumericError           :: value          -> ValueError location value value
+  Numeric2Error          :: value -> value -> ValueError location value value
+  ComparisonError        :: value -> value -> ValueError location value value
+  BitwiseError           :: value          -> ValueError location value value
+  Bitwise2Error          :: value -> value -> ValueError location value value
+  KeyValueError          :: value          -> ValueError location value (value, value)
+  -- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching.
+  ArithmeticError :: ArithException -> ValueError location value value
+  -- Out-of-bounds error
+  BoundsError :: [value] -> Prelude.Integer -> ValueError location value value
+
+
+
+instance Eq value => Eq1 (ValueError location value) where
+  liftEq _ (StringError a) (StringError b)                       = a == b
+  liftEq _ (NamespaceError a) (NamespaceError b)                 = a == b
+  liftEq _ (CallError a) (CallError b)                           = a == b
+  liftEq _ (BoolError a) (BoolError c)                           = a == c
+  liftEq _ (IndexError a b) (IndexError c d)                     = (a == c) && (b == d)
+  liftEq _ (Numeric2Error a b) (Numeric2Error c d)               = (a == c) && (b == d)
+  liftEq _ (ComparisonError a b) (ComparisonError c d)           = (a == c) && (b == d)
+  liftEq _ (Bitwise2Error a b) (Bitwise2Error c d)               = (a == c) && (b == d)
+  liftEq _ (BitwiseError a) (BitwiseError b)                     = a == b
+  liftEq _ (KeyValueError a) (KeyValueError b)                   = a == b
+  liftEq _ (BoundsError a b) (BoundsError c d)                   = (a == c) && (b == d)
+  liftEq _ _             _                                       = False
+
+deriving instance (Show value) => Show (ValueError location value resume)
+instance (Show value) => Show1 (ValueError location value) where
+  liftShowsPrec _ _ = showsPrec
+
+throwValueError :: (Member (Resumable (ValueError location value)) effects, MonadEvaluator location term value effects m) => ValueError location value resume -> m effects resume
+throwValueError = throwResumable

src/Data/File.hs

@@ -0,0 +1,30 @@
+module Data.File where
+
+import           Data.ByteString.Char8 as BC (pack)
+import           Data.Language
+import           Prologue
+import           System.FilePath.Posix
+
+data File = File
+  { filePath :: FilePath
+  , fileLanguage :: Maybe Language
+  }
+  deriving (Eq, Ord, Show)
+
+data Project = Project
+  { projectRootDir :: FilePath
+  , projectFiles :: [File]
+  , projectLanguage :: Language
+  , projectEntryPoints :: [File]
+  }
+  deriving (Eq, Ord, Show)
+
+file :: FilePath -> File
+file path = File path (languageForFilePath path)
+  where languageForFilePath = languageForType . takeExtension
+
+projectName :: Project -> ByteString
+projectName = BC.pack . dropExtensions . takeFileName . projectRootDir
+
+projectExtensions :: Project -> [String]
+projectExtensions = extensionsForLanguage . projectLanguage

src/Data/Language.hs

@@ -26,7 +26,7 @@ languageForType mediaType = case mediaType of
     ".md" -> Just Markdown
     ".rb" -> Just Ruby
     ".go" -> Just Go
-    ".js" -> Just TypeScript
+    ".js" -> Just JavaScript
     ".ts" -> Just TypeScript
     ".tsx" -> Just TypeScript
     ".jsx" -> Just JSX
@@ -34,3 +34,13 @@ languageForType mediaType = case mediaType of
     ".php" -> Just PHP
     ".phpt" -> Just PHP
     _ -> Nothing
+
+extensionsForLanguage :: Language -> [String]
+extensionsForLanguage language = case language of
+  Go -> [".go"]
+  JavaScript -> [".js"]
+  PHP -> [".php"]
+  Python -> [".py"]
+  Ruby -> [".rb"]
+  TypeScript -> [".ts", ".tsx", ".d.tsx"]
+  _ -> []

src/Data/Map/Monoidal.hs

@@ -11,6 +11,7 @@ module Data.Map.Monoidal
 
 import qualified Data.Map as Map
 import Data.Semigroup.Reducer as Reducer
+import Data.Semilattice.Lower
 import Prelude hiding (lookup)
 import Prologue hiding (Map)
 
@@ -42,3 +43,5 @@ instance (Ord key, Reducer a value) => Reducer (key, a) (Map key value) where
   unit (key, a) = Map (Map.singleton key (unit a))
   cons (key, a) (Map m) = Map (Map.insertWith (<>) key (unit a) m)
   snoc (Map m) (key, a) = Map (Map.insertWith (flip (<>)) key (unit a) m)
+
+instance Lower (Map key value) where lowerBound = Map lowerBound

src/Data/Range.hs

@@ -7,9 +7,10 @@ module Data.Range
 , subtractRange
 ) where
 
-import Prologue
 import Data.Aeson
 import Data.JSON.Fields
+import Data.Semilattice.Lower
+import Prologue
 
 -- | A half-open interval of integers, defined by start & end indices.
 data Range = Range { start :: {-# UNPACK #-} !Int, end :: {-# UNPACK #-} !Int }
@@ -51,3 +52,6 @@ instance Ord Range where
 
 instance ToJSONFields Range where
   toJSONFields Range{..} = ["sourceRange" .= [ start, end ]]
+
+instance Lower Range where
+  lowerBound = Range 0 0

src/Data/Record.hs

@@ -1,10 +1,11 @@
 {-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Data.Record where
 
-import Prologue
 import Data.Aeson
 import Data.JSON.Fields
 import Data.Kind
+import Data.Semilattice.Lower
+import Prologue
 
 -- | A type-safe, extensible record structure.
 -- |
@@ -87,3 +88,10 @@ instance ToJSONFields (Record '[]) where
 instance ToJSONFields (Record fs) => ToJSON (Record fs) where
   toJSON = object . toJSONFields
   toEncoding = pairs . mconcat . toJSONFields
+
+
+instance (Lower h, Lower (Record t)) => Lower (Record (h ': t)) where
+  lowerBound = lowerBound :. lowerBound
+
+instance Lower (Record '[]) where
+  lowerBound = Nil

src/Data/Scientific/Exts.hs

@@ -1,19 +1,21 @@
 module Data.Scientific.Exts
     ( module Data.Scientific
+    , attemptUnsafeArithmetic
     , parseScientific
     ) where
 
-import Prelude hiding (filter, null, takeWhile)
-
 import Control.Applicative
-import Control.Monad
+import Control.Exception as Exc (evaluate, try)
+import Control.Monad hiding (fail)
 import Data.Attoparsec.ByteString.Char8
 import Data.ByteString.Char8 hiding (readInt, takeWhile)
 import Data.Char (isOctDigit)
 import Data.Scientific
-import Data.Semigroup
 import Numeric
+import Prelude hiding (fail, filter, null, takeWhile)
+import Prologue hiding (null)
 import Text.Read (readMaybe)
+import System.IO.Unsafe
 
 parseScientific :: ByteString -> Either String Scientific
 parseScientific = parseOnly parser
@@ -38,9 +40,9 @@ parser = signed (choice [hex, oct, bin, dec]) where
   -- The ending stanza. Note the explicit endOfInput call to ensure we haven't left any dangling input.
   done = skipWhile (inClass "iIjJlL") *> endOfInput
 
-  -- Wrapper around readMaybe. Analogous to maybeFail in the Prologue, but no need to pull that in.
+  -- Wrapper around readMaybe.
   attempt :: Read a => String -> Parser a
-  attempt str = maybe (fail ("No parse: " <> str)) pure (readMaybe str)
+  attempt str = maybeM (fail ("No parse: " <> str)) (readMaybe str)
 
   -- Parse a hex value, leaning on the parser provided by Attoparsec.
   hex = fromIntegral <$> (string "0x" *> hexadecimal @Integer)
@@ -97,3 +99,10 @@ parser = signed (choice [hex, oct, bin, dec]) where
     let trail = if null trailings then "0" else trailings
 
     attempt (unpack (leads <> "." <> trail <> exponent))
+
+-- | Attempt to evaluate the given term into WHNF. If doing so raises an 'ArithException', such as
+-- 'ZeroDivisionError' or 'RatioZeroDenominator', 'Left' will be returned.
+-- Hooray for uncatchable exceptions that bubble up from third-party code.
+attemptUnsafeArithmetic :: a -> Either ArithException a
+attemptUnsafeArithmetic = unsafePerformIO . Exc.try . evaluate
+{-# NOINLINE attemptUnsafeArithmetic #-}

src/Data/Semilattice/Lower.hs

@@ -0,0 +1,40 @@
+{-# 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.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 = []
+
+-- 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

@@ -9,10 +9,11 @@ module Data.Span
 , emptySpan
 ) where
 
-import Prologue
 import Data.Aeson ((.=), (.:))
 import qualified Data.Aeson as A
 import Data.JSON.Fields
+import Data.Semilattice.Lower
+import Prologue
 
 -- | Source position information
 data Pos = Pos
@@ -56,3 +57,6 @@ instance A.FromJSON Span where
 
 instance ToJSONFields Span where
   toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ]
+
+instance Lower Span where
+  lowerBound = Span (Pos 1 1) (Pos 1 1)

src/Data/Syntax.hs

@@ -111,9 +111,11 @@ instance Evaluatable Identifier where
 instance FreeVariables1 Identifier where
   liftFreeVariables _ (Identifier x) = pure x
 
+instance Declarations1 Identifier where
+  liftDeclaredName _ (Identifier x) = pure x
 
 newtype Program a = Program [a]
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Program where liftEq = genericLiftEq
 instance Ord1 Program where liftCompare = genericLiftCompare
@@ -124,7 +126,7 @@ instance Evaluatable Program where
 
 -- | An accessibility modifier, e.g. private, public, protected, etc.
 newtype AccessibilityModifier a = AccessibilityModifier ByteString
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 AccessibilityModifier where liftEq = genericLiftEq
 instance Ord1 AccessibilityModifier where liftCompare = genericLiftCompare
@@ -137,7 +139,7 @@ instance Evaluatable AccessibilityModifier
 --
 --   This can be used to represent an implicit no-op, e.g. the alternative in an 'if' statement without an 'else'.
 data Empty a = Empty
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Empty where liftEq _ _ _ = True
 instance Ord1 Empty where liftCompare _ _ _ = EQ
@@ -146,21 +148,10 @@ instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
 instance Evaluatable Empty where
   eval _ = unit
 
--- | A parenthesized expression or statement. All the languages we target support this concept.
-
-newtype Paren a = Paren a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
-
-instance Eq1 Paren where liftEq = genericLiftEq
-instance Ord1 Paren where liftCompare = genericLiftCompare
-instance Show1 Paren where liftShowsPrec = genericLiftShowsPrec
-
-instance Evaluatable Paren where
-  eval (Paren a) = subtermValue a
 
 -- | Syntax representing a parsing or assignment error.
 data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Error where liftEq = genericLiftEq
 instance Ord1 Error where liftCompare = genericLiftCompare
@@ -191,7 +182,7 @@ instance Ord ErrorStack where
 
 
 data Context a = Context { contextTerms :: NonEmpty a, contextSubject :: a }
-  deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Diffable Context where
   subalgorithmFor blur focus (Context n s) = Context <$> traverse blur n <*> focus s

src/Data/Syntax/Comment.hs

@@ -7,7 +7,7 @@ import Diffing.Algorithm
 
 -- | An unnested comment (line or block).
 newtype Comment a = Comment { commentContent :: ByteString }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Comment where liftEq = genericLiftEq
 instance Ord1 Comment where liftCompare = genericLiftCompare

src/Data/Syntax/Declaration.hs

@@ -7,7 +7,7 @@ import Diffing.Algorithm
 import Prologue
 
 data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a }
-  deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Diffable Function where
   equivalentBySubterm = Just . functionName
@@ -27,9 +27,12 @@ instance Evaluatable Function where
     pure v
     where paramNames = foldMap (freeVariables . subterm)
 
+instance Declarations a => Declarations (Function a) where
+  declaredName Function{..} = declaredName functionName
+
 
 data Method a = Method { methodContext :: ![a], methodReceiver :: !a, methodName :: !a, methodParameters :: ![a], methodBody :: !a }
-  deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Diffable Method where
   equivalentBySubterm = Just . methodName
@@ -51,7 +54,7 @@ instance Evaluatable Method where
 
 -- | A method signature in TypeScript or a method spec in Go.
 data MethodSignature a = MethodSignature { _methodSignatureContext :: ![a], _methodSignatureName :: !a, _methodSignatureParameters :: ![a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 MethodSignature where liftEq = genericLiftEq
 instance Ord1 MethodSignature where liftCompare = genericLiftCompare
@@ -62,7 +65,7 @@ instance Evaluatable MethodSignature
 
 
 newtype RequiredParameter a = RequiredParameter { requiredParameter :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 RequiredParameter where liftEq = genericLiftEq
 instance Ord1 RequiredParameter where liftCompare = genericLiftCompare
@@ -73,7 +76,7 @@ instance Evaluatable RequiredParameter
 
 
 newtype OptionalParameter a = OptionalParameter { optionalParameter :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 OptionalParameter where liftEq = genericLiftEq
 instance Ord1 OptionalParameter where liftCompare = genericLiftCompare
@@ -88,7 +91,7 @@ instance Evaluatable OptionalParameter
 -- TODO: It would be really nice to have a more meaningful type contained in here than [a]
 -- | A declaration of possibly many variables such as var foo = 5, bar = 6 in JavaScript.
 newtype VariableDeclaration a = VariableDeclaration { variableDeclarations :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 VariableDeclaration where liftEq = genericLiftEq
 instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare
@@ -98,9 +101,15 @@ instance Evaluatable VariableDeclaration where
   eval (VariableDeclaration [])   = unit
   eval (VariableDeclaration decs) = multiple =<< traverse subtermValue decs
 
+instance Declarations a => Declarations (VariableDeclaration a) where
+  declaredName (VariableDeclaration vars) = case vars of
+    [var] -> declaredName var
+    _     -> Nothing
+
+
 -- | A TypeScript/Java style interface declaration to implement.
 data InterfaceDeclaration a = InterfaceDeclaration { interfaceDeclarationContext :: ![a], interfaceDeclarationIdentifier :: !a, interfaceDeclarationBody :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 InterfaceDeclaration where liftEq = genericLiftEq
 instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare
@@ -109,10 +118,13 @@ instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec
 -- TODO: Implement Eval instance for InterfaceDeclaration
 instance Evaluatable InterfaceDeclaration
 
+instance Declarations a => Declarations (InterfaceDeclaration a) where
+  declaredName InterfaceDeclaration{..} = declaredName interfaceDeclarationIdentifier
+
 
 -- | A public field definition such as a field definition in a JavaScript class.
 data PublicFieldDefinition a = PublicFieldDefinition { publicFieldContext :: ![a], publicFieldPropertyName :: !a, publicFieldValue :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 PublicFieldDefinition where liftEq = genericLiftEq
 instance Ord1 PublicFieldDefinition where liftCompare = genericLiftCompare
@@ -123,7 +135,7 @@ instance Evaluatable PublicFieldDefinition
 
 
 data Variable a = Variable { variableName :: !a, variableType :: !a, variableValue :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Variable where liftEq = genericLiftEq
 instance Ord1 Variable where liftCompare = genericLiftCompare
@@ -133,7 +145,10 @@ instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Variable
 
 data Class a = Class { classContext :: ![a], classIdentifier :: !a, classSuperclasses :: ![a], classBody :: !a }
-  deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
+
+instance Declarations a => Declarations (Class a) where
+  declaredName (Class _ name _ _) = declaredName name
 
 instance Diffable Class where
   equivalentBySubterm = Just . classIdentifier
@@ -154,7 +169,7 @@ instance Evaluatable Class where
 
 -- | A decorator in Python
 data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Decorator where liftEq = genericLiftEq
 instance Ord1 Decorator where liftCompare = genericLiftCompare
@@ -168,7 +183,7 @@ instance Evaluatable Decorator
 
 -- | An ADT, i.e. a disjoint sum of products, like 'data' in Haskell, or 'enum' in Rust or Swift.
 data Datatype a = Datatype { datatypeName :: !a, datatypeConstructors :: ![a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Data.Syntax.Declaration.Datatype where liftEq = genericLiftEq
 instance Ord1 Data.Syntax.Declaration.Datatype where liftCompare = genericLiftCompare
@@ -180,7 +195,7 @@ instance Evaluatable Data.Syntax.Declaration.Datatype
 
 -- | A single constructor in a datatype, or equally a 'struct' in C, Rust, or Swift.
 data Constructor a = Constructor { constructorName :: !a, constructorFields :: ![a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Data.Syntax.Declaration.Constructor where liftEq = genericLiftEq
 instance Ord1 Data.Syntax.Declaration.Constructor where liftCompare = genericLiftCompare
@@ -192,7 +207,7 @@ instance Evaluatable Data.Syntax.Declaration.Constructor
 
 -- | Comprehension (e.g. ((a for b in c if a()) in Python)
 data Comprehension a = Comprehension { comprehensionValue :: !a, comprehensionBody :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Comprehension where liftEq = genericLiftEq
 instance Ord1 Comprehension where liftCompare = genericLiftCompare
@@ -204,7 +219,7 @@ instance Evaluatable Comprehension
 
 -- | A declared type (e.g. `a []int` in Go).
 data Type a = Type { typeName :: !a, typeKind :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Type where liftEq = genericLiftEq
 instance Ord1 Type where liftCompare = genericLiftCompare
@@ -216,11 +231,20 @@ instance Evaluatable Type
 
 -- | Type alias declarations in Javascript/Haskell, etc.
 data TypeAlias a = TypeAlias { typeAliasContext :: ![a], typeAliasIdentifier :: !a, typeAliasKind :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 TypeAlias where liftEq = genericLiftEq
 instance Ord1 TypeAlias where liftCompare = genericLiftCompare
 instance Show1 TypeAlias where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for TypeAlias
-instance Evaluatable TypeAlias
+instance Evaluatable TypeAlias where
+  eval TypeAlias{..} = do
+    name <- either (throwEvalError . FreeVariablesError) pure (freeVariable (subterm typeAliasIdentifier))
+    v <- subtermValue typeAliasKind
+    addr <- lookupOrAlloc name
+    assign addr v
+    modifyEnv (Env.insert name addr) $> v
+
+instance Declarations a => Declarations (TypeAlias a) where
+  declaredName TypeAlias{..} = declaredName typeAliasIdentifier

src/Data/Syntax/Directive.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}
+module Data.Syntax.Directive where
+
+import           Data.Abstract.Evaluatable
+import           Data.Abstract.Module (ModuleInfo(..))
+import qualified Data.ByteString.Char8 as BC
+import           Diffing.Algorithm
+import           Prologue
+
+-- A file directive like the Ruby constant `__FILE__`.
+data File a = File
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
+
+instance Eq1 File where liftEq = genericLiftEq
+instance Ord1 File where liftCompare = genericLiftCompare
+instance Show1 File where liftShowsPrec = genericLiftShowsPrec
+
+instance Evaluatable File where
+  eval File = currentModule >>= string . BC.pack . modulePath

src/Data/Syntax/Expression.hs

@@ -2,15 +2,14 @@
 module Data.Syntax.Expression where
 
 import Data.Abstract.Evaluatable
-import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent)
+import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv)
 import Data.Fixed
 import Diffing.Algorithm
-import Prelude
+import Prologue hiding (index)
-import Prologue
 
 -- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell.
 data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Call where liftEq = genericLiftEq
 instance Ord1 Call where liftCompare = genericLiftCompare
@@ -28,7 +27,7 @@ data Comparison a
   | GreaterThanEqual !a !a
   | Equal !a !a
   | Comparison !a !a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Comparison where liftEq = genericLiftEq
 instance Ord1 Comparison where liftCompare = genericLiftCompare
@@ -50,10 +49,11 @@ data Arithmetic a
   | Minus !a !a
   | Times !a !a
   | DividedBy !a !a
+  | FloorDivision !a !a
   | Modulo !a !a
   | Power !a !a
   | Negate !a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Arithmetic where liftEq = genericLiftEq
 instance Ord1 Arithmetic where liftCompare = genericLiftCompare
@@ -61,19 +61,20 @@ instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Arithmetic where
   eval = traverse subtermValue >=> go where
-    go (Plus a b)      = liftNumeric2 add a b  where add    = liftReal (+)
+    go (Plus a b)          = liftNumeric2 add a b  where add    = liftReal (+)
-    go (Minus a b)     = liftNumeric2 sub a b  where sub    = liftReal (-)
+    go (Minus a b)         = liftNumeric2 sub a b  where sub    = liftReal (-)
-    go (Times a b)     = liftNumeric2 mul a b  where mul    = liftReal (*)
+    go (Times a b)         = liftNumeric2 mul a b  where mul    = liftReal (*)
-    go (DividedBy a b) = liftNumeric2 div' a b where div'   = liftIntegralFrac div (/)
+    go (DividedBy a b)     = liftNumeric2 div' a b where div'   = liftIntegralFrac div (/)
-    go (Modulo a b)    = liftNumeric2 mod'' a b where mod'' = liftIntegralFrac mod mod'
+    go (Modulo a b)        = liftNumeric2 mod'' a b where mod'' = liftIntegralFrac mod mod'
-    go (Power a b)     = liftNumeric2 liftedExponent a b
+    go (Power a b)         = liftNumeric2 liftedExponent a b
-    go (Negate a)      = liftNumeric negate a
+    go (Negate a)          = liftNumeric negate a
+    go (FloorDivision a b) = liftNumeric2 liftedFloorDiv a b
 
 -- | Regex matching operators (Ruby's =~ and ~!)
 data Match a
   = Matches !a !a
   | NotMatches !a !a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Match where liftEq = genericLiftEq
 instance Ord1 Match where liftCompare = genericLiftCompare
@@ -88,7 +89,7 @@ data Boolean a
   | And !a !a
   | Not !a
   | XOr !a !a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Boolean where liftEq = genericLiftEq
 instance Ord1 Boolean where liftCompare = genericLiftCompare
@@ -108,7 +109,7 @@ instance Evaluatable Boolean where
 
 -- | Javascript delete operator
 newtype Delete a = Delete a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Delete where liftEq = genericLiftEq
 instance Ord1 Delete where liftCompare = genericLiftCompare
@@ -120,7 +121,7 @@ instance Evaluatable Delete
 
 -- | A sequence expression such as Javascript or C's comma operator.
 data SequenceExpression a = SequenceExpression { _firstExpression :: !a, _secondExpression :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 SequenceExpression where liftEq = genericLiftEq
 instance Ord1 SequenceExpression where liftCompare = genericLiftCompare
@@ -132,7 +133,7 @@ instance Evaluatable SequenceExpression
 
 -- | Javascript void operator
 newtype Void a = Void a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Void where liftEq = genericLiftEq
 instance Ord1 Void where liftCompare = genericLiftCompare
@@ -144,7 +145,7 @@ instance Evaluatable Void
 
 -- | Javascript typeof operator
 newtype Typeof a = Typeof a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Typeof where liftEq = genericLiftEq
 instance Ord1 Typeof where liftCompare = genericLiftCompare
@@ -163,7 +164,7 @@ data Bitwise a
   | RShift !a !a
   | UnsignedRShift !a !a
   | Complement a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Bitwise where liftEq = genericLiftEq
 instance Ord1 Bitwise where liftCompare = genericLiftCompare
@@ -185,34 +186,35 @@ instance Evaluatable Bitwise where
 -- | Member Access (e.g. a.b)
 data MemberAccess a
   = MemberAccess !a !a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 MemberAccess where liftEq = genericLiftEq
 instance Ord1 MemberAccess where liftCompare = genericLiftCompare
 instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable MemberAccess where
-  eval (fmap subtermValue -> MemberAccess mem acc) = do
+  eval (fmap subtermValue -> MemberAccess mem acc) = evaluateInScopedEnv mem acc
-    lhs <- mem >>= scopedEnvironment
-    localEnv (mappend lhs) acc
 
 -- | Subscript (e.g a[1])
 data Subscript a
   = Subscript !a ![a]
   | Member !a !a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Subscript where liftEq = genericLiftEq
 instance Ord1 Subscript where liftCompare = genericLiftCompare
 instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Subscript
-instance Evaluatable Subscript
+instance Evaluatable Subscript where
+  eval (Subscript l [r]) = join (index <$> subtermValue l <*> subtermValue r)
+  eval (Subscript _ _)   = throwResumable (Unspecialized "Eval unspecialized for subscript with slices")
+  eval (Member _ _)      = throwResumable (Unspecialized "Eval unspecialized for member access")
 
 
 -- | Enumeration (e.g. a[1:10:1] in Python (start at index 1, stop at index 10, step 1 element from start to stop))
 data Enumeration a = Enumeration { enumerationStart :: !a, enumerationEnd :: !a, enumerationStep :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Enumeration where liftEq = genericLiftEq
 instance Ord1 Enumeration where liftCompare = genericLiftCompare
@@ -224,7 +226,7 @@ instance Evaluatable Enumeration
 
 -- | InstanceOf (e.g. a instanceof b in JavaScript
 data InstanceOf a = InstanceOf { instanceOfSubject :: !a, instanceOfObject :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 InstanceOf where liftEq = genericLiftEq
 instance Ord1 InstanceOf where liftCompare = genericLiftCompare
@@ -236,7 +238,7 @@ instance Evaluatable InstanceOf
 
 -- | ScopeResolution (e.g. import a.b in Python or a::b in C++)
 newtype ScopeResolution a = ScopeResolution [a]
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ScopeResolution where liftEq = genericLiftEq
 instance Ord1 ScopeResolution where liftCompare = genericLiftCompare
@@ -248,7 +250,7 @@ instance Evaluatable ScopeResolution
 
 -- | A non-null expression such as Typescript or Swift's ! expression.
 newtype NonNullExpression a = NonNullExpression { nonNullExpression :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 NonNullExpression where liftEq = genericLiftEq
 instance Ord1 NonNullExpression where liftCompare = genericLiftCompare
@@ -260,7 +262,7 @@ instance Evaluatable NonNullExpression
 
 -- | An await expression in Javascript or C#.
 newtype Await a = Await { awaitSubject :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Await where liftEq = genericLiftEq
 instance Ord1 Await where liftCompare = genericLiftCompare
@@ -272,7 +274,7 @@ instance Evaluatable Await
 
 -- | An object constructor call in Javascript, Java, etc.
 newtype New a = New { newSubject :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 New where liftEq = genericLiftEq
 instance Ord1 New where liftCompare = genericLiftCompare
@@ -283,7 +285,7 @@ instance Evaluatable New
 
 -- | A cast expression to a specified type.
 data Cast a =  Cast { castSubject :: !a, castType :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Cast where liftEq = genericLiftEq
 instance Ord1 Cast where liftCompare = genericLiftCompare

src/Data/Syntax/Literal.hs

@@ -7,14 +7,14 @@ import Data.ByteString.Char8 (readInteger, unpack)
 import qualified Data.ByteString.Char8 as B
 import Data.Scientific.Exts
 import Diffing.Algorithm
-import Prelude hiding (Float, fail, null)
+import Prelude hiding (Float, null)
 import Prologue hiding (Set, hash, null)
 import Text.Read (readMaybe)
 
 -- Boolean
 
 newtype Boolean a = Boolean Bool
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 true :: Boolean a
 true = Boolean True
@@ -34,7 +34,7 @@ instance Evaluatable Boolean where
 
 -- | A literal integer of unspecified width. No particular base is implied.
 newtype Integer a = Integer { integerContent :: ByteString }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq
 instance Ord1 Data.Syntax.Literal.Integer where liftCompare = genericLiftCompare
@@ -42,14 +42,15 @@ instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShow
 
 instance Evaluatable Data.Syntax.Literal.Integer where
   -- TODO: This instance probably shouldn't have readInteger?
-  eval (Data.Syntax.Literal.Integer x) = integer (maybe 0 fst (readInteger x))
+  eval (Data.Syntax.Literal.Integer x) =
+    integer =<< maybeM (throwEvalError (IntegerFormatError x)) (fst <$> readInteger x)
 
 -- TODO: Should IntegerLiteral hold an Integer instead of a ByteString?
 -- TODO: Consider a Numeric datatype with FloatingPoint/Integral/etc constructors.
 
 -- | A literal float of unspecified width.
 newtype Float a = Float { floatContent  :: ByteString }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq
 instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare
@@ -57,28 +58,27 @@ instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsP
 
 instance Evaluatable Data.Syntax.Literal.Float where
   eval (Float s) =
-    case parseScientific s of
+    float =<< either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s)
-      Right num -> float num
-      Left  err -> fail ("Parse error: " <> err)
 
 -- Rational literals e.g. `2/3r`
 newtype Rational a = Rational ByteString
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Data.Syntax.Literal.Rational where liftEq = genericLiftEq
 instance Ord1 Data.Syntax.Literal.Rational where liftCompare = genericLiftCompare
 instance Show1 Data.Syntax.Literal.Rational where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Data.Syntax.Literal.Rational where
-  eval (Rational r) = let trimmed = B.takeWhile (/= 'r') r in
+  eval (Rational r) =
-    case readMaybe @Prelude.Integer (unpack trimmed) of
+    let
-      Just i  -> rational (toRational i)
+      trimmed = B.takeWhile (/= 'r') r
-      Nothing -> fail ("Bug: invalid rational " <> show r)
+      parsed = readMaybe @Prelude.Integer (unpack trimmed)
+    in rational =<< maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed
 
 
 -- Complex literals e.g. `3 + 2i`
 newtype Complex a = Complex ByteString
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Data.Syntax.Literal.Complex where liftEq = genericLiftEq
 instance Ord1 Data.Syntax.Literal.Complex where liftCompare = genericLiftCompare
@@ -90,7 +90,7 @@ instance Evaluatable Complex
 -- Strings, symbols
 
 newtype String a = String { stringElements :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Data.Syntax.Literal.String where liftEq = genericLiftEq
 instance Ord1 Data.Syntax.Literal.String where liftCompare = genericLiftCompare
@@ -104,7 +104,7 @@ instance Evaluatable Data.Syntax.Literal.String
 
 -- | An interpolation element within a string literal.
 newtype InterpolationElement a = InterpolationElement { interpolationBody :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 InterpolationElement where liftEq = genericLiftEq
 instance Ord1 InterpolationElement where liftCompare = genericLiftCompare
@@ -116,7 +116,7 @@ instance Evaluatable InterpolationElement
 
 -- | A sequence of textual contents within a string literal.
 newtype TextElement a = TextElement { textElementContent :: ByteString }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 TextElement where liftEq = genericLiftEq
 instance Ord1 TextElement where liftCompare = genericLiftCompare
@@ -126,7 +126,7 @@ instance Evaluatable TextElement where
   eval (TextElement x) = string x
 
 data Null a = Null
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Null where liftEq = genericLiftEq
 instance Ord1 Null where liftCompare = genericLiftCompare
@@ -135,7 +135,7 @@ instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Null where eval = const null
 
 newtype Symbol a = Symbol { symbolContent :: ByteString }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Symbol where liftEq = genericLiftEq
 instance Ord1 Symbol where liftCompare = genericLiftCompare
@@ -145,7 +145,7 @@ instance Evaluatable Symbol where
   eval (Symbol s) = symbol s
 
 newtype Regex a = Regex { regexContent :: ByteString }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Regex where liftEq = genericLiftEq
 instance Ord1 Regex where liftCompare = genericLiftCompare
@@ -161,7 +161,7 @@ instance Evaluatable Regex
 -- Collections
 
 newtype Array a = Array { arrayElements :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Array where liftEq = genericLiftEq
 instance Ord1 Array where liftCompare = genericLiftCompare
@@ -171,7 +171,7 @@ instance Evaluatable Array where
   eval (Array a) = array =<< traverse subtermValue a
 
 newtype Hash a = Hash { hashElements :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Hash where liftEq = genericLiftEq
 instance Ord1 Hash where liftCompare = genericLiftCompare
@@ -181,7 +181,7 @@ instance Evaluatable Hash where
   eval = hashElements >>> traverse (subtermValue >=> asPair) >=> hash
 
 data KeyValue a = KeyValue { key :: !a, value :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 KeyValue where liftEq = genericLiftEq
 instance Ord1 KeyValue where liftCompare = genericLiftCompare
@@ -192,7 +192,7 @@ instance Evaluatable KeyValue where
     join (kvPair <$> key <*> value)
 
 newtype Tuple a = Tuple { tupleContents :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Tuple where liftEq = genericLiftEq
 instance Ord1 Tuple where liftCompare = genericLiftCompare
@@ -202,7 +202,7 @@ instance Evaluatable Tuple where
   eval (Tuple cs) = multiple =<< traverse subtermValue cs
 
 newtype Set a = Set { setElements :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Set where liftEq = genericLiftEq
 instance Ord1 Set where liftCompare = genericLiftCompare
@@ -216,7 +216,7 @@ instance Evaluatable Set
 
 -- | A declared pointer (e.g. var pointer *int in Go)
 newtype Pointer a = Pointer a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Pointer where liftEq = genericLiftEq
 instance Ord1 Pointer where liftCompare = genericLiftCompare
@@ -228,7 +228,7 @@ instance Evaluatable Pointer
 
 -- | A reference to a pointer's address (e.g. &pointer in Go)
 newtype Reference a = Reference a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Reference where liftEq = genericLiftEq
 instance Ord1 Reference where liftCompare = genericLiftCompare

src/Data/Syntax/Statement.hs

@@ -9,7 +9,7 @@ import Prologue
 
 -- | Conditional. This must have an else block, which can be filled with some default value when omitted in the source, e.g. 'pure ()' for C-style if-without-else or 'pure Nothing' for Ruby-style, in both cases assuming some appropriate Applicative context into which the If will be lifted.
 data If a = If { ifCondition :: !a, ifThenBody :: !a, ifElseBody :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 If where liftEq = genericLiftEq
 instance Ord1 If where liftCompare = genericLiftCompare
@@ -22,7 +22,7 @@ instance Evaluatable If where
 
 -- | 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 }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Else where liftEq = genericLiftEq
 instance Ord1 Else where liftCompare = genericLiftCompare
@@ -35,7 +35,7 @@ instance Evaluatable Else
 
 -- | Goto statement (e.g. `goto a` in Go).
 newtype Goto a = Goto { gotoLocation :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Goto where liftEq = genericLiftEq
 instance Ord1 Goto where liftCompare = genericLiftCompare
@@ -47,7 +47,7 @@ instance Evaluatable Goto
 
 -- | A pattern-matching or computed jump control-flow statement, like 'switch' in C or JavaScript, or 'case' in Ruby or Haskell.
 data Match a = Match { matchSubject :: !a, matchPatterns :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Match where liftEq = genericLiftEq
 instance Ord1 Match where liftCompare = genericLiftCompare
@@ -59,7 +59,7 @@ instance Evaluatable Match
 
 -- | A pattern in a pattern-matching or computed jump control-flow statement, like 'case' in C or JavaScript, 'when' in Ruby, or the left-hand side of '->' in the body of Haskell 'case' expressions.
 data Pattern a = Pattern { _pattern :: !a, patternBody :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Pattern where liftEq = genericLiftEq
 instance Ord1 Pattern where liftCompare = genericLiftCompare
@@ -71,7 +71,7 @@ instance Evaluatable Pattern
 
 -- | A let statement or local binding, like 'a as b' or 'let a = b'.
 data Let a  = Let { letVariable :: !a, letValue :: !a, letBody :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Let where liftEq = genericLiftEq
 instance Ord1 Let where liftCompare = genericLiftCompare
@@ -88,7 +88,7 @@ instance Evaluatable Let where
 
 -- | Assignment to a variable or other lvalue.
 data Assignment a = Assignment { assignmentContext :: ![a], assignmentTarget :: !a, assignmentValue :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Assignment where liftEq = genericLiftEq
 instance Ord1 Assignment where liftCompare = genericLiftCompare
@@ -96,12 +96,17 @@ instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Assignment where
   eval Assignment{..} = do
-    lhs <- subtermValue assignmentTarget >>= scopedEnvironment
+    case freeVariables (subterm assignmentTarget) of
-    localEnv (mappend lhs) (subtermValue assignmentValue)
+      [name] -> do
+        v <- subtermValue assignmentValue
+        addr <- lookupOrAlloc name
+        assign addr v
+        modifyEnv (Env.insert name addr) $> v
+      _ -> evaluateInScopedEnv (subtermValue assignmentTarget) (subtermValue assignmentValue)
 
 -- | Post increment operator (e.g. 1++ in Go, or i++ in C).
 newtype PostIncrement a = PostIncrement a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 PostIncrement where liftEq = genericLiftEq
 instance Ord1 PostIncrement where liftCompare = genericLiftCompare
@@ -113,7 +118,7 @@ instance Evaluatable PostIncrement
 
 -- | Post decrement operator (e.g. 1-- in Go, or i-- in C).
 newtype PostDecrement a = PostDecrement a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 PostDecrement where liftEq = genericLiftEq
 instance Ord1 PostDecrement where liftCompare = genericLiftCompare
@@ -149,17 +154,17 @@ instance Evaluatable PreDecrement
 -- Returns
 
 newtype Return a = Return a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Return where liftEq = genericLiftEq
 instance Ord1 Return where liftCompare = genericLiftCompare
 instance Show1 Return where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Return where
-  eval (Return x) = subtermValue x
+  eval (Return x) = subtermValue x >>= earlyReturn
 
 newtype Yield a = Yield a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Yield where liftEq = genericLiftEq
 instance Ord1 Yield where liftCompare = genericLiftCompare
@@ -170,29 +175,28 @@ instance Evaluatable Yield
 
 
 newtype Break a = Break a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Break where liftEq = genericLiftEq
 instance Ord1 Break where liftCompare = genericLiftCompare
 instance Show1 Break where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for Break
+instance Evaluatable Break where
-instance Evaluatable Break
+  eval (Break x) = subtermValue x >>= throwBreak
-
 
 newtype Continue a = Continue a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Continue where liftEq = genericLiftEq
 instance Ord1 Continue where liftCompare = genericLiftCompare
 instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for Continue
+instance Evaluatable Continue where
-instance Evaluatable Continue
+  -- TODO: figure out what to do with the datum inside Continue. what can it represent?
-
+  eval (Continue _) = throwContinue
 
 newtype Retry a = Retry a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Retry where liftEq = genericLiftEq
 instance Ord1 Retry where liftCompare = genericLiftCompare
@@ -203,7 +207,7 @@ instance Evaluatable Retry
 
 
 newtype NoOp a = NoOp a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 NoOp where liftEq = genericLiftEq
 instance Ord1 NoOp where liftCompare = genericLiftCompare
@@ -215,7 +219,7 @@ instance Evaluatable NoOp where
 -- Loops
 
 data For a = For { forBefore :: !a, forCondition :: !a, forStep :: !a, forBody :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 For where liftEq = genericLiftEq
 instance Ord1 For where liftCompare = genericLiftCompare
@@ -226,7 +230,7 @@ instance Evaluatable For where
 
 
 data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ForEach where liftEq = genericLiftEq
 instance Ord1 ForEach where liftCompare = genericLiftCompare
@@ -237,7 +241,7 @@ instance Evaluatable ForEach
 
 
 data While a = While { whileCondition :: !a, whileBody :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 While where liftEq = genericLiftEq
 instance Ord1 While where liftCompare = genericLiftCompare
@@ -247,7 +251,7 @@ instance Evaluatable While where
   eval While{..} = while (subtermValue whileCondition)  (subtermValue whileBody)
 
 data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 DoWhile where liftEq = genericLiftEq
 instance Ord1 DoWhile where liftCompare = genericLiftCompare
@@ -259,7 +263,7 @@ instance Evaluatable DoWhile where
 -- Exception handling
 
 newtype Throw a = Throw a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Throw where liftEq = genericLiftEq
 instance Ord1 Throw where liftCompare = genericLiftCompare
@@ -270,7 +274,7 @@ instance Evaluatable Throw
 
 
 data Try a = Try { tryBody :: !a, tryCatch :: ![a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Try where liftEq = genericLiftEq
 instance Ord1 Try where liftCompare = genericLiftCompare
@@ -281,7 +285,7 @@ instance Evaluatable Try
 
 
 data Catch a = Catch { catchException :: !a, catchBody :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Catch where liftEq = genericLiftEq
 instance Ord1 Catch where liftCompare = genericLiftCompare
@@ -292,7 +296,7 @@ instance Evaluatable Catch
 
 
 newtype Finally a = Finally a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Finally where liftEq = genericLiftEq
 instance Ord1 Finally where liftCompare = genericLiftCompare
@@ -306,7 +310,7 @@ instance Evaluatable Finally
 
 -- | ScopeEntry (e.g. `BEGIN {}` block in Ruby or Perl).
 newtype ScopeEntry a = ScopeEntry [a]
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ScopeEntry where liftEq = genericLiftEq
 instance Ord1 ScopeEntry where liftCompare = genericLiftCompare
@@ -318,7 +322,7 @@ instance Evaluatable ScopeEntry
 
 -- | ScopeExit (e.g. `END {}` block in Ruby or Perl).
 newtype ScopeExit a = ScopeExit [a]
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ScopeExit where liftEq = genericLiftEq
 instance Ord1 ScopeExit where liftCompare = genericLiftCompare
@@ -326,3 +330,14 @@ instance Show1 ScopeExit where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for ScopeExit
 instance Evaluatable ScopeExit
+
+-- | HashBang line (e.g. `#!/usr/bin/env node`)
+newtype HashBang a = HashBang ByteString
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
+
+instance Eq1 HashBang where liftEq = genericLiftEq
+instance Ord1 HashBang where liftCompare = genericLiftCompare
+instance Show1 HashBang where liftShowsPrec = genericLiftShowsPrec
+
+-- TODO: Implement Eval instance for HashBang
+instance Evaluatable HashBang

src/Data/Syntax/Type.hs

@@ -7,7 +7,7 @@ import Prelude hiding (Int, Float, Bool)
 import Prologue hiding (Map)
 
 data Array a = Array { arraySize :: Maybe a, arrayElementType :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Array where liftEq = genericLiftEq
 instance Ord1 Array where liftCompare = genericLiftCompare
@@ -19,7 +19,7 @@ instance Evaluatable Array
 
 -- TODO: What about type variables? re: FreeVariables1
 data Annotation a = Annotation { annotationSubject :: !a, annotationType :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Annotation where liftEq = genericLiftEq
 instance Ord1 Annotation where liftCompare = genericLiftCompare
@@ -31,7 +31,7 @@ instance Evaluatable Annotation where
 
 
 data Function a = Function { functionParameters :: [a], functionReturn :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Function where liftEq = genericLiftEq
 instance Ord1 Function where liftCompare = genericLiftCompare
@@ -42,7 +42,7 @@ instance Evaluatable Function
 
 
 newtype Interface a = Interface [a]
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Interface where liftEq = genericLiftEq
 instance Ord1 Interface where liftCompare = genericLiftCompare
@@ -53,7 +53,7 @@ instance Evaluatable Interface
 
 
 data Map a = Map { mapKeyType :: a, mapElementType :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Map where liftEq = genericLiftEq
 instance Ord1 Map where liftCompare = genericLiftCompare
@@ -64,7 +64,7 @@ instance Evaluatable Map
 
 
 newtype Parenthesized a = Parenthesized a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Parenthesized where liftEq = genericLiftEq
 instance Ord1 Parenthesized where liftCompare = genericLiftCompare
@@ -75,7 +75,7 @@ instance Evaluatable Parenthesized
 
 
 newtype Pointer a = Pointer a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Pointer where liftEq = genericLiftEq
 instance Ord1 Pointer where liftCompare = genericLiftCompare
@@ -86,7 +86,7 @@ instance Evaluatable Pointer
 
 
 newtype Product a = Product [a]
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Product where liftEq = genericLiftEq
 instance Ord1 Product where liftCompare = genericLiftCompare
@@ -97,7 +97,7 @@ instance Evaluatable Product
 
 
 data Readonly a = Readonly
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Readonly where liftEq = genericLiftEq
 instance Ord1 Readonly where liftCompare = genericLiftCompare
@@ -108,7 +108,7 @@ instance Evaluatable Readonly
 
 
 newtype Slice a = Slice a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Slice where liftEq = genericLiftEq
 instance Ord1 Slice where liftCompare = genericLiftCompare
@@ -119,7 +119,7 @@ instance Evaluatable Slice
 
 
 newtype TypeParameters a = TypeParameters [a]
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 TypeParameters where liftEq = genericLiftEq
 instance Ord1 TypeParameters where liftCompare = genericLiftCompare

src/Language/Go/Assignment.hs

@@ -89,7 +89,6 @@ type Syntax =
    , Syntax.Error
    , Syntax.Empty
    , Syntax.Identifier
-   , Syntax.Paren
    , Syntax.Program
    , Type.Annotation
    , Type.Array
@@ -429,7 +428,7 @@ parameterDeclaration :: Assignment
 parameterDeclaration = makeTerm <$> symbol ParameterDeclaration <*> children (manyTerm expression)
 
 parenthesizedExpression :: Assignment
-parenthesizedExpression = makeTerm <$> symbol ParenthesizedExpression <*> (Syntax.Paren <$> children expressions)
+parenthesizedExpression = symbol ParenthesizedExpression *> children expressions
 
 selectorExpression :: Assignment
 selectorExpression = makeTerm <$> symbol SelectorExpression <*> children (Expression.MemberAccess <$> expression <*> expression)

src/Language/Go/Syntax.hs

@@ -1,48 +1,66 @@
-{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveAnyClass, ScopedTypeVariables #-}
 module Language.Go.Syntax where
 
-import Data.Abstract.Evaluatable hiding (Label)
+import           Data.Abstract.Evaluatable hiding (Label)
-import Data.Abstract.Module
+import           Data.Abstract.FreeVariables (Name (..), name)
-import Data.Abstract.FreeVariables (name)
+import           Data.Abstract.Module
-import Diffing.Algorithm
+import qualified Data.Abstract.Package as Package
-import qualified Data.ByteString.Char8 as BC
+import           Data.Abstract.Path
 import qualified Data.ByteString as B
-import System.FilePath.Posix
+import qualified Data.ByteString.Char8 as BC
-import Prologue
+import           Diffing.Algorithm
+import           Prologue
+import           System.FilePath.Posix
 
-newtype ImportPath = ImportPath { unPath :: FilePath }
+data Relative = Relative | NonRelative
+  deriving (Eq, Ord, Show)
+
+data ImportPath = ImportPath { unPath :: FilePath, pathIsRelative :: Relative }
   deriving (Eq, Ord, Show)
 
 importPath :: ByteString -> ImportPath
-importPath str = let path = stripQuotes str in ImportPath (BC.unpack path)
+importPath str = let path = stripQuotes str in ImportPath (BC.unpack path) (pathType path)
-  where stripQuotes = B.filter (`B.notElem` "\'\"")
+  where
+    stripQuotes = B.filter (`B.notElem` "\'\"")
+    pathType xs | not (B.null xs), BC.head xs == '.' = Relative
+                | otherwise = NonRelative
 
 defaultAlias :: ImportPath -> Name
 defaultAlias = name . BC.pack . takeFileName . unPath
 
--- TODO: need to delineate between relative and absolute Go imports
+resolveGoImport :: forall value term location effects m. MonadEvaluatable location term value effects m => ImportPath -> m effects [ModulePath]
-resolveGoImport :: MonadEvaluatable location term value m => FilePath -> m [ModulePath]
+resolveGoImport (ImportPath path Relative) = do
-resolveGoImport relImportPath = do
   ModuleInfo{..} <- currentModule
-  let relRootDir = takeDirectory (makeRelative moduleRoot modulePath)
+  paths <- listModulesInDir (joinPaths (takeDirectory modulePath) path)
-  listModulesInDir $ normalise (relRootDir </> normalise relImportPath)
+  case paths of
+    [] -> throwResumable @(ResolutionError value) $ GoImportError path
+    _ -> pure paths
+resolveGoImport (ImportPath path NonRelative) = do
+  package <- BC.unpack . unName . Package.packageName <$> currentPackage
+  traceM ("attempting to resolve " <> show path <> " for package " <> package)
+  case splitDirectories path of
+    -- Import an absolute path that's defined in this package being analyized.
+    -- First two are source, next is package name, remaining are path to package
+    -- (e.g. github.com/golang/<package>/path...).
+    (_ : _ : p : xs) | p == package -> listModulesInDir (joinPath xs)
+    _ -> throwResumable @(ResolutionError value) $ GoImportError path
 
 -- | Import declarations (symbols are added directly to the calling environment).
 --
 -- If the list of symbols is empty copy everything to the calling environment.
 data Import a = Import { importFrom :: ImportPath, importWildcardToken :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Import where liftEq = genericLiftEq
 instance Ord1 Import where liftCompare = genericLiftCompare
 instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Import where
-  eval (Import (ImportPath name) _) = do
+  eval (Import importPath _) = do
-    paths <- resolveGoImport name
+    paths <- resolveGoImport importPath
     for_ paths $ \path -> do
-      (importedEnv, _) <- isolate (require path)
+      (importedEnv, _) <- traceResolve (unPath importPath) path $ isolate (require path)
-      modifyEnv (mappend importedEnv)
+      modifyEnv (mergeEnvs importedEnv)
     unit
 
 
@@ -50,41 +68,41 @@ instance Evaluatable Import where
 --
 -- If the list of symbols is empty copy and qualify everything to the calling environment.
 data QualifiedImport a = QualifiedImport { qualifiedImportFrom :: !ImportPath, qualifiedImportAlias :: !a}
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 QualifiedImport where liftEq = genericLiftEq
 instance Ord1 QualifiedImport where liftCompare = genericLiftCompare
 instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable QualifiedImport where
-  eval (QualifiedImport (ImportPath name) aliasTerm) = do
+  eval (QualifiedImport importPath aliasTerm) = do
-    paths <- resolveGoImport name
+    paths <- resolveGoImport importPath
     alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
     void $ letrec' alias $ \addr -> do
       for_ paths $ \path -> do
-        (importedEnv, _) <- isolate (require path)
+        (importedEnv, _) <- traceResolve (unPath importPath) path $ isolate (require path)
-        modifyEnv (mappend importedEnv)
+        modifyEnv (mergeEnvs importedEnv)
 
-      makeNamespace alias addr []
+      makeNamespace alias addr Nothing
     unit
 
 -- | Side effect only imports (no symbols made available to the calling environment).
 data SideEffectImport a = SideEffectImport { sideEffectImportFrom :: !ImportPath, sideEffectImportToken :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 SideEffectImport where liftEq = genericLiftEq
 instance Ord1 SideEffectImport where liftCompare = genericLiftCompare
 instance Show1 SideEffectImport where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable SideEffectImport where
-  eval (SideEffectImport (ImportPath name) _) = do
+  eval (SideEffectImport importPath _) = do
-    paths <- resolveGoImport name
+    paths <- resolveGoImport importPath
-    for_ paths (isolate . require)
+    for_ paths $ \path -> traceResolve (unPath importPath) path $ isolate (require path)
     unit
 
 -- A composite literal in Go
 data Composite a = Composite { compositeType :: !a, compositeElement :: !a }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Composite where liftEq = genericLiftEq
 instance Ord1 Composite where liftCompare = genericLiftCompare
@@ -95,7 +113,7 @@ instance Evaluatable Composite
 
 -- | A default pattern in a Go select or switch statement (e.g. `switch { default: s() }`).
 newtype DefaultPattern a = DefaultPattern { defaultPatternBody :: a }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 DefaultPattern where liftEq = genericLiftEq
 instance Ord1 DefaultPattern where liftCompare = genericLiftCompare
@@ -106,7 +124,7 @@ instance Evaluatable DefaultPattern
 
 -- | A defer statement in Go (e.g. `defer x()`).
 newtype Defer a = Defer { deferBody :: a }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Defer where liftEq = genericLiftEq
 instance Ord1 Defer where liftCompare = genericLiftCompare
@@ -117,7 +135,7 @@ instance Evaluatable Defer
 
 -- | A go statement (i.e. go routine) in Go (e.g. `go x()`).
 newtype Go a = Go { goBody :: a }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Go where liftEq = genericLiftEq
 instance Ord1 Go where liftCompare = genericLiftCompare
@@ -128,7 +146,7 @@ instance Evaluatable Go
 
 -- | A label statement in Go (e.g. `label:continue`).
 data Label a = Label { _labelName :: !a, labelStatement :: !a }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Label where liftEq = genericLiftEq
 instance Ord1 Label where liftCompare = genericLiftCompare
@@ -139,7 +157,7 @@ instance Evaluatable Label
 
 -- | A rune literal in Go (e.g. `'⌘'`).
 newtype Rune a = Rune { _runeLiteral :: ByteString }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 -- TODO: Implement Eval instance for Rune
 instance Evaluatable Rune
@@ -150,7 +168,7 @@ instance Show1 Rune where liftShowsPrec = genericLiftShowsPrec
 
 -- | A select statement in Go (e.g. `select { case x := <-c: x() }` where each case is a send or receive operation on channels).
 newtype Select a = Select { selectCases :: a }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 -- TODO: Implement Eval instance for Select
 instance Evaluatable Select
@@ -161,7 +179,7 @@ instance Show1 Select where liftShowsPrec = genericLiftShowsPrec
 
 -- | A send statement in Go (e.g. `channel <- value`).
 data Send a = Send { sendReceiver :: !a, sendValue :: !a }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Send where liftEq = genericLiftEq
 instance Ord1 Send where liftCompare = genericLiftCompare
@@ -172,7 +190,7 @@ instance Evaluatable Send
 
 -- | A slice expression in Go (e.g. `a[1:4:3]` where a is a list, 1 is the low bound, 4 is the high bound, and 3 is the max capacity).
 data Slice a = Slice { sliceName :: !a, sliceLow :: !a, sliceHigh :: !a, sliceCapacity :: !a }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Slice where liftEq = genericLiftEq
 instance Ord1 Slice where liftCompare = genericLiftCompare
@@ -183,7 +201,7 @@ instance Evaluatable Slice
 
 -- | A type switch statement in Go (e.g. `switch x.(type) { // cases }`).
 data TypeSwitch a = TypeSwitch { typeSwitchSubject :: !a, typeSwitchCases :: !a }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 TypeSwitch where liftEq = genericLiftEq
 instance Ord1 TypeSwitch where liftCompare = genericLiftCompare
@@ -194,7 +212,7 @@ instance Evaluatable TypeSwitch
 
 -- | A type switch guard statement in a Go type switch statement (e.g. `switch i := x.(type) { // cases}`).
 newtype TypeSwitchGuard a = TypeSwitchGuard { typeSwitchGuardSubject :: a }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 TypeSwitchGuard where liftEq = genericLiftEq
 instance Ord1 TypeSwitchGuard where liftCompare = genericLiftCompare
@@ -205,7 +223,7 @@ instance Evaluatable TypeSwitchGuard
 
 -- | A receive statement in a Go select statement (e.g. `case value := <-channel` )
 data Receive a = Receive { receiveSubject :: !a, receiveExpression :: !a }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Receive where liftEq = genericLiftEq
 instance Ord1 Receive where liftCompare = genericLiftCompare
@@ -216,7 +234,7 @@ instance Evaluatable Receive
 
 -- | A receive operator unary expression in Go (e.g. `<-channel` )
 newtype ReceiveOperator a = ReceiveOperator a
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 ReceiveOperator where liftEq = genericLiftEq
 instance Ord1 ReceiveOperator where liftCompare = genericLiftCompare
@@ -227,7 +245,7 @@ instance Evaluatable ReceiveOperator
 
 -- | A field declaration in a Go struct type declaration.
 data Field a = Field { fieldContext :: ![a], fieldName :: !a }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Field where liftEq = genericLiftEq
 instance Ord1 Field where liftCompare = genericLiftCompare
@@ -238,7 +256,7 @@ instance Evaluatable Field
 
 
 data Package a = Package { packageName :: !a, packageContents :: ![a] }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Package where liftEq = genericLiftEq
 instance Ord1 Package where liftCompare = genericLiftCompare
@@ -250,7 +268,7 @@ instance Evaluatable Package where
 
 -- | A type assertion in Go (e.g. `x.(T)` where the value of `x` is not nil and is of type `T`).
 data TypeAssertion a = TypeAssertion { typeAssertionSubject :: !a, typeAssertionType :: !a }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 TypeAssertion where liftEq = genericLiftEq
 instance Ord1 TypeAssertion where liftCompare = genericLiftCompare
@@ -261,7 +279,7 @@ instance Evaluatable TypeAssertion
 
 -- | A type conversion expression in Go (e.g. `T(x)` where `T` is a type and `x` is an expression that can be converted to type `T`).
 data TypeConversion a = TypeConversion { typeConversionType :: !a, typeConversionSubject :: !a }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 TypeConversion where liftEq = genericLiftEq
 instance Ord1 TypeConversion where liftCompare = genericLiftCompare
@@ -272,7 +290,7 @@ instance Evaluatable TypeConversion
 
 -- | Variadic arguments and parameters in Go (e.g. parameter: `param ...Type`, argument: `Type...`).
 data Variadic a = Variadic { variadicContext :: [a], variadicIdentifier :: a }
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Variadic where liftEq = genericLiftEq
 instance Ord1 Variadic where liftCompare = genericLiftCompare

src/Language/Go/Type.hs

@@ -7,7 +7,7 @@ import Diffing.Algorithm
 
 -- | A Bidirectional channel in Go (e.g. `chan`).
 newtype BidirectionalChannel a = BidirectionalChannel a
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 BidirectionalChannel where liftEq = genericLiftEq
 instance Ord1 BidirectionalChannel where liftCompare = genericLiftCompare
@@ -18,7 +18,7 @@ instance Evaluatable BidirectionalChannel
 
 -- | A Receive channel in Go (e.g. `<-chan`).
 newtype ReceiveChannel a = ReceiveChannel a
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 ReceiveChannel where liftEq = genericLiftEq
 instance Ord1 ReceiveChannel where liftCompare = genericLiftCompare
@@ -29,7 +29,7 @@ instance Evaluatable ReceiveChannel
 
 -- | A Send channel in Go (e.g. `chan<-`).
 newtype SendChannel a = SendChannel a
-  deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 SendChannel where liftEq = genericLiftEq
 instance Ord1 SendChannel where liftCompare = genericLiftCompare

src/Language/JSON/Assignment.hs

@@ -23,10 +23,8 @@ type Syntax =
   , Literal.Float
   , Literal.KeyValue
   , Literal.Null
-  , Literal.String
   , Literal.TextElement
   , Syntax.Error
-  , []
   ]
 
 type Term = Term.Term (Union Syntax) (Record Location)

src/Language/PHP/Assignment.hs

@@ -103,7 +103,6 @@ type Syntax = '[
   , Syntax.NamespaceUseDeclaration
   , Syntax.NamespaceUseGroupClause
   , Syntax.NewVariable
-  , Syntax.Paren
   , Syntax.PrintIntrinsic
   , Syntax.Program
   , Syntax.PropertyDeclaration
@@ -288,7 +287,7 @@ primaryExpression = choice [
   ]
 
 parenthesizedExpression :: Assignment
-parenthesizedExpression = makeTerm <$> symbol ParenthesizedExpression <*> (Syntax.Paren <$> children (term expression))
+parenthesizedExpression = symbol ParenthesizedExpression *> children (term expression)
 
 classConstantAccessExpression :: Assignment
 classConstantAccessExpression = makeTerm <$> symbol ClassConstantAccessExpression <*> children (Expression.MemberAccess <$> term scopeResolutionQualifier <*> term name)

src/Language/PHP/Syntax.hs

@@ -1,16 +1,17 @@
-{-# LANGUAGE DeriveAnyClass, ViewPatterns #-}
+{-# LANGUAGE DeriveAnyClass, ViewPatterns, ScopedTypeVariables #-}
 module Language.PHP.Syntax where
 
 import           Data.Abstract.Evaluatable
 import           Data.Abstract.Module
 import           Data.Abstract.Path
 import qualified Data.ByteString.Char8 as BC
+import qualified Data.Language as Language
 import           Diffing.Algorithm
 import           Prelude hiding (fail)
 import           Prologue hiding (Text)
 
 newtype Text a = Text ByteString
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Text where liftEq = genericLiftEq
 instance Ord1 Text where liftCompare = genericLiftCompare
@@ -19,7 +20,7 @@ instance Evaluatable Text
 
 
 newtype VariableName a = VariableName a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 VariableName where liftEq = genericLiftEq
 instance Ord1 VariableName where liftCompare = genericLiftCompare
@@ -34,74 +35,70 @@ instance Evaluatable VariableName
 -- file, the complete contents of the included file are treated as though it
 -- were defined inside that function.
 
-resolvePHPName :: MonadEvaluatable location term value m => ByteString -> m ModulePath
+resolvePHPName :: forall value location term effects m. MonadEvaluatable location term value effects m => ByteString -> m effects ModulePath
-resolvePHPName n = resolve [name] >>= maybeFail notFound
+resolvePHPName n = do
+  modulePath <- resolve [name]
+  maybe (throwResumable @(ResolutionError value) $ NotFoundError name [name] Language.PHP) pure modulePath
   where name = toName n
-        notFound = "Unable to resolve: " <> name
         toName = BC.unpack . dropRelativePrefix . stripQuotes
 
-doInclude :: MonadEvaluatable location term value m => Subterm t (m value) -> m value
+include :: MonadEvaluatable location term value effects m
-doInclude pathTerm = do
+        => Subterm t (m effects value)
+        -> (ModulePath -> m effects (Environment location value, value))
+        -> m effects value
+include pathTerm f = do
   name <- subtermValue pathTerm >>= asString
   path <- resolvePHPName name
-  (importedEnv, v) <- isolate (load path)
+  (importedEnv, v) <- traceResolve name path $ isolate (f path)
-  modifyEnv (mappend importedEnv)
+  modifyEnv (mergeEnvs importedEnv)
-  pure v
-
-doIncludeOnce :: MonadEvaluatable location term value m => Subterm t (m value) -> m value
-doIncludeOnce pathTerm = do
-  name <- subtermValue pathTerm >>= asString
-  path <- resolvePHPName name
-  (importedEnv, v) <- isolate (require path)
-  modifyEnv (mappend importedEnv)
   pure v
 
 newtype Require a = Require a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Require where liftEq          = genericLiftEq
 instance Ord1 Require where liftCompare    = genericLiftCompare
 instance Show1 Require where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Require where
-  eval (Require path) = doInclude path
+  eval (Require path) = include path load
 
 
 newtype RequireOnce a = RequireOnce a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 RequireOnce where liftEq = genericLiftEq
 instance Ord1 RequireOnce where liftCompare = genericLiftCompare
 instance Show1 RequireOnce where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable RequireOnce where
-  eval (RequireOnce path) = doIncludeOnce path
+  eval (RequireOnce path) = include path require
 
 
 newtype Include a = Include a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Include where liftEq          = genericLiftEq
 instance Ord1 Include where liftCompare    = genericLiftCompare
 instance Show1 Include where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Include where
-  eval (Include path) = doInclude path
+  eval (Include path) = include path load
 
 
 newtype IncludeOnce a = IncludeOnce a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 IncludeOnce where liftEq          = genericLiftEq
 instance Ord1 IncludeOnce where liftCompare    = genericLiftCompare
 instance Show1 IncludeOnce where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable IncludeOnce where
-  eval (IncludeOnce path) = doIncludeOnce path
+  eval (IncludeOnce path) = include path require
 
 
 newtype ArrayElement a = ArrayElement a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 ArrayElement where liftEq          = genericLiftEq
 instance Ord1 ArrayElement where liftCompare    = genericLiftCompare
@@ -109,7 +106,7 @@ instance Show1 ArrayElement where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ArrayElement
 
 newtype GlobalDeclaration a = GlobalDeclaration [a]
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 GlobalDeclaration where liftEq          = genericLiftEq
 instance Ord1 GlobalDeclaration where liftCompare    = genericLiftCompare
@@ -117,7 +114,7 @@ instance Show1 GlobalDeclaration where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable GlobalDeclaration
 
 newtype SimpleVariable a = SimpleVariable a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 SimpleVariable where liftEq          = genericLiftEq
 instance Ord1 SimpleVariable where liftCompare    = genericLiftCompare
@@ -127,7 +124,7 @@ instance Evaluatable SimpleVariable
 
 -- | TODO: Unify with TypeScript's PredefinedType
 newtype CastType a = CastType { _castType :: ByteString }
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 CastType where liftEq = genericLiftEq
 instance Ord1 CastType where liftCompare = genericLiftCompare
@@ -135,7 +132,7 @@ instance Show1 CastType where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable CastType
 
 newtype ErrorControl a = ErrorControl a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 ErrorControl where liftEq = genericLiftEq
 instance Ord1 ErrorControl where liftCompare = genericLiftCompare
@@ -143,7 +140,7 @@ instance Show1 ErrorControl where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ErrorControl
 
 newtype Clone a = Clone a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Clone where liftEq = genericLiftEq
 instance Ord1 Clone where liftCompare = genericLiftCompare
@@ -151,7 +148,7 @@ instance Show1 Clone where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Clone
 
 newtype ShellCommand a = ShellCommand ByteString
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 ShellCommand where liftEq = genericLiftEq
 instance Ord1 ShellCommand where liftCompare = genericLiftCompare
@@ -160,7 +157,7 @@ instance Evaluatable ShellCommand
 
 -- | TODO: Combine with TypeScript update expression.
 newtype Update a = Update { _updateSubject :: a }
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Update where liftEq = genericLiftEq
 instance Ord1 Update where liftCompare = genericLiftCompare
@@ -168,7 +165,7 @@ instance Show1 Update where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Update
 
 newtype NewVariable a = NewVariable [a]
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 NewVariable where liftEq = genericLiftEq
 instance Ord1 NewVariable where liftCompare = genericLiftCompare
@@ -176,7 +173,7 @@ instance Show1 NewVariable where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable NewVariable
 
 newtype RelativeScope a = RelativeScope ByteString
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 RelativeScope where liftEq = genericLiftEq
 instance Ord1 RelativeScope where liftCompare = genericLiftCompare
@@ -184,34 +181,27 @@ instance Show1 RelativeScope where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable RelativeScope
 
 data QualifiedName a = QualifiedName !a !a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 QualifiedName where liftEq = genericLiftEq
 instance Ord1 QualifiedName where liftCompare = genericLiftCompare
 instance Show1 QualifiedName where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable QualifiedName where
-  eval (fmap subtermValue -> QualifiedName name iden) = do
+  eval (fmap subtermValue -> QualifiedName name iden) = evaluateInScopedEnv name iden
-    lhs <- name >>= scopedEnvironment
-    localEnv (mappend lhs) iden
-
 
 newtype NamespaceName a = NamespaceName (NonEmpty a)
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 NamespaceName where liftEq = genericLiftEq
 instance Ord1 NamespaceName where liftCompare = genericLiftCompare
 instance Show1 NamespaceName where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable NamespaceName where
-  eval (NamespaceName xs) = foldl1 f $ fmap subtermValue xs
+  eval (NamespaceName xs) = foldl1 evaluateInScopedEnv $ fmap subtermValue xs
-    where
-      f ns nam = do
-        env <- ns >>= scopedEnvironment
-        localEnv (mappend env) nam
 
 newtype ConstDeclaration a = ConstDeclaration [a]
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 ConstDeclaration where liftEq = genericLiftEq
 instance Ord1 ConstDeclaration where liftCompare = genericLiftCompare
@@ -219,7 +209,7 @@ instance Show1 ConstDeclaration where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ConstDeclaration
 
 data ClassConstDeclaration a = ClassConstDeclaration a [a]
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 ClassConstDeclaration where liftEq = genericLiftEq
 instance Ord1 ClassConstDeclaration where liftCompare = genericLiftCompare
@@ -227,7 +217,7 @@ instance Show1 ClassConstDeclaration where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ClassConstDeclaration
 
 newtype ClassInterfaceClause a = ClassInterfaceClause [a]
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 ClassInterfaceClause where liftEq = genericLiftEq
 instance Ord1 ClassInterfaceClause where liftCompare = genericLiftCompare
@@ -235,7 +225,7 @@ instance Show1 ClassInterfaceClause where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ClassInterfaceClause
 
 newtype ClassBaseClause a = ClassBaseClause a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 ClassBaseClause where liftEq = genericLiftEq
 instance Ord1 ClassBaseClause where liftCompare = genericLiftCompare
@@ -244,7 +234,7 @@ instance Evaluatable ClassBaseClause
 
 
 newtype UseClause a = UseClause [a]
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 UseClause where liftEq = genericLiftEq
 instance Ord1 UseClause where liftCompare = genericLiftCompare
@@ -252,7 +242,7 @@ instance Show1 UseClause where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable UseClause
 
 newtype ReturnType a = ReturnType a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 ReturnType where liftEq = genericLiftEq
 instance Ord1 ReturnType where liftCompare = genericLiftCompare
@@ -260,7 +250,7 @@ instance Show1 ReturnType where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ReturnType
 
 newtype TypeDeclaration a = TypeDeclaration a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 TypeDeclaration where liftEq = genericLiftEq
 instance Ord1 TypeDeclaration where liftCompare = genericLiftCompare
@@ -268,7 +258,7 @@ instance Show1 TypeDeclaration where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable TypeDeclaration
 
 newtype BaseTypeDeclaration a = BaseTypeDeclaration a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 BaseTypeDeclaration where liftEq = genericLiftEq
 instance Ord1 BaseTypeDeclaration where liftCompare = genericLiftCompare
@@ -276,7 +266,7 @@ instance Show1 BaseTypeDeclaration where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable BaseTypeDeclaration
 
 newtype ScalarType a = ScalarType ByteString
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 ScalarType where liftEq = genericLiftEq
 instance Ord1 ScalarType where liftCompare = genericLiftCompare
@@ -284,7 +274,7 @@ instance Show1 ScalarType where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ScalarType
 
 newtype EmptyIntrinsic a = EmptyIntrinsic a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 EmptyIntrinsic where liftEq = genericLiftEq
 instance Ord1 EmptyIntrinsic where liftCompare = genericLiftCompare
@@ -292,7 +282,7 @@ instance Show1 EmptyIntrinsic where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable EmptyIntrinsic
 
 newtype ExitIntrinsic a = ExitIntrinsic a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 ExitIntrinsic where liftEq = genericLiftEq
 instance Ord1 ExitIntrinsic where liftCompare = genericLiftCompare
@@ -300,7 +290,7 @@ instance Show1 ExitIntrinsic where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ExitIntrinsic
 
 newtype IssetIntrinsic a = IssetIntrinsic a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 IssetIntrinsic where liftEq = genericLiftEq
 instance Ord1 IssetIntrinsic where liftCompare = genericLiftCompare
@@ -308,7 +298,7 @@ instance Show1 IssetIntrinsic where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable IssetIntrinsic
 
 newtype EvalIntrinsic a = EvalIntrinsic a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 EvalIntrinsic where liftEq = genericLiftEq
 instance Ord1 EvalIntrinsic where liftCompare = genericLiftCompare
@@ -316,7 +306,7 @@ instance Show1 EvalIntrinsic where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable EvalIntrinsic
 
 newtype PrintIntrinsic a = PrintIntrinsic a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 PrintIntrinsic where liftEq = genericLiftEq
 instance Ord1 PrintIntrinsic where liftCompare = genericLiftCompare
@@ -324,7 +314,7 @@ instance Show1 PrintIntrinsic where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable PrintIntrinsic
 
 newtype NamespaceAliasingClause a = NamespaceAliasingClause a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 NamespaceAliasingClause where liftEq = genericLiftEq
 instance Ord1 NamespaceAliasingClause where liftCompare = genericLiftCompare
@@ -332,7 +322,7 @@ instance Show1 NamespaceAliasingClause where liftShowsPrec = genericLiftShowsPre
 instance Evaluatable NamespaceAliasingClause
 
 newtype NamespaceUseDeclaration a = NamespaceUseDeclaration [a]
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 NamespaceUseDeclaration where liftEq = genericLiftEq
 instance Ord1 NamespaceUseDeclaration where liftCompare = genericLiftCompare
@@ -340,7 +330,7 @@ instance Show1 NamespaceUseDeclaration where liftShowsPrec = genericLiftShowsPre
 instance Evaluatable NamespaceUseDeclaration
 
 newtype NamespaceUseClause a = NamespaceUseClause [a]
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 NamespaceUseClause where liftEq = genericLiftEq
 instance Ord1 NamespaceUseClause where liftCompare = genericLiftCompare
@@ -348,7 +338,7 @@ instance Show1 NamespaceUseClause where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable NamespaceUseClause
 
 newtype NamespaceUseGroupClause a = NamespaceUseGroupClause [a]
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 NamespaceUseGroupClause where liftEq = genericLiftEq
 instance Ord1 NamespaceUseGroupClause where liftCompare = genericLiftCompare
@@ -356,7 +346,7 @@ instance Show1 NamespaceUseGroupClause where liftShowsPrec = genericLiftShowsPre
 instance Evaluatable NamespaceUseGroupClause
 
 data Namespace a = Namespace { namespaceName :: a, namespaceBody :: a }
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Namespace where liftEq = genericLiftEq
 instance Ord1 Namespace where liftCompare = genericLiftCompare
@@ -366,16 +356,16 @@ instance Evaluatable Namespace where
   eval Namespace{..} = go names
     where
       names = freeVariables (subterm namespaceName)
-      go [] = fail "expected at least one free variable in namespaceName, found none"
+      go [] = raise (fail "expected at least one free variable in namespaceName, found none")
       -- The last name creates a closure over the namespace body.
       go [name] = letrec' name $ \addr ->
-        subtermValue namespaceBody *> makeNamespace name addr []
+        subtermValue namespaceBody *> makeNamespace name addr Nothing
       -- Each namespace name creates a closure over the subsequent namespace closures
       go (name:xs) = letrec' name $ \addr ->
-        go xs <* makeNamespace name addr []
+        go xs <* makeNamespace name addr Nothing
 
 data TraitDeclaration a = TraitDeclaration { traitName :: a, traitStatements :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 TraitDeclaration where liftEq = genericLiftEq
 instance Ord1 TraitDeclaration where liftCompare = genericLiftCompare
@@ -383,7 +373,7 @@ instance Show1 TraitDeclaration where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable TraitDeclaration
 
 data AliasAs a = AliasAs { aliasAsName  :: a, aliasAsModifier :: a, aliasAsClause :: a }
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 AliasAs where liftEq = genericLiftEq
 instance Ord1 AliasAs where liftCompare = genericLiftCompare
@@ -391,7 +381,7 @@ instance Show1 AliasAs where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable AliasAs
 
 data InsteadOf a = InsteadOf a a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 InsteadOf where liftEq = genericLiftEq
 instance Ord1 InsteadOf where liftCompare = genericLiftCompare
@@ -399,7 +389,7 @@ instance Show1 InsteadOf where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable InsteadOf
 
 newtype TraitUseSpecification a = TraitUseSpecification [a]
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 TraitUseSpecification where liftEq = genericLiftEq
 instance Ord1 TraitUseSpecification where liftCompare = genericLiftCompare
@@ -407,7 +397,7 @@ instance Show1 TraitUseSpecification where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable TraitUseSpecification
 
 data TraitUseClause a = TraitUseClause [a] a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 TraitUseClause where liftEq = genericLiftEq
 instance Ord1 TraitUseClause where liftCompare = genericLiftCompare
@@ -415,7 +405,7 @@ instance Show1 TraitUseClause where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable TraitUseClause
 
 data DestructorDeclaration a = DestructorDeclaration [a] a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 DestructorDeclaration where liftEq = genericLiftEq
 instance Ord1 DestructorDeclaration where liftCompare = genericLiftCompare
@@ -423,7 +413,7 @@ instance Show1 DestructorDeclaration where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable DestructorDeclaration
 
 newtype Static a = Static ByteString
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Static where liftEq = genericLiftEq
 instance Ord1 Static where liftCompare = genericLiftCompare
@@ -431,7 +421,7 @@ instance Show1 Static where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Static
 
 newtype ClassModifier a = ClassModifier ByteString
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 ClassModifier where liftEq = genericLiftEq
 instance Ord1 ClassModifier where liftCompare = genericLiftCompare
@@ -439,7 +429,7 @@ instance Show1 ClassModifier where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ClassModifier
 
 data ConstructorDeclaration a = ConstructorDeclaration [a] [a] a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 ConstructorDeclaration where liftEq = genericLiftEq
 instance Ord1 ConstructorDeclaration where liftCompare = genericLiftCompare
@@ -447,7 +437,7 @@ instance Show1 ConstructorDeclaration where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ConstructorDeclaration
 
 data PropertyDeclaration a = PropertyDeclaration a [a]
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 PropertyDeclaration where liftEq = genericLiftEq
 instance Ord1 PropertyDeclaration where liftCompare = genericLiftCompare
@@ -455,7 +445,7 @@ instance Show1 PropertyDeclaration where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable PropertyDeclaration
 
 data PropertyModifier a = PropertyModifier a a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 PropertyModifier where liftEq = genericLiftEq
 instance Ord1 PropertyModifier where liftCompare = genericLiftCompare
@@ -463,7 +453,7 @@ instance Show1 PropertyModifier where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable PropertyModifier
 
 data InterfaceDeclaration a = InterfaceDeclaration a a [a]
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 InterfaceDeclaration where liftEq = genericLiftEq
 instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare
@@ -471,7 +461,7 @@ instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable InterfaceDeclaration
 
 newtype InterfaceBaseClause a = InterfaceBaseClause [a]
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 InterfaceBaseClause where liftEq = genericLiftEq
 instance Ord1 InterfaceBaseClause where liftCompare = genericLiftCompare
@@ -479,7 +469,7 @@ instance Show1 InterfaceBaseClause where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable InterfaceBaseClause
 
 newtype Echo a = Echo a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Echo where liftEq = genericLiftEq
 instance Ord1 Echo where liftCompare = genericLiftCompare
@@ -487,7 +477,7 @@ instance Show1 Echo where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Echo
 
 newtype Unset a = Unset a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Unset where liftEq = genericLiftEq
 instance Ord1 Unset where liftCompare = genericLiftCompare
@@ -495,7 +485,7 @@ instance Show1 Unset where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Unset
 
 data Declare a = Declare a a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Declare where liftEq = genericLiftEq
 instance Ord1 Declare where liftCompare = genericLiftCompare
@@ -503,7 +493,7 @@ instance Show1 Declare where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Declare
 
 newtype DeclareDirective a = DeclareDirective a
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 DeclareDirective where liftEq = genericLiftEq
 instance Ord1 DeclareDirective where liftCompare = genericLiftCompare
@@ -511,7 +501,7 @@ instance Show1 DeclareDirective where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable DeclareDirective
 
 newtype LabeledStatement a = LabeledStatement { _labeledStatementIdentifier :: a }
-  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
+  deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 LabeledStatement where liftEq = genericLiftEq
 instance Ord1 LabeledStatement where liftCompare = genericLiftCompare

src/Language/Python/Assignment.hs

@@ -79,7 +79,6 @@ type Syntax =
    , Syntax.Empty
    , Syntax.Error
    , Syntax.Identifier
-   , Syntax.Paren
    , Syntax.Program
    , Type.Annotation
    , []
@@ -191,7 +190,7 @@ keywordArgument :: Assignment
 keywordArgument = makeTerm <$> symbol KeywordArgument <*> children (Statement.Assignment [] <$> term expression <*> term expression)
 
 parenthesizedExpression :: Assignment
-parenthesizedExpression = makeTerm <$> symbol ParenthesizedExpression <*> (Syntax.Paren <$> children expressions)
+parenthesizedExpression = symbol ParenthesizedExpression *> children expressions
 
 parameter :: Assignment
 parameter =  makeTerm <$> symbol DefaultParameter <*> children (Statement.Assignment [] <$> term expression <*> term expression)
@@ -243,16 +242,11 @@ exceptClause = makeTerm <$> symbol ExceptClause <*> children
                    <*> expressions)
 
 functionDefinition :: Assignment
-functionDefinition
+functionDefinition =
-  =   makeFunctionDeclaration <$> symbol FunctionDefinition <*> children ((,,,) <$> term expression <* symbol Parameters <*> children (manyTerm expression) <*> optional (symbol Type *> children (term expression)) <*> expressions)
+      makeFunctionDeclaration <$> symbol FunctionDefinition <*> children ((,,,) <$> term expression <* symbol Parameters <*> children (manyTerm expression) <*> optional (symbol Type *> children (term expression)) <*> expressions)
-  <|> makeAsyncFunctionDeclaration <$> symbol AsyncFunctionDefinition <*> children ((,,,,) <$> term async' <*> term expression <* symbol Parameters <*> children (manyTerm expression) <*> optional (symbol Type *> children (term expression)) <*> expressions)
   <|> makeFunctionDeclaration <$> (symbol Lambda' <|> symbol Lambda) <*> children ((,,,) <$ token AnonLambda <*> emptyTerm <*> (symbol LambdaParameters *> children (manyTerm expression) <|> pure []) <*> optional (symbol Type *> children (term expression)) <*> expressions)
   where
     makeFunctionDeclaration loc (functionName', functionParameters, ty, functionBody) = makeTerm loc $ Type.Annotation (makeTerm loc $ Declaration.Function [] functionName' functionParameters functionBody) (fromMaybe (makeTerm loc Syntax.Empty) ty)
-    makeAsyncFunctionDeclaration loc (async', functionName', functionParameters, ty, functionBody) = makeTerm loc $ Type.Annotation (makeTerm loc $ Type.Annotation (makeTerm loc $ Declaration.Function [] functionName' functionParameters functionBody) (fromMaybe (makeTerm loc Syntax.Empty) ty)) async'
-
-async' :: Assignment
-async' = makeTerm <$> symbol AnonAsync <*> (Syntax.Identifier . name <$> source)
 
 classDefinition :: Assignment
 classDefinition = makeTerm <$> symbol ClassDefinition <*> children (Declaration.Class [] <$> term expression <*> argumentList <*> expressions)
@@ -300,8 +294,9 @@ binaryOperator = makeTerm' <$> symbol BinaryOperator <*> children (infixTerm exp
   [ (inj .) . Expression.Plus      <$ symbol AnonPlus
   , (inj .) . Expression.Minus     <$ symbol AnonMinus
   , (inj .) . Expression.Times     <$ symbol AnonStar
+  , (inj .) . Expression.Times     <$ symbol AnonAt -- Matrix multiplication, TODO: May not want to assign to Expression.Times.
   , (inj .) . Expression.DividedBy <$ symbol AnonSlash
-  , (inj .) . Expression.DividedBy <$ symbol AnonSlashSlash
+  , (inj .) . Expression.FloorDivision <$ symbol AnonSlashSlash
   , (inj .) . Expression.Modulo    <$ symbol AnonPercent
   , (inj .) . Expression.Power     <$ symbol AnonStarStar
   , (inj .) . Expression.BOr       <$ symbol AnonPipe
@@ -318,11 +313,12 @@ booleanOperator = makeTerm' <$> symbol BooleanOperator <*> children (infixTerm e
   ])
 
 assignment' :: Assignment
-assignment' =  makeTerm  <$> symbol Assignment <*> children (Statement.Assignment [] <$> term expressionList <*> term rvalue)
+assignment' =  makeAssignment <$> symbol Assignment <*> children ((,,) <$> term expressionList <*> optional (symbol Type *> children (term expression)) <*> term rvalue)
            <|> makeTerm' <$> symbol AugmentedAssignment <*> children (infixTerm expressionList (term rvalue)
                   [ assign Expression.Plus      <$ symbol AnonPlusEqual
                   , assign Expression.Minus     <$ symbol AnonMinusEqual
                   , assign Expression.Times     <$ symbol AnonStarEqual
+                  , assign Expression.Times     <$ symbol AnonAtEqual -- Matrix multiplication assignment. TODO: May not want to assign to Expression.Times.
                   , assign Expression.Power     <$ symbol AnonStarStarEqual
                   , assign Expression.DividedBy <$ symbol AnonSlashEqual
                   , assign Expression.DividedBy <$ symbol AnonSlashSlashEqual
@@ -334,6 +330,7 @@ assignment' =  makeTerm  <$> symbol Assignment <*> children (Statement.Assignmen
                   , assign Expression.BXOr      <$ symbol AnonCaretEqual
                   ])
   where rvalue = expressionList <|> assignment' <|> yield
+        makeAssignment loc (lhs, maybeType, rhs) = makeTerm loc (Statement.Assignment (maybeToList maybeType) lhs rhs)
         assign :: (f :< Syntax) => (Term -> Term -> f Term) -> Term -> Term -> Union Syntax Term
         assign c l r = inj (Statement.Assignment [] l (makeTerm1 (c l r)))
 

src/Language/Python/Syntax.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-}
+{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables #-}
 module Language.Python.Syntax where
 
 import           Data.Abstract.Environment as Env
@@ -8,7 +8,7 @@ import           Data.Abstract.Module
 import           Data.Align.Generic
 import qualified Data.ByteString.Char8 as BC
 import           Data.Functor.Classes.Generic
-import           Data.List (intercalate)
+import qualified Data.Language as Language
 import qualified Data.List.NonEmpty as NonEmpty
 import           Data.Mergeable
 import           Diffing.Algorithm
@@ -51,15 +51,15 @@ relativeQualifiedName prefix paths = RelativeQualifiedName (BC.unpack prefix) (J
 -- Subsequent imports of `parent.two` or `parent.three` will execute
 --     `parent/two/__init__.py` and
 --     `parent/three/__init__.py` respectively.
-resolvePythonModules :: MonadEvaluatable location term value m => QualifiedName -> m (NonEmpty ModulePath)
+resolvePythonModules :: forall value term location effects m. MonadEvaluatable location term value effects m => QualifiedName -> m effects (NonEmpty ModulePath)
 resolvePythonModules q = do
   relRootDir <- rootDir q <$> currentModule
   for (moduleNames q) $ \name -> do
-    x <- trace ("resolving: " <> show name) $ search relRootDir name
+    x <- search relRootDir name
-    trace ("found: " <> show x) (pure x)
+    traceResolve name x $ pure x
   where
-    rootDir (QualifiedName _) ModuleInfo{..}           = takeDirectory (makeRelative moduleRoot modulePath)
+    rootDir (QualifiedName _) ModuleInfo{..}           = mempty -- overall rootDir of the Package.
-    rootDir (RelativeQualifiedName n _) ModuleInfo{..} = upDir numDots (takeDirectory (makeRelative moduleRoot modulePath))
+    rootDir (RelativeQualifiedName n _) ModuleInfo{..} = upDir numDots (takeDirectory modulePath)
       where numDots = pred (length n)
             upDir n dir | n <= 0 = dir
                         | otherwise = takeDirectory (upDir (pred n) dir)
@@ -68,25 +68,21 @@ resolvePythonModules q = do
     moduleNames (RelativeQualifiedName x Nothing)      = error $ "importing from '" <> show x <> "' is not implemented"
     moduleNames (RelativeQualifiedName _ (Just paths)) = moduleNames paths
 
-    notFound xs = "Unable to resolve module import: " <> friendlyName q <> ", searched: " <> show xs
     search rootDir x = do
+      traceM ("searching for " <> show x <> " in " <> show rootDir)
       let path = normalise (rootDir </> normalise x)
       let searchPaths = [ path </> "__init__.py"
                         , path <.> ".py"
                         ]
-      trace ("searching in: " <> show searchPaths) $
+      modulePath <- resolve searchPaths
-        resolve searchPaths >>= maybeFail (notFound searchPaths)
+      maybe (throwResumable @(ResolutionError value) $ NotFoundError path searchPaths Language.Python) pure modulePath
-
-    friendlyName :: QualifiedName -> String
-    friendlyName (QualifiedName xs)                = intercalate "." (NonEmpty.toList xs)
-    friendlyName (RelativeQualifiedName prefix qn) = prefix <> maybe "" friendlyName qn
 
 
 -- | Import declarations (symbols are added directly to the calling environment).
 --
 -- If the list of symbols is empty copy everything to the calling environment.
 data Import a = Import { importFrom :: QualifiedName, importSymbols :: ![(Name, Name)] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Import where liftEq = genericLiftEq
 instance Ord1 Import where liftCompare = genericLiftCompare
@@ -105,7 +101,7 @@ instance Evaluatable Import where
     -- Last module path is the one we want to import
     let path = NonEmpty.last modulePaths
     (importedEnv, _) <- isolate (require path)
-    modifyEnv (mappend (select importedEnv))
+    modifyEnv (mergeEnvs (select importedEnv))
     unit
     where
       select importedEnv
@@ -114,7 +110,7 @@ instance Evaluatable Import where
 
 
 newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: QualifiedName }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 QualifiedImport where liftEq = genericLiftEq
 instance Ord1 QualifiedImport where liftCompare = genericLiftCompare
@@ -122,7 +118,7 @@ instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec
 
 -- import a.b.c
 instance Evaluatable QualifiedImport where
-  eval (QualifiedImport (RelativeQualifiedName _ _))        = fail "technically this is not allowed in python"
+  eval (QualifiedImport (RelativeQualifiedName _ _))        = raise (fail "technically this is not allowed in python")
   eval (QualifiedImport name@(QualifiedName qualifiedName)) = do
     modulePaths <- resolvePythonModules name
     go (NonEmpty.zip (FV.name . BC.pack <$> qualifiedName) modulePaths)
@@ -130,17 +126,17 @@ instance Evaluatable QualifiedImport where
       -- Evaluate and import the last module, updating the environment
       go ((name, path) :| []) = letrec' name $ \addr -> do
         (importedEnv, _) <- isolate (require path)
-        modifyEnv (mappend importedEnv)
+        modifyEnv (mergeEnvs importedEnv)
-        void $ makeNamespace name addr []
+        void $ makeNamespace name addr Nothing
         unit
       -- Evaluate each parent module, creating a just namespace
       go ((name, path) :| xs) = letrec' name $ \addr -> do
         void $ isolate (require path)
         void $ go (NonEmpty.fromList xs)
-        makeNamespace name addr []
+        makeNamespace name addr Nothing
 
 data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportFrom :: QualifiedName, qualifiedAliasedImportAlias :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 QualifiedAliasedImport where liftEq = genericLiftEq
 instance Ord1 QualifiedAliasedImport where liftCompare = genericLiftCompare
@@ -159,13 +155,13 @@ instance Evaluatable QualifiedAliasedImport where
     letrec' alias $ \addr -> do
       let path = NonEmpty.last modulePaths
       (importedEnv, _) <- isolate (require path)
-      modifyEnv (mappend importedEnv)
+      modifyEnv (mergeEnvs importedEnv)
-      void $ makeNamespace alias addr []
+      void $ makeNamespace alias addr Nothing
       unit
 
 -- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell)
 data Ellipsis a = Ellipsis
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Ellipsis where liftEq = genericLiftEq
 instance Ord1 Ellipsis where liftCompare = genericLiftCompare
@@ -176,7 +172,7 @@ instance Evaluatable Ellipsis
 
 
 data Redirect a = Redirect !a !a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Redirect where liftEq = genericLiftEq
 instance Ord1 Redirect where liftCompare = genericLiftCompare

src/Language/Ruby/Assignment.hs

@@ -17,6 +17,7 @@ import qualified Assigning.Assignment as Assignment
 import qualified Data.Syntax as Syntax
 import qualified Data.Syntax.Comment as Comment
 import qualified Data.Syntax.Declaration as Declaration
+import qualified Data.Syntax.Directive as Directive
 import qualified Data.Syntax.Expression as Expression
 import qualified Data.Syntax.Literal as Literal
 import qualified Data.Syntax.Statement as Statement
@@ -28,6 +29,7 @@ type Syntax = '[
     Comment.Comment
   , Declaration.Function
   , Declaration.Method
+  , Directive.File
   , Expression.Arithmetic
   , Expression.Bitwise
   , Expression.Boolean
@@ -72,14 +74,13 @@ type Syntax = '[
   , Syntax.Empty
   , Syntax.Error
   , Syntax.Identifier
-  , Syntax.Paren
   , Syntax.Program
-  , Ruby.Syntax.Send
   , Ruby.Syntax.Class
   , Ruby.Syntax.Load
   , Ruby.Syntax.LowPrecedenceBoolean
   , Ruby.Syntax.Module
   , Ruby.Syntax.Require
+  , Ruby.Syntax.Send
   , []
   ]
 
@@ -144,12 +145,24 @@ expressions :: Assignment
 expressions = makeTerm'' <$> location <*> many expression
 
 parenthesizedExpressions :: Assignment
-parenthesizedExpressions = makeTerm'' <$> symbol ParenthesizedStatements <*> children (Syntax.Paren <$> expressions)
+parenthesizedExpressions = makeTerm'' <$> symbol ParenthesizedStatements <*> children (many expression)
 
+withExtendedScope :: Assignment' a -> Assignment' a
+withExtendedScope inner = do
+  locals <- getRubyLocals
+  result <- inner
+  putRubyLocals locals
+  pure result
+
+withNewScope :: Assignment' a -> Assignment' a
+withNewScope inner = withExtendedScope $ do
+  putRubyLocals []
+  inner
+
+-- Looks up identifiers in the list of locals to determine vcall vs. local identifier.
 identifier :: Assignment
 identifier =
-      mk Identifier
+      vcallOrLocal
-  <|> mk Identifier'
   <|> mk Constant
   <|> mk InstanceVariable
   <|> mk ClassVariable
@@ -162,7 +175,17 @@ identifier =
   <|> mk HashSplatArgument
   <|> mk BlockArgument
   <|> mk Uninterpreted
-  where mk s = makeTerm <$> symbol s <*> (Syntax.Identifier . name <$> source)
+  where
+    mk s = makeTerm <$> symbol s <*> (Syntax.Identifier . name <$> source)
+    vcallOrLocal = do
+      (loc, ident, locals) <- identWithLocals
+      case ident of
+        "__FILE__" -> pure $ makeTerm loc Directive.File
+        _ -> do
+          let identTerm = makeTerm loc (Syntax.Identifier (name ident))
+          if ident `elem` locals
+            then pure identTerm
+            else pure $ makeTerm loc (Ruby.Syntax.Send Nothing (Just identTerm) [] Nothing)
 
 -- TODO: Handle interpolation in all literals that support it (strings, regexes, symbols, subshells, etc).
 literal :: Assignment
@@ -182,7 +205,7 @@ literal =
   <|> makeTerm <$> symbol String <*> (Literal.TextElement <$> source)
   <|> makeTerm <$> symbol ChainedString <*> children (many (makeTerm <$> symbol String <*> (Literal.TextElement <$> source)))
   <|> makeTerm <$> symbol Regex <*> (Literal.Regex <$> source)
-  <|> makeTerm <$> symbol Symbol <*> (Literal.Symbol <$> source)
+  <|> makeTerm <$> (symbol Symbol <|> symbol Symbol') <*> (Literal.Symbol <$> source)
 
 heredoc :: Assignment
 heredoc =  makeTerm <$> symbol HeredocBeginning <*> (Literal.TextElement <$> source)
@@ -195,48 +218,65 @@ endBlock :: Assignment
 endBlock = makeTerm <$> symbol EndBlock <*> children (Statement.ScopeExit <$> many expression)
 
 class' :: Assignment
-class' = makeTerm <$> symbol Class <*> children (Ruby.Syntax.Class <$> expression <*> (superclass <|> pure []) <*> expressions)
+class' = makeTerm <$> symbol Class <*> (withNewScope . children) (Ruby.Syntax.Class <$> expression <*> optional superclass <*> expressions)
-  where superclass = pure <$ symbol Superclass <*> children expression
+  where
+    superclass :: Assignment
+    superclass = symbol Superclass *> children expression
 
 singletonClass :: Assignment
-singletonClass = makeTerm <$> symbol SingletonClass <*> children (Ruby.Syntax.Class <$> expression <*> pure [] <*> expressions)
+singletonClass = makeTerm <$> symbol SingletonClass <*> (withNewScope . children) (Ruby.Syntax.Class <$> expression <*> pure Nothing <*> expressions)
 
 module' :: Assignment
-module' = makeTerm <$> symbol Module <*> children (Ruby.Syntax.Module <$> expression <*> many expression)
+module' = makeTerm <$> symbol Module <*> (withNewScope . children) (Ruby.Syntax.Module <$> expression <*> many expression)
 
 scopeResolution :: Assignment
 scopeResolution = makeTerm <$> symbol ScopeResolution <*> children (Expression.ScopeResolution <$> many expression)
 
 parameter :: Assignment
-parameter =
+parameter = postContextualize comment (term uncontextualizedParameter)
-      mk SplatParameter
+  where
-  <|> mk HashSplatParameter
+    uncontextualizedParameter =
-  <|> mk BlockParameter
+          lhsIdent
-  <|> mk KeywordParameter
+      <|> splatParameter
-  <|> mk OptionalParameter
+      <|> hashSplatParameter
-  <|> makeTerm <$> symbol DestructuredParameter <*> children (many parameter)
+      <|> blockParameter
-  <|> expression
+      <|> keywordParameter
-  where mk s = makeTerm <$> symbol s <*> (Syntax.Identifier . name <$> source)
+      <|> optionalParameter
+      <|> makeTerm <$> symbol DestructuredParameter <*> children (many parameter)
+    -- splat and hash splat arguments can be unnamed. we don't currently
+    -- support unnamed arguments in the term syntax, so the use of emptyTerm
+    -- here is a huge hack. what we should be able to do is return a Nothing
+    -- for the argument name for splats and hash splats. TODO fix me:
+    mkSplat s = symbol s *> children (lhsIdent <|> emptyTerm)
+    splatParameter = mkSplat SplatParameter
+    hashSplatParameter = mkSplat HashSplatParameter
+    blockParameter = symbol BlockParameter *> children lhsIdent
+    -- we don't yet care about default expressions for optional (including
+    -- keyword) parameters, but we need to match on them to prevent errors:
+    keywordParameter = symbol KeywordParameter *> children (lhsIdent <* optional expression)
+    optionalParameter = symbol OptionalParameter *> children (lhsIdent <* expression)
 
 method :: Assignment
-method = makeTerm <$> symbol Method <*> children (Declaration.Method [] <$> emptyTerm <*> expression <*> params <*> expressions')
+method = makeTerm <$> symbol Method <*> (withNewScope . children) (Declaration.Method <$> pure [] <*> emptyTerm <*> methodSelector <*> params <*> expressions')
   where params = symbol MethodParameters *> children (many parameter) <|> pure []
         expressions' = makeTerm <$> location <*> many expression
 
 singletonMethod :: Assignment
-singletonMethod = makeTerm <$> symbol SingletonMethod <*> children (Declaration.Method <$> pure [] <*> expression <*> expression <*> params <*> expressions)
+singletonMethod = makeTerm <$> symbol SingletonMethod <*> (withNewScope . children) (Declaration.Method <$> pure [] <*> expression <*> methodSelector <*> params <*> expressions)
   where params = symbol MethodParameters *> children (many parameter) <|> pure []
 
 lambda :: Assignment
-lambda = makeTerm <$> symbol Lambda <*> children (
+lambda = makeTerm <$> symbol Lambda <*> (withExtendedScope . children) (
   Declaration.Function [] <$> emptyTerm
                           <*> ((symbol BlockParameters <|> symbol LambdaParameters) *> children (many parameter) <|> pure [])
                           <*> expressions)
 
 block :: Assignment
-block =  makeTerm <$> symbol DoBlock <*> children (Declaration.Function <$> pure [] <*> emptyTerm <*> params <*> expressions)
+block =  makeTerm <$> symbol DoBlock <*> scopedBlockChildren
-     <|> makeTerm <$> symbol Block <*> children (Declaration.Function <$> pure [] <*> emptyTerm <*> params <*> expressions)
+     <|> makeTerm <$> symbol Block <*> scopedBlockChildren
-  where params = symbol BlockParameters *> children (many parameter) <|> pure []
+  where scopedBlockChildren = withExtendedScope blockChildren
+        blockChildren = children (Declaration.Function <$> pure [] <*> emptyTerm <*> params <*> expressions)
+        params = symbol BlockParameters *> children (many parameter) <|> pure []
 
 comment :: Assignment
 comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source)
@@ -306,7 +346,7 @@ methodCall = makeTerm' <$> symbol MethodCall <*> children (require <|> load <|>
     dotCall = symbol Call *> children (Ruby.Syntax.Send <$> (Just <$> term expression) <*> pure Nothing <*> args)
 
     selector = Just <$> term methodSelector
-    require = inj <$> ((symbol Identifier <|> symbol Identifier') *> do
+    require = inj <$> (symbol Identifier *> do
       s <- source
       guard (s `elem` ["require", "require_relative"])
       Ruby.Syntax.Require (s == "require_relative") <$> nameExpression)
@@ -321,9 +361,9 @@ methodSelector :: Assignment
 methodSelector = makeTerm <$> symbols <*> (Syntax.Identifier <$> (name <$> source))
   where
     symbols = symbol Identifier
-          <|> symbol Identifier'
           <|> symbol Constant
           <|> symbol Operator
+          <|> symbol Setter
           <|> symbol Super -- TODO(@charliesome): super calls are *not* method calls and need to be assigned into their own syntax terms
 
 call :: Assignment
@@ -370,8 +410,23 @@ assignment' = makeTerm  <$> symbol Assignment         <*> children (Statement.As
     rhs  = makeTerm <$> symbol RightAssignmentList <*> children (many expr) <|> expr
     expr = makeTerm <$> symbol RestAssignment      <*> (Syntax.Identifier . name <$> source)
        <|> makeTerm <$> symbol DestructuredLeftAssignment <*> children (many expr)
+       <|> lhsIdent
        <|> expression
 
+identWithLocals :: Assignment' (Record Location, ByteString, [ByteString])
+identWithLocals = do
+  loc <- symbol Identifier
+  -- source advances, so it's important we call getRubyLocals first
+  locals <- getRubyLocals
+  ident <- source
+  pure (loc, ident, locals)
+
+lhsIdent :: Assignment
+lhsIdent = do
+  (loc, ident, locals) <- identWithLocals
+  putRubyLocals (ident : locals)
+  pure $ makeTerm loc (Syntax.Identifier (name ident))
+
 unary :: Assignment
 unary = symbol Unary >>= \ location ->
       makeTerm location . Expression.Complement <$> children ( symbol AnonTilde *> expression )

src/Language/Ruby/Syntax.hs

@@ -7,6 +7,7 @@ import           Data.Abstract.Module (ModulePath)
 import           Data.Abstract.ModuleTable as ModuleTable
 import           Data.Abstract.Path
 import qualified Data.ByteString.Char8 as BC
+import qualified Data.Language as Language
 import           Diffing.Algorithm
 import           Prelude hiding (fail)
 import           Prologue
@@ -16,28 +17,25 @@ import           System.FilePath.Posix
 -- TODO: Fully sort out ruby require/load mechanics
 --
 -- require "json"
-resolveRubyName :: forall value term location m. MonadEvaluatable location term value m => ByteString -> m ModulePath
+resolveRubyName :: forall value term location effects m. MonadEvaluatable location term value effects m => ByteString -> m effects ModulePath
 resolveRubyName name = do
   let name' = cleanNameOrPath name
-  modulePath <- resolve [name' <.> "rb"]
+  let paths = [name' <.> "rb"]
-  maybe (throwException @(ResolutionError value) $ RubyError name') pure modulePath
+  modulePath <- resolve paths
+  maybe (throwResumable @(ResolutionError value) $ NotFoundError name' paths Language.Ruby) pure modulePath
 
 -- load "/root/src/file.rb"
-resolveRubyPath :: forall value term location m. MonadEvaluatable location term value m => ByteString -> m ModulePath
+resolveRubyPath :: forall value term location effects m. MonadEvaluatable location term value effects m => ByteString -> m effects ModulePath
 resolveRubyPath path = do
   let name' = cleanNameOrPath path
   modulePath <- resolve [name']
-  maybe (throwException @(ResolutionError value) $ RubyError name') pure modulePath
+  maybe (throwResumable @(ResolutionError value) $ NotFoundError name' [name'] Language.Ruby) pure modulePath
-
-maybeFailNotFound :: MonadFail m => String -> Maybe a -> m a
-maybeFailNotFound name = maybeFail notFound
-  where notFound = "Unable to resolve: " <> name
 
 cleanNameOrPath :: ByteString -> String
 cleanNameOrPath = BC.unpack . dropRelativePrefix . stripQuotes
 
 data Send a = Send { sendReceiver :: Maybe a, sendSelector :: Maybe a, sendArgs :: [a], sendBlock :: Maybe a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Send where liftEq = genericLiftEq
 instance Ord1 Send where liftCompare = genericLiftCompare
@@ -48,17 +46,11 @@ instance Evaluatable Send where
     let sel = case sendSelector of
           Just sel -> subtermValue sel
           Nothing -> variable (name "call")
-
+    func <- maybe sel (flip evaluateInScopedEnv sel . subtermValue) sendReceiver
-    func <- case sendReceiver of
-      Just recv -> do
-        recvEnv <- subtermValue recv >>= scopedEnvironment
-        localEnv (mappend recvEnv) sel
-      Nothing -> sel -- TODO Does this require `localize` so we don't leak terms when resolving `sendSelector`?
-
     call func (map subtermValue sendArgs) -- TODO pass through sendBlock
 
 data Require a = Require { requireRelative :: Bool, requirePath :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Require where liftEq = genericLiftEq
 instance Ord1 Require where liftCompare = genericLiftCompare
@@ -68,13 +60,13 @@ instance Evaluatable Require where
   eval (Require _ x) = do
     name <- subtermValue x >>= asString
     path <- resolveRubyName name
-    (importedEnv, v) <- isolate (doRequire path)
+    (importedEnv, v) <- traceResolve name path $ isolate (doRequire path)
     modifyEnv (`mergeNewer` importedEnv)
     pure v -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
 
-doRequire :: MonadEvaluatable location term value m
+doRequire :: MonadEvaluatable location term value effects m
           => ModulePath
-          -> m (Environment location value, value)
+          -> m effects (Environment location value, value)
 doRequire name = do
   moduleTable <- getModuleTable
   case ModuleTable.lookup name moduleTable of
@@ -83,7 +75,7 @@ doRequire name = do
 
 
 newtype Load a = Load { loadArgs :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Load where liftEq = genericLiftEq
 instance Ord1 Load where liftCompare = genericLiftCompare
@@ -97,19 +89,19 @@ instance Evaluatable Load where
     path <- subtermValue x >>= asString
     shouldWrap <- subtermValue wrap >>= asBool
     doLoad path shouldWrap
-  eval (Load _) = fail "invalid argument supplied to load, path is required"
+  eval (Load _) = raise (fail "invalid argument supplied to load, path is required")
 
-doLoad :: MonadEvaluatable location term value m => ByteString -> Bool -> m value
+doLoad :: MonadEvaluatable location term value effects m => ByteString -> Bool -> m effects value
 doLoad path shouldWrap = do
   path' <- resolveRubyPath path
-  (importedEnv, _) <- isolate (load path')
+  (importedEnv, _) <- traceResolve path path' $ isolate (load path')
-  unless shouldWrap $ modifyEnv (mappend importedEnv)
+  unless shouldWrap $ modifyEnv (mergeEnvs importedEnv)
   boolean Prelude.True -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load
 
 -- TODO: autoload
 
-data Class a = Class { classIdentifier :: !a, classSuperClasses :: ![a], classBody :: !a }
+data Class a = Class { classIdentifier :: !a, classSuperClass :: !(Maybe a), classBody :: !a }
-  deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Diffable Class where
   equivalentBySubterm = Just . classIdentifier
@@ -120,13 +112,13 @@ instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Class where
   eval Class{..} = do
-    supers <- traverse subtermValue classSuperClasses
+    super <- traverse subtermValue classSuperClass
     name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm classIdentifier)
     letrec' name $ \addr ->
-      subtermValue classBody <* makeNamespace name addr supers
+      subtermValue classBody <* makeNamespace name addr super
 
 data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Module where liftEq = genericLiftEq
 instance Ord1 Module where liftCompare = genericLiftCompare
@@ -136,12 +128,12 @@ instance Evaluatable Module where
   eval (Module iden xs) = do
     name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
     letrec' name $ \addr ->
-      eval xs <* makeNamespace name addr []
+      eval xs <* makeNamespace name addr Nothing
 
 data LowPrecedenceBoolean a
   = LowAnd !a !a
   | LowOr !a !a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Evaluatable LowPrecedenceBoolean where
   -- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands

src/Language/TypeScript/Assignment.hs

@@ -66,10 +66,12 @@ type Syntax = '[
   , Statement.Break
   , Statement.Catch
   , Statement.Continue
+  , Statement.DoWhile
   , Statement.Else
   , Statement.Finally
   , Statement.For
   , Statement.ForEach
+  , Statement.HashBang
   , Statement.If
   , Statement.Match
   , Statement.Pattern
@@ -77,16 +79,14 @@ type Syntax = '[
   , Statement.Return
   , Statement.ScopeEntry
   , Statement.ScopeExit
+  , Statement.Throw
   , Statement.Try
   , Statement.While
   , Statement.Yield
-  , Statement.Throw
-  , Statement.DoWhile
   , Syntax.AccessibilityModifier
   , Syntax.Empty
   , Syntax.Error
   , Syntax.Identifier
-  , Syntax.Paren
   , Syntax.Program
   , Syntax.Context
   , Type.Readonly
@@ -165,6 +165,7 @@ type Syntax = '[
   , TypeScript.Syntax.DefaultExport
   , TypeScript.Syntax.QualifiedExport
   , TypeScript.Syntax.QualifiedExportFrom
+  , TypeScript.Syntax.JavaScriptRequire
   , []
   ]
 
@@ -232,8 +233,8 @@ assignmentExpression :: Assignment
 assignmentExpression = makeTerm <$> symbol AssignmentExpression <*> children (Statement.Assignment [] <$> term (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) <*> expression)
 
 augmentedAssignmentExpression :: Assignment
-augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpression <*> children (infixTerm (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) expression [
+augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpression <*> children (infixTerm (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) (term expression) [
-  assign Expression.Plus <$ symbol AnonPlusEqual
+    assign Expression.Plus <$ symbol AnonPlusEqual
   , assign Expression.Minus <$ symbol AnonMinusEqual
   , assign Expression.Times <$ symbol AnonStarEqual
   , assign Expression.DividedBy <$ symbol AnonSlashEqual
@@ -241,7 +242,9 @@ augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpressi
   , assign Expression.BXOr <$ symbol AnonCaretEqual
   , assign Expression.BAnd <$ symbol AnonAmpersandEqual
   , assign Expression.RShift <$ symbol AnonRAngleRAngleEqual
+  , assign Expression.LShift <$ symbol AnonLAngleLAngleEqual
   , assign Expression.UnsignedRShift <$ symbol AnonRAngleRAngleRAngleEqual
+  , assign Expression.LShift <$ symbol AnonLAngleLAngleEqual
   , assign Expression.BOr <$ symbol AnonPipeEqual ])
   where assign :: (f :< Syntax) => (Term -> Term -> f Term) -> Term -> Term -> Union Syntax Term
         assign c l r = inj (Statement.Assignment [] l (makeTerm1 (c l r)))
@@ -481,8 +484,9 @@ function :: Assignment
 function = makeFunction <$> (symbol Grammar.Function <|> symbol Grammar.GeneratorFunction) <*> children ((,,) <$> term (identifier <|> emptyTerm) <*> callSignatureParts <*> term statementBlock)
   where makeFunction loc (id, (typeParams, params, annotation), statements) = makeTerm loc (Declaration.Function [typeParams, annotation] id params statements)
 
+-- TODO: FunctionSignatures can, but don't have to be ambient functions.
 ambientFunction :: Assignment
-ambientFunction = makeAmbientFunction <$> symbol Grammar.AmbientFunction <*> children ((,) <$> term identifier <*> callSignatureParts)
+ambientFunction = makeAmbientFunction <$> symbol Grammar.FunctionSignature <*> children ((,) <$> term identifier <*> callSignatureParts)
   where makeAmbientFunction loc (id, (typeParams, params, annotation)) = makeTerm loc (TypeScript.Syntax.AmbientFunction [typeParams, annotation] id params)
 
 ty :: Assignment
@@ -598,6 +602,7 @@ statement = handleError everything
       , continueStatement
       , returnStatement
       , throwStatement
+      , hashBang
       , emptyStatement
       , labeledStatement ]
 
@@ -611,20 +616,23 @@ doStatement :: Assignment
 doStatement = makeTerm <$> symbol DoStatement <*> children (flip Statement.DoWhile <$> term statement <*> term parenthesizedExpression)
 
 continueStatement :: Assignment
-continueStatement = makeTerm <$> symbol ContinueStatement <*> children (Statement.Continue <$> (statementIdentifier <|> emptyTerm))
+continueStatement = makeTerm <$> symbol ContinueStatement <*> children (Statement.Continue <$> (statementIdentifier <|> term emptyTerm))
 
 breakStatement :: Assignment
-breakStatement = makeTerm <$> symbol BreakStatement <*> children (Statement.Break <$> (statementIdentifier <|> emptyTerm))
+breakStatement = makeTerm <$> symbol BreakStatement <*> children (Statement.Break <$> (statementIdentifier <|> term emptyTerm))
 
 withStatement :: Assignment
 withStatement = makeTerm <$> symbol WithStatement <*> children (TypeScript.Syntax.With <$> term parenthesizedExpression <*> term statement)
 
 returnStatement :: Assignment
-returnStatement = makeTerm <$> symbol ReturnStatement <*> children (Statement.Return <$> (term expressions <|> emptyTerm))
+returnStatement = makeTerm <$> symbol ReturnStatement <*> children (Statement.Return <$> (term expressions <|> term emptyTerm))
 
 throwStatement :: Assignment
 throwStatement = makeTerm <$> symbol Grammar.ThrowStatement <*> children (Statement.Throw <$> term expressions)
 
+hashBang :: Assignment
+hashBang = makeTerm <$> symbol HashBangLine <*> (Statement.HashBang <$> source)
+
 labeledStatement :: Assignment
 labeledStatement = makeTerm <$> symbol Grammar.LabeledStatement <*> children (TypeScript.Syntax.LabeledStatement <$> statementIdentifier <*> term statement)
 
@@ -780,11 +788,21 @@ variableDeclaration :: Assignment
 variableDeclaration = makeTerm <$> (symbol Grammar.VariableDeclaration <|> symbol Grammar.LexicalDeclaration) <*> children (Declaration.VariableDeclaration <$> manyTerm variableDeclarator)
 
 variableDeclarator :: Assignment
-variableDeclarator = makeVarDecl <$> symbol VariableDeclarator <*> children ((,,) <$> term (identifier <|> destructuringPattern) <*> (term typeAnnotation' <|> emptyTerm) <*> (term expression <|> emptyTerm))
+variableDeclarator =
-  where makeVarDecl loc (subject, annotations, value) = makeTerm loc (Statement.Assignment [annotations] subject value)
+      makeTerm <$> symbol VariableDeclarator <*> children (TypeScript.Syntax.JavaScriptRequire <$> identifier <*> requireCall)
+  <|> makeVarDecl <$> symbol VariableDeclarator <*> children ((,,) <$> term (identifier <|> destructuringPattern) <*> (term typeAnnotation' <|> emptyTerm) <*> (term expression <|> emptyTerm))
+  where
+    makeVarDecl loc (subject, annotations, value) = makeTerm loc (Statement.Assignment [annotations] subject value)
+
+    requireCall = symbol CallExpression *> children ((symbol Identifier <|> symbol Identifier') *> do
+      s <- source
+      guard (s == "require")
+      symbol Arguments *> children (symbol Grammar.String *> (TypeScript.Syntax.importPath <$> source))
+      )
+
 
 parenthesizedExpression :: Assignment
-parenthesizedExpression = makeTerm <$> symbol ParenthesizedExpression <*> (Syntax.Paren <$> children (term expressions))
+parenthesizedExpression = symbol ParenthesizedExpression *> children (term expressions)
 
 switchStatement :: Assignment
 switchStatement = makeTerm <$> symbol SwitchStatement <*> children (Statement.Match <$> term parenthesizedExpression <*> term switchBody)

src/Language/TypeScript/Syntax.hs

@@ -1,14 +1,16 @@
-{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveAnyClass, ScopedTypeVariables #-}
 module Language.TypeScript.Syntax where
 
 import qualified Data.Abstract.Environment as Env
 import qualified Data.Abstract.FreeVariables as FV
 import           Data.Abstract.Evaluatable
+import           Data.Abstract.Path
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString as B
 import           Data.Abstract.Module (ModulePath, ModuleInfo(..))
+import qualified Data.Language as Language
 import           Diffing.Algorithm
-import           Prelude hiding (fail)
+import           Prelude
 import           Prologue
 import           System.FilePath.Posix
 
@@ -28,9 +30,11 @@ importPath str = let path = stripQuotes str in ImportPath (BC.unpack path) (path
 toName :: ImportPath -> Name
 toName = FV.name . BC.pack . unPath
 
-resolveTypeScriptModule :: MonadEvaluatable location term value m => ImportPath -> m ModulePath
+-- Node.js resolution algorithm: https://nodejs.org/api/modules.html#modules_all_together
-resolveTypeScriptModule (ImportPath path Relative)    = resolveRelativeTSModule path
+-- TypeScript has a couple of different strategies, but the main one mimics Node.js.
-resolveTypeScriptModule (ImportPath path NonRelative) = resolveNonRelativeTSModule path
+resolveWithNodejsStrategy :: MonadEvaluatable location term value effects m => ImportPath -> [String] -> m effects ModulePath
+resolveWithNodejsStrategy (ImportPath path Relative)    exts = resolveRelativePath path exts
+resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativePath path exts
 
 -- | Resolve a relative TypeScript import to a known 'ModuleName' or fail.
 --
@@ -39,14 +43,14 @@ resolveTypeScriptModule (ImportPath path NonRelative) = resolveNonRelativeTSModu
 -- /root/src/moduleB.ts
 -- /root/src/moduleB/package.json (if it specifies a "types" property)
 -- /root/src/moduleB/index.ts
-resolveRelativeTSModule :: MonadEvaluatable location term value m => FilePath -> m ModulePath
+resolveRelativePath :: forall value term location effects m. MonadEvaluatable location term value effects m => FilePath -> [String] -> m effects ModulePath
-resolveRelativeTSModule relImportPath = do
+resolveRelativePath relImportPath exts = do
   ModuleInfo{..} <- currentModule
-  let relRootDir = takeDirectory (makeRelative moduleRoot modulePath)
+  let relRootDir = takeDirectory modulePath
-  let path = normalise (relRootDir </> normalise relImportPath)
+  let path = joinPaths relRootDir relImportPath
-  resolveTSModule path >>= either notFound pure
+  resolveTSModule path exts >>= either notFound (\x -> traceResolve relImportPath x (pure x))
   where
-    notFound xs = fail $ "Unable to resolve relative module import: " <> show relImportPath <> ", looked for it in: " <> show xs
+    notFound xs = throwResumable @(ResolutionError value) $ NotFoundError relImportPath xs Language.TypeScript
 
 -- | Resolve a non-relative TypeScript import to a known 'ModuleName' or fail.
 --
@@ -58,34 +62,45 @@ resolveRelativeTSModule relImportPath = do
 --
 -- /root/node_modules/moduleB.ts, etc
 -- /node_modules/moduleB.ts, etc
-resolveNonRelativeTSModule :: MonadEvaluatable location term value m => FilePath -> m ModulePath
+resolveNonRelativePath :: forall value term location effects m. MonadEvaluatable location term value effects m => FilePath -> [String] -> m effects ModulePath
-resolveNonRelativeTSModule name = do
+resolveNonRelativePath name exts = do
   ModuleInfo{..} <- currentModule
-  go "." (makeRelative moduleRoot modulePath) mempty
+  go "." modulePath mempty
   where
     nodeModulesPath dir = takeDirectory dir </> "node_modules" </> name
     -- Recursively search in a 'node_modules' directory, stepping up a directory each time.
     go root path searched = do
-      res <- resolveTSModule (nodeModulesPath path)
+      res <- resolveTSModule (nodeModulesPath path) exts
       case res of
         Left xs | parentDir <- takeDirectory path , root /= parentDir -> go root parentDir (searched <> xs)
                 | otherwise -> notFound (searched <> xs)
-        Right m -> pure m
+        Right m -> traceResolve name m $ pure m
-    notFound xs = fail $ "Unable to resolve non-relative module import: " <> show name <> ", looked for it in: " <> show xs
+    notFound xs = throwResumable @(ResolutionError value) $ NotFoundError name xs Language.TypeScript
 
-resolveTSModule :: MonadEvaluatable location term value m => FilePath -> m (Either [FilePath] ModulePath)
+resolveTSModule :: MonadEvaluatable location term value effects m => FilePath -> [String] -> m effects (Either [FilePath] ModulePath)
-resolveTSModule path = maybe (Left searchPaths) Right <$> resolve searchPaths
+resolveTSModule path exts = maybe (Left searchPaths) Right <$> resolve searchPaths
-  where exts = ["ts", "tsx", "d.ts"]
+  where searchPaths =
-        searchPaths =
           ((path <.>) <$> exts)
           -- TODO: Requires parsing package.json, getting the path of the
           --       "types" property and adding that value to the search Paths.
           -- <> [searchDir </> "package.json"]
           <> (((path </> "index") <.>) <$> exts)
 
+typescriptExtensions :: [String]
+typescriptExtensions = ["ts", "tsx", "d.ts"]
+
+javascriptExtensions :: [String]
+javascriptExtensions = ["js"]
+
+evalRequire :: MonadEvaluatable location term value effects m => ModulePath -> Name -> m effects value
+evalRequire modulePath alias = letrec' alias $ \addr -> do
+  (importedEnv, _) <- isolate (require modulePath)
+  modifyEnv (mergeEnvs importedEnv)
+  void $ makeNamespace alias addr Nothing
+  unit
 
 data Import a = Import { importSymbols :: ![(Name, Name)], importFrom :: ImportPath }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Import where liftEq = genericLiftEq
 instance Ord1 Import where liftCompare = genericLiftCompare
@@ -94,33 +109,43 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
   -- http://www.typescriptlang.org/docs/handbook/module-resolution.html
 instance Evaluatable Import where
   eval (Import symbols importPath) = do
-    modulePath <- resolveTypeScriptModule importPath
+    modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
     (importedEnv, _) <- isolate (require modulePath)
-    modifyEnv (mappend (renamed importedEnv)) *> unit
+    modifyEnv (mergeEnvs (renamed importedEnv)) *> unit
     where
       renamed importedEnv
         | Prologue.null symbols = importedEnv
         | otherwise = Env.overwrite symbols importedEnv
 
+data JavaScriptRequire a = JavaScriptRequire { javascriptRequireIden :: !a, javascriptRequireFrom :: ImportPath }
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
+
+instance Eq1 JavaScriptRequire where liftEq = genericLiftEq
+instance Ord1 JavaScriptRequire where liftCompare = genericLiftCompare
+instance Show1 JavaScriptRequire where liftShowsPrec = genericLiftShowsPrec
+
+instance Evaluatable JavaScriptRequire where
+  eval (JavaScriptRequire aliasTerm importPath) = do
+    modulePath <- resolveWithNodejsStrategy importPath javascriptExtensions
+    alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
+    evalRequire modulePath alias
+
+
 data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportAlias :: !a, qualifiedAliasedImportFrom :: ImportPath }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 QualifiedAliasedImport where liftEq = genericLiftEq
 instance Ord1 QualifiedAliasedImport where liftCompare = genericLiftCompare
 instance Show1 QualifiedAliasedImport where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable QualifiedAliasedImport where
-  eval (QualifiedAliasedImport aliasTerm importPath ) = do
+  eval (QualifiedAliasedImport aliasTerm importPath) = do
-    modulePath <- resolveTypeScriptModule importPath
+    modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
     alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
-    letrec' alias $ \addr -> do
+    evalRequire modulePath alias
-      (importedEnv, _) <- isolate (require modulePath)
-      modifyEnv (mappend importedEnv)
-      void $ makeNamespace alias addr []
-      unit
 
 newtype SideEffectImport a = SideEffectImport { sideEffectImportFrom :: ImportPath }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 SideEffectImport where liftEq = genericLiftEq
 instance Ord1 SideEffectImport where liftCompare = genericLiftCompare
@@ -128,14 +153,14 @@ instance Show1 SideEffectImport where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable SideEffectImport where
   eval (SideEffectImport importPath) = do
-    modulePath <- resolveTypeScriptModule importPath
+    modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
     void $ isolate (require modulePath)
     unit
 
 
 -- | Qualified Export declarations
 newtype QualifiedExport a = QualifiedExport { qualifiedExportSymbols :: [(Name, Name)] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 QualifiedExport where liftEq = genericLiftEq
 instance Ord1 QualifiedExport where liftCompare = genericLiftCompare
@@ -151,7 +176,7 @@ instance Evaluatable QualifiedExport where
 
 -- | Qualified Export declarations that export from another module.
 data QualifiedExportFrom a = QualifiedExportFrom { qualifiedExportFrom :: ImportPath, qualifiedExportFromSymbols :: ![(Name, Name)]}
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 QualifiedExportFrom where liftEq = genericLiftEq
 instance Ord1 QualifiedExportFrom where liftCompare = genericLiftCompare
@@ -159,31 +184,37 @@ instance Show1 QualifiedExportFrom where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable QualifiedExportFrom where
   eval (QualifiedExportFrom importPath exportSymbols) = do
-    modulePath <- resolveTypeScriptModule importPath
+    modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
     (importedEnv, _) <- isolate (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
-      maybe (cannotExport modulePath name) (addExport name alias . Just) address
+      maybe (throwEvalError $ ExportError modulePath name) (addExport name alias . Just) address
     unit
-    where
-      cannotExport moduleName name = fail $
-        "module " <> show moduleName <> " does not export " <> show (unName name)
-
 
 newtype DefaultExport a = DefaultExport { defaultExport :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 DefaultExport where liftEq = genericLiftEq
 instance Ord1 DefaultExport where liftCompare = genericLiftCompare
 instance Show1 DefaultExport where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable DefaultExport where
+  eval (DefaultExport term) = do
+    v <- subtermValue term
+    case declaredName term of
+      Just name -> do
+        addr <- lookupOrAlloc name
+        assign addr v
+        addExport name name Nothing
+        void $ modifyEnv (Env.insert name addr)
+      Nothing -> throwEvalError DefaultExportError
+    unit
 
 
 -- | Lookup type for a type-level key in a typescript map.
 data LookupType a = LookupType { lookupTypeIdentifier :: a, lookupTypeKey :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 LookupType where liftEq = genericLiftEq
 instance Ord1 LookupType where liftCompare = genericLiftCompare
@@ -192,7 +223,7 @@ instance Evaluatable LookupType
 
 -- | ShorthandPropertyIdentifier used in object patterns such as var baz = { foo } to mean var baz = { foo: foo }
 newtype ShorthandPropertyIdentifier a = ShorthandPropertyIdentifier ByteString
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ShorthandPropertyIdentifier where liftEq = genericLiftEq
 instance Ord1 ShorthandPropertyIdentifier where liftCompare = genericLiftCompare
@@ -200,7 +231,7 @@ instance Show1 ShorthandPropertyIdentifier where liftShowsPrec = genericLiftShow
 instance Evaluatable ShorthandPropertyIdentifier
 
 data Union a = Union { _unionLeft :: !a, _unionRight :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Language.TypeScript.Syntax.Union where liftEq = genericLiftEq
 instance Ord1 Language.TypeScript.Syntax.Union where liftCompare = genericLiftCompare
@@ -208,7 +239,7 @@ instance Show1 Language.TypeScript.Syntax.Union where liftShowsPrec = genericLif
 instance Evaluatable Language.TypeScript.Syntax.Union
 
 data Intersection a = Intersection { _intersectionLeft :: !a, _intersectionRight :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Intersection where liftEq = genericLiftEq
 instance Ord1 Intersection where liftCompare = genericLiftCompare
@@ -216,7 +247,7 @@ instance Show1 Intersection where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Intersection
 
 data FunctionType a = FunctionType { _functionTypeParameters :: !a, _functionFormalParameters :: ![a], _functionType :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 FunctionType where liftEq = genericLiftEq
 instance Ord1 FunctionType where liftCompare = genericLiftCompare
@@ -224,7 +255,7 @@ instance Show1 FunctionType where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable FunctionType
 
 data AmbientFunction a = AmbientFunction { _ambientFunctionContext :: ![a], _ambientFunctionIdentifier :: !a, _ambientFunctionParameters :: ![a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 AmbientFunction where liftEq = genericLiftEq
 instance Ord1 AmbientFunction where liftCompare = genericLiftCompare
@@ -232,7 +263,7 @@ instance Show1 AmbientFunction where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable AmbientFunction
 
 data ImportRequireClause a = ImportRequireClause { _importRequireIdentifier :: !a, _importRequireSubject :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ImportRequireClause where liftEq = genericLiftEq
 instance Ord1 ImportRequireClause where liftCompare = genericLiftCompare
@@ -240,7 +271,7 @@ instance Show1 ImportRequireClause where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ImportRequireClause
 
 newtype ImportClause a = ImportClause { _importClauseElements :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ImportClause where liftEq = genericLiftEq
 instance Ord1 ImportClause where liftCompare = genericLiftCompare
@@ -248,7 +279,7 @@ instance Show1 ImportClause where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ImportClause
 
 newtype Tuple a = Tuple { _tupleElements :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Tuple where liftEq = genericLiftEq
 instance Ord1 Tuple where liftCompare = genericLiftCompare
@@ -258,7 +289,7 @@ instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Tuple
 
 data Constructor a = Constructor { _constructorTypeParameters :: !a, _constructorFormalParameters :: ![a], _constructorType :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Language.TypeScript.Syntax.Constructor where liftEq = genericLiftEq
 instance Ord1 Language.TypeScript.Syntax.Constructor where liftCompare = genericLiftCompare
@@ -266,7 +297,7 @@ instance Show1 Language.TypeScript.Syntax.Constructor where liftShowsPrec = gene
 instance Evaluatable Language.TypeScript.Syntax.Constructor
 
 data TypeParameter a = TypeParameter { _typeParameter :: !a, _typeParameterConstraint :: !a, _typeParameterDefaultType :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 TypeParameter where liftEq = genericLiftEq
 instance Ord1 TypeParameter where liftCompare = genericLiftCompare
@@ -274,7 +305,7 @@ instance Show1 TypeParameter where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable TypeParameter
 
 data TypeAssertion a = TypeAssertion { _typeAssertionParameters :: !a, _typeAssertionExpression :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 TypeAssertion where liftEq = genericLiftEq
 instance Ord1 TypeAssertion where liftCompare = genericLiftCompare
@@ -282,7 +313,7 @@ instance Show1 TypeAssertion where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable TypeAssertion
 
 newtype Annotation a = Annotation { _annotationType :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Annotation where liftEq = genericLiftEq
 instance Ord1 Annotation where liftCompare = genericLiftCompare
@@ -290,7 +321,7 @@ instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Annotation
 
 newtype Decorator a = Decorator { _decoratorTerm :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Decorator where liftEq = genericLiftEq
 instance Ord1 Decorator where liftCompare = genericLiftCompare
@@ -298,7 +329,7 @@ instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Decorator
 
 newtype ComputedPropertyName a = ComputedPropertyName a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ComputedPropertyName where liftEq = genericLiftEq
 instance Ord1 ComputedPropertyName where liftCompare = genericLiftCompare
@@ -306,7 +337,7 @@ instance Show1 ComputedPropertyName where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ComputedPropertyName
 
 newtype Constraint a = Constraint { _constraintType :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Constraint where liftEq = genericLiftEq
 instance Ord1 Constraint where liftCompare = genericLiftCompare
@@ -314,7 +345,7 @@ instance Show1 Constraint where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Constraint
 
 newtype DefaultType a = DefaultType { _defaultType :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 DefaultType where liftEq = genericLiftEq
 instance Ord1 DefaultType where liftCompare = genericLiftCompare
@@ -322,7 +353,7 @@ instance Show1 DefaultType where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable DefaultType
 
 newtype ParenthesizedType a = ParenthesizedType { _parenthesizedType :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ParenthesizedType where liftEq = genericLiftEq
 instance Ord1 ParenthesizedType where liftCompare = genericLiftCompare
@@ -330,7 +361,7 @@ instance Show1 ParenthesizedType where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ParenthesizedType
 
 newtype PredefinedType a = PredefinedType { _predefinedType :: ByteString }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 PredefinedType where liftEq = genericLiftEq
 instance Ord1 PredefinedType where liftCompare = genericLiftCompare
@@ -338,7 +369,7 @@ instance Show1 PredefinedType where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable PredefinedType
 
 newtype TypeIdentifier a = TypeIdentifier ByteString
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 TypeIdentifier where liftEq = genericLiftEq
 instance Ord1 TypeIdentifier where liftCompare = genericLiftCompare
@@ -346,7 +377,7 @@ instance Show1 TypeIdentifier where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable TypeIdentifier
 
 data NestedIdentifier a = NestedIdentifier !a !a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 NestedIdentifier where liftEq = genericLiftEq
 instance Ord1 NestedIdentifier where liftCompare = genericLiftCompare
@@ -354,7 +385,7 @@ instance Show1 NestedIdentifier where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable NestedIdentifier
 
 data NestedTypeIdentifier a = NestedTypeIdentifier !a !a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 NestedTypeIdentifier where liftEq = genericLiftEq
 instance Ord1 NestedTypeIdentifier where liftCompare = genericLiftCompare
@@ -362,7 +393,7 @@ instance Show1 NestedTypeIdentifier where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable NestedTypeIdentifier
 
 data GenericType a = GenericType { _genericTypeIdentifier :: !a, _genericTypeArguments :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 GenericType where liftEq = genericLiftEq
 instance Ord1 GenericType where liftCompare = genericLiftCompare
@@ -370,7 +401,7 @@ instance Show1 GenericType where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable GenericType
 
 data TypePredicate a = TypePredicate { _typePredicateIdentifier :: !a, _typePredicateType :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 TypePredicate where liftEq = genericLiftEq
 instance Ord1 TypePredicate where liftCompare = genericLiftCompare
@@ -378,7 +409,7 @@ instance Show1 TypePredicate where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable TypePredicate
 
 newtype ObjectType a = ObjectType { _objectTypeElements :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ObjectType where liftEq = genericLiftEq
 instance Ord1 ObjectType where liftCompare = genericLiftCompare
@@ -386,7 +417,7 @@ instance Show1 ObjectType where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ObjectType
 
 data With a = With { _withExpression :: !a, _withBody :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 With where liftEq = genericLiftEq
 instance Ord1 With where liftCompare = genericLiftCompare
@@ -394,7 +425,7 @@ instance Show1 With where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable With
 
 newtype AmbientDeclaration a = AmbientDeclaration { _ambientDeclarationBody :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 AmbientDeclaration where liftEq = genericLiftEq
 instance Ord1 AmbientDeclaration where liftCompare = genericLiftCompare
@@ -403,16 +434,19 @@ instance Show1 AmbientDeclaration where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable AmbientDeclaration where
   eval (AmbientDeclaration body) = subtermValue body
 
-data EnumDeclaration a = EnumDeclaration { _enumDeclarationIdentifier :: !a, _enumDeclarationBody :: ![a] }
+data EnumDeclaration a = EnumDeclaration { enumDeclarationIdentifier :: !a, _enumDeclarationBody :: ![a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 EnumDeclaration where liftEq = genericLiftEq
 instance Ord1 EnumDeclaration where liftCompare = genericLiftCompare
 instance Show1 EnumDeclaration where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable EnumDeclaration
 
+instance Declarations a => Declarations (EnumDeclaration a) where
+  declaredName EnumDeclaration{..} = declaredName enumDeclarationIdentifier
+
 newtype ExtendsClause a = ExtendsClause { _extendsClauses :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ExtendsClause where liftEq = genericLiftEq
 instance Ord1 ExtendsClause where liftCompare = genericLiftCompare
@@ -420,7 +454,7 @@ instance Show1 ExtendsClause where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ExtendsClause
 
 newtype ArrayType a = ArrayType { _arrayType :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ArrayType where liftEq = genericLiftEq
 instance Ord1 ArrayType where liftCompare = genericLiftCompare
@@ -428,7 +462,7 @@ instance Show1 ArrayType where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ArrayType
 
 newtype FlowMaybeType a = FlowMaybeType { _flowMaybeType :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 FlowMaybeType where liftEq = genericLiftEq
 instance Ord1 FlowMaybeType where liftCompare = genericLiftCompare
@@ -436,7 +470,7 @@ instance Show1 FlowMaybeType where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable FlowMaybeType
 
 newtype TypeQuery a = TypeQuery { _typeQuerySubject :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 TypeQuery where liftEq = genericLiftEq
 instance Ord1 TypeQuery where liftCompare = genericLiftCompare
@@ -444,7 +478,7 @@ instance Show1 TypeQuery where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable TypeQuery
 
 newtype IndexTypeQuery a = IndexTypeQuery { _indexTypeQuerySubject :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 IndexTypeQuery where liftEq = genericLiftEq
 instance Ord1 IndexTypeQuery where liftCompare = genericLiftCompare
@@ -452,7 +486,7 @@ instance Show1 IndexTypeQuery where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable IndexTypeQuery
 
 newtype TypeArguments a = TypeArguments { _typeArguments :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 TypeArguments where liftEq = genericLiftEq
 instance Ord1 TypeArguments where liftCompare = genericLiftCompare
@@ -460,7 +494,7 @@ instance Show1 TypeArguments where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable TypeArguments
 
 newtype ThisType a = ThisType ByteString
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ThisType where liftEq = genericLiftEq
 instance Ord1 ThisType where liftCompare = genericLiftCompare
@@ -468,7 +502,7 @@ instance Show1 ThisType where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ThisType
 
 newtype ExistentialType a = ExistentialType ByteString
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ExistentialType where liftEq = genericLiftEq
 instance Ord1 ExistentialType where liftCompare = genericLiftCompare
@@ -476,7 +510,7 @@ instance Show1 ExistentialType where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ExistentialType
 
 newtype LiteralType a = LiteralType { _literalTypeSubject :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 LiteralType where liftEq = genericLiftEq
 instance Ord1 LiteralType where liftCompare = genericLiftCompare
@@ -484,7 +518,7 @@ instance Show1 LiteralType where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable LiteralType
 
 data PropertySignature a = PropertySignature { _modifiers :: ![a], _propertySignaturePropertyName :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 PropertySignature where liftEq = genericLiftEq
 instance Ord1 PropertySignature where liftCompare = genericLiftCompare
@@ -492,7 +526,7 @@ instance Show1 PropertySignature where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable PropertySignature
 
 data CallSignature a = CallSignature { _callSignatureTypeParameters :: !a, _callSignatureParameters :: ![a], _callSignatureType :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 CallSignature where liftEq = genericLiftEq
 instance Ord1 CallSignature where liftCompare = genericLiftCompare
@@ -501,7 +535,7 @@ instance Evaluatable CallSignature
 
 -- | Todo: Move type params and type to context
 data ConstructSignature a = ConstructSignature { _constructSignatureTypeParameters :: !a, _constructSignatureParameters :: ![a], _constructSignatureType :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ConstructSignature where liftEq = genericLiftEq
 instance Ord1 ConstructSignature where liftCompare = genericLiftCompare
@@ -509,7 +543,7 @@ instance Show1 ConstructSignature where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ConstructSignature
 
 data IndexSignature a = IndexSignature { _indexSignatureSubject :: a, _indexSignatureType :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 IndexSignature where liftEq = genericLiftEq
 instance Ord1 IndexSignature where liftCompare = genericLiftCompare
@@ -517,7 +551,7 @@ instance Show1 IndexSignature where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable IndexSignature
 
 data AbstractMethodSignature a = AbstractMethodSignature { _abstractMethodSignatureContext :: ![a], _abstractMethodSignatureName :: !a, _abstractMethodSignatureParameters :: ![a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 AbstractMethodSignature where liftEq = genericLiftEq
 instance Ord1 AbstractMethodSignature where liftCompare = genericLiftCompare
@@ -525,7 +559,7 @@ instance Show1 AbstractMethodSignature where liftShowsPrec = genericLiftShowsPre
 instance Evaluatable AbstractMethodSignature
 
 data Debugger a = Debugger
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Debugger where liftEq = genericLiftEq
 instance Ord1 Debugger where liftCompare = genericLiftCompare
@@ -533,7 +567,7 @@ instance Show1 Debugger where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Debugger
 
 data ForOf a = ForOf { _forOfBinding :: !a, _forOfSubject :: !a, _forOfBody :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ForOf where liftEq = genericLiftEq
 instance Ord1 ForOf where liftCompare = genericLiftCompare
@@ -541,7 +575,7 @@ instance Show1 ForOf where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ForOf
 
 data This a = This
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 This where liftEq = genericLiftEq
 instance Ord1 This where liftCompare = genericLiftCompare
@@ -549,7 +583,7 @@ instance Show1 This where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable This
 
 data LabeledStatement a = LabeledStatement { _labeledStatementIdentifier :: !a, _labeledStatementSubject :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 LabeledStatement where liftEq = genericLiftEq
 instance Ord1 LabeledStatement where liftCompare = genericLiftCompare
@@ -557,7 +591,7 @@ instance Show1 LabeledStatement where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable LabeledStatement
 
 newtype Update a = Update { _updateSubject :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Update where liftEq = genericLiftEq
 instance Ord1 Update where liftCompare = genericLiftCompare
@@ -565,7 +599,7 @@ instance Show1 Update where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Update
 
 data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Module where liftEq = genericLiftEq
 instance Ord1 Module where liftCompare = genericLiftCompare
@@ -575,12 +609,12 @@ instance Evaluatable Module where
   eval (Module iden xs) = do
     name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
     letrec' name $ \addr ->
-      eval xs <* makeNamespace name addr []
+      eval xs <* makeNamespace name addr Nothing
 
 
 
 data InternalModule a = InternalModule { internalModuleIdentifier :: !a, internalModuleStatements :: ![a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 InternalModule where liftEq = genericLiftEq
 instance Ord1 InternalModule where liftCompare = genericLiftCompare
@@ -590,11 +624,14 @@ instance Evaluatable InternalModule where
   eval (InternalModule iden xs) = do
     name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
     letrec' name $ \addr ->
-      eval xs <* makeNamespace name addr []
+      eval xs <* makeNamespace name addr Nothing
+
+instance Declarations a => Declarations (InternalModule a) where
+  declaredName InternalModule{..} = declaredName internalModuleIdentifier
 
 
 data ImportAlias a = ImportAlias { _importAliasSubject :: !a, _importAlias :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ImportAlias where liftEq = genericLiftEq
 instance Ord1 ImportAlias where liftCompare = genericLiftCompare
@@ -602,7 +639,7 @@ instance Show1 ImportAlias where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ImportAlias
 
 data Super a = Super
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Super where liftEq = genericLiftEq
 instance Ord1 Super where liftCompare = genericLiftCompare
@@ -610,7 +647,7 @@ instance Show1 Super where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Super
 
 data Undefined a = Undefined
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 Undefined where liftEq = genericLiftEq
 instance Ord1 Undefined where liftCompare = genericLiftCompare
@@ -618,23 +655,35 @@ instance Show1 Undefined where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Undefined
 
 data ClassHeritage a = ClassHeritage { _classHeritageExtendsClause :: !a, _implementsClause :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ClassHeritage where liftEq = genericLiftEq
 instance Ord1 ClassHeritage where liftCompare = genericLiftCompare
 instance Show1 ClassHeritage where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ClassHeritage
 
-data AbstractClass a = AbstractClass { _abstractClassIdentifier :: !a,  _abstractClassTypeParameters :: !a, _classHeritage :: ![a], _classBody :: !a }
+data AbstractClass a = AbstractClass { abstractClassIdentifier :: !a,  _abstractClassTypeParameters :: !a, classHeritage :: ![a], classBody :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 AbstractClass where liftEq = genericLiftEq
 instance Ord1 AbstractClass where liftCompare = genericLiftCompare
 instance Show1 AbstractClass where liftShowsPrec = genericLiftShowsPrec
-instance Evaluatable AbstractClass
+instance Declarations a => Declarations (AbstractClass a) where
+  declaredName AbstractClass{..} = declaredName abstractClassIdentifier
+
+instance Evaluatable AbstractClass where
+  eval AbstractClass{..} = do
+    name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm abstractClassIdentifier)
+    supers <- traverse subtermValue classHeritage
+    (v, addr) <- letrec name $ do
+      void $ subtermValue classBody
+      classEnv <- Env.head <$> getEnv
+      klass name supers classEnv
+    v <$ modifyEnv (Env.insert name addr)
+
 
 data JsxElement a = JsxElement { _jsxOpeningElement :: !a,  _jsxElements :: ![a], _jsxClosingElement :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 JsxElement where liftEq = genericLiftEq
 instance Ord1 JsxElement where liftCompare = genericLiftCompare
@@ -642,7 +691,7 @@ instance Show1 JsxElement where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable JsxElement
 
 newtype JsxText a = JsxText ByteString
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 JsxText where liftEq = genericLiftEq
 instance Ord1 JsxText where liftCompare = genericLiftCompare
@@ -650,7 +699,7 @@ instance Show1 JsxText where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable JsxText
 
 newtype JsxExpression a = JsxExpression { _jsxExpression :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 JsxExpression where liftEq = genericLiftEq
 instance Ord1 JsxExpression where liftCompare = genericLiftCompare
@@ -658,7 +707,7 @@ instance Show1 JsxExpression where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable JsxExpression
 
 data JsxOpeningElement a = JsxOpeningElement { _jsxOpeningElementIdentifier :: !a,  _jsxAttributes :: ![a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 JsxOpeningElement where liftEq = genericLiftEq
 instance Ord1 JsxOpeningElement where liftCompare = genericLiftCompare
@@ -666,7 +715,7 @@ instance Show1 JsxOpeningElement where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable JsxOpeningElement
 
 newtype JsxClosingElement a = JsxClosingElement { _jsxClosingElementIdentifier :: a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 JsxClosingElement where liftEq = genericLiftEq
 instance Ord1 JsxClosingElement where liftCompare = genericLiftCompare
@@ -674,7 +723,7 @@ instance Show1 JsxClosingElement where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable JsxClosingElement
 
 data JsxSelfClosingElement a = JsxSelfClosingElement { _jsxSelfClosingElementIdentifier :: !a, _jsxSelfClosingElementAttributes :: ![a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 JsxSelfClosingElement where liftEq = genericLiftEq
 instance Ord1 JsxSelfClosingElement where liftCompare = genericLiftCompare
@@ -682,7 +731,7 @@ instance Show1 JsxSelfClosingElement where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable JsxSelfClosingElement
 
 data JsxAttribute a = JsxAttribute { _jsxAttributeTarget :: !a, _jsxAttributeValue :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 JsxAttribute where liftEq = genericLiftEq
 instance Ord1 JsxAttribute where liftCompare = genericLiftCompare
@@ -690,7 +739,7 @@ instance Show1 JsxAttribute where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable JsxAttribute
 
 newtype ImplementsClause a = ImplementsClause { _implementsClauseTypes :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 ImplementsClause where liftEq = genericLiftEq
 instance Ord1 ImplementsClause where liftCompare = genericLiftCompare
@@ -698,7 +747,7 @@ instance Show1 ImplementsClause where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable ImplementsClause
 
 data OptionalParameter a = OptionalParameter { _optionalParameterContext :: ![a], _optionalParameterSubject :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 OptionalParameter where liftEq = genericLiftEq
 instance Ord1 OptionalParameter where liftCompare = genericLiftCompare
@@ -706,7 +755,7 @@ instance Show1 OptionalParameter where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable OptionalParameter
 
 data RequiredParameter a = RequiredParameter { _requiredParameterContext :: ![a], _requiredParameterSubject :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 RequiredParameter where liftEq = genericLiftEq
 instance Ord1 RequiredParameter where liftCompare = genericLiftCompare
@@ -714,7 +763,7 @@ instance Show1 RequiredParameter where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable RequiredParameter
 
 data RestParameter a = RestParameter { _restParameterContext :: ![a], _restParameterSubject :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 RestParameter where liftEq = genericLiftEq
 instance Ord1 RestParameter where liftCompare = genericLiftCompare
@@ -722,7 +771,7 @@ instance Show1 RestParameter where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable RestParameter
 
 newtype JsxFragment a = JsxFragment [a]
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 JsxFragment where liftEq = genericLiftEq
 instance Ord1 JsxFragment where liftCompare = genericLiftCompare
@@ -730,7 +779,7 @@ instance Show1 JsxFragment where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable JsxFragment
 
 data JsxNamespaceName a = JsxNamespaceName a a
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
 
 instance Eq1 JsxNamespaceName where liftEq = genericLiftEq
 instance Ord1 JsxNamespaceName where liftCompare = genericLiftCompare

src/Parsing/Parser.hs

@@ -2,8 +2,11 @@
 module Parsing.Parser
 ( Parser(..)
 , SomeParser(..)
+, SomeAnalysisParser(..)
 , someParser
+, someAnalysisParser
 , ApplyAll
+, ApplyAll'
 -- À la carte parsers
 , goParser
 , javaParser
@@ -15,32 +18,69 @@ module Parsing.Parser
 , phpParser
 ) where
 
-import Prologue
+import           Assigning.Assignment
-import Assigning.Assignment
 import qualified CMarkGFM
-import Data.AST
+import           Data.AST
-import Data.Kind
+import           Data.Kind
-import Data.Language
+import           Data.Language
-import Data.Record
+import           Data.Record
 import qualified Data.Syntax as Syntax
-import Data.Term
+import           Data.Term
-import Foreign.Ptr
+import           Data.File
+import           Foreign.Ptr
+import qualified GHC.TypeLits as TypeLevel
 import qualified Language.Go.Assignment as Go
 import qualified Language.Java.Assignment as Java
 import qualified Language.JSON.Assignment as JSON
 import qualified Language.Markdown.Assignment as Markdown
+import qualified Language.PHP.Assignment as PHP
+import           Language.Preluded
 import qualified Language.Python.Assignment as Python
 import qualified Language.Ruby.Assignment as Ruby
 import qualified Language.TypeScript.Assignment as TypeScript
-import qualified Language.PHP.Assignment as PHP
+import           Prologue
+import           TreeSitter.Go
+import           TreeSitter.JSON
 import qualified TreeSitter.Language as TS (Language, Symbol)
-import TreeSitter.Go
+import           TreeSitter.Java
-import TreeSitter.JSON
+import           TreeSitter.PHP
-import TreeSitter.Java
+import           TreeSitter.Python
-import TreeSitter.PHP
+import           TreeSitter.Ruby
-import TreeSitter.Python
+import           TreeSitter.TypeScript
-import TreeSitter.Ruby
+
-import TreeSitter.TypeScript
+
+type family ApplyAll' (typeclasses :: [(* -> *) -> Constraint]) (fs :: [* -> *]) :: Constraint where
+  ApplyAll' (typeclass ': typeclasses) fs = (Apply typeclass fs, ApplyAll' typeclasses fs)
+  ApplyAll' '[] fs = ()
+
+-- | A parser, suitable for program analysis, for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints.
+data SomeAnalysisParser typeclasses ann where
+  SomeAnalysisParser :: ( Member Syntax.Identifier fs
+                        , ApplyAll' typeclasses fs)
+                     => Parser (Term (Union fs) ann) -- ^ A parser.
+                     -> Maybe File                   -- ^ Maybe path to prelude.
+                     -> SomeAnalysisParser typeclasses ann
+
+-- | A parser for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints.
+someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax
+                      , ApplyAll' typeclasses Java.Syntax
+                      , ApplyAll' typeclasses PHP.Syntax
+                      , ApplyAll' typeclasses Python.Syntax
+                      , ApplyAll' typeclasses Ruby.Syntax
+                      , ApplyAll' typeclasses TypeScript.Syntax
+                      )
+                   => proxy typeclasses                                -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@.
+                   -> Language                                         -- ^ The 'Language' to select.
+                   -> SomeAnalysisParser typeclasses (Record Location) -- ^ A 'SomeAnalysisParser abstracting the syntax type to be produced.
+someAnalysisParser _ Go         = SomeAnalysisParser goParser Nothing
+someAnalysisParser _ Java       = SomeAnalysisParser javaParser Nothing
+someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser Nothing
+someAnalysisParser _ PHP        = SomeAnalysisParser phpParser Nothing
+someAnalysisParser _ Python     = SomeAnalysisParser pythonParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Python))
+someAnalysisParser _ Ruby       = SomeAnalysisParser rubyParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Ruby))
+someAnalysisParser _ TypeScript = SomeAnalysisParser typescriptParser Nothing
+someAnalysisParser _ l          = error $ "Analysis not supported for: " <> show l
+
 
 -- | A parser from 'Source' onto some term type.
 data Parser term where

src/Prologue.hs

@@ -3,7 +3,8 @@ module Prologue
   ( module X
   , foldMapA
   , maybeM
-  , maybeFail
+  , maybeLast
+  , fromMaybeLast
   ) where
 
 
@@ -61,10 +62,13 @@ import GHC.Stack as X
 foldMapA :: (Alternative m, Foldable t) => (b -> m a) -> t b -> m a
 foldMapA f = getAlt . foldMap (Alt . f)
 
+
+maybeLast :: Foldable t => b -> (a -> b) -> t a -> b
+maybeLast b f = maybe b f . getLast . foldMap (Last . Just)
+
+fromMaybeLast :: Foldable t => a -> t a -> a
+fromMaybeLast b = fromMaybe b . getLast . foldMap (Last . Just)
+
 -- | Extract the 'Just' of a 'Maybe' in an 'Applicative' context or, given 'Nothing', run the provided action.
 maybeM :: Applicative f => f a -> Maybe a -> f a
 maybeM f = maybe f pure
-
--- | Either extract the 'Just' of a 'Maybe' or invoke 'fail' with the provided string.
-maybeFail :: MonadFail m => String -> Maybe a -> m a
-maybeFail s = maybeM (X.fail s)

src/Rendering/Renderer.hs

@@ -2,6 +2,7 @@
 module Rendering.Renderer
 ( DiffRenderer(..)
 , TermRenderer(..)
+, GraphRenderer(..)
 , SomeRenderer(..)
 , renderSExpressionDiff
 , renderSExpressionTerm
@@ -65,10 +66,17 @@ data TermRenderer output where
 deriving instance Eq (TermRenderer output)
 deriving instance Show (TermRenderer output)
 
+-- | Specification of renderers for graph analysis, producing output in the parameter type.
+data GraphRenderer output where
+  JSONGraphRenderer :: GraphRenderer ByteString
+  DOTGraphRenderer :: GraphRenderer ByteString
+
+deriving instance Eq (GraphRenderer output)
+deriving instance Show (GraphRenderer output)
 
 -- | Abstraction of some renderer to some 'Monoid'al output which can be serialized to a 'ByteString'.
 --
---   This type abstracts the type indices of 'DiffRenderer' and 'TermRenderer' s.t. multiple renderers can be present in a single list, alternation, etc., while retaining the ability to render and serialize. (Without 'SomeRenderer', the different output types of individual term/diff renderers prevent them from being used in a homogeneously typed setting.)
+--   This type abstracts the type indices of 'DiffRenderer', 'TermRenderer', and 'GraphRenderer' s.t. multiple renderers can be present in a single list, alternation, etc., while retaining the ability to render and serialize. (Without 'SomeRenderer', the different output types of individual term/diff renderers prevent them from being used in a homogeneously typed setting.)
 data SomeRenderer f where
   SomeRenderer :: (Output output, Show (f output)) => f output -> SomeRenderer f
 

src/Semantic/CLI.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ApplicativeDo, TemplateHaskell #-}
 module Semantic.CLI
 ( main
 -- Testing
@@ -6,33 +6,37 @@ module Semantic.CLI
 , runParse
 ) where
 
-import Prologue
+import           Data.File
-import Data.Language
+import           Data.Language
-import Data.List (intercalate)
+import           Data.List (intercalate)
-import Data.List.Split (splitWhen)
+import           Data.List.Split (splitWhen)
-import Data.Version (showVersion)
+import           Data.Version (showVersion)
-import Development.GitRev
+import           Development.GitRev
-import Options.Applicative
+import           Options.Applicative
-import Rendering.Renderer
 import qualified Paths_semantic as Library (version)
-import Semantic.IO (languageForFilePath)
+import           Prologue
+import           Rendering.Renderer
 import qualified Semantic.Diff as Semantic (diffBlobPairs)
+import qualified Semantic.Graph as Semantic (graph)
+import           Semantic.IO (languageForFilePath)
 import qualified Semantic.Log as Log
 import qualified Semantic.Parse as Semantic (parseBlobs)
 import qualified Semantic.Task as Task
-import System.IO (Handle, stdin, stdout)
+import           System.IO (Handle, stdin, stdout)
-import Text.Read
+import           Text.Read
-
 
 main :: IO ()
 main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions
 
-runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> Task.TaskEff ByteString
+runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both File] -> Task.TaskEff ByteString
 runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs
 
-runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> Task.TaskEff ByteString
+runParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
 runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
 
+runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> FilePath -> Language -> [FilePath] -> Task.TaskEff ByteString
+runGraph (SomeRenderer r) rootDir dir excludeDirs = Semantic.graph r <=< Task.readProject rootDir dir excludeDirs
+
 -- | 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.
@@ -43,54 +47,58 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
     versionString = "semantic version " <> showVersion Library.version <> " (" <> $(gitHash) <> ")"
     description = fullDesc <> header "semantic -- Parse and diff semantically"
 
-    optionsParser = Log.Options
+    optionsParser = do
-      <$> (not <$> switch (long "disable-colour" <> long "disable-color" <> help "Disable ANSI colors in log messages even if the terminal is a TTY."))
+      disableColour <- not <$> switch (long "disable-colour" <> long "disable-color" <> help "Disable ANSI colors in log messages even if the terminal is a TTY.")
-      <*> options [("error", Just Log.Error), ("warning", Just Log.Warning), ("info", Just Log.Info), ("debug", Just Log.Debug), ("none", Nothing)]
+      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.")
+                          (long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.")
-      <*> optional (strOption (long "request-id" <> help "A string to use as the request identifier for any logged messages." <> metavar "id"))
+      requestId <- optional (strOption $ long "request-id" <> help "A string to use as the request identifier for any logged messages." <> metavar "id")
-      -- The rest of the logging options are set automatically at runtime.
+      failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.")
-      <*> pure False -- IsTerminal
+      pure $ Log.Options disableColour logLevel requestId False False Log.logfmtFormatter 0 failOnWarning
-      <*> pure False -- PrintSource
+
-      <*> pure Log.logfmtFormatter -- Formatter
+    argumentsParser = do
-      <*> pure 0 -- ProcessID
+      subparser <- hsubparser (diffCommand <> parseCommand <> graphCommand)
-      <*> switch (long "fail-on-warning" <> help "Fail on assignment warnings.")
+      output <- Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (Left stdout)
-    argumentsParser = (. Task.writeToOutput) . (>>=)
+      pure $ subparser >>= Task.writeToOutput output
-      <$> hsubparser (diffCommand <> parseCommand)
-      <*> (   Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout")
-          <|> pure (Left stdout) )
 
     diffCommand = command "diff" (info diffArgumentsParser (progDesc "Show changes between commits or paths"))
-    diffArgumentsParser = runDiff
+    diffArgumentsParser = do
-      <$> (   flag  (SomeRenderer SExpressionDiffRenderer) (SomeRenderer SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree")
+      renderer <- flag  (SomeRenderer SExpressionDiffRenderer) (SomeRenderer SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree")
-          <|> flag'                                        (SomeRenderer JSONDiffRenderer)        (long "json" <> help "Output JSON diff trees")
+              <|> flag'                                        (SomeRenderer JSONDiffRenderer)        (long "json" <> help "Output JSON diff trees")
-          <|> flag'                                        (SomeRenderer ToCDiffRenderer)         (long "toc" <> help "Output JSON table of contents diff summary")
+              <|> flag'                                        (SomeRenderer ToCDiffRenderer)         (long "toc" <> help "Output JSON table of contents diff summary")
-          <|> flag'                                        (SomeRenderer DOTDiffRenderer)         (long "dot" <> help "Output the diff as a DOT graph"))
+              <|> flag'                                        (SomeRenderer DOTDiffRenderer)         (long "dot" <> help "Output the diff as a DOT graph")
-      <*> (   Right <$> some (both
+      filesOrStdin <- Right <$> some (both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin)
-          <$> argument filePathReader (metavar "FILE_A")
+      pure $ runDiff renderer filesOrStdin
-          <*> argument filePathReader (metavar "FILE_B"))
-          <|> pure (Left stdin) )
 
     parseCommand = command "parse" (info parseArgumentsParser (progDesc "Print parse trees for path(s)"))
-    parseArgumentsParser = runParse
+    parseArgumentsParser = do
-      <$> (   flag  (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)")
+      renderer <- flag  (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)")
-          <|> flag'                                        (SomeRenderer JSONTermRenderer)        (long "json" <> help "Output JSON parse trees")
+              <|> flag'                                        (SomeRenderer JSONTermRenderer)        (long "json" <> help "Output JSON parse trees")
-          <|> flag'                                        (SomeRenderer TagsTermRenderer)        (long "tags" <> help "Output JSON tags")
+              <|> flag'                                        (SomeRenderer TagsTermRenderer)        (long "tags" <> help "Output JSON tags")
-          <|> flag'                                        (SomeRenderer . SymbolsTermRenderer)   (long "symbols" <> help "Output JSON symbol list")
+              <|> flag'                                        (SomeRenderer . SymbolsTermRenderer)   (long "symbols" <> help "Output JSON symbol list")
-              <*> (   option symbolFieldsReader (  long "fields"
+                   <*> (option symbolFieldsReader (  long "fields"
-                                                <> help "Comma delimited list of specific fields to return (symbols output only)."
+                                                 <> help "Comma delimited list of specific fields to return (symbols output only)."
-                                                <> metavar "FIELDS")
+                                                 <> metavar "FIELDS")
                   <|> pure defaultSymbolFields)
-          <|> flag'                                        (SomeRenderer ImportsTermRenderer)     (long "import-graph" <> help "Output JSON import graph")
+              <|> flag'                                        (SomeRenderer ImportsTermRenderer)     (long "import-graph" <> help "Output JSON import graph")
-          <|> flag'                                        (SomeRenderer DOTTermRenderer)         (long "dot" <> help "Output DOT graph parse trees"))
+              <|> flag'                                        (SomeRenderer DOTTermRenderer)         (long "dot" <> help "Output DOT graph parse trees")
-      <*> (   Right <$> some (argument filePathReader (metavar "FILES..."))
+      filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
-          <|> pure (Left stdin) )
+      pure $ runParse renderer filesOrStdin
+
+    graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute an import graph a directory or entry point"))
+    graphArgumentsParser = do
+      renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer)  (long "dot" <> help "Output in DOT graph format (default)")
+              <|> flag'                                (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph")
+      rootDir <- optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIRECTORY"))
+      excludeDirs <- many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)"))
+      File{..} <- argument filePathReader (metavar "DIRECTORY:LANGUAGE")
+      pure $ runGraph renderer rootDir filePath (fromJust fileLanguage) excludeDirs
 
     filePathReader = eitherReader parseFilePath
     parseFilePath arg = case splitWhen (== ':') arg of
-        [a, b] | Just lang <- readMaybe a -> Right (b, Just lang)
+        [a, b] | lang <- readMaybe b -> Right (File a lang)
-               | Just lang <- readMaybe b -> Right (a, Just lang)
+               | lang <- readMaybe a -> Right (File b lang)
-        [path] -> Right (path, languageForFilePath path)
+        [path] -> maybe (Left $ "Cannot identify language for path: " <> path) (Right . File path . Just) (languageForFilePath path)
-        _ -> Left ("cannot parse `" <> arg <> "`\nexpecting LANGUAGE:FILE or just FILE")
+        args -> Left ("cannot parse `" <> join args <> "`\nexpecting FILE:LANGUAGE or just FILE")
 
     optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options)
     options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options) <> metavar (intercalate "|" (fmap fst options)))

src/Semantic/Graph.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE GADTs #-}
+module Semantic.Graph where
+
+import           Analysis.Abstract.BadAddresses
+import           Analysis.Abstract.BadModuleResolutions
+import           Analysis.Abstract.BadSyntax
+import           Analysis.Abstract.BadValues
+import           Analysis.Abstract.BadVariables
+import           Analysis.Abstract.Erroring
+import           Analysis.Abstract.Evaluating
+import           Analysis.Abstract.ImportGraph
+import qualified Control.Exception as Exc
+import           Data.Abstract.Address
+import qualified Data.Abstract.Evaluatable as Analysis
+import           Data.Abstract.FreeVariables
+import           Data.Abstract.Located
+import           Data.Abstract.Module
+import           Data.Abstract.Package as Package
+import           Data.Abstract.Value (Value)
+import           Data.File
+import           Data.Output
+import qualified Data.Syntax as Syntax
+import           Data.Term
+import           Parsing.Parser
+import           Prologue hiding (MonadError (..))
+import           Rendering.Renderer
+import           Semantic.IO (Files)
+import           Semantic.Task
+
+graph :: Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs
+      => GraphRenderer output
+      -> Project
+      -> Eff effs ByteString
+graph renderer project
+  | SomeAnalysisParser parser prelude <- someAnalysisParser
+    (Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do
+    parsePackage parser prelude project >>= graphImports >>= case renderer of
+      JSONGraphRenderer -> pure . toOutput
+      DOTGraphRenderer  -> pure . renderImportGraph
+
+-- | Parse a list of files into a 'Package'.
+parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs
+             => Parser term       -- ^ A parser.
+             -> Maybe File        -- ^ Prelude (optional).
+             -> Project           -- ^ Project to parse into a package.
+             -> Eff effs (Package term)
+parsePackage parser preludeFile project@Project{..} = do
+  prelude <- traverse (parseModule parser Nothing) preludeFile
+  p <- parseModules parser project
+  trace ("project: " <> show p) $ pure (Package.fromModules n Nothing prelude (length projectEntryPoints) p)
+  where
+    n = name (projectName project)
+
+    -- | Parse all files in a project into 'Module's.
+    parseModules :: Members '[Distribute WrappedTask, Files, Task] effs => Parser term -> Project -> Eff effs [Module term]
+    parseModules parser Project{..} = distributeFor (projectEntryPoints <> projectFiles) (WrapTask . parseModule parser (Just projectRootDir))
+
+-- | Parse a file into a 'Module'.
+parseModule :: Members '[Files, Task] effs => Parser term -> Maybe FilePath -> File -> Eff effs (Module term)
+parseModule parser rootDir file = do
+  blob <- readBlob file
+  moduleForBlob rootDir blob <$> parse parser blob
+
+
+type ImportGraphAnalysis term
+  = ImportGraphing
+  ( BadAddresses
+  ( BadModuleResolutions
+  ( BadVariables
+  ( BadValues
+  ( BadSyntax
+  ( Erroring (Analysis.LoadError term)
+  ( Evaluating
+    (Located Precise term)
+    term
+    (Value (Located Precise term)))))))))
+
+-- | Render the import graph for a given 'Package'.
+graphImports :: ( Show ann
+                , Ord ann
+                , Apply Analysis.Declarations1 syntax
+                , Apply Analysis.Evaluatable syntax
+                , Apply FreeVariables1 syntax
+                , Apply Functor syntax
+                , Apply Ord1 syntax
+                , Apply Eq1 syntax
+                , Apply Show1 syntax
+                , Member Syntax.Identifier syntax
+                , Members '[Exc SomeException, Task] effs
+                )
+             => Package (Term (Union syntax) ann) -> Eff effs ImportGraph
+graphImports package = analyze (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package) >>= extractGraph
+  where
+    asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value
+                               -> Package term
+                               -> ImportGraphAnalysis term effs value
+    asAnalysisForTypeOfPackage = const
+
+    extractGraph result = case result of
+      (Right (Right ((_, graph), _)), _) -> pure graph
+      _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result)))

src/Semantic/IO.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TupleSections, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
 module Semantic.IO
 ( readFile
 , readFilePair
@@ -6,9 +6,13 @@ module Semantic.IO
 , readBlobPairsFromHandle
 , readBlobsFromHandle
 , readBlobsFromPaths
+, readProjectFromPaths
 , readBlobsFromDir
+, findFiles
 , languageForFilePath
 , NoLanguageForBlob(..)
+, readBlob
+, readProject
 , readBlobs
 , readBlobPairs
 , writeToOutput
@@ -25,6 +29,7 @@ import           Control.Monad.IO.Class
 import           Data.Aeson
 import qualified Data.Blob as Blob
 import           Data.Bool
+import           Data.File
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
 import           Data.Language
@@ -32,6 +37,8 @@ import           Data.Source
 import           Prelude hiding (readFile)
 import           Prologue hiding (MonadError (..), fail)
 import           System.Directory (doesDirectoryExist)
+import qualified System.Directory.Tree as Tree
+import           System.Directory.Tree (AnchoredDirTree(..))
 import           System.Exit
 import           System.FilePath
 import           System.FilePath.Glob
@@ -39,16 +46,16 @@ import           System.IO (Handle)
 import           Text.Read
 
 -- | Read a utf8-encoded file to a 'Blob'.
-readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m (Maybe Blob.Blob)
+readFile :: forall m. MonadIO m => File -> m (Maybe Blob.Blob)
-readFile "/dev/null" _ = pure Nothing
+readFile (File "/dev/null" _) = pure Nothing
-readFile path language = do
+readFile (File path language) = do
   raw <- liftIO (Just <$> B.readFile path)
   pure $ Blob.sourceBlob path language . fromBytes <$> raw
 
-readFilePair :: forall m. MonadIO m => (FilePath, Maybe Language) -> (FilePath, Maybe Language) -> m Blob.BlobPair
+readFilePair :: forall m. MonadIO m => File -> File -> m Blob.BlobPair
 readFilePair a b = do
-  before <- uncurry readFile a
+  before <- readFile a
-  after <- uncurry readFile b
+  after <- readFile b
   case (before, after) of
     (Just a, Nothing) -> pure (Join (This a))
     (Nothing, Just b) -> pure (Join (That b))
@@ -75,14 +82,56 @@ readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob]
 readBlobsFromHandle = fmap toBlobs . readFromHandle
   where toBlobs BlobParse{..} = fmap toBlob blobs
 
-readBlobsFromPaths :: MonadIO m => [(FilePath, Maybe Language)] -> m [Blob.Blob]
+readBlobFromPath :: MonadIO m => File -> m Blob.Blob
-readBlobsFromPaths files = catMaybes <$> traverse (uncurry readFile) files
+readBlobFromPath file = do
+  maybeFile <- readFile file
+  maybe (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) pure maybeFile
+
+readBlobsFromPaths :: MonadIO m => [File] -> m [Blob.Blob]
+readBlobsFromPaths files = catMaybes <$> traverse readFile files
+
+readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
+readProjectFromPaths maybeRoot path lang excludeDirs = do
+  isDir <- isDirectory path
+  let (filterFun, entryPoints, rootDir) = if isDir
+      then (id, [], fromMaybe path maybeRoot)
+      else (filter (/= path), [toFile path], fromMaybe (takeDirectory path) maybeRoot)
+
+  paths <- liftIO $ filterFun <$> findFiles rootDir exts excludeDirs
+  pure $ Project rootDir (toFile <$> paths) lang entryPoints
+  where
+    toFile path = File path (Just lang)
+    exts = extensionsForLanguage lang
+
+-- Recursively find files in a directory.
+findFiles :: forall m. MonadIO m => FilePath -> [String] -> [FilePath] -> m [FilePath]
+findFiles path exts excludeDirs = do
+  _:/dir <- liftIO $ Tree.build path
+  pure $ (onlyFiles . Tree.filterDir (withExtensions exts) . Tree.filterDir (notIn excludeDirs)) dir
+  where
+    -- Build a list of only FilePath's (remove directories and failures)
+    onlyFiles (Tree.Dir _ fs)   = concatMap onlyFiles fs
+    onlyFiles (Tree.Failed _ _) = []
+    onlyFiles (Tree.File _ f)   = [f]
+
+    -- Predicate for Files with one of the extensions in 'exts'.
+    withExtensions exts (Tree.File n _)
+      | takeExtension n `elem` exts = True
+      | otherwise                   = False
+    withExtensions _ _              = True
+
+    -- Predicate for contents NOT in a directory
+    notIn dirs (Tree.Dir n _)
+      | (x:_) <- n, x == '.' = False -- Don't include directories that start with '.'.
+      | n `elem` dirs = False
+      | otherwise = True
+    notIn _ _ = True
 
 readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob]
 readBlobsFromDir path = do
   paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path)
-  let paths' = catMaybes $ fmap (\p -> (p,) . Just <$> languageForFilePath p) paths
+  let paths' = catMaybes $ fmap (\p -> File p . Just <$> languageForFilePath p) paths
-  blobs <- traverse (uncurry readFile) paths'
+  blobs <- traverse readFile paths'
   pure (catMaybes blobs)
 
 readFromHandle :: (FromJSON a, MonadIO m) => Handle -> m a
@@ -129,15 +178,20 @@ instance FromJSON BlobPair where
 newtype NoLanguageForBlob = NoLanguageForBlob FilePath
   deriving (Eq, Exception, Ord, Show, Typeable)
 
+readBlob :: Member Files effs => File -> Eff effs Blob.Blob
+readBlob = send . ReadBlob
 
 -- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
-readBlobs :: Member Files effs => Either Handle [(FilePath, Maybe Language)] -> Eff effs [Blob.Blob]
+readBlobs :: Member Files effs => Either Handle [File] -> Eff effs [Blob.Blob]
 readBlobs = send . ReadBlobs
 
 -- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
-readBlobPairs :: Member Files effs => Either Handle [Both (FilePath, Maybe Language)] -> Eff effs [Blob.BlobPair]
+readBlobPairs :: Member Files effs => Either Handle [Both File] -> Eff effs [Blob.BlobPair]
 readBlobPairs = send . ReadBlobPairs
 
+readProject :: Member Files effs => Maybe FilePath -> FilePath -> Language -> [FilePath] -> Eff effs Project
+readProject rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs
+
 -- | A task which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'.
 writeToOutput :: Member Files effs => Either Handle FilePath -> B.ByteString -> Eff effs ()
 writeToOutput path = send . WriteToOutput path
@@ -145,17 +199,21 @@ writeToOutput path = send . WriteToOutput path
 
 -- | An effect to read/write 'Blob.Blob's from 'Handle's or 'FilePath's.
 data Files out where
-  ReadBlobs     :: Either Handle [(FilePath, Maybe Language)] -> Files [Blob.Blob]
+  ReadBlob      :: File -> Files Blob.Blob
-  ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> Files [Blob.BlobPair]
+  ReadBlobs     :: Either Handle [File] -> Files [Blob.Blob]
+  ReadBlobPairs :: Either Handle [Both File] -> Files [Blob.BlobPair]
+  ReadProject   :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project
   WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files ()
 
 -- | Run a 'Files' effect in 'IO'.
 runFiles :: Members '[Exc SomeException, IO] effs => Eff (Files ': effs) a -> Eff effs a
 runFiles = interpret $ \ files -> case files of
+  ReadBlob path -> rethrowing (readBlobFromPath path)
   ReadBlobs (Left handle) -> rethrowing (readBlobsFromHandle handle)
-  ReadBlobs (Right paths@[(path, Nothing)]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path))
+  ReadBlobs (Right paths@[File path _]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path))
   ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths)
   ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source)
+  ReadProject rootDir dir language excludeDirs -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs)
   WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents)
 
 

src/Semantic/Log.hs

@@ -68,7 +68,7 @@ terminalFormatter :: Options -> Message -> String
 terminalFormatter Options{..} (Message level message pairs time) =
     showChar '[' . showTime time . showString "] "
   . showLevel level . showChar ' '
-  . showString (printf "%-20s" message)
+  . showString (printf "%-20s " message)
   . showPairs pairs
   . showChar '\n' $ ""
   where

src/Semantic/Task.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
 module Semantic.Task
 ( Task
 , TaskEff
@@ -7,8 +7,10 @@ module Semantic.Task
 , RAlgebra
 , Differ
 -- * I/O
+, IO.readBlob
 , IO.readBlobs
 , IO.readBlobPairs
+, IO.readProject
 , IO.writeToOutput
 -- * Telemetry
 , writeLog
@@ -16,14 +18,10 @@ module Semantic.Task
 , time
 -- * High-level flow
 , parse
-, parseModule
-, parseModules
-, parsePackage
 , analyze
 , decorate
 , diff
 , render
-, graphImports
 -- * Concurrency
 , distribute
 , distributeFor
@@ -45,26 +43,15 @@ module Semantic.Task
 , Telemetry
 ) where
 
-import qualified Analysis.Abstract.ImportGraph as Abstract
-import           Analysis.Abstract.Evaluating
 import           Analysis.Decorator (decoratorWithAlgebra)
 import qualified Assigning.Assignment as Assignment
 import qualified Control.Abstract.Analysis as Analysis
-import qualified Control.Exception as Exc
 import           Control.Monad
 import           Control.Monad.Effect.Exception
 import           Control.Monad.Effect.Internal as Eff hiding (run)
 import           Control.Monad.Effect.Reader
 import           Control.Monad.Effect.Run as Run
-import           Data.Abstract.Address
-import qualified Data.Abstract.Evaluatable as Analysis
-import           Data.Abstract.FreeVariables
-import           Data.Abstract.Located
-import           Data.Abstract.Module
-import           Data.Abstract.Package as Package
-import           Data.Abstract.Value (Value)
 import           Data.Blob
-import qualified Data.ByteString as B
 import           Data.Diff
 import qualified Data.Error as Error
 import           Data.Record
@@ -73,7 +60,7 @@ import           Data.Term
 import           Parsing.CMark
 import           Parsing.Parser
 import           Parsing.TreeSitter
-import           Prologue hiding (MonadError(..))
+import           Prologue hiding (MonadError (..))
 import           Semantic.Distribute
 import qualified Semantic.IO as IO
 import           Semantic.Log
@@ -100,23 +87,8 @@ type Renderer i o = i -> o
 parse :: Member Task effs => Parser term -> Blob -> Eff effs term
 parse parser = send . Parse parser
 
--- | Parse a file into a 'Module'.
-parseModule :: Members '[IO.Files, Task] effs => Parser term -> Maybe FilePath -> FilePath -> Eff effs (Module term)
-parseModule parser rootDir path = do
-  blob <- head <$> IO.readBlobs (Right [(path, IO.languageForFilePath path)])
-  moduleForBlob rootDir blob <$> parse parser blob
-
--- | Parse a list of files into 'Module's.
-parseModules :: Members '[IO.Files, Task] effs => Parser term -> FilePath -> [FilePath] -> Eff effs [Module term]
-parseModules parser rootDir = traverse (parseModule parser (Just rootDir))
-
--- | Parse a list of files into a 'Package'.
-parsePackage :: Members '[IO.Files, Task] effs => PackageName -> Parser term -> FilePath -> [FilePath] -> Eff effs (Package term)
-parsePackage name parser rootDir paths = Package (PackageInfo name Nothing) . Package.fromModules <$> parseModules parser rootDir paths
-
-
 -- | A task running some 'Analysis.MonadAnalysis' to completion.
-analyze :: Member Task effs => Analysis.SomeAnalysis m result -> Eff effs result
+analyze :: (Analysis.Interpreter m analysisEffects, Member Task effs) => m analysisEffects result -> Eff effs (Analysis.Result m analysisEffects result)
 analyze = send . Analyze
 
 -- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
@@ -131,18 +103,6 @@ diff differ term1 term2 = send (Semantic.Task.Diff differ term1 term2)
 render :: Member Task effs => Renderer input output -> input -> Eff effs output
 render renderer = send . Render renderer
 
-
--- | Render and serialize the import graph for a given 'Package'.
-graphImports :: (Apply Eq1 syntax, Apply Analysis.Evaluatable syntax, Apply FreeVariables1 syntax, Apply Functor syntax, Apply Ord1 syntax, Apply Show1 syntax, Member Syntax.Identifier syntax, Members '[Exc SomeException, Task] effs, Ord ann, Show ann) => Package (Term (Union syntax) ann) -> Eff effs B.ByteString
-graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package)) >>= renderGraph
-  where asAnalysisForTypeOfPackage :: Abstract.ImportGraphing (Evaluating (Located Precise term) term (Value (Located Precise term))) effects value -> Package term -> Abstract.ImportGraphing (Evaluating (Located Precise term) term (Value (Located Precise term))) effects value
-        asAnalysisForTypeOfPackage = const
-
-        renderGraph result = case result of
-          (Right (Right (Right (Right (Right (Right (_, graph)))))), _) -> pure $! Abstract.renderImportGraph graph
-          _ -> throwError (toException (Exc.ErrorCall "graphImports: import graph rendering failed"))
-
-
 -- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'.
 --
 -- > runTask = runTaskWithOptions defaultOptions
@@ -171,7 +131,7 @@ runTaskWithOptions options task = do
 -- | An effect describing high-level tasks to be performed.
 data Task output where
   Parse    :: Parser term -> Blob -> Task term
-  Analyze  :: Analysis.SomeAnalysis m result -> Task result
+  Analyze  :: Analysis.Interpreter m effects => m effects result -> Task (Analysis.Result m effects result)
   Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields)))
   Diff     :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2)
   Render   :: Renderer input output -> input -> Task output
@@ -180,7 +140,7 @@ data Task output where
 runTaskF :: Members '[Reader Options, Telemetry, Exc SomeException, IO] effs => Eff (Task ': effs) a -> Eff effs a
 runTaskF = interpret $ \ task -> case task of
   Parse parser blob -> runParser blob parser
-  Analyze analysis -> pure (Analysis.runSomeAnalysis analysis)
+  Analyze analysis -> pure (Analysis.interpret analysis)
   Decorate algebra term -> pure (decoratorWithAlgebra algebra term)
   Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2)
   Render renderer input -> pure (renderer input)
@@ -197,11 +157,13 @@ runParser blob@Blob{..} parser = case parser of
     time "parse.tree_sitter_ast_parse" languageTag $
       IO.rethrowing (parseToAST language blob)
   AssignmentParser parser assignment -> do
+    traceM ("Parsing " <> blobPath)
     ast <- runParser blob parser `catchError` \ (SomeException err) -> do
       writeStat (Stat.increment "parse.parse_failures" languageTag)
       writeLog Error "failed parsing" (("task", "parse") : blobFields)
       throwError (toException err)
     options <- ask
+    traceM ("Assigning " <> blobPath)
     time "parse.assign" languageTag $
       case Assignment.assign blobSource assignment ast of
         Left err -> do

src/Semantic/Util.hs

@@ -1,148 +1,91 @@
--- MonoLocalBinds is to silence a warning about a simplifiable constraint.
-{-# LANGUAGE DataKinds, MonoLocalBinds, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
 {-# OPTIONS_GHC -Wno-missing-signatures #-}
 module Semantic.Util where
 
-import Analysis.Abstract.BadVariables
+import           Analysis.Abstract.BadAddresses
-import Analysis.Abstract.BadModuleResolutions
+import           Analysis.Abstract.BadModuleResolutions
-import Analysis.Abstract.BadValues
+import           Analysis.Abstract.BadSyntax
-import Analysis.Abstract.Caching
+import           Analysis.Abstract.BadValues
-import Analysis.Abstract.Quiet
+import           Analysis.Abstract.BadVariables
-import Analysis.Abstract.Dead
+import           Analysis.Abstract.Caching
-import Analysis.Abstract.Evaluating as X
+import           Analysis.Abstract.Collecting
-import Analysis.Abstract.ImportGraph
+import           Analysis.Abstract.Erroring
-import Analysis.Abstract.Tracing
+import           Analysis.Abstract.Evaluating as X
-import Analysis.Declaration
+import           Analysis.Abstract.TypeChecking
-import Control.Abstract.Analysis
+import           Control.Abstract.Analysis
-import Control.Monad.IO.Class
+import           Data.Abstract.Address
-import Data.Abstract.Evaluatable hiding (head)
+import           Data.Abstract.Evaluatable
-import Data.Abstract.Address
+import           Data.Abstract.Located
-import Data.Abstract.Located
+import           Data.Abstract.Type
-import Data.Abstract.Module
+import           Data.Abstract.Value
-import Data.Abstract.Package as Package
+import           Data.Blob
-import Data.Abstract.Type
+import           Data.File
-import Data.Abstract.Value
+import qualified Data.Language as Language
-import Data.Blob
-import Data.Diff
-import Data.Range
-import Data.Record
-import Data.Span
-import Data.Term
-import Diffing.Algorithm
-import Diffing.Interpreter
-import System.FilePath.Glob
 import qualified GHC.TypeLits as TypeLevel
-import Language.Preluded
+import           Language.Preluded
-import Parsing.Parser
+import           Parsing.Parser
-import Prologue
+import           Prologue
-import Semantic.Diff (diffTermPair)
+import           Semantic.Graph
-import Semantic.IO as IO
+import           Semantic.IO as IO
-import Semantic.Task hiding (parsePackage)
+import           Semantic.Task
-import qualified Semantic.Task as Task
-import System.FilePath.Posix
 
 import qualified Language.Go.Assignment as Go
+import qualified Language.PHP.Assignment as PHP
 import qualified Language.Python.Assignment as Python
 import qualified Language.Ruby.Assignment as Ruby
 import qualified Language.TypeScript.Assignment as TypeScript
 
--- Ruby
+type JustEvaluating term
-evalRubyProject = runEvaluatingWithPrelude rubyParser ["rb"]
+  = Erroring (AddressError (Located Precise term) (Value (Located Precise term)))
-evalRubyFile path = runEvaluating <$> (withPrelude <$> parsePrelude rubyParser <*> (evaluateModule <$> parseFile rubyParser Nothing path))
+  ( Erroring (EvalError (Value (Located Precise term)))
+  ( Erroring (ResolutionError (Value (Located Precise term)))
+  ( Erroring (Unspecialized (Value (Located Precise term)))
+  ( Erroring (ValueError (Located Precise term) (Value (Located Precise term)))
+  ( Erroring (LoadError term)
+  ( Evaluating (Located Precise term) term (Value (Located Precise term))))))))
 
-evalRubyProjectGraph path = runAnalysis @(ImportGraphing (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise Ruby.Term) Ruby.Term (Value (Located Precise Ruby.Term)))))))) <$> (withPrelude <$> parsePrelude rubyParser <*> (evaluatePackageBody <$> parseProject rubyParser ["rb"] path))
+type EvaluatingWithHoles term
+  = BadAddresses
+  ( BadModuleResolutions
+  ( BadVariables
+  ( BadValues
+  ( BadSyntax
+  ( Erroring (LoadError term)
+  ( Evaluating (Located Precise term) term (Value (Located Precise term))))))))
 
-evalRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating (Located Precise Ruby.Term) Ruby.Term (Value (Located Precise Ruby.Term)))) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths
+-- The order is significant here: Caching has to come on the outside, or its Interpreter instance
+-- will expect the TypeError exception type to have an Ord instance, which is wrong.
+type Checking term
+  = Caching
+  ( TypeChecking
+  ( Erroring (AddressError Monovariant Type)
+  ( Erroring (EvalError Type)
+  ( Erroring (ResolutionError Type)
+  ( Erroring (Unspecialized Type)
+  ( Erroring (LoadError term)
+  ( Retaining
+  ( Evaluating Monovariant term Type))))))))
 
-evalRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Precise Ruby.Term (Value Precise))) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths
+evalGoProject path = interpret @(JustEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path
+evalRubyProject path = interpret @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path
+evalPHPProject path = interpret @(JustEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path
+evalPythonProject path = interpret @(JustEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path
+evalTypeScriptProjectQuietly path = interpret @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path
+evalTypeScriptProject path = interpret @(JustEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path
 
--- Go
+typecheckGoFile path = interpret @(Checking Go.Term) <$> evaluateProject goParser Language.Go Nothing path
-evalGoProject path = runEvaluating . evaluatePackageBody <$> parseProject goParser ["go"] path
-evalGoFile path = runEvaluating . evaluateModule <$> parseFile goParser Nothing path
 
-typecheckGoFile path = runAnalysis @(Caching (Evaluating Monovariant Go.Term Type)) . evaluateModule <$> parseFile goParser Nothing path
+rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Language.Ruby)
+pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Language.Python)
 
--- Python
+-- Evaluate a project, starting at a single entrypoint.
-evalPythonProject = runEvaluatingWithPrelude pythonParser ["py"]
+evaluateProject parser lang prelude path = evaluatePackage <$> runTask (readProject Nothing path lang [] >>= parsePackage parser prelude)
-evalPythonFile path = runEvaluating <$> (withPrelude <$> parsePrelude pythonParser <*> (evaluateModule <$> parseFile pythonParser Nothing path))
 
-evalPythonImportGraph name paths = runAnalysis @(ImportGraphing (Evaluating (Located Precise Python.Term) Python.Term (Value (Located Precise Python.Term)))) . evaluatePackage <$> parsePackage name pythonParser (dropFileName (head paths)) paths
+evalRubyFile path = interpret @(JustEvaluating Ruby.Term) <$> evaluateFile rubyParser path
-
+evaluateFile parser path = evaluateModule <$> runTask (parseModule parser Nothing (file path))
-typecheckPythonFile path = runAnalysis @(Caching (Evaluating Monovariant Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path
-tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Precise Python.Term (Value Precise))) . evaluateModule <$> parseFile pythonParser Nothing path
-evalDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Precise Python.Term (Value Precise)))) . evaluateModule <$> parseFile pythonParser Nothing path
-
--- PHP
-evalPHPProject path = runEvaluating . evaluatePackageBody <$> parseProject phpParser ["php"] path
-evalPHPFile path = runEvaluating . evaluateModule <$> parseFile phpParser Nothing path
-
--- TypeScript
-evalTypeScriptProject path = runEvaluating . evaluatePackageBody <$> parseProject typescriptParser ["ts", "tsx"] path
-evalTypeScriptFile path = runEvaluating . evaluateModule <$> parseFile typescriptParser Nothing path
-typecheckTypeScriptFile path = runAnalysis @(Caching (Evaluating Monovariant TypeScript.Term Type)) . evaluateModule <$> parseFile typescriptParser Nothing path
-
-runEvaluatingWithPrelude parser exts path = runEvaluating <$> (withPrelude <$> parsePrelude parser <*> (evaluatePackageBody <$> parseProject parser exts path))
-
--- TODO: Remove this by exporting EvaluatingEffects
-runEvaluating :: forall term effects a.
-                 ( Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) ~ effects
-                 , Corecursive term
-                 , Recursive term )
-              => Evaluating Precise term (Value Precise) effects a
-              -> Final effects a
-runEvaluating = runAnalysis @(Evaluating Precise term (Value Precise))
-
-parsePrelude :: forall term. TypeLevel.KnownSymbol (PreludePath term) => Parser term -> IO (Module term)
-parsePrelude parser = do
-  let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term))
-  parseFile parser Nothing preludePath
-
-parseProject :: Parser term
-                -> [Prelude.String]
-                -> FilePath
-                -> IO (PackageBody term)
-parseProject parser exts entryPoint = do
-  let rootDir = takeDirectory entryPoint
-  paths <- getPaths exts rootDir
-  modules <- parseFiles parser rootDir paths
-  pure $ fromModulesWithEntryPoint modules (takeFileName entryPoint)
-
-withPrelude prelude a = do
-  preludeEnv <- evaluateModule prelude *> getEnv
-  withDefaultEnvironment preludeEnv a
-
-getPaths exts = fmap fold . globDir (compile . mappend "**/*." <$> exts)
 
 
--- Read and parse a file.
+parseFile :: Parser term -> FilePath -> IO term
-parseFile :: Parser term -> Maybe FilePath -> FilePath -> IO (Module term)
+parseFile parser = runTask . (parse parser <=< readBlob . file)
-parseFile parser rootDir path = runTask $ do
-  blob <- file path
-  moduleForBlob rootDir blob <$> parse parser blob
 
-parseFiles :: Parser term -> FilePath -> [FilePath] -> IO [Module term]
+blob :: FilePath -> IO Blob
-parseFiles parser rootDir = traverse (parseFile parser (Just rootDir))
+blob = runTask . readBlob . file
-
-parsePackage :: PackageName -> Parser term -> FilePath -> [FilePath] -> IO (Package term)
-parsePackage name parser rootDir = runTask . Task.parsePackage name parser rootDir
-
-
--- Read a file from the filesystem into a Blob.
-file :: MonadIO m => FilePath -> m Blob
-file path = fromJust <$> IO.readFile path (languageForFilePath path)
-
--- Diff helpers
-diffWithParser :: ( HasField fields Data.Span.Span
-                  , HasField fields Range
-                  , Eq1 syntax
-                  , Show1 syntax
-                  , Traversable syntax
-                  , Diffable syntax
-                  , GAlign syntax
-                  , HasDeclaration syntax
-                  , Members '[Distribute WrappedTask, Task] effs
-                  )
-               => Parser (Term syntax (Record fields))
-               -> BlobPair
-               -> Eff effs (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields)))
-diffWithParser parser blobs = distributeFor blobs (\ blob -> WrapTask $ parse parser blob >>= decorate (declarationAlgebra blob)) >>= diffTermPair diffTerms . runJoin

test/Analysis/Go/Spec.hs

@@ -1,6 +1,10 @@
 {-# LANGUAGE OverloadedLists #-}
 module Analysis.Go.Spec (spec) where
 
+import Data.Abstract.Evaluatable (EvalError(..), interpret)
+import qualified Language.Go.Assignment as Go
+import qualified Data.Language as Language
+
 import SpecHelpers
 
 
@@ -28,3 +32,4 @@ spec = parallel $ do
   where
     fixtures = "test/fixtures/go/analysis/"
     evaluate entry = evalGoProject (fixtures <> entry)
+    evalGoProject path = interpret @(TestEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path

test/Analysis/PHP/Spec.hs

@@ -1,6 +1,10 @@
 {-# LANGUAGE OverloadedLists #-}
 module Analysis.PHP.Spec (spec) where
 
+import Data.Abstract.Evaluatable (EvalError(..), interpret)
+import qualified Language.PHP.Assignment as PHP
+import qualified Data.Language as Language
+
 import SpecHelpers
 
 
@@ -32,3 +36,4 @@ spec = parallel $ do
   where
     fixtures = "test/fixtures/php/analysis/"
     evaluate entry = evalPHPProject (fixtures <> entry)
+    evalPHPProject path = interpret @(TestEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path

test/Analysis/Python/Spec.hs

@@ -1,8 +1,11 @@
 {-# LANGUAGE OverloadedLists, OverloadedStrings #-}
 module Analysis.Python.Spec (spec) where
 
+import Data.Abstract.Evaluatable (EvalError(..), interpret)
 import Data.Abstract.Value
 import Data.Map
+import qualified Language.Python.Assignment as Python
+import qualified Data.Language as Language
 
 import SpecHelpers
 
@@ -37,14 +40,15 @@ spec = parallel $ do
 
     it "subclasses" $ do
       v <- fst <$> evaluate "subclass.py"
-      v `shouldBe` Right (Right (Right (Right (Right (Right (pure (injValue (String "\"bar\""))))))))
+      v `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"bar\"")))))))))
 
     it "handles multiple inheritance left-to-right" $ do
       v <- fst <$> evaluate "multiple_inheritance.py"
-      v `shouldBe` Right (Right (Right (Right (Right (Right (pure (injValue (String "\"foo!\""))))))))
+      v `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"foo!\"")))))))))
 
   where
     ns n = Just . Latest . Just . injValue . Namespace n
     addr = Address . Precise
     fixtures = "test/fixtures/python/analysis/"
     evaluate entry = evalPythonProject (fixtures <> entry)
+    evalPythonProject path = interpret @(TestEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path

test/Analysis/Ruby/Spec.hs

@@ -2,12 +2,15 @@
 
 module Analysis.Ruby.Spec (spec) where
 
-import Data.Abstract.Evaluatable (EvalError(..))
+import Data.Abstract.Evaluatable
-import Data.Abstract.Value
+import Data.Abstract.Value as Value
+import Data.Abstract.Number as Number
 import Control.Monad.Effect (SomeExc(..))
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Map
 import Data.Map.Monoidal as Map
+import qualified Language.Ruby.Assignment as Ruby
+import qualified Data.Language as Language
 
 import SpecHelpers
 
@@ -32,7 +35,7 @@ spec = parallel $ do
 
     it "evaluates subclass" $ do
       res <- evaluate "subclass.rb"
-      fst res `shouldBe` Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"<bar>\"")))))))
+      fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"<bar>\"")))))))))
       environment (snd res) `shouldBe` [ ("Bar", addr 6)
                                        , ("Foo", addr 3)
                                        , ("Object", addr 0) ]
@@ -44,16 +47,33 @@ spec = parallel $ do
 
     it "evaluates modules" $ do
       res <- evaluate "modules.rb"
-      fst res `shouldBe` Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"<hello>\"")))))))
+      fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"<hello>\"")))))))))
       environment (snd res) `shouldBe` [ ("Object", addr 0)
                                        , ("Bar", addr 3) ]
 
+    it "handles break correctly" $ do
+      res <- evaluate "break.rb"
+      fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Integer (Number.Integer 3))))))))))
+
+    it "handles break correctly" $ do
+      res <- evaluate "next.rb"
+      fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Integer (Number.Integer 8))))))))))
+
+    it "calls functions with arguments" $ do
+      res <- evaluate "call.rb"
+      fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Integer (Number.Integer 579))))))))))
+
+    it "evaluates early return statements" $ do
+      res <- evaluate "early-return.rb"
+      fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Integer (Number.Integer 123))))))))))
+
     it "has prelude" $ do
       res <- fst <$> evaluate "preluded.rb"
-      res `shouldBe` Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"<foo>\"")))))))
+      res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"<foo>\"")))))))))
 
   where
     ns n = Just . Latest . Just . injValue . Namespace n
     addr = Address . Precise
     fixtures = "test/fixtures/ruby/analysis/"
     evaluate entry = evalRubyProject (fixtures <> entry)
+    evalRubyProject path = interpret @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path

test/Analysis/TypeScript/Spec.hs

@@ -1,8 +1,13 @@
 {-# LANGUAGE OverloadedLists #-}
 module Analysis.TypeScript.Spec (spec) where
 
-import SpecHelpers
+import Data.Abstract.Evaluatable
+import qualified Language.TypeScript.Assignment as TypeScript
+import Data.Abstract.Value as Value
+import Data.Abstract.Number as Number
+import qualified Data.Language as Language
 
+import SpecHelpers
 
 spec :: Spec
 spec = parallel $ do
@@ -25,12 +30,17 @@ spec = parallel $ do
 
     it "side effect only imports" $ do
       env <- environment . snd <$> evaluate "main2.ts"
-      env `shouldBe` mempty
+      env `shouldBe` emptyEnv
 
     it "fails exporting symbols not defined in the module" $ do
       v <- fst <$> evaluate "bad-export.ts"
-      v `shouldBe` Left "module \"foo.ts\" does not export \"pip\""
+      v `shouldBe` Right (Right (Right (Right (Right (Left (SomeExc (ExportError "foo.ts" (Name "pip"))))))))
+
+    it "evaluates early return statements" $ do
+      res <- evaluate "early-return.ts"
+      fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Float (Number.Decimal 123.0))))))))))
 
   where
     fixtures = "test/fixtures/typescript/analysis/"
     evaluate entry = evalTypeScriptProject (fixtures <> entry)
+    evalTypeScriptProject path = interpret @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path

test/Assigning/Assignment/Spec.hs

@@ -188,13 +188,13 @@ spec = do
     it "advances past the current node" $
       snd <$> runAssignment "hi" source (makeState [ node Red 0 2 [] ])
       `shouldBe`
-        Right (State 2 (Pos 1 3) [] [])
+        Right (State 2 (Pos 1 3) [] [] [])
 
   describe "children" $ do
     it "advances past the current node" $
       snd <$> runAssignment "a" (children (pure (Out ""))) (makeState [node Red 0 1 []])
       `shouldBe`
-        Right (State 1 (Pos 1 2) [] [])
+        Right (State 1 (Pos 1 2) [] [] [])
 
     it "matches if its subrule matches" $
       () <$ runAssignment "a" (children red) (makeState [node Blue 0 1 [node Red 0 1 []]])

test/Data/Abstract/Path/Spec.hs

@@ -0,0 +1,20 @@
+module Data.Abstract.Path.Spec(spec) where
+
+import Data.Abstract.Path
+import SpecHelpers
+
+spec :: Spec
+spec = parallel $
+  describe "joinPaths" $ do
+    it "joins empty paths" $
+      joinPaths "" "" `shouldBe` "."
+    it "joins relative paths" $
+      joinPaths "a/b" "./c" `shouldBe` "a/b/c"
+    it "joins absolute paths" $
+      joinPaths "/a/b" "c" `shouldBe` "/a/b/c"
+    it "walks up directories for ../" $
+      joinPaths "a/b" "../c" `shouldBe` "a/c"
+    it "walks up directories for multiple ../" $
+      joinPaths "a/b" "../../c" `shouldBe` "c"
+    it "stops walking at top directory" $
+      joinPaths "a/b" "../../../c" `shouldBe` "c"

test/Integration/Spec.hs

@@ -1,27 +1,22 @@
 module Integration.Spec (spec) where
 
-import Data.Foldable (find, traverse_)
+import Data.Foldable (find, traverse_, for_)
 import Data.List (union, concat, transpose)
 import qualified Data.ByteString as B
 import System.FilePath.Glob
+import System.FilePath.Posix
 
 import SpecHelpers
 
+languages :: [FilePath]
+languages = ["go", "javascript", "python", "ruby", "typescript"]
 
 spec :: Spec
 spec = parallel $ do
-  it "lists example fixtures" $ do
+  for_ languages $ \language -> do
-    examples "test/fixtures/go/" `shouldNotReturn` []
+    let dir = "test/fixtures" </> language </> "corpus"
-    examples "test/fixtures/javascript/" `shouldNotReturn` []
+    it (language <> " corpus exists") $ examples dir `shouldNotReturn` []
-    examples "test/fixtures/python/" `shouldNotReturn` []
+    describe (language <> " corpus") $ runTestsIn dir []
-    examples "test/fixtures/ruby/" `shouldNotReturn` []
-    examples "test/fixtures/typescript/" `shouldNotReturn` []
-
-  describe "go" $ runTestsIn "test/fixtures/go/" []
-  describe "javascript" $ runTestsIn "test/fixtures/javascript/" []
-  describe "python" $ runTestsIn "test/fixtures/python/" []
-  describe "ruby" $ runTestsIn "test/fixtures/ruby/" []
-  describe "typescript" $ runTestsIn "test/fixtures/typescript/" []
 
   where
     runTestsIn :: FilePath -> [(FilePath, String)] -> SpecWith ()

test/Matching/Go/Spec.hs

@@ -30,11 +30,11 @@ loopMatcher = target <* go where
 spec :: Spec
 spec = describe "matching/go" $ do
   it "extracts integers" $ do
-    parsed <- moduleBody <$> parseFile goParser Nothing "test/fixtures/go/matching/integers.go"
+    parsed <- parseFile goParser "test/fixtures/go/matching/integers.go"
     let matched = runMatcher integerMatcher parsed
     sort matched `shouldBe` ["1", "2", "3"]
 
   it "counts for loops" $ do
-    parsed <- moduleBody <$> parseFile goParser Nothing "test/fixtures/go/matching/for.go"
+    parsed <- parseFile goParser "test/fixtures/go/matching/for.go"
     let matched = runMatcher @[] loopMatcher parsed
     length matched `shouldBe` 2

test/Rendering/TOC/Spec.hs

@@ -1,16 +1,24 @@
-{-# LANGUAGE DataKinds, TypeOperators #-}
+{-# LANGUAGE DataKinds, MonoLocalBinds, TypeOperators #-}
 module Rendering.TOC.Spec (spec) where
 
 import Analysis.Declaration
 import Data.Aeson
+import Data.Align.Generic
 import Data.Bifunctor
+import Data.Bifunctor.Join
 import Data.Diff
+import Data.Functor.Classes
 import Data.Patch
+import Data.Range
+import Data.Record
+import Data.Span
+import Data.Term
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
 import Data.Union
+import Diffing.Algorithm
 import Diffing.Interpreter
-import Prelude hiding (readFile)
+import Prelude
 import qualified Data.Syntax as Syntax
 import qualified Data.Syntax.Declaration as Declaration
 import Rendering.TOC
@@ -44,7 +52,7 @@ spec = parallel $ do
       diffTOC blankDiff `shouldBe` [ ]
 
     it "summarizes changed methods" $ do
-      sourceBlobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.B.rb")
+      sourceBlobs <- blobsForPaths (both "ruby/toc/methods.A.rb" "ruby/toc/methods.B.rb")
       diff <- runTask $ diffWithParser rubyParser sourceBlobs
       diffTOC diff `shouldBe`
         [ TOCSummary "Method" "self.foo" (Span (Pos 1 1) (Pos 2 4)) "added"
@@ -53,7 +61,7 @@ spec = parallel $ do
         ]
 
     it "summarizes changed classes" $ do
-      sourceBlobs <- blobsForPaths (both "ruby/classes.A.rb" "ruby/classes.B.rb")
+      sourceBlobs <- blobsForPaths (both "ruby/toc/classes.A.rb" "ruby/toc/classes.B.rb")
       diff <- runTask $ diffWithParser rubyParser sourceBlobs
       diffTOC diff `shouldBe`
         [ TOCSummary "Class" "Baz" (Span (Pos 1 1) (Pos 2 4)) "removed"
@@ -62,37 +70,37 @@ spec = parallel $ do
         ]
 
     it "dedupes changes in same parent method" $ do
-      sourceBlobs <- blobsForPaths (both "javascript/duplicate-parent.A.js" "javascript/duplicate-parent.B.js")
+      sourceBlobs <- blobsForPaths (both "javascript/toc/duplicate-parent.A.js" "javascript/toc/duplicate-parent.B.js")
       diff <- runTask $ diffWithParser typescriptParser sourceBlobs
       diffTOC diff `shouldBe`
         [ TOCSummary "Function" "myFunction" (Span (Pos 1 1) (Pos 6 2)) "modified" ]
 
     it "dedupes similar methods" $ do
-      sourceBlobs <- blobsForPaths (both "javascript/erroneous-duplicate-method.A.js" "javascript/erroneous-duplicate-method.B.js")
+      sourceBlobs <- blobsForPaths (both "javascript/toc/erroneous-duplicate-method.A.js" "javascript/toc/erroneous-duplicate-method.B.js")
       diff <- runTask $ diffWithParser typescriptParser sourceBlobs
       diffTOC diff `shouldBe`
         [ TOCSummary "Function" "performHealthCheck" (Span (Pos 8 1) (Pos 29 2)) "modified" ]
 
     it "summarizes Go methods with receivers with special formatting" $ do
-      sourceBlobs <- blobsForPaths (both "go/method-with-receiver.A.go" "go/method-with-receiver.B.go")
+      sourceBlobs <- blobsForPaths (both "go/toc/method-with-receiver.A.go" "go/toc/method-with-receiver.B.go")
       diff <- runTask $ diffWithParser goParser sourceBlobs
       diffTOC diff `shouldBe`
         [ TOCSummary "Method" "(*apiClient) CheckAuth" (Span (Pos 3 1) (Pos 3 101)) "added" ]
 
     it "summarizes Ruby methods that start with two identifiers" $ do
-      sourceBlobs <- blobsForPaths (both "ruby/method-starts-with-two-identifiers.A.rb" "ruby/method-starts-with-two-identifiers.B.rb")
+      sourceBlobs <- blobsForPaths (both "ruby/toc/method-starts-with-two-identifiers.A.rb" "ruby/toc/method-starts-with-two-identifiers.B.rb")
       diff <- runTask $ diffWithParser rubyParser sourceBlobs
       diffTOC diff `shouldBe`
         [ TOCSummary "Method" "foo" (Span (Pos 1 1) (Pos 4 4)) "modified" ]
 
     it "handles unicode characters in file" $ do
-      sourceBlobs <- blobsForPaths (both "ruby/unicode.A.rb" "ruby/unicode.B.rb")
+      sourceBlobs <- blobsForPaths (both "ruby/toc/unicode.A.rb" "ruby/toc/unicode.B.rb")
       diff <- runTask $ diffWithParser rubyParser sourceBlobs
       diffTOC diff `shouldBe`
         [ TOCSummary "Method" "foo" (Span (Pos 6 1) (Pos 7 4)) "added" ]
 
     it "properly slices source blob that starts with a newline and has multi-byte chars" $ do
-      sourceBlobs <- blobsForPaths (both "javascript/starts-with-newline.js" "javascript/starts-with-newline.js")
+      sourceBlobs <- blobsForPaths (both "javascript/toc/starts-with-newline.js" "javascript/toc/starts-with-newline.js")
       diff <- runTask $ diffWithParser rubyParser sourceBlobs
       diffTOC diff `shouldBe` []
 
@@ -135,24 +143,24 @@ spec = parallel $ do
 
   describe "diff with ToCDiffRenderer'" $ do
     it "produces JSON output" $ do
-      blobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.B.rb")
+      blobs <- blobsForPaths (both "ruby/toc/methods.A.rb" "ruby/toc/methods.B.rb")
       output <- runTask (diffBlobPair ToCDiffRenderer blobs)
-      toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"self.foo\",\"changeType\":\"added\"},{\"span\":{\"start\":[4,1],\"end\":[6,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{}}\n" :: ByteString)
+      toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"self.foo\",\"changeType\":\"added\"},{\"span\":{\"start\":[4,1],\"end\":[6,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{}}\n" :: ByteString)
 
     it "produces JSON output if there are parse errors" $ do
-      blobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.X.rb")
+      blobs <- blobsForPaths (both "ruby/toc/methods.A.rb" "ruby/toc/methods.X.rb")
       output <- runTask (diffBlobPair ToCDiffRenderer blobs)
-      toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"removed\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"expected end of input nodes, but got ParseError\",\"language\":\"Ruby\"}]}}\n" :: ByteString)
+      toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"removed\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"expected end of input nodes, but got ParseError\",\"language\":\"Ruby\"}]}}\n" :: ByteString)
 
     it "ignores anonymous functions" $ do
-      blobs <- blobsForPaths (both "ruby/lambda.A.rb" "ruby/lambda.B.rb")
+      blobs <- blobsForPaths (both "ruby/toc/lambda.A.rb" "ruby/toc/lambda.B.rb")
       output <- runTask (diffBlobPair ToCDiffRenderer blobs)
       toOutput output `shouldBe` ("{\"changes\":{},\"errors\":{}}\n" :: ByteString)
 
     it "summarizes Markdown headings" $ do
-      blobs <- blobsForPaths (both "markdown/headings.A.md" "markdown/headings.B.md")
+      blobs <- blobsForPaths (both "markdown/toc/headings.A.md" "markdown/toc/headings.B.md")
       output <- runTask (diffBlobPair ToCDiffRenderer blobs)
-      toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/markdown/headings.A.md -> test/fixtures/toc/markdown/headings.B.md\":[{\"span\":{\"start\":[1,1],\"end\":[3,16]},\"category\":\"Heading 1\",\"term\":\"Introduction\",\"changeType\":\"removed\"},{\"span\":{\"start\":[5,1],\"end\":[7,4]},\"category\":\"Heading 2\",\"term\":\"Two\",\"changeType\":\"modified\"},{\"span\":{\"start\":[9,1],\"end\":[11,10]},\"category\":\"Heading 3\",\"term\":\"This heading is new\",\"changeType\":\"added\"},{\"span\":{\"start\":[13,1],\"end\":[14,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString)
+      toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/markdown/toc/headings.A.md -> test/fixtures/markdown/toc/headings.B.md\":[{\"span\":{\"start\":[1,1],\"end\":[3,16]},\"category\":\"Heading 1\",\"term\":\"Introduction\",\"changeType\":\"removed\"},{\"span\":{\"start\":[5,1],\"end\":[7,4]},\"category\":\"Heading 2\",\"term\":\"Two\",\"changeType\":\"modified\"},{\"span\":{\"start\":[9,1],\"end\":[11,10]},\"category\":\"Heading 3\",\"term\":\"This heading is new\",\"changeType\":\"added\"},{\"span\":{\"start\":[13,1],\"end\":[14,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString)
 
 
 type Diff' = Diff ListableSyntax (Record '[Maybe Declaration, Range, Span]) (Record '[Maybe Declaration, Range, Span])
@@ -215,10 +223,26 @@ isMethodOrFunction a
   | otherwise                                      = False
 
 blobsForPaths :: Both FilePath -> IO BlobPair
-blobsForPaths = readFilePair . fmap ("test/fixtures/toc/" <>)
+blobsForPaths = readFilePair . fmap ("test/fixtures" </>)
 
 blankDiff :: Diff'
 blankDiff = merge (arrayInfo, arrayInfo) (inj [ inserting (termIn literalInfo (inj (Syntax.Identifier (name "\"a\"")))) ])
   where
     arrayInfo = Nothing :. Range 0 3 :. Span (Pos 1 1) (Pos 1 5) :. Nil
     literalInfo = Nothing :. Range 1 2 :. Span (Pos 1 2) (Pos 1 4) :. Nil
+
+-- Diff helpers
+diffWithParser :: ( HasField fields Data.Span.Span
+                  , HasField fields Range
+                  , Eq1 syntax
+                  , Show1 syntax
+                  , Traversable syntax
+                  , Diffable syntax
+                  , GAlign syntax
+                  , HasDeclaration syntax
+                  , Members '[Distribute WrappedTask, Task] effs
+                  )
+               => Parser (Term syntax (Record fields))
+               -> BlobPair
+               -> Eff effs (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields)))
+diffWithParser parser blobs = distributeFor blobs (\ blob -> WrapTask $ parse parser blob >>= decorate (declarationAlgebra blob)) >>= diffTermPair diffTerms . runJoin

test/Semantic/CLI/Spec.hs

@@ -26,34 +26,34 @@ spec = parallel $ do
       when (actual /= expected) $ print actual
       actual `shouldBe` expected
 
-parseFixtures :: [(SomeRenderer TermRenderer, Either Handle [(FilePath, Maybe Language)], ByteString)]
+parseFixtures :: [(SomeRenderer TermRenderer, Either Handle [File], ByteString)]
 parseFixtures =
   [ (SomeRenderer SExpressionTermRenderer, pathMode, sExpressionParseTreeOutput)
   , (SomeRenderer JSONTermRenderer, pathMode, jsonParseTreeOutput)
   , (SomeRenderer JSONTermRenderer, pathMode', jsonParseTreeOutput')
   , (SomeRenderer JSONTermRenderer, Right [], emptyJsonParseTreeOutput)
-  , (SomeRenderer (SymbolsTermRenderer defaultSymbolFields), Right [("test/fixtures/ruby/method-declaration.A.rb", Just Ruby)], symbolsOutput)
+  , (SomeRenderer (SymbolsTermRenderer defaultSymbolFields), Right [File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)], symbolsOutput)
-  , (SomeRenderer TagsTermRenderer, Right [("test/fixtures/ruby/method-declaration.A.rb", Just Ruby)], tagsOutput)
+  , (SomeRenderer TagsTermRenderer, Right [File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)], tagsOutput)
   ]
-  where pathMode = Right [("test/fixtures/ruby/and-or.A.rb", Just Ruby)]
+  where pathMode = Right [File "test/fixtures/ruby/corpus/and-or.A.rb" (Just Ruby)]
-        pathMode' = Right [("test/fixtures/ruby/and-or.A.rb", Just Ruby), ("test/fixtures/ruby/and-or.B.rb", Just Ruby)]
+        pathMode' = Right [File "test/fixtures/ruby/corpus/and-or.A.rb" (Just Ruby), File "test/fixtures/ruby/corpus/and-or.B.rb" (Just Ruby)]
 
-        sExpressionParseTreeOutput = "(Program\n  (LowAnd\n    (Identifier)\n    (Identifier)))\n"
+        sExpressionParseTreeOutput = "(Program\n  (LowAnd\n    (Send\n      (Identifier))\n    (Send\n      (Identifier))))\n"
-        jsonParseTreeOutput = "{\"trees\":[{\"path\":\"test/fixtures/ruby/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowAnd\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"}]}\n"
+        jsonParseTreeOutput = "{\"trees\":[{\"path\":\"test/fixtures/ruby/corpus/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowAnd\",\"children\":[{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}}],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"}]}\n"
-        jsonParseTreeOutput' = "{\"trees\":[{\"path\":\"test/fixtures/ruby/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowAnd\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"},{\"path\":\"test/fixtures/ruby/and-or.B.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowOr\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[7,10],\"sourceSpan\":{\"start\":[1,8],\"end\":[1,11]}}],\"sourceRange\":[0,10],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,11]}},{\"category\":\"LowAnd\",\"children\":[{\"category\":\"LowOr\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[11,12],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,2]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"b\",\"sourceRange\":[16,17],\"sourceSpan\":{\"start\":[2,6],\"end\":[2,7]}}],\"sourceRange\":[11,17],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,7]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"c\",\"sourceRange\":[22,23],\"sourceSpan\":{\"start\":[2,12],\"end\":[2,13]}}],\"sourceRange\":[11,23],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,13]}}],\"sourceRange\":[0,24],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}},\"language\":\"Ruby\"}]}\n"
+        jsonParseTreeOutput' = "{\"trees\":[{\"path\":\"test/fixtures/ruby/corpus/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowAnd\",\"children\":[{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}}],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"},{\"path\":\"test/fixtures/ruby/corpus/and-or.B.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowOr\",\"children\":[{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}}],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[7,10],\"sourceSpan\":{\"start\":[1,8],\"end\":[1,11]}}],\"sourceRange\":[7,10],\"sourceSpan\":{\"start\":[1,8],\"end\":[1,11]}}],\"sourceRange\":[0,10],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,11]}},{\"category\":\"LowAnd\",\"children\":[{\"category\":\"LowOr\",\"children\":[{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[11,12],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,2]}}],\"sourceRange\":[11,12],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,2]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"b\",\"sourceRange\":[16,17],\"sourceSpan\":{\"start\":[2,6],\"end\":[2,7]}}],\"sourceRange\":[16,17],\"sourceSpan\":{\"start\":[2,6],\"end\":[2,7]}}],\"sourceRange\":[11,17],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,7]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"c\",\"sourceRange\":[22,23],\"sourceSpan\":{\"start\":[2,12],\"end\":[2,13]}}],\"sourceRange\":[22,23],\"sourceSpan\":{\"start\":[2,12],\"end\":[2,13]}}],\"sourceRange\":[11,23],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,13]}}],\"sourceRange\":[0,24],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}},\"language\":\"Ruby\"}]}\n"
         emptyJsonParseTreeOutput = "{\"trees\":[]}\n"
-        symbolsOutput = "{\"files\":[{\"path\":\"test/fixtures/ruby/method-declaration.A.rb\",\"symbols\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"kind\":\"Method\",\"symbol\":\"foo\"}],\"language\":\"Ruby\"}]}\n"
+        symbolsOutput = "{\"files\":[{\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb\",\"symbols\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"kind\":\"Method\",\"symbol\":\"foo\"}],\"language\":\"Ruby\"}]}\n"
-        tagsOutput = "[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"path\":\"test/fixtures/ruby/method-declaration.A.rb\",\"kind\":\"Method\",\"symbol\":\"foo\",\"line\":\"def foo\",\"language\":\"Ruby\"}]\n"
+        tagsOutput = "[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb\",\"kind\":\"Method\",\"symbol\":\"foo\",\"line\":\"def foo\",\"language\":\"Ruby\"}]\n"
 
 
-diffFixtures :: [(SomeRenderer DiffRenderer, Either Handle [Both (FilePath, Maybe Language)], ByteString)]
+diffFixtures :: [(SomeRenderer DiffRenderer, Either Handle [Both File], ByteString)]
 diffFixtures =
   [ (SomeRenderer JSONDiffRenderer, pathMode, jsonOutput)
   , (SomeRenderer SExpressionDiffRenderer, pathMode, sExpressionOutput)
   , (SomeRenderer ToCDiffRenderer, pathMode, tocOutput)
   ]
-  where pathMode = Right [both ("test/fixtures/ruby/method-declaration.A.rb", Just Ruby) ("test/fixtures/ruby/method-declaration.B.rb", Just Ruby)]
+  where pathMode = Right [both (File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)) (File "test/fixtures/ruby/corpus/method-declaration.B.rb"  (Just Ruby))]
 
-        jsonOutput =  "{\"diffs\":[{\"diff\":{\"merge\":{\"after\":{\"category\":\"Program\",\"sourceRange\":[0,21],\"sourceSpan\":{\"start\":[1,1],\"end\":[4,1]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Method\",\"sourceRange\":[0,20],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,4]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}},\"children\":[],\"before\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}}}},{\"patch\":{\"replace\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}]}},{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[8,9],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,10]}}}},{\"merge\":{\"after\":{\"category\":\"\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}},\"children\":[{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"baz\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"before\":{\"category\":\"[]\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Method\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}}}},\"stat\":{\"replace\":[{\"path\":\"test/fixtures/ruby/method-declaration.A.rb\",\"language\":\"Ruby\"},{\"path\":\"test/fixtures/ruby/method-declaration.B.rb\",\"language\":\"Ruby\"}],\"path\":\"test/fixtures/ruby/method-declaration.A.rb -> test/fixtures/ruby/method-declaration.B.rb\"}}]}\n"
+        jsonOutput =  "{\"diffs\":[{\"diff\":{\"merge\":{\"after\":{\"category\":\"Program\",\"sourceRange\":[0,21],\"sourceSpan\":{\"start\":[1,1],\"end\":[4,1]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Method\",\"sourceRange\":[0,20],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,4]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}},\"children\":[],\"before\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}}}},{\"patch\":{\"replace\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}]}},{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[8,9],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,10]}}}},{\"merge\":{\"after\":{\"category\":\"\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}},\"children\":[{\"patch\":{\"insert\":{\"category\":\"Send\",\"children\":[{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"baz\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"before\":{\"category\":\"[]\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Method\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}}}},\"stat\":{\"replace\":[{\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb\",\"language\":\"Ruby\"},{\"path\":\"test/fixtures/ruby/corpus/method-declaration.B.rb\",\"language\":\"Ruby\"}],\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb -> test/fixtures/ruby/corpus/method-declaration.B.rb\"}}]}\n"
-        sExpressionOutput = "(Program\n  (Method\n    (Empty)\n  { (Identifier)\n  ->(Identifier) }\n  {+(Identifier)+}\n    (\n    {+(Identifier)+})))\n"
+        sExpressionOutput = "(Program\n  (Method\n    (Empty)\n  { (Identifier)\n  ->(Identifier) }\n  {+(Identifier)+}\n    (\n    {+(Send\n      {+(Identifier)+})+})))\n"
-        tocOutput = "{\"changes\":{\"test/fixtures/ruby/method-declaration.A.rb -> test/fixtures/ruby/method-declaration.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"}]},\"errors\":{}}\n"
+        tocOutput = "{\"changes\":{\"test/fixtures/ruby/corpus/method-declaration.A.rb -> test/fixtures/ruby/corpus/method-declaration.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"}]},\"errors\":{}}\n"

test/Semantic/IO/Spec.hs

@@ -12,67 +12,67 @@ spec :: Spec
 spec = parallel $ do
   describe "readFile" $ do
     it "returns a blob for extant files" $ do
-      Just blob <- readFile "semantic.cabal" Nothing
+      Just blob <- readFile (File "semantic.cabal" Nothing)
       blobPath blob `shouldBe` "semantic.cabal"
 
     it "throws for absent files" $ do
-      readFile "this file should not exist" Nothing `shouldThrow` anyIOException
+      readFile (File "this file should not exist" Nothing) `shouldThrow` anyIOException
 
   describe "readBlobPairsFromHandle" $ do
     let a = sourceBlob "method.rb" (Just Ruby) "def foo; end"
     let b = sourceBlob "method.rb" (Just Ruby) "def bar(x); end"
     it "returns blobs for valid JSON encoded diff input" $ do
-      blobs <- blobsFromFilePath "test/fixtures/input/diff.json"
+      blobs <- blobsFromFilePath "test/fixtures/cli/diff.json"
       blobs `shouldBe` [blobPairDiffing a b]
 
     it "returns blobs when there's no before" $ do
-      blobs <- blobsFromFilePath "test/fixtures/input/diff-no-before.json"
+      blobs <- blobsFromFilePath "test/fixtures/cli/diff-no-before.json"
       blobs `shouldBe` [blobPairInserting b]
 
     it "returns blobs when there's null before" $ do
-      blobs <- blobsFromFilePath "test/fixtures/input/diff-null-before.json"
+      blobs <- blobsFromFilePath "test/fixtures/cli/diff-null-before.json"
       blobs `shouldBe` [blobPairInserting b]
 
     it "returns blobs when there's no after" $ do
-      blobs <- blobsFromFilePath "test/fixtures/input/diff-no-after.json"
+      blobs <- blobsFromFilePath "test/fixtures/cli/diff-no-after.json"
       blobs `shouldBe` [blobPairDeleting a]
 
     it "returns blobs when there's null after" $ do
-      blobs <- blobsFromFilePath "test/fixtures/input/diff-null-after.json"
+      blobs <- blobsFromFilePath "test/fixtures/cli/diff-null-after.json"
       blobs `shouldBe` [blobPairDeleting a]
 
 
     it "returns blobs for unsupported language" $ do
-      h <- openFile "test/fixtures/input/diff-unsupported-language.json" ReadMode
+      h <- openFile "test/fixtures/cli/diff-unsupported-language.json" ReadMode
       blobs <- readBlobPairsFromHandle h
       let b' = sourceBlob "test.kt" Nothing "fun main(args: Array<String>) {\nprintln(\"hi\")\n}\n"
       blobs `shouldBe` [blobPairInserting b']
 
     it "detects language based on filepath for empty language" $ do
-      blobs <- blobsFromFilePath "test/fixtures/input/diff-empty-language.json"
+      blobs <- blobsFromFilePath "test/fixtures/cli/diff-empty-language.json"
       blobs `shouldBe` [blobPairDiffing a b]
 
     it "throws on blank input" $ do
-      h <- openFile "test/fixtures/input/blank.json" ReadMode
+      h <- openFile "test/fixtures/cli/blank.json" ReadMode
       readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1)
 
     it "throws if language field not given" $ do
-      h <- openFile "test/fixtures/input/diff-no-language.json" ReadMode
+      h <- openFile "test/fixtures/cli/diff-no-language.json" ReadMode
       readBlobsFromHandle h `shouldThrow` (== ExitFailure 1)
 
     it "throws if null on before and after" $ do
-      h <- openFile "test/fixtures/input/diff-null-both-sides.json" ReadMode
+      h <- openFile "test/fixtures/cli/diff-null-both-sides.json" ReadMode
       readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1)
 
   describe "readBlobsFromHandle" $ do
     it "returns blobs for valid JSON encoded parse input" $ do
-      h <- openFile "test/fixtures/input/parse.json" ReadMode
+      h <- openFile "test/fixtures/cli/parse.json" ReadMode
       blobs <- readBlobsFromHandle h
       let a = sourceBlob "method.rb" (Just Ruby) "def foo; end"
       blobs `shouldBe` [a]
 
     it "throws on blank input" $ do
-      h <- openFile "test/fixtures/input/blank.json" ReadMode
+      h <- openFile "test/fixtures/cli/blank.json" ReadMode
       readBlobsFromHandle h `shouldThrow` (== ExitFailure 1)
 
   where blobsFromFilePath path = do

test/Spec.hs

@@ -7,6 +7,7 @@ import qualified Analysis.Ruby.Spec
 import qualified Analysis.TypeScript.Spec
 import qualified Assigning.Assignment.Spec
 import qualified Data.Diff.Spec
+import qualified Data.Abstract.Path.Spec
 import qualified Data.Functor.Classes.Generic.Spec
 import qualified Data.Mergeable.Spec
 import qualified Data.Scientific.Spec
@@ -35,6 +36,7 @@ main = hspec $ do
     describe "Analysis.TypeScript" Analysis.TypeScript.Spec.spec
     describe "Assigning.Assignment" Assigning.Assignment.Spec.spec
     describe "Data.Diff" Data.Diff.Spec.spec
+    describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec
     describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec
     describe "Data.Mergeable" Data.Mergeable.Spec.spec
     describe "Data.Scientific" Data.Scientific.Spec.spec

test/SpecHelpers.hs

@@ -1,22 +1,29 @@
 {-# LANGUAGE GADTs, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
-module SpecHelpers (
+module SpecHelpers
-  module X
+( module X
 , diffFilePaths
 , parseFilePath
 , readFilePair
-, readFileVerbatim
 , addr
 , ns
 , verbatim
 , Verbatim(..)
-, ) where
+, TestEvaluating
+) where
 
-import Analysis.Abstract.Evaluating as X (EvaluatingState(..))
+import Analysis.Abstract.Erroring
+import Analysis.Abstract.Evaluating
+import Control.Abstract.Addressable
+import Control.Abstract.Evaluator as X (EvaluatorState(..))
+import Control.Abstract.Value
 import Data.Abstract.Address as X
+import Data.Abstract.Evaluatable
 import Data.Abstract.FreeVariables as X hiding (dropExtension)
 import Data.Abstract.Heap as X
 import Data.Abstract.ModuleTable as X hiding (lookup)
+import Data.Abstract.Value (Namespace(..), Value, ValueError, injValue)
 import Data.Blob as X
+import Data.File as X
 import Data.Functor.Listable as X
 import Data.Language as X
 import Data.Output as X
@@ -47,7 +54,6 @@ import Test.LeanCheck as X
 
 import qualified Data.ByteString as B
 import qualified Semantic.IO as IO
-import Data.Abstract.Value
 
 -- | Returns an s-expression formatted diff for the specified FilePath pair.
 diffFilePaths :: Both FilePath -> IO ByteString
@@ -55,15 +61,21 @@ diffFilePaths paths = readFilePair paths >>= runTask . diffBlobPair SExpressionD
 
 -- | Returns an s-expression parse tree for the specified FilePath.
 parseFilePath :: FilePath -> IO ByteString
-parseFilePath path = (fromJust <$> IO.readFile path (IO.languageForFilePath path)) >>= runTask . parseBlob SExpressionTermRenderer
+parseFilePath path = (fromJust <$> IO.readFile (file path)) >>= runTask . parseBlob SExpressionTermRenderer
 
 -- | Read two files to a BlobPair.
 readFilePair :: Both FilePath -> IO BlobPair
-readFilePair paths = let paths' = fmap (\p -> (p, IO.languageForFilePath p)) paths in
+readFilePair paths = let paths' = fmap file paths in
                      runBothWith IO.readFilePair paths'
 
-readFileVerbatim :: FilePath -> IO Verbatim
+type TestEvaluating term
-readFileVerbatim = fmap verbatim . B.readFile
+  = Erroring (AddressError Precise (Value Precise))
+  ( Erroring (EvalError (Value Precise))
+  ( Erroring (ResolutionError (Value Precise))
+  ( Erroring (Unspecialized (Value Precise))
+  ( Erroring (ValueError Precise (Value Precise))
+  ( Erroring (LoadError term)
+  ( Evaluating Precise term (Value Precise)))))))
 
 ns n = Just . Latest . Just . injValue . Namespace n
 addr = Address . Precise