Merge origin/master

.ghci

@@ -25,7 +25,7 @@ assignmentExample lang = case lang of
   "Markdown" -> mk "md" "markdown"
   "JSON" -> mk "json" "json"
   _ -> 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,11 +10,16 @@ dist-newstyle
 .ghc.environment.*
 
 tmp/
-
 bin/
 
+/test/fixtures/*/examples
+
 *.hp
 *.prof
+*.pyc
+
+/test.*
+/*.html
 
 .bundle/
 .licenses/vendor/gems

.gitmodules

@@ -1,39 +1,18 @@
-[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
 [submodule "vendor/effects"]
 	path = vendor/effects
 	url = https://github.com/joshvera/effects.git
-[submodule "languages/c/vendor/tree-sitter-c"]
-	path = languages/c/vendor/tree-sitter-c
-	url = https://github.com/tree-sitter/tree-sitter-c.git
-[submodule "languages/javascript/vendor/tree-sitter-javascript"]
-	path = languages/javascript/vendor/tree-sitter-javascript
-	url = https://github.com/tree-sitter/tree-sitter-javascript.git
 [submodule "vendor/haskell-tree-sitter"]
 	path = vendor/haskell-tree-sitter
 	url = https://github.com/tree-sitter/haskell-tree-sitter.git
 [submodule "vendor/freer-cofreer"]
 	path = vendor/freer-cofreer
 	url = https://github.com/robrix/freer-cofreer.git
-[submodule "vendor/ghc-mod"]
-	path = vendor/ghc-mod
-	url = https://github.com/joshvera/ghc-mod
 [submodule "vendor/grpc-haskell"]
 	path = vendor/grpc-haskell
-	url = https://github.com/awakesecurity/gRPC-haskell/
+	url = https://github.com/joshvera/gRPC-haskell/
-[submodule "vendor/proto3-suite"]
+[submodule "vendor/fastsum"]
-	path = vendor/proto3-suite
+	path = vendor/fastsum
-	url = https://github.com/joshvera/proto3-suite
+	url = git@github.com:patrickt/fastsum.git
-[submodule "vendor/proto3-wire"]
-	path = vendor/proto3-wire
-	url = https://github.com/joshvera/proto3-wire

.stylish-haskell.yaml

@@ -0,0 +1,234 @@
+# stylish-haskell configuration file
+# ==================================
+
+# The stylish-haskell tool is mainly configured by specifying steps. These steps
+# are a list, so they have an order, and one specific step may appear more than
+# once (if needed). Each file is processed by these steps in the given order.
+steps:
+  # Convert some ASCII sequences to their Unicode equivalents. This is disabled
+  # by default.
+  # - unicode_syntax:
+  #     # In order to make this work, we also need to insert the UnicodeSyntax
+  #     # language pragma. If this flag is set to true, we insert it when it's
+  #     # not already present. You may want to disable it if you configure
+  #     # language extensions using some other method than pragmas. Default:
+  #     # true.
+  #     add_language_pragma: true
+
+  # Align the right hand side of some elements.  This is quite conservative
+  # and only applies to statements where each element occupies a single
+  # line.
+  - simple_align:
+      cases: true
+      top_level_patterns: true
+      records: true
+
+  # Import cleanup
+  - imports:
+      # There are different ways we can align names and lists.
+      #
+      # - global: Align the import names and import list throughout the entire
+      #   file.
+      #
+      # - file: Like global, but don't add padding when there are no qualified
+      #   imports in the file.
+      #
+      # - group: Only align the imports per group (a group is formed by adjacent
+      #   import lines).
+      #
+      # - none: Do not perform any alignment.
+      #
+      # Default: global.
+      align: group
+
+      # The following options affect only import list alignment.
+      #
+      # List align has following options:
+      #
+      # - after_alias: Import list is aligned with end of import including
+      #   'as' and 'hiding' keywords.
+      #
+      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
+      #   >                                          init, last, length)
+      #
+      # - with_alias: Import list is aligned with start of alias or hiding.
+      #
+      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
+      #   >                                 init, last, length)
+      #
+      # - new_line: Import list starts always on new line.
+      #
+      #   > import qualified Data.List      as List
+      #   >     (concat, foldl, foldr, head, init, last, length)
+      #
+      # Default: after_alias
+      list_align: after_alias
+
+      # Right-pad the module names to align imports in a group:
+      #
+      # - true: a little more readable
+      #
+      #   > import qualified Data.List       as List (concat, foldl, foldr,
+      #   >                                           init, last, length)
+      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
+      #   >                                           init, last, length)
+      #
+      # - false: diff-safe
+      #
+      #   > import qualified Data.List as List (concat, foldl, foldr, init,
+      #   >                                     last, length)
+      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
+      #   >                                           init, last, length)
+      #
+      # Default: true
+      pad_module_names: false
+
+      # Long list align style takes effect when import is too long. This is
+      # determined by 'columns' setting.
+      #
+      # - inline: This option will put as much specs on same line as possible.
+      #
+      # - new_line: Import list will start on new line.
+      #
+      # - new_line_multiline: Import list will start on new line when it's
+      #   short enough to fit to single line. Otherwise it'll be multiline.
+      #
+      # - multiline: One line per import list entry.
+      #   Type with constructor list acts like single import.
+      #
+      #   > import qualified Data.Map as M
+      #   >     ( empty
+      #   >     , singleton
+      #   >     , ...
+      #   >     , delete
+      #   >     )
+      #
+      # Default: inline
+      long_list_align: new_line_multiline
+
+      # Align empty list (importing instances)
+      #
+      # Empty list align has following options
+      #
+      # - inherit: inherit list_align setting
+      #
+      # - right_after: () is right after the module name:
+      #
+      #   > import Vector.Instances ()
+      #
+      # Default: inherit
+      empty_list_align: inherit
+
+      # List padding determines indentation of import list on lines after import.
+      # This option affects 'long_list_align'.
+      #
+      # - <integer>: constant value
+      #
+      # - module_name: align under start of module name.
+      #   Useful for 'file' and 'group' align settings.
+      list_padding: 4
+
+      # Separate lists option affects formatting of import list for type
+      # or class. The only difference is single space between type and list
+      # of constructors, selectors and class functions.
+      #
+      # - true: There is single space between Foldable type and list of it's
+      #   functions.
+      #
+      #   > import Data.Foldable (Foldable (fold, foldl, foldMap))
+      #
+      # - false: There is no space between Foldable type and list of it's
+      #   functions.
+      #
+      #   > import Data.Foldable (Foldable(fold, foldl, foldMap))
+      #
+      # Default: true
+      separate_lists: true
+
+      # Space surround option affects formatting of import lists on a single
+      # line. The only difference is single space after the initial
+      # parenthesis and a single space before the terminal parenthesis.
+      #
+      # - true: There is single space associated with the enclosing
+      #   parenthesis.
+      #
+      #   > import Data.Foo ( foo )
+      #
+      # - false: There is no space associated with the enclosing parenthesis
+      #
+      #   > import Data.Foo (foo)
+      #
+      # Default: false
+      space_surround: false
+
+  # Language pragmas
+  - language_pragmas:
+      # We can generate different styles of language pragma lists.
+      #
+      # - vertical: Vertical-spaced language pragmas, one per line.
+      #
+      # - compact: A more compact style.
+      #
+      # - compact_line: Similar to compact, but wrap each line with
+      #   `{-#LANGUAGE #-}'.
+      #
+      # Default: vertical.
+      style: compact
+
+      # Align affects alignment of closing pragma brackets.
+      #
+      # - true: Brackets are aligned in same column.
+      #
+      # - false: Brackets are not aligned together. There is only one space
+      #   between actual import and closing bracket.
+      #
+      # Default: true
+      align: true
+
+      # stylish-haskell can detect redundancy of some language pragmas. If this
+      # is set to true, it will remove those redundant pragmas. Default: true.
+      remove_redundant: true
+
+  # Replace tabs by spaces. This is disabled by default.
+  # - tabs:
+  #     # Number of spaces to use for each tab. Default: 8, as specified by the
+  #     # Haskell report.
+  #     spaces: 8
+
+  # Remove trailing whitespace
+  - trailing_whitespace: {}
+
+# A common setting is the number of columns (parts of) code will be wrapped
+# to. Different steps take this into account. Default: 80.
+columns: 120
+
+# By default, line endings are converted according to the OS. You can override
+# preferred format here.
+#
+# - native: Native newline format. CRLF on Windows, LF on other OSes.
+#
+# - lf: Convert to LF ("\n").
+#
+# - crlf: Convert to CRLF ("\r\n").
+#
+# Default: native.
+newline: native
+
+# Sometimes, language extensions are specified in a cabal file or from the
+# command line instead of using language pragmas in the file. stylish-haskell
+# needs to be aware of these, so it can parse the file correctly.
+language_extensions:
+  - DataKinds
+  - DeriveFoldable
+  - DeriveFunctor
+  - DeriveGeneric
+  - DeriveTraversable
+  - ExplicitNamespaces
+  - FlexibleContexts
+  - FlexibleInstances
+  - MultiParamTypeClasses
+  - OverloadedStrings
+  - RecordWildCards
+  - StandaloneDeriving
+  - StrictData
+  - TypeApplications

Dockerfile.release

@@ -0,0 +1,20 @@
+FROM debian:stable-slim
+
+ARG SEMANTIC_HASH=d96ce9c4be2b8208a26fd9d0974723340fd9ac65
+
+# Install dependencies
+RUN apt-get update && \
+    apt-get install -y curl libgmp10
+
+# Install Semantic
+RUN curl -L https://github-janky-artifacts.s3.amazonaws.com/semantic-diff-linux/$SEMANTIC_HASH | tar -C /usr/local/bin -xzf -
+
+# Cleanup
+RUN apt-get remove -y curl && \
+    apt-get autoremove -y && \
+    apt-get clean -y && \
+    rm -rf /var/lib/apt/lists/*
+
+WORKDIR /workspace
+
+ENTRYPOINT ["/usr/local/bin/semantic"]

HLint.hs

@@ -4,6 +4,9 @@ import "hint" HLint.Generalise
 
 ignore "Use mappend"
 ignore "Redundant do"
+-- TODO: investigate whether cost-center analysis is better with lambda-case than it was
+ignore "Use lambda-case"
+
 error "generalize ++" = (++) ==> (<>)
 -- AMP fallout
 error "generalize mapM"  = mapM  ==> traverse

bench/Main.hs

@@ -0,0 +1,29 @@
+module Main where
+
+import Criterion.Main
+import Semantic.Util
+import Data.Monoid
+import Control.Monad
+
+-- We use `fmap show` to ensure that all the parts of the result of evaluation are
+-- evaluated themselves. While an NFData instance is the most morally correct way
+-- to do this, I'm reluctant to add NFData instances to every single datatype in the
+-- project—coercing the result into a string will suffice, though it throws off the
+-- memory allocation results a bit.
+pyEval :: FilePath -> Benchmarkable
+pyEval = whnfIO . fmap show . evalPythonProject . ("bench/bench-fixtures/python/" <>)
+
+rbEval :: FilePath -> Benchmarkable
+rbEval = whnfIO . fmap show . evalRubyProject . ("bench/bench-fixtures/ruby/" <>)
+
+main :: IO ()
+main = defaultMain
+  [ bgroup "python" [ bench "assignment" $ pyEval "simple-assignment.py"
+                    , bench "function def" $ pyEval "function-definition.py"
+                    , bench "if + function calls" $ pyEval "if-statement-functions.py"
+                    ]
+  , bgroup "ruby" [ bench "assignment" $ rbEval "simple-assignment.rb"
+                  , bench "function def" $ rbEval "function-definition.rb"
+                  , bench "if + function calls" $ rbEval "if-statement-functions.rb"
+                  ]
+  ]

bench/bench-fixtures/python/function-definition.py

@@ -0,0 +1,14 @@
+def a():
+  b
+
+def c(d):
+  e
+
+def g(g, *h):
+  i
+
+def h(i=1):
+  i
+
+def i(j="default", **c):
+  j

bench/bench-fixtures/python/if-statement-functions.py

@@ -0,0 +1,12 @@
+def foo(): return "bipp"
+
+def bar(): return foo()
+
+def baz(): return bar()
+
+def why(): return "elle"
+
+if True:
+    baz()
+else:
+    why()

bench/bench-fixtures/python/simple-assignment.py

@@ -0,0 +1,5 @@
+foo = 2
+bar = foo
+dang = 3
+song = dang
+song

bench/bench-fixtures/ruby/function-definition.rb

@@ -0,0 +1,19 @@
+def a()
+  "b"
+end
+
+def c(d)
+  "e"
+end
+
+def g(g_)
+  "i"
+end
+
+def h(i=1)
+  i
+end
+
+def i()
+  "j"
+end

bench/bench-fixtures/ruby/if-statement-functions.rb

@@ -0,0 +1,21 @@
+def foo()
+  "bipp"
+end
+
+def bar()
+  foo()
+end
+
+def baz()
+  bar()
+end
+
+def why()
+  return "elle"
+end
+
+if true
+  baz()
+else
+  why()
+end

bench/bench-fixtures/ruby/simple-assignment.rb

@@ -0,0 +1,5 @@
+foo = 2
+bar = foo
+dang = 3
+song = dang
+song

preludes/python.py

@@ -0,0 +1,3 @@
+def print(x):
+  __semantic_print(x)
+  return x

preludes/ruby.rb

@@ -0,0 +1,13 @@
+class Object
+  def new
+    self
+  end
+
+  def inspect
+    return "<object>"
+  end
+end
+
+def puts(obj)
+  __semantic_print(obj)
+end

script/generate-example

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

semantic.cabal

@@ -15,57 +15,75 @@ library
   hs-source-dirs:      src
   exposed-modules:
                      -- Analyses & term annotations
-                       -- Analysis.Abstract.Caching
+                       Analysis.Abstract.Caching
-                     -- , Analysis.Abstract.Collecting
+                     , Analysis.Abstract.Collecting
-                     -- , Analysis.Abstract.Dead
+                     , Analysis.Abstract.Dead
-                       Analysis.Abstract.Evaluating
+                     , Analysis.Abstract.Evaluating
-                     -- , Analysis.Abstract.Tracing
+                     , Analysis.Abstract.Graph
+                     , Analysis.Abstract.Tracing
+                     , Analysis.CallGraph
                      , Analysis.ConstructorName
                      , Analysis.CyclomaticComplexity
                      , Analysis.Decorator
                      , Analysis.Declaration
                      , Analysis.IdentifierName
-                     , Analysis.ModuleDef
+                     , Analysis.PackageDef
                      -- Semantic assignment
                      , Assigning.Assignment
                      , Assigning.Assignment.Table
-                     -- Control flow
+                     -- Control structures & interfaces for abstract interpretation
-                     , Control.Effect
+                     , Control.Abstract
-                     -- Effects used in abstract interpretation
+                     , Control.Abstract.Addressable
-                     , Control.Monad.Effect.Addressable
+                     , Control.Abstract.Configuration
-                     -- , Control.Monad.Effect.Cache
+                     , Control.Abstract.Context
-                     -- , Control.Monad.Effect.Dead
+                     , Control.Abstract.Environment
-                     , Control.Monad.Effect.Evaluatable
+                     , Control.Abstract.Evaluator
-                     -- , Control.Monad.Effect.Fresh
+                     , Control.Abstract.Exports
-                     -- , Control.Monad.Effect.GC
+                     , Control.Abstract.Goto
-                     -- , Control.Monad.Effect.NonDet
+                     , Control.Abstract.Heap
-                     -- , Control.Monad.Effect.Trace
+                     , Control.Abstract.Matching
-                     -- General datatype definitions & generic algorithms
+                     , Control.Abstract.Modules
+                     , Control.Abstract.Roots
+                     , Control.Abstract.Value
+                     -- Datatypes for abstract interpretation
                      , Data.Abstract.Address
                      , Data.Abstract.Cache
                      , Data.Abstract.Configuration
+                     , Data.Abstract.Declarations
                      , Data.Abstract.Environment
-                     , Data.Abstract.Linker
+                     , Data.Abstract.Evaluatable
+                     , Data.Abstract.Exports
                      , Data.Abstract.FreeVariables
+                     , Data.Abstract.Heap
                      , Data.Abstract.Live
-                     , Data.Abstract.Store
+                     , Data.Abstract.Module
+                     , Data.Abstract.ModuleTable
+                     , Data.Abstract.Number
+                     , Data.Abstract.Package
+                     , Data.Abstract.Path
                      , Data.Abstract.Type
                      , Data.Abstract.Value
+                     -- General datatype definitions & generic algorithms
                      , Data.Algebra
                      , Data.Align.Generic
                      , Data.AST
                      , Data.Blob
                      , Data.Diff
                      , Data.Error
+                     , Data.File
                      , Data.Functor.Both
                      , Data.Functor.Classes.Generic
                      , Data.JSON.Fields
                      , Data.Language
+                     , Data.Map.Monoidal
                      , Data.Mergeable
                      , Data.Output
                      , Data.Patch
                      , Data.Range
                      , Data.Record
+                     , Data.Semigroup.App
+                     , Data.Semilattice.Lower
+                     , Data.Scientific.Exts
                      , Data.Source
                      , Data.Span
                      , Data.SplitDiff
@@ -73,6 +91,7 @@ library
                      , Data.Syntax
                      , Data.Syntax.Comment
                      , Data.Syntax.Declaration
+                     , Data.Syntax.Directive
                      , Data.Syntax.Expression
                      , Data.Syntax.Literal
                      , Data.Syntax.Statement
@@ -95,12 +114,14 @@ library
                      , Language.JSON.Assignment
                      , Language.Ruby.Grammar
                      , Language.Ruby.Assignment
+                     , Language.Ruby.Syntax
                      , Language.TypeScript.Assignment
                      , Language.TypeScript.Grammar
                      , Language.TypeScript.Syntax
                      , Language.PHP.Assignment
                      , Language.PHP.Grammar
                      , Language.PHP.Syntax
+                     , Language.Preluded
                      , Language.Python.Assignment
                      , Language.Python.Grammar
                      , Language.Python.Syntax
@@ -118,13 +139,17 @@ library
                      , Rendering.Symbol
                      , Rendering.TOC
                      -- High-level flow & operational functionality (logging, stats, etc.)
-                     , Semantic
                      , Semantic.CLI
+                     , Semantic.Diff
+                     , Semantic.Distribute
+                     , Semantic.Graph
                      , Semantic.IO
                      , Semantic.Log
+                     , Semantic.Parse
+                     , Semantic.Queue
                      , Semantic.Stat
                      , Semantic.Task
-                     , Semantic.Queue
+                     , Semantic.Telemetry
                      , Semantic.Util
                     -- Custom Prelude
                      , Prologue
@@ -134,13 +159,15 @@ library
                      , ansi-terminal
                      , array
                      , async
+                     , attoparsec
                      , bifunctors
                      , bytestring
                      , cmark-gfm
-                     , comonad
                      , containers
                      , directory
+                     , directory-tree
                      , effects
+                     , fastsum
                      , filepath
                      , free
                      , freer-cofreer
@@ -156,9 +183,10 @@ library
                      , optparse-applicative
                      , parallel
                      , parsers
-                     , pointed
                      , recursion-schemes
-                     , semigroups
+                     , reducers
+                     , scientific
+                     , semigroupoids
                      , split
                      , stm-chans
                      , template-haskell
@@ -174,16 +202,20 @@ library
                      , tree-sitter-ruby
                      , tree-sitter-typescript
   default-language:    Haskell2010
-  default-extensions: DeriveFoldable
+  default-extensions:  DataKinds
+                     , DeriveFoldable
                      , DeriveFunctor
                      , DeriveGeneric
                      , DeriveTraversable
                      , FlexibleContexts
                      , FlexibleInstances
+                     , MultiParamTypeClasses
                      , OverloadedStrings
                      , RecordWildCards
+                     , StandaloneDeriving
                      , StrictData
-  ghc-options:         -Wall -fno-warn-name-shadowing -O -j
+                     , TypeApplications
+  ghc-options:         -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -O -j
   ghc-prof-options:    -fprof-auto
 
 executable semantic
@@ -201,18 +233,26 @@ test-suite test
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test
   main-is:             Spec.hs
-  other-modules:       Assigning.Assignment.Spec
+  other-modules:       Analysis.Go.Spec
+                     , Analysis.PHP.Spec
+                     , Analysis.Python.Spec
+                     , Analysis.Ruby.Spec
+                     , Analysis.TypeScript.Spec
+                     , Assigning.Assignment.Spec
+                     , Control.Abstract.Evaluator.Spec
                      , Data.Diff.Spec
+                     , Data.Abstract.Path.Spec
                      , Data.Functor.Classes.Generic.Spec
                      , Data.Functor.Listable
                      , Data.Mergeable.Spec
+                     , Data.Scientific.Spec
                      , Data.Source.Spec
                      , Data.Term.Spec
                      , Diffing.Algorithm.RWS.Spec
                      , Diffing.Algorithm.SES.Spec
                      , Diffing.Interpreter.Spec
                      , Integration.Spec
-                     , Rendering.Imports.Spec
+                     , Matching.Go.Spec
                      , Rendering.TOC.Spec
                      , Semantic.Spec
                      , Semantic.CLI.Spec
@@ -227,6 +267,7 @@ test-suite test
                      , bytestring
                      , comonad
                      , effects
+                     , fastsum
                      , filepath
                      , free
                      , Glob
@@ -245,7 +286,39 @@ test-suite test
                      , these
   ghc-options:       -threaded -rtsopts -with-rtsopts=-N -j
   default-language:    Haskell2010
-  default-extensions:  DeriveFunctor, DeriveGeneric, FlexibleContexts, FlexibleInstances, OverloadedStrings, RecordWildCards
+  default-extensions:  DataKinds
+                     , DeriveFunctor
+                     , DeriveGeneric
+                     , FlexibleContexts
+                     , FlexibleInstances
+                     , MultiParamTypeClasses
+                     , OverloadedStrings
+                     , RecordWildCards
+                     , StandaloneDeriving
+                     , TypeApplications
+
+test-suite doctests
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Doctests.hs
+  default-language:    Haskell2010
+  ghc-options:         -dynamic -threaded -j
+  build-depends:       base
+                     , doctest
+                     , QuickCheck
+
+benchmark evaluation
+  hs-source-dirs: bench
+  type:           exitcode-stdio-1.0
+  main-is:        Main.hs
+  ghc-options:    -threaded -rtsopts "-with-rtsopts=-N -A4m -n2m -T" -static -j -O
+  cc-options:     -DU_STATIC_IMPLEMENTATION=1
+  cpp-options:    -DU_STATIC_IMPLEMENTATION=1
+  default-language: Haskell2010
+  build-depends:  base
+                , criterion
+                , semantic
+
 
 source-repository head
   type:     git

src/Analysis/Abstract/Caching.hs

@@ -1,125 +1,94 @@
-{-# LANGUAGE ConstraintKinds, DataKinds, ScopedTypeVariables, TypeApplications #-}
+{-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators #-}
-module Analysis.Abstract.Caching where
+module Analysis.Abstract.Caching
+( cachingTerms
+, convergingModules
+, caching
+) where
 
-import Prologue
+import Control.Abstract
-import Data.Monoid (Alt(..))
-import Analysis.Abstract.Collecting
-import Control.Effect
-import Control.Monad.Effect.Addressable
-import Control.Monad.Effect.Cache
-import Control.Monad.Effect.Env
-import Control.Monad.Effect.Fail
-import Control.Monad.Effect.Fresh
-import Control.Monad.Effect.Internal hiding (run)
-import Control.Monad.Effect.NonDet
-import Control.Monad.Effect.Reader
-import Control.Monad.Effect.State
-import Data.Abstract.Address
 import Data.Abstract.Cache
-import Data.Abstract.Configuration
+import Data.Abstract.Module
-import Data.Abstract.Environment
+import Data.Semilattice.Lower
-import Data.Abstract.Eval
+import Prologue
-import Data.Abstract.Live
-import Data.Abstract.Store
-import Data.Abstract.Value
-import qualified Data.Set as Set
 
--- | The effects necessary for caching analyses.
+-- | Look up the set of values for a given configuration in the in-cache.
-type Caching t v
+consultOracle :: (Cacheable term location (Cell location) value, Member (Reader (Cache term location (Cell location) value)) effects) => Configuration term location (Cell location) value -> Evaluator location value effects (Set (value, Heap location (Cell location) value))
-  = '[ Fresh                                  -- For 'MonadFresh'.
+consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask
-     , Reader (Live (LocationFor v) v)        -- For 'MonadGC'.
-     , Reader (Environment (LocationFor v) v) -- For 'MonadEnv'.
-     , Fail                                   -- For 'MonadFail'.
-     , NonDetEff                              -- For 'Alternative' & 'MonadNonDet'.
-     , State (Store (LocationFor v) v)        -- For 'MonadStore'.
-     , Reader (Cache (LocationFor v) t v)     -- For 'MonadCacheIn'.
-     , State (Cache (LocationFor v) t v)      -- For 'MonadCacheOut'.
-     ]
 
--- | A constraint synonym for the interfaces necessary for caching analyses.
+-- | Run an action with the given in-cache.
-type MonadCaching t v m
+withOracle :: Member (Reader (Cache term location (Cell location) value)) effects => Cache term location (Cell location) value -> Evaluator location value effects a -> Evaluator location value effects a
-  = ( MonadEnv v m
+withOracle cache = local (const cache)
-    , MonadStore v m
+
-    , MonadCacheIn t v m
+
-    , MonadCacheOut t v m
+-- | Look up the set of values for a given configuration in the out-cache.
-    , MonadGC v m
+lookupCache :: (Cacheable term location (Cell location) value, Member (State (Cache term location (Cell location) value)) effects) => Configuration term location (Cell location) value -> Evaluator location value effects (Maybe (Set (value, Heap location (Cell location) value)))
-    , Alternative m
+lookupCache configuration = cacheLookup configuration <$> get
+
+-- | Run an action, caching its result and 'Heap' under the given configuration.
+cachingConfiguration :: (Cacheable term location (Cell location) value, Members '[State (Cache term location (Cell location) value), State (Heap location (Cell location) value)] effects) => Configuration term location (Cell location) value -> Set (value, Heap location (Cell location) value) -> Evaluator location value effects value -> Evaluator location value effects value
+cachingConfiguration configuration values action = do
+  modify' (cacheSet configuration values)
+  result <- (,) <$> action <*> get
+  fst result <$ modify' (cacheInsert configuration result)
+
+putCache :: Member (State (Cache term location (Cell location) value)) effects => Cache term location (Cell location) value -> Evaluator location value effects ()
+putCache = put
+
+-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
+isolateCache :: forall term location value effects a . Member (State (Cache term location (Cell location) value)) effects => Evaluator location value effects a -> Evaluator location value effects (Cache term location (Cell location) value)
+isolateCache action = putCache @term lowerBound *> action *> get
+
+
+-- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
+cachingTerms :: ( Cacheable term location (Cell location) value
+                , Corecursive term
+                , Members '[ Fresh
+                           , NonDet
+                           , Reader (Cache term location (Cell location) value)
+                           , Reader (Live location value)
+                           , State (Cache term location (Cell location) value)
+                           , State (Environment location value)
+                           , State (Heap location (Cell location) value)
+                           ] effects
                 )
-
+             => SubtermAlgebra (Base term) term (Evaluator location value effects value)
-
+             -> SubtermAlgebra (Base term) term (Evaluator location value effects value)
--- | Coinductively-cached evaluation.
+cachingTerms recur term = do
-evalCache :: forall v term
+  c <- getConfiguration (embedSubterm term)
-          . ( Ord v
+  cached <- lookupCache c
-            , Ord term
-            , Ord (LocationFor v)
-            , Ord (Cell (LocationFor v) v)
-            , Foldable (Cell (LocationFor v))
-            , Functor (Base term)
-            , Recursive term
-            , Addressable (LocationFor v) (Eff (Caching term v))
-            , Semigroup (Cell (LocationFor v) v)
-            , ValueRoots (LocationFor v) v
-            , Eval term v (Eff (Caching term v)) (Base term)
-            )
-          => term
-          -> Final (Caching term v) v
-evalCache e = run @(Caching term v) (fixCache (fix (evCache (evCollect (\ recur yield -> eval recur yield . project)))) pure e)
-
-
--- | Evaluation of a single iteration of an analysis, given a 'MonadCacheIn' instance as an oracle for results and a 'MonadCacheOut' instance to record computed results in.
-evCache :: forall t v m
-        . ( Ord (LocationFor v)
-          , Ord t
-          , Ord v
-          , Ord (Cell (LocationFor v) v)
-          , MonadCaching t v m
-          )
-        => (((v -> m v) -> t -> m v) -> (v -> m v) -> t -> m v)
-        -> ((v -> m v) -> t -> m v)
-        -> (v -> m v) -> t -> m v
-evCache ev0 ev' yield e = do
-  c <- getConfiguration e
-  cached <- getsCache (cacheLookup c)
   case cached of
     Just pairs -> scatter pairs
     Nothing -> do
-      pairs <- asksCache (fromMaybe mempty . cacheLookup c)
+      pairs <- consultOracle c
-      modifyCache (cacheSet c pairs)
+      cachingConfiguration c pairs (recur term)
-      v <- ev0 ev' yield e
-      store' <- getStore
-      modifyCache (cacheInsert c (v, store'))
-      pure v
 
--- | Coinductively iterate the analysis of a term until the results converge.
+convergingModules :: ( Cacheable term location (Cell location) value
-fixCache :: forall t v m
+                     , Members '[ Fresh
-         . ( Ord (LocationFor v)
+                                , NonDet
-           , Ord t
+                                , Reader (Cache term location (Cell location) value)
-           , Ord v
+                                , Reader (Live location value)
-           , Ord (Cell (LocationFor v) v)
+                                , State (Cache term location (Cell location) value)
-           , MonadCaching t v m
+                                , State (Environment location value)
-           , MonadNonDet m
+                                , State (Heap location (Cell location) value)
-           , MonadFresh m
+                                ] effects
                      )
-         => ((v -> m v) -> t -> m v)
+                  => SubtermAlgebra Module term (Evaluator location value effects value)
-         -> (v -> m v) -> t -> m v
+                  -> SubtermAlgebra Module term (Evaluator location value effects value)
-fixCache ev' yield e = do
+convergingModules recur m = do
-  c <- getConfiguration e
+  c <- getConfiguration (subterm (moduleBody m))
-  cache <- converge (\ prevCache -> do
+  -- Convergence here is predicated upon an Eq instance, not α-equivalence
-    putCache (mempty :: Cache (LocationFor v) t v)
+  cache <- converge (\ prevCache -> isolateCache $ do
-    putStore (configurationStore c)
+    putHeap (configurationHeap c)
-    reset 0
+    -- We need to reset fresh generation so that this invocation converges.
-    _ <- localCache (const prevCache) (gather Set.singleton (ev' yield e))
+    resetFresh 0 $
-    getCache) mempty
+    -- 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 (gatherM (const ()) (recur m))) lowerBound
   maybe empty scatter (cacheLookup c cache)
 
--- | Get the current 'Configuration' with a passed-in term.
-getConfiguration :: (MonadEnv v m, MonadGC v m, MonadStore v m) => t -> m (Configuration (LocationFor v) t v)
-getConfiguration term = Configuration term <$> askRoots <*> askEnv <*> getStore
-
-
--- | Nondeterministically write each of a collection of stores & return their associated results.
-scatter :: (Alternative m, Foldable t, MonadStore a m) => t (a, Store (LocationFor a) a) -> m a
-scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value))
 
 -- | Iterate a monadic action starting from some initial seed until the results converge.
 --
@@ -135,3 +104,14 @@ converge f = loop
             pure x
           else
             loop x'
+
+-- | Nondeterministically write each of a collection of stores & return their associated results.
+scatter :: (Foldable t, Members '[NonDet, State (Heap location (Cell location) value)] effects) => t (a, Heap location (Cell location) value) -> Evaluator location value effects a
+scatter = foldMapA (\ (value, heap') -> putHeap heap' $> value)
+
+
+caching :: Alternative f => Evaluator location value (NonDet ': Reader (Cache term location (Cell location) value) ': State (Cache term location (Cell location) value) ': effects) a -> Evaluator location value effects (f a, Cache term location (Cell location) value)
+caching
+  = runState lowerBound
+  . runReader lowerBound
+  . runNonDetA

src/Analysis/Abstract/Collecting.hs

@@ -1,51 +1,55 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
-module Analysis.Abstract.Collecting where
+module Analysis.Abstract.Collecting
+( collectingTerms
+, providingLiveSet
+) where
 
-import Prologue
+import Control.Abstract
-import Control.Monad.Effect.GC
+import Data.Abstract.Heap
-import Data.Abstract.Address
 import Data.Abstract.Live
-import Data.Abstract.Store
+import Data.Semilattice.Lower
-import Data.Abstract.Value
+import Prologue
 
--- | Small-step evaluation which garbage-collects any non-rooted addresses after evaluating each term.
+-- | An analysis performing GC after every instruction.
-evCollect :: forall t v m
+collectingTerms :: ( Foldable (Cell location)
-          .  ( Ord (LocationFor v)
+                   , Members '[ Reader (Live location value)
-             , Foldable (Cell (LocationFor v))
+                              , State (Heap location (Cell location) value)
-             , MonadStore v m
+                              ] effects
-             , MonadGC v m
+                   , Ord location
-             , ValueRoots (LocationFor v) v
+                   , ValueRoots location value
                    )
-          => (((v -> m v) -> t -> m v) -> (v -> m v) -> t -> m v)
+                => SubtermAlgebra (Base term) term (Evaluator location value effects value)
-          -> ((v -> m v) -> t -> m v)
+                -> SubtermAlgebra (Base term) term (Evaluator location value effects value)
-          -> (v -> m v) -> t -> m v
+collectingTerms recur term = do
-evCollect ev0 ev' yield e = do
+  roots <- askRoots
-  roots <- askRoots :: m (Live (LocationFor v) v)
+  v <- recur term
-  v <- ev0 ev' yield e
+  v <$ modifyHeap (gc (roots <> valueRoots v))
-  modifyStore (gc (roots <> valueRoots v))
-  pure v
 
--- | Collect any addresses in the store not rooted in or reachable from the given 'Live' set.
+-- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
-gc :: ( Ord (LocationFor a)
+gc :: ( Ord location
-      , Foldable (Cell (LocationFor a))
+      , Foldable (Cell location)
-      , ValueRoots (LocationFor a) a
+      , ValueRoots location value
       )
-   => Live (LocationFor a) a  -- ^ The set of addresses to consider rooted.
+   => Live location value                 -- ^ The set of addresses to consider rooted.
-   -> Store (LocationFor a) a -- ^ A store to collect unreachable addresses within.
+   -> Heap location (Cell location) value -- ^ A heap to collect unreachable addresses within.
-   -> Store (LocationFor a) a -- ^ A garbage-collected store.
+   -> Heap location (Cell location) value -- ^ A garbage-collected heap.
-gc roots store = storeRestrict store (reachable roots store)
+gc roots heap = heapRestrict heap (reachable roots heap)
 
--- | Compute the set of addresses reachable from a given root set in a given store.
+-- | Compute the set of addresses reachable from a given root set in a given heap.
-reachable :: ( Ord (LocationFor a)
+reachable :: ( Ord location
-             , Foldable (Cell (LocationFor a))
+             , Foldable (Cell location)
-             , ValueRoots (LocationFor a) a
+             , ValueRoots location value
              )
-          => Live (LocationFor a) a  -- ^ The set of root addresses.
+          => Live location value                 -- ^ The set of root addresses.
-          -> Store (LocationFor a) a -- ^ The store to trace addresses through.
+          -> Heap location (Cell location) value -- ^ The heap to trace addresses through.
-          -> Live (LocationFor a) a  -- ^ The set of addresses reachable from the root set.
+          -> Live location value                 -- ^ The set of addresses reachable from the root set.
-reachable roots store = go mempty roots
+reachable roots heap = go mempty roots
   where go seen set = case liveSplit set of
           Nothing -> seen
-          Just (a, as) -> go (liveInsert a seen) (case storeLookupAll a store of
+          Just (a, as) -> go (liveInsert a seen) (case heapLookupAll a heap of
             Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen
             _           -> seen)
+
+
+providingLiveSet :: Evaluator location value (Reader (Live location value) ': effects) a -> Evaluator location value effects a
+providingLiveSet = runReader lowerBound

src/Analysis/Abstract/Dead.hs

@@ -1,53 +1,53 @@
-{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeApplications #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators #-}
-module Analysis.Abstract.Dead where
+module Analysis.Abstract.Dead
+( Dead(..)
+, revivingTerms
+, killingModules
+, providingDeadSet
+) where
 
+import Control.Abstract.Evaluator
+import Data.Abstract.Module
+import Data.Semigroup.Reducer as Reducer
+import Data.Semilattice.Lower
+import Data.Set (delete)
 import Prologue
-import Control.Effect
-import Control.Monad.Effect hiding (run)
-import Control.Monad.Effect.Addressable
-import Control.Monad.Effect.Dead
-import Control.Monad.Effect.Fail
-import Control.Monad.Effect.Reader
-import Control.Monad.Effect.State
-import Data.Abstract.Address
-import Data.Abstract.Environment
-import Data.Abstract.Eval
-import Data.Abstract.Store
-import Data.Abstract.Value
 
--- | The effects necessary for dead code analysis.
+-- | A set of “dead” (unreachable) terms.
-type DeadCodeEvaluating t v
+newtype Dead term = Dead { unDead :: Set term }
-  = '[ State (Dead t)                         -- For 'MonadDead'.
+  deriving (Eq, Foldable, Lower, Monoid, Ord, Semigroup, Show)
-     , Fail                                   -- For 'MonadFail'.
+
-     , State (Store (LocationFor v) v)        -- For 'MonadStore'.
+deriving instance Ord term => Reducer term (Dead term)
-     , Reader (Environment (LocationFor v) v) -- For 'MonadEnv'.
+
-     ]
+-- | Update the current 'Dead' set.
+killAll :: Member (State (Dead term)) effects => Dead term -> Evaluator location value effects ()
+killAll = put
+
+-- | Revive a single term, removing it from the current 'Dead' set.
+revive :: (Member (State (Dead term)) effects, Ord term) => term -> Evaluator location value effects ()
+revive t = modify' (Dead . delete t . unDead)
+
+-- | Compute the set of all subterms recursively.
+subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead term
+subterms term = term `cons` para (foldMap (uncurry cons)) term
 
 
--- | Dead code analysis
+revivingTerms :: ( Corecursive term
-evalDead :: forall v term
+                 , Member (State (Dead term)) effects
-         . ( Ord v
                  , Ord term
-           , Foldable (Base term)
-           , Recursive term
-           , Eval term v (Eff (DeadCodeEvaluating term v)) (Base term)
-           , Addressable (LocationFor v) (Eff (DeadCodeEvaluating term v))
-           , Semigroup (Cell (LocationFor v) v)
                  )
-         => term
+              => SubtermAlgebra (Base term) term (Evaluator location value effects a)
-         -> Final (DeadCodeEvaluating term v) v
+              -> SubtermAlgebra (Base term) term (Evaluator location value effects a)
-evalDead e0 = run @(DeadCodeEvaluating term v) $ do
+revivingTerms recur term = revive (embedSubterm term) *> recur term
-  killAll (Dead (subterms e0))
-  fix (evDead (\ recur yield -> eval recur yield . project)) pure e0
-  where
-    subterms :: (Ord a, Recursive a, Foldable (Base a)) => a -> Set a
-    subterms term = para (foldMap (uncurry ((<>) . point))) term <> point term
 
--- | Evaluation which 'revive's each visited term.
+killingModules :: ( Foldable (Base term)
-evDead :: (Ord t, MonadDead t m)
+                  , Member (State (Dead term)) effects
-       => (((v -> m v) -> t -> m v) -> (v -> m v) -> t -> m v)
+                  , Ord term
-       -> ((v -> m v) -> t -> m v)
+                  , Recursive term
-       -> (v -> m v) -> t -> m v
+                  )
-evDead ev0 ev' yield e = do
+               => SubtermAlgebra Module term (Evaluator location value effects a)
-  revive e
+               -> SubtermAlgebra Module term (Evaluator location value effects a)
-  ev0 ev' yield e
+killingModules recur m = killAll (subterms (subterm (moduleBody m))) *> recur m
+
+providingDeadSet :: Evaluator location value (State (Dead term) ': effects) a -> Evaluator location value effects (a, Dead term)
+providingDeadSet = runState lowerBound

src/Analysis/Abstract/Evaluating.hs

@@ -1,91 +1,41 @@
-{-# LANGUAGE ConstraintKinds, DataKinds, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
-module Analysis.Abstract.Evaluating where
+module Analysis.Abstract.Evaluating
+( EvaluatingState(..)
+, evaluating
+) where
 
-import Prologue
+import Control.Abstract
-import Control.Effect
+import Data.Semilattice.Lower
-import Control.Monad.Effect (Eff, Members)
-import Control.Monad.Effect.Embedded
-import Control.Monad.Effect.Evaluatable
-import Control.Monad.Effect.Fail
-import Control.Monad.Effect.Reader
-import Control.Monad.Effect.State
-import Data.Abstract.Linker
-import Data.Abstract.Store
-import Data.Abstract.Value
-import Data.Abstract.FreeVariables
-import Data.Algebra
-import Data.Blob
-import Prelude hiding (fail)
-import qualified Data.Map as Map
-import System.FilePath.Posix
 
-import qualified Data.ByteString.Char8 as BC
+-- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@.
+data EvaluatingState location value = EvaluatingState
+  { environment :: Environment location value
+  , heap        :: Heap location (Cell location) value
+  , modules     :: ModuleTable (Maybe (Environment location value, value))
+  , exports     :: Exports location value
+  }
 
--- | The effects necessary for concrete interpretation.
+deriving instance (Eq (Cell location value), Eq location, Eq value) => Eq (EvaluatingState location value)
-type Evaluating v
+deriving instance (Ord (Cell location value), Ord location, Ord value) => Ord (EvaluatingState location value)
-  = '[ Fail
+deriving instance (Show (Cell location value), Show location, Show value) => Show (EvaluatingState location value)
-     , State (Store (LocationFor v) v)
-     , State (EnvironmentFor v)      -- Global (imperative) environment
-     , Reader (EnvironmentFor v)     -- Local environment (e.g. binding over a closure)
-     , Reader (Linker (Evaluator v)) -- Linker effects
-     , State (Linker v)              -- Cache of evaluated modules
-     ]
-
-newtype Evaluator v = Evaluator { runEvaluator :: Eff (Evaluating v) v }
-
--- | Require/import another term/file and return an Effect.
---
--- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module.
-require :: forall v term es.
-        ( Members (Evaluating v) es
-        , FreeVariables term
-        )
-        => term -> Eff es v
-require term = get @(Linker v) >>= maybe (load term) pure . linkerLookup name
-  where name = moduleName term
-
--- | Load another term/file and return an Effect.
---
--- Always loads/evaluates.
-load :: forall v term es.
-        ( Members (Evaluating v) es
-        , FreeVariables term
-        )
-        => term -> Eff es v
-load term = ask @(Linker (Evaluator v)) >>= maybe notFound evalAndCache . linkerLookup name
-  where name = moduleName term
-        notFound = fail ("cannot find " <> show name)
-        evalAndCache e = do
-          v <- raiseEmbedded (runEvaluator e)
-          modify @(Linker v) (linkerInsert name v)
-          pure v
-
--- | Get a module name from a term (expects single free variables).
-moduleName :: FreeVariables term => term -> Prelude.String
-moduleName term = let [n] = toList (freeVariables term) in BC.unpack n
 
 
--- | Evaluate a term to a value.
+evaluating :: Evaluator location value
-evaluate :: forall v term.
+                (  Fail
-         ( Ord v
+                ': Fresh
-         , Ord (LocationFor v)
+                ': Reader (Environment location value)
-         , Evaluatable (Evaluating v) term v (Base term)
+                ': State (Environment location value)
-         , Recursive term
+                ': State (Heap location (Cell location) value)
-         )
+                ': State (ModuleTable (Maybe (Environment location value, value)))
-         => term
+                ': State (Exports location value)
-         -> Final (Evaluating v) v
+                ': effects) result
-evaluate = run @(Evaluating v) . foldSubterms eval
+           -> Evaluator location value effects (Either String result, EvaluatingState location value)
-
+evaluating
--- | Evaluate terms and an entry point to a value.
+  = fmap (\ ((((result, env), heap), modules), exports) -> (result, EvaluatingState env heap modules exports))
-evaluates :: forall v term.
+  . runState lowerBound -- State (Exports location value)
-          ( Ord v
+  . runState lowerBound -- State (ModuleTable (Maybe (Environment location value, value)))
-          , Ord (LocationFor v)
+  . runState lowerBound -- State (Heap location (Cell location) value)
-          , Evaluatable (Evaluating v) term v (Base term)
+  . runState lowerBound -- State (Environment location value)
-          , Recursive term
+  . runReader lowerBound -- Reader (Environment location value)
-          )
+  . runFresh 0
-          => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated
+  . runFail
-          -> (Blob, term)   -- Entrypoint
-          -> Final (Evaluating v) v
-evaluates pairs (Blob{..}, t) = run @(Evaluating v) (local @(Linker (Evaluator v)) (const (Linker (Map.fromList (map toPathActionPair pairs)))) (foldSubterms eval t))
-  where
-    toPathActionPair (Blob{..}, t) = (dropExtensions blobPath, Evaluator (foldSubterms eval t))

src/Analysis/Abstract/Graph.hs

@@ -0,0 +1,196 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+module Analysis.Abstract.Graph
+( Graph(..)
+, Vertex(..)
+, renderGraph
+, appendGraph
+, variableDefinition
+, moduleInclusion
+, packageInclusion
+, packageGraph
+, graphingTerms
+, graphingLoadErrors
+, graphingModules
+, graphing
+) where
+
+import qualified Algebra.Graph as G
+import qualified Algebra.Graph.Class as GC
+import           Algebra.Graph.Class hiding (Graph, Vertex)
+import           Algebra.Graph.Export.Dot hiding (vertexName)
+import           Control.Abstract
+import           Data.Abstract.Address
+import           Data.Abstract.Evaluatable (LoadError (..))
+import           Data.Abstract.FreeVariables
+import           Data.Abstract.Module (Module(moduleInfo), ModuleInfo(..))
+import           Data.Abstract.Package (PackageInfo(..))
+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.
+newtype Graph = Graph { unGraph :: G.Graph Vertex }
+  deriving (Eq, GC.Graph, Show)
+
+-- | A vertex of some specific type.
+data Vertex
+  = Package  { vertexName :: ByteString }
+  | Module   { vertexName :: ByteString }
+  | Variable { vertexName :: ByteString }
+  deriving (Eq, Ord, Show)
+
+-- | Render a 'Graph' to a 'ByteString' in DOT notation.
+renderGraph :: Graph -> ByteString
+renderGraph = export style . unGraph
+
+style :: Style Vertex ByteString
+style = (defaultStyle vertexName)
+  { vertexAttributes = vertexAttributes
+  , edgeAttributes   = edgeAttributes
+  }
+  where vertexAttributes Package{}  = [ "style" := "dashed", "shape" := "box" ]
+        vertexAttributes Module{}   = [ "style" := "dotted, rounded", "shape" := "box" ]
+        vertexAttributes Variable{} = []
+        edgeAttributes Package{}  Module{}   = [ "style" := "dashed" ]
+        edgeAttributes Module{}   Variable{} = [ "style" := "dotted" ]
+        edgeAttributes Variable{} Module{}   = [ "color" := "blue" ]
+        edgeAttributes _          _          = []
+
+
+-- | Add vertices to the graph for evaluated identifiers.
+graphingTerms :: ( Element Syntax.Identifier syntax
+                 , Members '[ Reader (Environment (Located location) value)
+                            , Reader ModuleInfo
+                            , Reader PackageInfo
+                            , State (Environment (Located location) value)
+                            , State Graph
+                            ] effects
+                 , term ~ Term (Sum syntax) ann
+                 )
+              => SubtermAlgebra (Base term) term (Evaluator (Located location) value effects a)
+              -> SubtermAlgebra (Base term) term (Evaluator (Located location) value effects a)
+graphingTerms recur term@(In _ syntax) = do
+  case projectSum syntax of
+    Just (Syntax.Identifier name) -> do
+      moduleInclusion (Variable (unName name))
+      variableDefinition name
+    _ -> pure ()
+  recur term
+
+-- | Add vertices to the graph for 'LoadError's.
+graphingLoadErrors :: Members '[ Reader ModuleInfo
+                               , Resumable (LoadError location value)
+                               , State Graph
+                               ] effects
+                   => SubtermAlgebra (Base term) term (Evaluator location value effects a)
+                   -> SubtermAlgebra (Base term) term (Evaluator location value effects a)
+graphingLoadErrors recur term = recur term `resumeLoadError` (\ (ModuleNotFound name) -> moduleInclusion (Module (BC.pack name)) *> moduleNotFound name)
+
+-- | Add vertices to the graph for evaluated modules and the packages containing them.
+graphingModules :: Members '[ Reader ModuleInfo
+                            , Reader PackageInfo
+                            , State Graph
+                            ] effects
+               => SubtermAlgebra Module term (Evaluator location value effects a)
+               -> SubtermAlgebra Module term (Evaluator location value effects a)
+graphingModules recur m = do
+  let name = BC.pack (modulePath (moduleInfo m))
+  packageInclusion (Module name)
+  moduleInclusion (Module name)
+  recur m
+
+
+packageGraph :: PackageInfo -> Graph
+packageGraph = vertex . Package . unName . packageName
+
+moduleGraph :: ModuleInfo -> Graph
+moduleGraph = vertex . Module . BC.pack . modulePath
+
+-- | Add an edge from the current package to the passed vertex.
+packageInclusion :: ( Effectful m
+                    , Members '[ Reader PackageInfo
+                               , State Graph
+                               ] effects
+                    , Monad (m effects)
+                    )
+                 => Vertex
+                 -> m effects ()
+packageInclusion v = do
+  p <- currentPackage
+  appendGraph (packageGraph p `connect` vertex v)
+
+-- | Add an edge from the current module to the passed vertex.
+moduleInclusion :: ( Effectful m
+                   , Members '[ Reader ModuleInfo
+                              , State Graph
+                              ] effects
+                   , Monad (m effects)
+                   )
+                => Vertex
+                -> m effects ()
+moduleInclusion v = do
+  m <- currentModule
+  appendGraph (moduleGraph m `connect` vertex v)
+
+-- | Add an edge from the passed variable name to the module it originated within.
+variableDefinition :: ( Member (Reader (Environment (Located location) value)) effects
+                      , Member (State (Environment (Located location) value)) effects
+                      , Member (State Graph) effects
+                      )
+                   => Name
+                   -> Evaluator (Located location) value effects ()
+variableDefinition name = do
+  graph <- maybe empty (moduleGraph . locationModule . unAddress) <$> lookupEnv name
+  appendGraph (vertex (Variable (unName name)) `connect` graph)
+
+appendGraph :: (Effectful m, Member (State Graph) effects) => Graph -> m effects ()
+appendGraph = modify' . (<>)
+
+
+instance Semigroup Graph where
+  (<>) = overlay
+
+instance Monoid Graph where
+  mempty = empty
+  mappend = (<>)
+
+instance Ord Graph where
+  compare (Graph G.Empty)           (Graph G.Empty)           = EQ
+  compare (Graph G.Empty)           _                               = LT
+  compare _                               (Graph G.Empty)           = GT
+  compare (Graph (G.Vertex a))      (Graph (G.Vertex b))      = compare a b
+  compare (Graph (G.Vertex _))      _                               = LT
+  compare _                               (Graph (G.Vertex _))      = GT
+  compare (Graph (G.Overlay a1 a2)) (Graph (G.Overlay b1 b2)) = (compare `on` Graph) a1 b1 <> (compare `on` Graph) a2 b2
+  compare (Graph (G.Overlay _  _))  _                               = LT
+  compare _                               (Graph (G.Overlay _ _))   = GT
+  compare (Graph (G.Connect a1 a2)) (Graph (G.Connect b1 b2)) = (compare `on` Graph) a1 b1 <> (compare `on` Graph) a2 b2
+
+instance Output Graph where
+  toOutput = toStrict . (<> "\n") . encode
+
+instance ToJSON Graph where
+  toJSON Graph{..} = object [ "vertices" .= vertices, "edges" .= edges ]
+    where
+      vertices = toJSON (G.vertexList unGraph)
+      edges = fmap (\(a, b) -> object [ "source" .= vertexToText a, "target" .= vertexToText b ]) (G.edgeList unGraph)
+
+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"
+
+
+graphing :: Effectful m => m (State Graph ': effects) result -> m effects (result, Graph)
+graphing = runState mempty

src/Analysis/Abstract/Tracing.hs

@@ -1,73 +1,32 @@
-{-# LANGUAGE AllowAmbiguousTypes, DataKinds, ScopedTypeVariables, TypeApplications, TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
-module Analysis.Abstract.Tracing where
+module Analysis.Abstract.Tracing
+( tracingTerms
+, tracing
+) where
 
-import Prologue
+import Control.Abstract hiding (trace)
-import Control.Effect
-import Control.Monad.Effect hiding (run)
-import Control.Monad.Effect.Addressable
-import Control.Monad.Effect.Env
-import Control.Monad.Effect.Fail
-import Control.Monad.Effect.Reader
-import Control.Monad.Effect.State
-import Control.Monad.Effect.Trace
 import Control.Monad.Effect.Writer
-import Data.Abstract.Address
+import Data.Semigroup.Reducer as Reducer
-import Data.Abstract.Configuration
+import Prologue
-import Data.Abstract.Environment
-import Data.Abstract.Eval
-import Data.Abstract.Store
-import Data.Abstract.Value
 
--- | The effects necessary for tracing analyses.
+-- | Trace analysis.
-type Tracing g t v
+--
-  = '[ Writer (g (Configuration (LocationFor v) t v)) -- For 'MonadTrace'.
+--   Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
-     , Fail                                           -- For 'MonadFail'.
+tracingTerms :: ( Corecursive term
-     , State (Store (LocationFor v) v)                -- For 'MonadStore'.
+                , Members '[ Reader (Live location value)
-     , Reader (Environment (LocationFor v) v)         -- For 'MonadEnv'.
+                           , State (Environment location value)
-     ]
+                           , State (Heap location (Cell location) value)
-
+                           , Writer (trace (Configuration term location (Cell location) value))
--- | Linear trace analysis.
+                           ] effects
-evalTrace :: forall v term
+                , Reducer (Configuration term location (Cell location) value) (trace (Configuration term location (Cell location) value))
-          . ( Ord v, Ord term, Ord (Cell (LocationFor v) v)
-            , Functor (Base term)
-            , Recursive term
-            , Addressable (LocationFor v) (Eff (Tracing [] term v))
-            , MonadGC v (Eff (Tracing [] term v))
-            , Semigroup (Cell (LocationFor v) v)
-            , Eval term v (Eff (Tracing [] term v)) (Base term)
                 )
-          => term -> Final (Tracing [] term v) v
+             => trace (Configuration term location (Cell location) value)
-evalTrace = run @(Tracing [] term v) . fix (evTell @[] (\ recur yield -> eval recur yield . project)) pure
+             -> SubtermAlgebra (Base term) term (Evaluator location value effects a)
+             -> SubtermAlgebra (Base term) term (Evaluator location value effects a)
+tracingTerms proxy recur term = getConfiguration (embedSubterm term) >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur term
 
--- | Reachable configuration analysis.
+trace :: Member (Writer (trace (Configuration term location (Cell location) value))) effects => trace (Configuration term location (Cell location) value) -> Evaluator location value effects ()
-evalReach :: forall v term
+trace = tell
-          . ( Ord v, Ord term, Ord (LocationFor v), Ord (Cell (LocationFor v) v)
-            , Functor (Base term)
-            , Recursive term
-            , Addressable (LocationFor v) (Eff (Tracing Set term v))
-            , MonadGC v (Eff (Tracing Set term v))
-            , Semigroup (Cell (LocationFor v) v)
-            , Eval term v (Eff (Tracing Set term v)) (Base term)
-            )
-          => term -> Final (Tracing Set term v) v
-evalReach = run @(Tracing Set term v) . fix (evTell @Set (\ recur yield -> eval recur yield . project)) pure
 
-
+tracing :: Monoid (trace (Configuration term location (Cell location) value)) => Evaluator location value (Writer (trace (Configuration term location (Cell location) value)) ': effects) a -> Evaluator location value effects (a, trace (Configuration term location (Cell location) value))
--- | Small-step evaluation which records every visited configuration.
+tracing = runWriter
-evTell :: forall g t m v
-       . ( Monoid (g (Configuration (LocationFor v) t v))
-         , Pointed g
-         , MonadTrace t v g m
-         , MonadEnv v m
-         , MonadStore v m
-         , MonadGC v m
-         )
-       => (((v -> m v) -> t -> m v) -> (v -> m v) -> t -> m v)
-       -> ((v -> m v) -> t -> m v)
-       -> (v -> m v) -> t -> m v
-evTell ev0 ev' yield e = do
-  env <- askEnv
-  store <- getStore
-  roots <- askRoots
-  trace (point (Configuration e roots env store) :: g (Configuration (LocationFor v) t v))
-  ev0 ev' yield e

src/Analysis/CallGraph.hs

@@ -0,0 +1,111 @@
+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
+module Analysis.CallGraph
+( CallGraph(..)
+, renderCallGraph
+, buildCallGraph
+, CallGraphAlgebra(..)
+) where
+
+import qualified Algebra.Graph as G
+import Algebra.Graph.Class
+import Algebra.Graph.Export.Dot
+import Data.Abstract.FreeVariables
+import Data.Sum
+import qualified Data.Syntax as Syntax
+import qualified Data.Syntax.Declaration as Declaration
+import Data.Term
+import Prologue hiding (empty)
+
+-- | The graph of function definitions to symbols used in a given program.
+newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name }
+  deriving (Eq, Graph, Show)
+
+-- | Build the 'CallGraph' for a 'Term' recursively.
+buildCallGraph :: (CallGraphAlgebra syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> [Name] -> CallGraph
+buildCallGraph = foldSubterms callGraphAlgebra
+
+
+-- | Render a 'CallGraph' to a 'ByteString' in DOT notation.
+renderCallGraph :: CallGraph -> ByteString
+renderCallGraph = export (defaultStyle unName) . unCallGraph
+
+
+-- | Types which contribute to a 'CallGraph'. There is exactly one instance of this typeclass; customizing the 'CallGraph's for a new type is done by defining an instance of 'CustomCallGraphAlgebra' instead.
+--
+--   This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap.
+class CallGraphAlgebra syntax where
+  -- | A 'SubtermAlgebra' computing the 'CallGraph' for a piece of @syntax@.
+  callGraphAlgebra :: FreeVariables term => syntax (Subterm term ([Name] -> CallGraph)) -> [Name] -> CallGraph
+
+instance (CallGraphAlgebraStrategy syntax ~ strategy, CallGraphAlgebraWithStrategy strategy syntax) => CallGraphAlgebra syntax where
+  callGraphAlgebra = callGraphAlgebraWithStrategy (Proxy :: Proxy strategy)
+
+
+-- | Types whose contribution to a 'CallGraph' is customized. If an instance’s definition is not being used, ensure that the type is mapped to 'Custom' in the 'CallGraphAlgebraStrategy'.
+class CustomCallGraphAlgebra syntax where
+  customCallGraphAlgebra :: FreeVariables term => syntax (Subterm term ([Name] -> CallGraph)) -> [Name] -> CallGraph
+
+-- | 'Declaration.Function's produce a vertex for their name, with edges to any free variables in their body.
+instance CustomCallGraphAlgebra Declaration.Function where
+  customCallGraphAlgebra Declaration.Function{..} bound = foldMap vertex (freeVariables (subterm functionName)) `connect` subtermValue functionBody (foldMap (freeVariables . subterm) functionParameters <> bound)
+
+-- | 'Declaration.Method's produce a vertex for their name, with edges to any free variables in their body.
+instance CustomCallGraphAlgebra Declaration.Method where
+  customCallGraphAlgebra Declaration.Method{..} bound = foldMap vertex (freeVariables (subterm methodName)) `connect` subtermValue methodBody (foldMap (freeVariables . subterm) methodParameters <> bound)
+
+-- | 'Syntax.Identifier's produce a vertex iff it’s unbound in the 'Set'.
+instance CustomCallGraphAlgebra Syntax.Identifier where
+  customCallGraphAlgebra (Syntax.Identifier name) bound
+    | name `elem` bound = empty
+    | otherwise         = vertex name
+
+instance Apply CallGraphAlgebra syntaxes => CustomCallGraphAlgebra (Sum syntaxes) where
+  customCallGraphAlgebra = apply @CallGraphAlgebra callGraphAlgebra
+
+instance CallGraphAlgebra syntax => CustomCallGraphAlgebra (TermF syntax a) where
+  customCallGraphAlgebra = callGraphAlgebra . termFOut
+
+
+-- | The mechanism selecting 'Default'/'Custom' implementations for 'callGraphAlgebra' depending on the @syntax@ type.
+class CallGraphAlgebraWithStrategy (strategy :: Strategy) syntax where
+  callGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term ([Name] -> CallGraph)) -> [Name] -> CallGraph
+
+-- | The 'Default' definition of 'callGraphAlgebra' combines all of the 'CallGraph's within the @syntax@ 'Monoid'ally.
+instance Foldable syntax => CallGraphAlgebraWithStrategy 'Default syntax where
+  callGraphAlgebraWithStrategy _ = foldMap subtermValue
+
+-- | The 'Custom' strategy calls out to the 'customCallGraphAlgebra' method.
+instance CustomCallGraphAlgebra syntax => CallGraphAlgebraWithStrategy 'Custom syntax where
+  callGraphAlgebraWithStrategy _ = customCallGraphAlgebra
+
+
+-- | Which instance of 'CustomCallGraphAlgebra' to use for a given @syntax@ type.
+data Strategy = Default | Custom
+
+-- | A mapping of @syntax@ types onto 'Strategy's.
+type family CallGraphAlgebraStrategy syntax where
+  CallGraphAlgebraStrategy Declaration.Function = 'Custom
+  CallGraphAlgebraStrategy Declaration.Method = 'Custom
+  CallGraphAlgebraStrategy Syntax.Identifier = 'Custom
+  CallGraphAlgebraStrategy (Sum fs) = 'Custom
+  CallGraphAlgebraStrategy (TermF f a) = 'Custom
+  CallGraphAlgebraStrategy a = 'Default
+
+instance Semigroup CallGraph where
+  (<>) = overlay
+
+instance Monoid CallGraph where
+  mempty = empty
+  mappend = (<>)
+
+instance Ord CallGraph where
+  compare (CallGraph G.Empty)           (CallGraph G.Empty)           = EQ
+  compare (CallGraph G.Empty)           _                             = LT
+  compare _                             (CallGraph G.Empty)           = GT
+  compare (CallGraph (G.Vertex a))      (CallGraph (G.Vertex b))      = compare a b
+  compare (CallGraph (G.Vertex _))      _                             = LT
+  compare _                             (CallGraph (G.Vertex _))      = GT
+  compare (CallGraph (G.Overlay a1 a2)) (CallGraph (G.Overlay b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2
+  compare (CallGraph (G.Overlay _  _))  _                             = LT
+  compare _                             (CallGraph (G.Overlay _ _))   = GT
+  compare (CallGraph (G.Connect a1 a2)) (CallGraph (G.Connect b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2

src/Analysis/ConstructorName.hs

@@ -1,16 +1,17 @@
-{-# LANGUAGE DataKinds, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.ConstructorName
 ( ConstructorName(..)
 , ConstructorLabel(..)
 , constructorLabel
 ) where
 
-import Prologue
 import Data.Aeson
 import Data.ByteString.Char8 (ByteString, pack, unpack)
 import Data.JSON.Fields
+import Data.Sum
 import Data.Term
 import Data.Text.Encoding (decodeUtf8)
+import Prologue
 
 -- | Compute a 'ConstructorLabel' label for a 'Term'.
 constructorLabel :: ConstructorName syntax => TermF syntax a b -> ConstructorLabel
@@ -38,8 +39,8 @@ instance (ConstructorNameStrategy syntax ~ strategy, ConstructorNameWithStrategy
 class CustomConstructorName syntax where
   customConstructorName :: syntax a -> String
 
-instance Apply ConstructorName fs => CustomConstructorName (Union fs) where
+instance Apply ConstructorName fs => CustomConstructorName (Sum fs) where
-  customConstructorName = apply (Proxy :: Proxy ConstructorName) constructorName
+  customConstructorName = apply @ConstructorName constructorName
 
 instance CustomConstructorName [] where
   customConstructorName [] = "[]"
@@ -48,7 +49,7 @@ instance CustomConstructorName [] where
 data Strategy = Default | Custom
 
 type family ConstructorNameStrategy syntax where
-  ConstructorNameStrategy (Union _) = 'Custom
+  ConstructorNameStrategy (Sum _) = 'Custom
   ConstructorNameStrategy []      = 'Custom
   ConstructorNameStrategy syntax  = 'Default
 

src/Analysis/CyclomaticComplexity.hs

@@ -5,11 +5,12 @@ module Analysis.CyclomaticComplexity
 , cyclomaticComplexityAlgebra
 ) where
 
-import Prologue
 import Data.Aeson
+import Data.Sum
 import qualified Data.Syntax.Declaration as Declaration
 import qualified Data.Syntax.Statement as Statement
 import Data.Term
+import Prologue
 
 -- | The cyclomatic complexity of a (sub)term.
 newtype CyclomaticComplexity = CyclomaticComplexity Int
@@ -31,7 +32,7 @@ newtype CyclomaticComplexity = CyclomaticComplexity Int
 --   If you’re getting errors about missing a 'CustomHasCyclomaticComplexity' instance for your syntax type, you probably forgot step 1.
 --
 --   If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2.
-cyclomaticComplexityAlgebra :: (Foldable syntax, HasCyclomaticComplexity syntax) => TermF syntax ann CyclomaticComplexity -> CyclomaticComplexity
+cyclomaticComplexityAlgebra :: HasCyclomaticComplexity syntax => TermF syntax ann CyclomaticComplexity -> CyclomaticComplexity
 cyclomaticComplexityAlgebra (In _ syntax) = toCyclomaticComplexity syntax
 
 
@@ -71,9 +72,9 @@ instance CustomHasCyclomaticComplexity Statement.If
 instance CustomHasCyclomaticComplexity Statement.Pattern
 instance CustomHasCyclomaticComplexity Statement.While
 
--- | Produce a 'CyclomaticComplexity' for 'Union's using the 'HasCyclomaticComplexity' instance & therefore using a 'CustomHasCyclomaticComplexity' instance when one exists & the type is listed in 'CyclomaticComplexityStrategy'.
+-- | Produce a 'CyclomaticComplexity' for 'Sum's using the 'HasCyclomaticComplexity' instance & therefore using a 'CustomHasCyclomaticComplexity' instance when one exists & the type is listed in 'CyclomaticComplexityStrategy'.
-instance Apply HasCyclomaticComplexity fs => CustomHasCyclomaticComplexity (Union fs) where
+instance Apply HasCyclomaticComplexity fs => CustomHasCyclomaticComplexity (Sum fs) where
-  customToCyclomaticComplexity = apply (Proxy :: Proxy HasCyclomaticComplexity) toCyclomaticComplexity
+  customToCyclomaticComplexity = apply @HasCyclomaticComplexity toCyclomaticComplexity
 
 
 -- | A strategy for defining a 'HasCyclomaticComplexity' instance. Intended to be promoted to the kind level using @-XDataKinds@.
@@ -102,7 +103,7 @@ type family CyclomaticComplexityStrategy syntax where
   CyclomaticComplexityStrategy Statement.If = 'Custom
   CyclomaticComplexityStrategy Statement.Pattern = 'Custom
   CyclomaticComplexityStrategy Statement.While = 'Custom
-  CyclomaticComplexityStrategy (Union fs) = 'Custom
+  CyclomaticComplexityStrategy (Sum fs) = 'Custom
   CyclomaticComplexityStrategy a = 'Default
 
 

src/Analysis/Declaration.hs

@@ -1,11 +1,11 @@
-{-# LANGUAGE DataKinds, MultiParamTypeClasses, TypeOperators, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
+{-# LANGUAGE TypeOperators, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
 module Analysis.Declaration
 ( Declaration(..)
 , HasDeclaration
 , declarationAlgebra
 ) where
 
-import Prologue
+import Data.Abstract.FreeVariables (Name(..))
 import Data.Blob
 import Data.Error (Error(..), showExpectation)
 import Data.Language as Language
@@ -13,21 +13,25 @@ import Data.Range
 import Data.Record
 import Data.Source as Source
 import Data.Span
-import Data.Term
+import Data.Sum
 import qualified Data.Syntax as Syntax
 import qualified Data.Syntax.Declaration as Declaration
 import qualified Data.Syntax.Expression as Expression
+import Data.Term
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
 import qualified Language.Markdown.Syntax as Markdown
+import qualified Language.Ruby.Syntax as Ruby.Syntax
+import Prologue
 
 -- | A declaration’s identifier and type.
 data Declaration
   = MethodDeclaration   { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language, declarationReceiver :: Maybe T.Text }
   | ClassDeclaration    { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language }
-  | ImportDeclaration   { declarationIdentifier :: T.Text, declarationAlias :: T.Text, declarationSymbols :: [(T.Text, T.Text)], declarationLanguage :: Maybe Language }
+  | ImportDeclaration   { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language, declarationAlias :: T.Text, declarationSymbols :: [(T.Text, T.Text)] }
   | FunctionDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language }
   | HeadingDeclaration  { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language, declarationLevel :: Int }
-  | CallReference       { declarationIdentifier :: T.Text, declarationImportIdentifier :: [T.Text] }
+  | CallReference       { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language, declarationImportIdentifier :: [T.Text] }
   | ErrorDeclaration    { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language }
   deriving (Eq, Generic, Show)
 
@@ -96,58 +100,48 @@ instance CustomHasDeclaration whole Declaration.Function where
     -- Do not summarize anonymous functions
     | isEmpty identifierAnn = Nothing
     -- Named functions
-    | otherwise             = Just $ FunctionDeclaration (getSource identifierAnn) (getFunctionSource blob (In ann decl)) blobLanguage
+    | otherwise             = Just $ FunctionDeclaration (getSource blobSource identifierAnn) (getFunctionSource blob (In ann decl)) blobLanguage
-    where getSource = toText . flip Source.slice blobSource . getField
+    where isEmpty = (== 0) . rangeLength . getField
-          isEmpty = (== 0) . rangeLength . getField
 
 -- | Produce a 'MethodDeclaration' for 'Declaration.Method' nodes. If the method’s receiver is non-empty (defined as having a non-empty 'Range'), the 'declarationIdentifier' will be formatted as 'receiver.method_name'; otherwise it will be simply 'method_name'.
 instance CustomHasDeclaration whole Declaration.Method where
   customToDeclaration blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _)
     -- Methods without a receiver
-    | isEmpty receiverAnn = Just $ MethodDeclaration (getSource identifierAnn) (getMethodSource blob (In ann decl)) blobLanguage Nothing
+    | isEmpty receiverAnn = Just $ MethodDeclaration (getSource blobSource identifierAnn) (getMethodSource blob (In ann decl)) blobLanguage Nothing
     -- Methods with a receiver type and an identifier (e.g. (a *Type) in Go).
     | blobLanguage == Just Go
-    , [ _, Term (In receiverType _) ] <- toList receiverF = Just $ MethodDeclaration (getSource identifierAnn) (getMethodSource blob (In ann decl)) blobLanguage (Just (getSource receiverType))
+    , [ _, Term (In receiverType _) ] <- toList receiverF = Just $ MethodDeclaration (getSource blobSource identifierAnn) (getMethodSource blob (In ann decl)) blobLanguage (Just (getSource blobSource receiverType))
     -- Methods with a receiver (class methods) are formatted like `receiver.method_name`
-    | otherwise           = Just $ MethodDeclaration (getSource identifierAnn) (getMethodSource blob (In ann decl)) blobLanguage (Just (getSource receiverAnn))
+    | otherwise           = Just $ MethodDeclaration (getSource blobSource identifierAnn) (getMethodSource blob (In ann decl)) blobLanguage (Just (getSource blobSource receiverAnn))
-    where getSource = toText . flip Source.slice blobSource . getField
+    where isEmpty = (== 0) . rangeLength . getField
-          isEmpty = (== 0) . rangeLength . getField
 
 -- | Produce a 'ClassDeclaration' for 'Declaration.Class' nodes.
 instance CustomHasDeclaration whole Declaration.Class where
   customToDeclaration blob@Blob{..} ann decl@(Declaration.Class _ (Term (In identifierAnn _), _) _ _)
-    -- Classes
+    = Just $ ClassDeclaration (getSource blobSource identifierAnn) (getClassSource blob (In ann decl)) blobLanguage
-    = Just $ ClassDeclaration (getSource identifierAnn) (getClassSource blob (In ann decl)) blobLanguage
-    where getSource = toText . flip Source.slice blobSource . getField
 
-instance (Declaration.ImportSymbol :< fs) => CustomHasDeclaration (Union fs) Declaration.Import where
+instance CustomHasDeclaration whole Ruby.Syntax.Class where
-  customToDeclaration Blob{..} _ (Declaration.Import (Term (In fromAnn _), _) (Term (In aliasAnn _), _) symbols)
+  customToDeclaration blob@Blob{..} ann decl@(Ruby.Syntax.Class (Term (In identifierAnn _), _) _ _)
-    = Just $ ImportDeclaration name (getAlias blobLanguage (getSource aliasAnn)) (mapMaybe getSymbol symbols) blobLanguage
+    = Just $ ClassDeclaration (getSource blobSource identifierAnn) (getRubyClassSource blob (In ann decl)) blobLanguage
-    where
-      name = getSource fromAnn
-      getAlias lang alias | Just TypeScript <- lang, T.null alias = basename name
-                          | Just Go <- lang, T.null alias = basename name
-                          | otherwise = alias
-      basename = last . T.splitOn "/"
-      getSource = T.dropAround (`elem` ['"', '\'']) . toText . flip Source.slice blobSource . getField
-      getSymbol (Term (In _ f), _) | Just (Declaration.ImportSymbol (Term (In nameAnn _)) (Term (In aliasAnn _))) <- prj f
-                                   = Just (getSource nameAnn, getSource aliasAnn)
-                                   | otherwise = Nothing
 
-instance (Expression.MemberAccess :< fs) => CustomHasDeclaration (Union fs) Expression.Call where
+getSource :: HasField fields Range => Source -> Record fields -> Text
+getSource blobSource = toText . flip Source.slice blobSource . getField
+
+instance (Syntax.Identifier :< fs, Expression.MemberAccess :< fs) => CustomHasDeclaration (Sum fs) Expression.Call where
   customToDeclaration Blob{..} _ (Expression.Call _ (Term (In fromAnn fromF), _) _ _)
-    | Just (Expression.MemberAccess (Term (In leftAnn leftF)) (Term (In idenAnn _))) <- prj fromF = Just $ CallReference (getSource idenAnn) (memberAccess leftAnn leftF)
+    | Just (Expression.MemberAccess (Term (In leftAnn leftF)) (Term (In idenAnn _))) <- projectSum fromF = Just $ CallReference (getSource idenAnn) mempty blobLanguage (memberAccess leftAnn leftF)
-    | otherwise = Just $ CallReference (getSource fromAnn) []
+    | Just (Syntax.Identifier (Name name)) <- projectSum fromF = Just $ CallReference (T.decodeUtf8 name) mempty blobLanguage []
+    | otherwise = Just $ CallReference (getSource fromAnn) mempty blobLanguage []
     where
       memberAccess modAnn termFOut
-        | Just (Expression.MemberAccess (Term (In leftAnn leftF)) (Term (In rightAnn rightF))) <- prj termFOut
+        | Just (Expression.MemberAccess (Term (In leftAnn leftF)) (Term (In rightAnn rightF))) <- projectSum termFOut
         = memberAccess leftAnn leftF <> memberAccess rightAnn rightF
         | otherwise = [getSource modAnn]
       getSource = toText . flip Source.slice blobSource . getField
 
--- | Produce a 'Declaration' for 'Union's using the 'HasDeclaration' instance & therefore using a 'CustomHasDeclaration' instance when one exists & the type is listed in 'DeclarationStrategy'.
+-- | Produce a 'Declaration' for 'Sum's using the 'HasDeclaration' instance & therefore using a 'CustomHasDeclaration' instance when one exists & the type is listed in 'DeclarationStrategy'.
-instance Apply (HasDeclaration' whole) fs => CustomHasDeclaration whole (Union fs) where
+instance Apply (HasDeclaration' whole) fs => CustomHasDeclaration whole (Sum fs) where
-  customToDeclaration blob ann = apply (Proxy :: Proxy (HasDeclaration' whole)) (toDeclaration' blob ann)
+  customToDeclaration blob ann = apply @(HasDeclaration' whole) (toDeclaration' blob ann)
 
 
 -- | A strategy for defining a 'HasDeclaration' instance. Intended to be promoted to the kind level using @-XDataKinds@.
@@ -167,13 +161,13 @@ class HasDeclarationWithStrategy (strategy :: Strategy) whole syntax where
 --   If you’re seeing errors about missing a 'CustomHasDeclaration' instance for a given type, you’ve probably listed it in here but not defined a 'CustomHasDeclaration' instance for it, or else you’ve listed the wrong type in here. Conversely, if your 'customHasDeclaration' method is never being called, you may have forgotten to list the type in here.
 type family DeclarationStrategy syntax where
   DeclarationStrategy Declaration.Class = 'Custom
+  DeclarationStrategy Ruby.Syntax.Class = 'Custom
   DeclarationStrategy Declaration.Function = 'Custom
-  DeclarationStrategy Declaration.Import = 'Custom
   DeclarationStrategy Declaration.Method = 'Custom
   DeclarationStrategy Markdown.Heading = 'Custom
   DeclarationStrategy Expression.Call = 'Custom
   DeclarationStrategy Syntax.Error = 'Custom
-  DeclarationStrategy (Union fs) = 'Custom
+  DeclarationStrategy (Sum fs) = 'Custom
   DeclarationStrategy a = 'Default
 
 
@@ -206,3 +200,10 @@ getClassSource Blob{..} (In a r)
         bodyRange = getField <$> case r of
           Declaration.Class _ _ _ (Term (In a' _), _) -> Just a'
     in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange
+
+getRubyClassSource :: (HasField fields Range) => Blob -> TermF Ruby.Syntax.Class (Record fields) (Term syntax (Record fields), a) -> T.Text
+getRubyClassSource Blob{..} (In a r)
+  = let declRange = getField a
+        bodyRange = getField <$> case r of
+          Ruby.Syntax.Class _ _ (Term (In a' _), _) -> Just a'
+    in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange

src/Analysis/IdentifierName.hs

@@ -1,20 +1,22 @@
-{-# LANGUAGE DataKinds, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.IdentifierName
 ( IdentifierName(..)
 , IdentifierLabel(..)
 , identifierLabel
 ) where
 
-import Prologue
+import           Data.Abstract.FreeVariables (Name (..))
 import           Data.Aeson
 import           Data.JSON.Fields
+import           Data.Sum
+import qualified Data.Syntax
 import           Data.Term
 import           Data.Text.Encoding (decodeUtf8)
-import qualified Data.Syntax
+import           Prologue
 
 -- | Compute a 'IdentifierLabel' label for a 'Term'.
 identifierLabel :: IdentifierName syntax => TermF syntax a b -> Maybe IdentifierLabel
-identifierLabel (In _ s) = IdentifierLabel <$> (identifierName s)
+identifierLabel (In _ s) = IdentifierLabel <$> identifierName s
 
 newtype IdentifierLabel = IdentifierLabel ByteString
   deriving (Show)
@@ -35,16 +37,16 @@ instance (IdentifierNameStrategy syntax ~ strategy, IdentifierNameWithStrategy s
 class CustomIdentifierName syntax where
   customIdentifierName :: syntax a -> Maybe ByteString
 
-instance Apply IdentifierName fs => CustomIdentifierName (Union fs) where
+instance Apply IdentifierName fs => CustomIdentifierName (Sum fs) where
-  customIdentifierName = apply (Proxy :: Proxy IdentifierName) identifierName
+  customIdentifierName = apply @IdentifierName identifierName
 
 instance CustomIdentifierName Data.Syntax.Identifier where
-  customIdentifierName (Data.Syntax.Identifier name) = Just name
+  customIdentifierName (Data.Syntax.Identifier (Name name)) = Just name
 
 data Strategy = Default | Custom
 
 type family IdentifierNameStrategy syntax where
-  IdentifierNameStrategy (Union _) = 'Custom
+  IdentifierNameStrategy (Sum _) = 'Custom
   IdentifierNameStrategy Data.Syntax.Identifier = 'Custom
   IdentifierNameStrategy syntax = 'Default
 

src/Analysis/ModuleDef.hs

@@ -1,94 +0,0 @@
-{-# LANGUAGE DataKinds, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
-module Analysis.ModuleDef
-( ModuleDef(..)
-, HasModuleDef
-, moduleDefAlgebra
-) where
-
-import Prologue
-import Data.Blob
-import Data.Range
-import Data.Record
-import Data.Source as Source
-import Data.Span
-import qualified Data.Syntax.Declaration as Declaration
-import Data.Term
-import qualified Data.Text as T
-
-newtype ModuleDef = ModuleDef { moduleDefIdentifier :: T.Text }
-  deriving (Eq, Generic, Show)
-
--- | An r-algebra producing 'Just' a 'ModuleDef' for syntax nodes corresponding to high-level declarations, or 'Nothing' otherwise.
---
---   Customizing this for a given syntax type involves two steps:
---
---   1. Defining a 'CustomHasModuleDef' instance for the type.
---   2. Adding the type to the 'ModuleDefStrategy' type family.
---
---   If you’re getting errors about missing a 'CustomHasModuleDef' instance for your syntax type, you probably forgot step 1.
---
---   If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2.
-moduleDefAlgebra :: (HasField fields Range, HasField fields Span, Foldable syntax, HasModuleDef syntax) => Blob -> RAlgebra (TermF syntax (Record fields)) (Term syntax (Record fields)) (Maybe ModuleDef)
-moduleDefAlgebra blob (In ann syntax) = toModuleDef blob ann syntax
-
-
--- | Types for which we can produce a 'ModuleDef' in 'Maybe'. There is exactly one instance of this typeclass; adding customized 'ModuleDef's for a new type is done by defining an instance of 'CustomHasModuleDef' instead.
---
---   This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap.
-class HasModuleDef syntax where
-  -- | Compute a 'ModuleDef' for a syntax type using its 'CustomHasModuleDef' instance, if any, or else falling back to the default definition (which simply returns 'Nothing').
-  toModuleDef :: (Foldable whole, HasField fields Range, HasField fields Span) => Blob -> Record fields -> syntax (Term whole (Record fields), Maybe ModuleDef) -> Maybe ModuleDef
-
--- | Define 'toModuleDef' using the 'CustomHasModuleDef' instance for a type if there is one or else use the default definition.
---
---   This instance determines whether or not there is an instance for @syntax@ by looking it up in the 'ModuleDefStrategy' type family. Thus producing a 'ModuleDef' for a node requires both defining a 'CustomHasModuleDef' instance _and_ adding a definition for the type to the 'ModuleDefStrategy' type family to return 'Custom'.
---
---   Note that since 'ModuleDefStrategy' has a fallback case for its final entry, this instance will hold for all types of kind @* -> *@. Thus, this must be the only instance of 'HasModuleDef', as any other instance would be indistinguishable.
-instance (ModuleDefStrategy syntax ~ strategy, HasModuleDefWithStrategy strategy syntax) => HasModuleDef syntax where
-  toModuleDef = toModuleDefWithStrategy (Proxy :: Proxy strategy)
-
-
--- | Types for which we can produce a customized 'ModuleDef'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions).
-class CustomHasModuleDef syntax where
-  -- | Produce a customized 'ModuleDef' for a given syntax node.
-  customToModuleDef :: (Foldable whole, HasField fields Range, HasField fields Span) => Blob -> Record fields -> syntax (Term whole (Record fields), Maybe ModuleDef) -> Maybe ModuleDef
-
-
-instance CustomHasModuleDef Declaration.Module where
-  customToModuleDef Blob{..} _ (Declaration.Module (Term (In fromAnn _), _) _)
-    = Just $ ModuleDef (getSource fromAnn)
-    where getSource = toText . flip Source.slice blobSource . getField
-
--- | Produce a 'ModuleDef' for 'Union's using the 'HasModuleDef' instance & therefore using a 'CustomHasModuleDef' instance when one exists & the type is listed in 'ModuleDefStrategy'.
-instance Apply HasModuleDef fs => CustomHasModuleDef (Union fs) where
-  customToModuleDef blob ann = apply (Proxy :: Proxy HasModuleDef) (toModuleDef blob ann)
-
-
--- | A strategy for defining a 'HasModuleDef' instance. Intended to be promoted to the kind level using @-XDataKinds@.
-data Strategy = Default | Custom
-
--- | Produce a 'ModuleDef' for a syntax node using either the 'Default' or 'Custom' strategy.
---
---   You should probably be using 'CustomHasModuleDef' instead of this class; and you should not define new instances of this class.
-class HasModuleDefWithStrategy (strategy :: Strategy) syntax where
-  toModuleDefWithStrategy :: (Foldable whole, HasField fields Range, HasField fields Span) => proxy strategy -> Blob -> Record fields -> syntax (Term whole (Record fields), Maybe ModuleDef) -> Maybe ModuleDef
-
-
--- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy.
---
---   Only entries for which we want to use the 'Custom' strategy should be listed, with the exception of the final entry which maps all other types onto the 'Default' strategy.
---
---   If you’re seeing errors about missing a 'CustomHasModuleDef' instance for a given type, you’ve probably listed it in here but not defined a 'CustomHasModuleDef' instance for it, or else you’ve listed the wrong type in here. Conversely, if your 'customHasModuleDef' method is never being called, you may have forgotten to list the type in here.
-type family ModuleDefStrategy syntax where
-  ModuleDefStrategy Declaration.Module = 'Custom
-  ModuleDefStrategy (Union fs) = 'Custom
-  ModuleDefStrategy a = 'Default
-
-
--- | The 'Default' strategy produces 'Nothing'.
-instance HasModuleDefWithStrategy 'Default syntax where
-  toModuleDefWithStrategy _ _ _ _ = Nothing
-
--- | The 'Custom' strategy delegates the selection of the strategy to the 'CustomHasModuleDef' instance for the type.
-instance CustomHasModuleDef syntax => HasModuleDefWithStrategy 'Custom syntax where
-  toModuleDefWithStrategy _ = customToModuleDef

src/Analysis/PackageDef.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
+module Analysis.PackageDef
+( PackageDef(..)
+, HasPackageDef
+, packageDefAlgebra
+) where
+
+import Data.Blob
+import Data.Range
+import Data.Record
+import Data.Source as Source
+import Data.Span
+import Data.Sum
+import Data.Term
+import qualified Data.Text as T
+import qualified Language.Go.Syntax
+import Prologue
+
+newtype PackageDef = PackageDef { moduleDefIdentifier :: T.Text }
+  deriving (Eq, Generic, Show)
+
+-- | An r-algebra producing 'Just' a 'PackageDef' for syntax nodes corresponding to high-level declarations, or 'Nothing' otherwise.
+--
+--   Customizing this for a given syntax type involves two steps:
+--
+--   1. Defining a 'CustomHasPackageDef' instance for the type.
+--   2. Adding the type to the 'PackageDefStrategy' type family.
+--
+--   If you’re getting errors about missing a 'CustomHasPackageDef' instance for your syntax type, you probably forgot step 1.
+--
+--   If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2.
+packageDefAlgebra :: (HasField fields Range, HasField fields Span, Foldable syntax, HasPackageDef syntax) => Blob -> RAlgebra (TermF syntax (Record fields)) (Term syntax (Record fields)) (Maybe PackageDef)
+packageDefAlgebra blob (In ann syntax) = toPackageDef blob ann syntax
+
+
+-- | Types for which we can produce a 'PackageDef' in 'Maybe'. There is exactly one instance of this typeclass; adding customized 'PackageDef's for a new type is done by defining an instance of 'CustomHasPackageDef' instead.
+--
+--   This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap.
+class HasPackageDef syntax where
+  -- | Compute a 'PackageDef' for a syntax type using its 'CustomHasPackageDef' instance, if any, or else falling back to the default definition (which simply returns 'Nothing').
+  toPackageDef :: (Foldable whole, HasField fields Range, HasField fields Span) => Blob -> Record fields -> syntax (Term whole (Record fields), Maybe PackageDef) -> Maybe PackageDef
+
+-- | Define 'toPackageDef' using the 'CustomHasPackageDef' instance for a type if there is one or else use the default definition.
+--
+--   This instance determines whether or not there is an instance for @syntax@ by looking it up in the 'PackageDefStrategy' type family. Thus producing a 'PackageDef' for a node requires both defining a 'CustomHasPackageDef' instance _and_ adding a definition for the type to the 'PackageDefStrategy' type family to return 'Custom'.
+--
+--   Note that since 'PackageDefStrategy' has a fallback case for its final entry, this instance will hold for all types of kind @* -> *@. Thus, this must be the only instance of 'HasPackageDef', as any other instance would be indistinguishable.
+instance (PackageDefStrategy syntax ~ strategy, HasPackageDefWithStrategy strategy syntax) => HasPackageDef syntax where
+  toPackageDef = toPackageDefWithStrategy (Proxy :: Proxy strategy)
+
+
+-- | Types for which we can produce a customized 'PackageDef'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions).
+class CustomHasPackageDef syntax where
+  -- | Produce a customized 'PackageDef' for a given syntax node.
+  customToPackageDef :: (Foldable whole, HasField fields Range, HasField fields Span) => Blob -> Record fields -> syntax (Term whole (Record fields), Maybe PackageDef) -> Maybe PackageDef
+
+
+instance CustomHasPackageDef Language.Go.Syntax.Package where
+  customToPackageDef Blob{..} _ (Language.Go.Syntax.Package (Term (In fromAnn _), _) _)
+    = Just $ PackageDef (getSource fromAnn)
+    where getSource = toText . flip Source.slice blobSource . getField
+
+-- | Produce a 'PackageDef' for 'Sum's using the 'HasPackageDef' instance & therefore using a 'CustomHasPackageDef' instance when one exists & the type is listed in 'PackageDefStrategy'.
+instance Apply HasPackageDef fs => CustomHasPackageDef (Sum fs) where
+  customToPackageDef blob ann = apply @HasPackageDef (toPackageDef blob ann)
+
+
+-- | A strategy for defining a 'HasPackageDef' instance. Intended to be promoted to the kind level using @-XDataKinds@.
+data Strategy = Default | Custom
+
+-- | Produce a 'PackageDef' for a syntax node using either the 'Default' or 'Custom' strategy.
+--
+--   You should probably be using 'CustomHasPackageDef' instead of this class; and you should not define new instances of this class.
+class HasPackageDefWithStrategy (strategy :: Strategy) syntax where
+  toPackageDefWithStrategy :: (Foldable whole, HasField fields Range, HasField fields Span) => proxy strategy -> Blob -> Record fields -> syntax (Term whole (Record fields), Maybe PackageDef) -> Maybe PackageDef
+
+
+-- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy.
+--
+--   Only entries for which we want to use the 'Custom' strategy should be listed, with the exception of the final entry which maps all other types onto the 'Default' strategy.
+--
+--   If you’re seeing errors about missing a 'CustomHasPackageDef' instance for a given type, you’ve probably listed it in here but not defined a 'CustomHasPackageDef' instance for it, or else you’ve listed the wrong type in here. Conversely, if your 'customHasPackageDef' method is never being called, you may have forgotten to list the type in here.
+type family PackageDefStrategy syntax where
+  PackageDefStrategy Language.Go.Syntax.Package = 'Custom
+  PackageDefStrategy (Sum fs) = 'Custom
+  PackageDefStrategy a = 'Default
+
+
+-- | The 'Default' strategy produces 'Nothing'.
+instance HasPackageDefWithStrategy 'Default syntax where
+  toPackageDefWithStrategy _ _ _ _ = Nothing
+
+-- | The 'Custom' strategy delegates the selection of the strategy to the 'CustomHasPackageDef' instance for the type.
+instance CustomHasPackageDef syntax => HasPackageDefWithStrategy 'Custom syntax where
+  toPackageDefWithStrategy _ = customToPackageDef

src/Assigning/Assignment.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds, GADTs, InstanceSigs, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack
 -- | Assignment of AST onto some other structure (typically terms).
 --
 --   Parsing yields an AST represented as a Rose tree labelled with symbols in the language’s grammar and source locations (byte Range and Span). An Assignment represents a (partial) map from AST nodes onto some other structure; in essence, it’s a parser that operates over trees. (For our purposes, this structure is typically Terms annotated with source locations.) Assignments are able to match based on symbol, sequence, and hierarchy; thus, in @x = y@, both @x@ and @y@ might have the same symbol, @Identifier@, the left can be assigned to a variable declaration, while the right can be assigned to a variable reference.
@@ -36,9 +37,7 @@
 --
 --   Assignments can represent alternatives as either committed or uncommitted choices, both written with '<|>'. “Committed” in this context means that a failure in one of the alternatives will not result in backtracking followed by an attempt of one of the other alternatives; thus, committed choice is more efficient. (By the same token, it enables much better error messages since backtracking erases most of the relevant context.) Committed choices are constructed via the following rules:
 --
---   1. 'empty' is dropped from choices:
+--   1. 'empty' is dropped from choices.
---   prop> empty <|> a = a -- empty is the left-identity of <|>
---   prop> a <|> empty = a -- empty is the right-identity of <|>
 --
 --   2. 'symbol' rules construct a committed choice (with only a single alternative).
 --
@@ -78,6 +77,8 @@ module Assigning.Assignment
 , while
 , until
 , manyThrough
+, getRubyLocals
+, putRubyLocals
 -- Results
 , Error(..)
 , errorCallStack
@@ -122,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
@@ -141,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
@@ -240,12 +250,14 @@ 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
                     (a, state') <- go child state { stateNodes = toList f, stateCallSites = maybe id (:) (tracingCallSite t) stateCallSites } >>= requireExhaustive (tracingCallSite t)
                     yield a (advanceState state' { stateNodes = stateNodes, stateCallSites = stateCallSites })
-                  Choose choices _ handler | Just choice <- Table.lookup (nodeSymbol node) choices -> (go choice state `catchError` (maybe throwError (flip go state .) handler)) >>= uncurry yield
+                  Choose choices _ handler | Just choice <- Table.lookup (nodeSymbol node) choices -> (go choice state `catchError` maybe throwError (flip go state .) handler) >>= uncurry yield
                   _ -> anywhere (Just node)
 
                 anywhere node = case runTracing t of
@@ -270,7 +282,7 @@ requireExhaustive callSite (a, state) = let state' = skipTokens state in case st
   Term (In node _) : _ -> Left (withStateCallStack callSite state (nodeError [] node))
 
 withStateCallStack :: Maybe (String, SrcLoc) -> State ast grammar -> (HasCallStack => a) -> a
-withStateCallStack callSite state action = withCallStack (freezeCallStack (fromCallSiteList (maybe id (:) callSite (stateCallSites state)))) action
+withStateCallStack callSite state = withCallStack (freezeCallStack (fromCallSiteList (maybe id (:) callSite (stateCallSites state))))
 
 skipTokens :: Symbol grammar => State ast grammar -> State ast grammar
 skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . termAnnotation) (stateNodes state) }
@@ -278,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.
@@ -287,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
@@ -303,7 +316,7 @@ instance (Enum grammar, Eq1 ast, Ix grammar) => Semigroup (Assignment ast gramma
 
 instance (Enum grammar, Eq1 ast, Ix grammar) => Monoid (Assignment ast grammar a) where
   mempty = empty
-  mappend = (<|>)
+  mappend = (<>)
 
 instance (Enum grammar, Eq1 ast, Ix grammar) => Alternative (Assignment ast grammar) where
   empty :: HasCallStack => Assignment ast grammar a
@@ -375,5 +388,9 @@ 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
+
+{-# ANN module ("HLint: ignore Avoid return" :: String) #-}

src/Assigning/Assignment/Table.hs

@@ -6,7 +6,7 @@ module Assigning.Assignment.Table
 , lookup
 ) where
 
-import Prologue hiding (toList)
+import Prologue
 import Prelude hiding (lookup)
 import qualified Data.IntMap as IntMap
 import qualified Data.IntSet as IntSet
@@ -18,7 +18,7 @@ data Table i a = Table { tableAddresses :: [i], tableBranches :: IntMap a }
 singleton :: Enum i => i -> a -> Table i a
 singleton i a = Table [i] (IntMap.singleton (fromEnum i) a)
 
-fromListWith :: (Enum i, Ord i) => (a -> a -> a) -> [(i, a)] -> Table i a
+fromListWith :: Enum i => (a -> a -> a) -> [(i, a)] -> Table i a
 fromListWith with assocs = Table (toEnum <$> IntSet.toList (IntSet.fromList (fromEnum . fst <$> assocs))) (IntMap.fromListWith with (first fromEnum <$> assocs))
 
 toPairs :: Enum i => Table i a -> [(i, a)]
@@ -29,9 +29,12 @@ lookup :: Enum i => i -> Table i a -> Maybe a
 lookup i = IntMap.lookup (fromEnum i) . tableBranches
 
 
+instance (Enum i, Monoid a) => Semigroup (Table i a) where
+  (Table i1 b1) <> (Table i2 b2) = Table (i1 `mappend` i2) (IntMap.unionWith mappend b1 b2)
+
 instance (Enum i, Monoid a) => Monoid (Table i a) where
   mempty = Table mempty mempty
-  mappend (Table i1 b1) (Table i2 b2) = Table (i1 `mappend` i2) (IntMap.unionWith mappend b1 b2)
+  mappend = (<>)
 
 instance (Enum i, Show i) => Show1 (Table i) where
   liftShowsPrec spA slA d t = showsBinaryWith showsPrec (const (liftShowList spA slA)) "Table" d (tableAddresses t) (toPairs t)

src/Control/Abstract.hs

@@ -0,0 +1,15 @@
+module Control.Abstract
+( module X
+) where
+
+import Control.Abstract.Addressable as X
+import Control.Abstract.Configuration as X
+import Control.Abstract.Context as X
+import Control.Abstract.Environment as X
+import Control.Abstract.Evaluator as X
+import Control.Abstract.Exports as X
+import Control.Abstract.Heap as X
+import Control.Abstract.Goto as X
+import Control.Abstract.Modules as X
+import Control.Abstract.Roots as X
+import Control.Abstract.Value as X

src/Control/Abstract/Addressable.hs

@@ -0,0 +1,129 @@
+{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
+module Control.Abstract.Addressable where
+
+import Control.Abstract.Context
+import Control.Abstract.Environment
+import Control.Abstract.Evaluator
+import Control.Abstract.Heap
+import Data.Abstract.Address
+import Data.Abstract.Environment (insert)
+import Data.Abstract.FreeVariables
+import Data.Semigroup.Reducer
+import Prologue
+
+-- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap.
+class Ord location => Addressable location effects where
+  derefCell :: Address location value -> Cell location value -> Evaluator location value effects (Maybe value)
+
+  allocLoc :: Name -> Evaluator location value effects location
+
+-- | Look up or allocate an address for a 'Name'.
+lookupOrAlloc :: ( Addressable location effects
+                 , Members '[ Reader (Environment location value)
+                            , State (Environment location value)
+                            ] effects
+                 )
+              => Name
+              -> Evaluator location value effects (Address location value)
+lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure
+
+
+letrec :: ( Addressable location effects
+          , Members '[ Reader (Environment location value)
+                     , State (Environment location value)
+                     , State (Heap location (Cell location) value)
+                     ] effects
+          , Reducer value (Cell location value)
+          )
+       => Name
+       -> Evaluator location value effects value
+       -> Evaluator location value effects (value, Address location value)
+letrec name body = do
+  addr <- lookupOrAlloc name
+  v <- localEnv (insert name addr) body
+  assign addr v
+  pure (v, addr)
+
+-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
+letrec' :: ( Addressable location effects
+           , Members '[ Reader (Environment location value)
+                      , State (Environment location value)
+                      ] effects
+           )
+        => Name
+        -> (Address location value -> Evaluator location value effects value)
+        -> Evaluator location value effects value
+letrec' name body = do
+  addr <- lookupOrAlloc name
+  v <- localEnv id (body addr)
+  v <$ modifyEnv (insert name addr)
+
+
+-- | Look up and dereference the given 'Name', throwing an exception for free variables.
+variable :: ( Addressable location effects
+            , Members '[ Reader (Environment location value)
+                       , Resumable (AddressError location value)
+                       , Resumable (EnvironmentError value)
+                       , State (Environment location value)
+                       , State (Heap location (Cell location) value)
+                       ] effects
+            )
+         => Name
+         -> Evaluator location value effects value
+variable name = lookupEnv name >>= maybe (freeVariableError name) deref
+
+-- Instances
+
+-- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
+instance Member Fresh effects => Addressable Precise effects where
+  derefCell _ = pure . unLatest
+  allocLoc _ = Precise <$> fresh
+
+-- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
+instance Member NonDet effects => Addressable Monovariant effects where
+  derefCell _ cell | null cell = pure Nothing
+                   | otherwise = foldMapA (pure . Just) cell
+  allocLoc = pure . Monovariant
+
+instance ( Addressable location effects
+         , Members '[ Reader ModuleInfo
+                    , Reader PackageInfo
+                    ] effects
+         )
+      => Addressable (Located location) effects where
+  derefCell (Address (Located loc _ _)) = raiseEff . lowerEff . derefCell (Address loc)
+
+  allocLoc name = raiseEff (lowerEff (Located <$> allocLoc name <*> currentPackage <*> currentModule))
+
+-- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized.
+deref :: (Addressable location effects, Members '[Resumable (AddressError location value), State (Heap location (Cell location) value)] effects) => Address location value -> Evaluator location value effects value
+deref addr = do
+  cell <- lookupHeap addr >>= maybeM (throwAddressError (UnallocatedAddress addr))
+  derefed <- derefCell addr cell
+  maybeM (throwAddressError (UninitializedAddress addr)) derefed
+
+alloc :: Addressable location effects => Name -> Evaluator location value effects (Address location value)
+alloc = fmap Address . allocLoc
+
+data AddressError location value resume where
+  UnallocatedAddress :: Address location value -> AddressError location value (Cell location value)
+  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 :: Member (Resumable (AddressError location value)) effects => AddressError location value resume -> Evaluator location value effects resume
+throwAddressError = throwResumable
+
+runAddressError :: Evaluator location value (Resumable (AddressError location value) ': effects) a -> Evaluator location value effects (Either (SomeExc (AddressError location value)) a)
+runAddressError = runResumable
+
+runAddressErrorWith :: (forall resume . AddressError location value resume -> Evaluator location value effects resume) -> Evaluator location value (Resumable (AddressError location value) ': effects) a -> Evaluator location value effects a
+runAddressErrorWith = runResumableWith

src/Control/Abstract/Configuration.hs

@@ -0,0 +1,15 @@
+module Control.Abstract.Configuration
+( Configuration(..)
+, Live
+, getConfiguration
+) where
+
+import Control.Abstract.Environment
+import Control.Abstract.Evaluator
+import Control.Abstract.Heap
+import Control.Abstract.Roots
+import Data.Abstract.Configuration
+
+-- | Get the current 'Configuration' with a passed-in term.
+getConfiguration :: Members '[Reader (Live location value), State (Environment location value), State (Heap location (Cell location) value)] effects => term -> Evaluator location value effects (Configuration term location (Cell location) value)
+getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap

src/Control/Abstract/Context.hs

@@ -0,0 +1,55 @@
+module Control.Abstract.Context
+( ModuleInfo
+, currentModule
+, withCurrentModule
+, PackageInfo
+, currentPackage
+, withCurrentPackage
+, Span
+, currentSpan
+, withCurrentSpan
+, withCurrentCallStack
+) where
+
+import Control.Monad.Effect
+import Control.Monad.Effect.Reader
+import Data.Abstract.Module
+import Data.Abstract.Package
+import Data.Span
+import GHC.Stack
+import Prologue
+
+-- | Get the currently evaluating 'ModuleInfo'.
+currentModule :: (Effectful m, Member (Reader ModuleInfo) effects) => m effects ModuleInfo
+currentModule = ask
+
+-- | Run an action with a locally-replaced 'ModuleInfo'.
+withCurrentModule :: (Effectful m, Member (Reader ModuleInfo) effects) => ModuleInfo -> m effects a -> m effects a
+withCurrentModule = local . const
+
+-- | Get the currently evaluating 'PackageInfo'.
+currentPackage :: (Effectful m, Member (Reader PackageInfo) effects) => m effects PackageInfo
+currentPackage = ask
+
+-- | Run an action with a locally-replaced 'PackageInfo'.
+withCurrentPackage :: (Effectful m, Member (Reader PackageInfo) effects) => PackageInfo -> m effects a -> m effects a
+withCurrentPackage = local . const
+
+-- | Get the 'Span' of the currently-evaluating term (if any).
+currentSpan :: (Effectful m, Member (Reader Span) effects) => m effects Span
+currentSpan = ask
+
+-- | Run an action with a locally-replaced 'Span'.
+withCurrentSpan :: (Effectful m, Member (Reader Span) effects) => Span -> m effects a -> m effects a
+withCurrentSpan = local . const
+
+
+-- | Run an action with locally-replaced 'ModuleInfo' & 'Span' derived from the passed 'SrcLoc'.
+withCurrentSrcLoc :: (Effectful m, Members '[Reader ModuleInfo, Reader Span] effects) => SrcLoc -> m effects a -> m effects a
+withCurrentSrcLoc loc = withCurrentModule (moduleInfoFromSrcLoc loc) . withCurrentSpan (spanFromSrcLoc loc)
+
+-- | Run an action with locally replaced 'ModuleInfo' & 'Span' derived from the Haskell call stack.
+--
+--   This is suitable for contextualizing builtins & other functionality intended for use from client code but defined in Haskell source.
+withCurrentCallStack :: (Effectful m, Members '[Reader ModuleInfo, Reader Span] effects) => CallStack -> m effects a -> m effects a
+withCurrentCallStack = maybe id (withCurrentSrcLoc . snd) . listToMaybe . getCallStack

src/Control/Abstract/Environment.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE GADTs, RankNTypes, TypeOperators #-}
+module Control.Abstract.Environment
+( Environment
+, getEnv
+, putEnv
+, modifyEnv
+, withEnv
+, defaultEnvironment
+, withDefaultEnvironment
+, fullEnvironment
+, localEnv
+, localize
+, lookupEnv
+, EnvironmentError(..)
+, freeVariableError
+, runEnvironmentError
+, runEnvironmentErrorWith
+) where
+
+import Control.Abstract.Evaluator
+import Data.Abstract.Address
+import Data.Abstract.Environment as Env
+import Data.Abstract.FreeVariables
+import Prologue
+
+-- | Retrieve the environment.
+getEnv :: Member (State (Environment location value)) effects => Evaluator location value effects (Environment location value)
+getEnv = get
+
+-- | Set the environment.
+putEnv :: Member (State (Environment location value)) effects => Environment location value -> Evaluator location value effects ()
+putEnv = put
+
+-- | Update the global environment.
+modifyEnv :: Member (State (Environment location value)) effects => (Environment location value -> Environment location value) -> Evaluator location value effects ()
+modifyEnv = modify'
+
+-- | Sets the environment for the lifetime of the given action.
+withEnv :: Member (State (Environment location value)) effects => Environment location value -> Evaluator location value effects a -> Evaluator location value effects a
+withEnv = localState . const
+
+
+-- | Retrieve the default environment.
+defaultEnvironment :: Member (Reader (Environment location value)) effects => Evaluator location value effects (Environment location value)
+defaultEnvironment = ask
+
+-- | Set the default environment for the lifetime of an action.
+--   Usually only invoked in a top-level evaluation function.
+withDefaultEnvironment :: Member (Reader (Environment location value)) effects => Environment location value -> Evaluator location value effects a -> Evaluator location value effects a
+withDefaultEnvironment e = local (const e)
+
+-- | Obtain an environment that is the composition of the current and default environments.
+--   Useful for debugging.
+fullEnvironment :: Members '[Reader (Environment location value), State (Environment location value)] effects => Evaluator location value effects (Environment location value)
+fullEnvironment = mergeEnvs <$> getEnv <*> defaultEnvironment
+
+-- | Run an action with a locally-modified environment.
+localEnv :: Member (State (Environment location value)) effects => (Environment location value -> Environment location value) -> Evaluator location value effects a -> Evaluator location value 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 :: Member (State (Environment location value)) effects => Evaluator location value effects a -> Evaluator location value effects a
+localize = localEnv id
+
+-- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
+lookupEnv :: Members '[Reader (Environment location value), State (Environment location value)] effects => Name -> Evaluator location value effects (Maybe (Address location value))
+lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)
+
+
+-- | Errors involving the environment.
+data EnvironmentError value return where
+  FreeVariable :: Name -> EnvironmentError value value
+
+deriving instance Eq (EnvironmentError value return)
+deriving instance Show (EnvironmentError value return)
+instance Show1 (EnvironmentError value) where liftShowsPrec _ _ = showsPrec
+instance Eq1 (EnvironmentError value) where liftEq _ (FreeVariable n1) (FreeVariable n2) = n1 == n2
+
+freeVariableError :: Member (Resumable (EnvironmentError value)) effects => Name -> Evaluator location value effects value
+freeVariableError = throwResumable . FreeVariable
+
+runEnvironmentError :: Evaluator location value (Resumable (EnvironmentError value) ': effects) a -> Evaluator location value effects (Either (SomeExc (EnvironmentError value)) a)
+runEnvironmentError = runResumable
+
+runEnvironmentErrorWith :: (forall resume . EnvironmentError value resume -> Evaluator location value effects resume) -> Evaluator location value (Resumable (EnvironmentError value) ': effects) a -> Evaluator location value effects a
+runEnvironmentErrorWith = runResumableWith

src/Control/Abstract/Evaluator.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
+module Control.Abstract.Evaluator
+  ( Evaluator(..)
+  -- * Effects
+  , Return(..)
+  , earlyReturn
+  , catchReturn
+  , runReturn
+  , LoopControl(..)
+  , throwBreak
+  , throwContinue
+  , catchLoopControl
+  , runLoopControl
+  , module Control.Monad.Effect
+  , module Control.Monad.Effect.Fail
+  , module Control.Monad.Effect.Fresh
+  , module Control.Monad.Effect.NonDet
+  , module Control.Monad.Effect.Reader
+  , module Control.Monad.Effect.Resumable
+  , module Control.Monad.Effect.State
+  , module Control.Monad.Effect.Trace
+  ) where
+
+import Control.Monad.Effect
+import Control.Monad.Effect.Fail
+import Control.Monad.Effect.Fresh
+import Control.Monad.Effect.NonDet
+import Control.Monad.Effect.Reader
+import Control.Monad.Effect.Resumable
+import Control.Monad.Effect.State
+import Control.Monad.Effect.Trace
+import Prologue
+
+-- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the location, term, and value types.
+--
+--   These parameters enable us to constrain the types of effects using them s.t. we can avoid both ambiguous types when they aren’t mentioned outside of the context, and lengthy, redundant annotations on the use sites of functions employing these effects.
+--
+--   These effects will typically include the environment, heap, module table, etc. effects necessary for evaluation of modules and terms, but may also include any other effects so long as they’re eventually handled.
+newtype Evaluator location value effects a = Evaluator { runEvaluator :: Eff effects a }
+  deriving (Applicative, Effectful, Functor, Monad)
+
+deriving instance Member NonDet effects => Alternative (Evaluator location value effects)
+
+
+-- Effects
+
+-- | 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 :: Member (Return value) effects => value -> Evaluator location value effects value
+earlyReturn = send . Return
+
+catchReturn :: Member (Return value) effects => Evaluator location value effects a -> (forall x . Return value x -> Evaluator location value effects a) -> Evaluator location value effects a
+catchReturn action handler = interpose pure (\ ret _ -> handler ret) action
+
+runReturn :: Evaluator location value (Return value ': effects) value -> Evaluator location value effects value
+runReturn = relay pure (\ (Return value) _ -> pure value)
+
+
+-- | Effects for control flow around loops (breaking and continuing).
+data LoopControl value resume where
+  Break    :: value -> LoopControl value value
+  Continue :: value -> LoopControl value value
+
+deriving instance Eq value => Eq (LoopControl value a)
+deriving instance Show value => Show (LoopControl value a)
+
+throwBreak :: Member (LoopControl value) effects => value -> Evaluator location value effects value
+throwBreak = send . Break
+
+throwContinue :: Member (LoopControl value) effects => value -> Evaluator location value effects value
+throwContinue = send . Continue
+
+catchLoopControl :: Member (LoopControl value) effects => Evaluator location value effects a -> (forall x . LoopControl value x -> Evaluator location value effects a) -> Evaluator location value effects a
+catchLoopControl action handler = interpose pure (\ control _ -> handler control) action
+
+runLoopControl :: Evaluator location value (LoopControl value ': effects) value -> Evaluator location value effects value
+runLoopControl = relay pure (\ eff _ -> case eff of
+  Break    value -> pure value
+  Continue value -> pure value)

src/Control/Abstract/Exports.hs

@@ -0,0 +1,33 @@
+module Control.Abstract.Exports
+( Exports
+, getExports
+, putExports
+, modifyExports
+, addExport
+, withExports
+) where
+
+import Control.Abstract.Evaluator
+import Data.Abstract.Address
+import Data.Abstract.Exports
+import Data.Abstract.FreeVariables
+
+-- | Get the global export state.
+getExports :: Member (State (Exports location value)) effects => Evaluator location value effects (Exports location value)
+getExports = get
+
+-- | Set the global export state.
+putExports :: Member (State (Exports location value)) effects => Exports location value -> Evaluator location value effects ()
+putExports = put
+
+-- | Update the global export state.
+modifyExports :: Member (State (Exports location value)) effects => (Exports location value -> Exports location value) -> Evaluator location value effects ()
+modifyExports = modify'
+
+-- | Add an export to the global export state.
+addExport :: Member (State (Exports location value)) effects => Name -> Name -> Maybe (Address location value) -> Evaluator location value effects ()
+addExport name alias = modifyExports . insert name alias
+
+-- | Sets the global export state for the lifetime of the given action.
+withExports :: Member (State (Exports location value)) effects => Exports location value -> Evaluator location value effects a -> Evaluator location value effects a
+withExports = localState . const

src/Control/Abstract/Goto.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE GADTs, TypeOperators #-}
+module Control.Abstract.Goto
+( GotoTable
+, Label
+, label
+, goto
+, Goto(..)
+, runGoto
+) where
+
+import           Control.Abstract.Evaluator
+import           Control.Monad.Effect (Eff)
+import qualified Data.IntMap as IntMap
+import           Prelude hiding (fail)
+import           Prologue
+
+type GotoTable inner value = IntMap.IntMap (Eff (Goto inner value ': inner) value)
+
+-- | The type of labels.
+--   TODO: This should be rolled into 'Name' and tracked in the environment, both so that we can abstract over labels like any other location, and so that we can garbage collect unreachable labels.
+type Label = Int
+
+
+-- | 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 :: Evaluator location value (Goto effects value ': effects) value -> Evaluator location value (Goto effects value ': effects) Label
+label = send . Label . lowerEff
+
+-- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated.
+goto :: Label -> Evaluator location value (Goto effects value ': effects) (Evaluator location value (Goto effects value ': effects) value)
+goto = fmap raiseEff . send . Goto
+
+
+-- | 'Goto' effects embed an 'Eff' action which can be run in the environment under the 'Goto' itself.
+--
+--   It’s tempting to try to use a 'Member' constraint to require a 'Goto' effect:
+--
+--   @
+--   foo :: Member (Goto effects a) effects => Eff effects a
+--   @
+--
+--   However, using this type would require that the type of the effect list include a reference to itself, which is forbidden by the occurs check: we wouldn’t be able to write a handler for 'Goto' if it could be used at that type. Instead, one can either use a smaller, statically known effect list inside the 'Goto', e.g. @Member (Goto outer) inner@ where @outer@ is a suffix of @inner@ (and with some massaging to raise the @outer@ actions into the @inner@ context), or use 'Goto' when it’s statically known to be the head of the list: @Eff (Goto rest a ': rest) b@. In either case, the 'Eff' actions embedded in the effect are themselves able to contain further 'Goto' effects,
+data Goto effects value return where
+  Label :: Eff (Goto effects value ': effects) value -> Goto effects value Label
+  Goto  :: Label -> Goto effects value (Eff (Goto effects value ': effects) value)
+
+-- | Run a 'Goto' effect in terms of a 'State' effect holding a 'GotoTable', accessed via wrap/unwrap functions.
+--
+--   The wrap/unwrap functions are necessary in order for ghc to be able to typecheck the table, since it necessarily contains references to its own effect list. Since @GotoTable (… ': State (GotoTable … value) ': …) value@ can’t be written, and a recursive type equality constraint won’t typecheck, callers will need to employ a @newtype@ to break the self-reference. The effect list of the table the @newtype@ contains will include all of the effects between the 'Goto' effect and the 'State' effect (including the 'State' but not the 'Goto'). E.g. if the 'State' is the next effect, a valid wrapper would be∷
+--
+--   @
+--   newtype Gotos effects value = Gotos { getGotos :: GotoTable (State (Gotos effects value) ': effects) value }
+--   @
+--
+--   Callers can then evaluate the high-level 'Goto' effect by passing @Gotos@ and @getGotos@ to 'runGoto'.
+runGoto :: Members '[ Fail
+                    , Fresh
+                    , State table
+                    ] effects
+        => (GotoTable effects value -> table)
+        -> (table -> GotoTable effects value)
+        -> Evaluator location value (Goto effects value ': effects) a
+        -> Evaluator location value effects a
+runGoto from to = interpret (\ goto -> do
+  table <- to <$> getTable
+  case goto of
+    Label action -> do
+      supremum <- fresh
+      supremum <$ putTable (from (IntMap.insert supremum action table))
+    Goto label   -> maybeM (raiseEff (fail ("unknown label: " <> show label))) (IntMap.lookup label table))
+
+getTable :: Member (State table) effects => Evaluator location value effects table
+getTable = get
+
+putTable :: Member (State table) effects => table -> Evaluator location value effects ()
+putTable = put

src/Control/Abstract/Heap.hs

@@ -0,0 +1,40 @@
+module Control.Abstract.Heap
+( Heap
+, Cell
+, getHeap
+, putHeap
+, modifyHeap
+, lookupHeap
+, assign
+) where
+
+import Control.Abstract.Evaluator
+import Data.Abstract.Address
+import Data.Abstract.Heap
+import Data.Semigroup.Reducer
+
+-- | Retrieve the heap.
+getHeap :: Member (State (Heap location (Cell location) value)) effects => Evaluator location value effects (Heap location (Cell location) value)
+getHeap = get
+
+-- | Set the heap.
+putHeap :: Member (State (Heap location (Cell location) value)) effects => Heap location (Cell location) value -> Evaluator location value effects ()
+putHeap = put
+
+-- | Update the heap.
+modifyHeap :: Member (State (Heap location (Cell location) value)) effects => (Heap location (Cell location) value -> Heap location (Cell location) value) -> Evaluator location value effects ()
+modifyHeap = modify'
+
+-- | Look up the cell for the given 'Address' in the 'Heap'.
+lookupHeap :: (Member (State (Heap location (Cell location) value)) effects, Ord location) => Address location value -> Evaluator location value effects (Maybe (Cell location value))
+lookupHeap = flip fmap getHeap . heapLookup
+
+-- | Write a value to the given 'Address' in the 'Store'.
+assign :: ( Member (State (Heap location (Cell location) value)) effects
+          , Ord location
+          , Reducer value (Cell location value)
+          )
+       => Address location value
+       -> value
+       -> Evaluator location value effects ()
+assign address = modifyHeap . heapInsert address

src/Control/Abstract/Matching.hs

@@ -0,0 +1,125 @@
+{-# LANGUAGE GADTs, TypeOperators #-}
+
+module Control.Abstract.Matching
+  ( Matcher
+  , TermMatcher
+  , target
+  , ensure
+  , match
+  , matchM
+  , narrow
+  , narrow'
+  , succeeds
+  , fails
+  , runMatcher
+  ) where
+
+import           Data.Algebra
+import           Data.Sum
+import           Data.Term
+import           Prologue
+
+-- | A @Matcher t a@ is a tree automaton that matches some 'Recursive' and 'Corecursive' type @t@, yielding values of type @a@.
+--   Matching operations are implicitly recursive: when you run a 'Matcher', it is applied bottom-up.
+--   If a matching operation returns a value, it is assumed to have succeeded. You use the 'guard', 'narrow', and 'ensure'
+--   functions to control whether a given datum is matched. The @t@ datum matched by a matcher is immutable; future APIs will
+--   provide the ability to rewrite and change these data.
+data Matcher t a where
+  -- TODO: Choice is inflexible and slow. A Sum over fs can be queried for its index, and we can build a jump table over that.
+  -- We can copy NonDet to have fair conjunction or disjunction.
+  Choice :: Matcher t a -> Matcher t a -> Matcher t a
+  Target :: Matcher t t
+  Empty  :: Matcher t a
+  -- We could have implemented this by changing the semantics of how Then is interpreted, but that would make Then and Sequence inconsistent.
+  Match  :: (t -> Maybe u) -> Matcher u a -> Matcher t a
+  Pure   :: a -> Matcher t a
+  Then   :: Matcher t b -> (b -> Matcher t a) -> Matcher t a
+
+-- | A convenience alias for matchers that both target and return 'Term' values.
+type TermMatcher fs ann = Matcher (Term (Sum fs) ann) (Term (Sum fs) ann)
+
+instance Functor (Matcher t) where
+  fmap = liftA
+
+instance Applicative (Matcher t) where
+  pure   = Pure
+  -- We can add a Sequence constructor to optimize this when we need.
+  (<*>)  = ap
+
+instance Alternative (Matcher t) where
+  empty = Empty
+  (<|>) = Choice
+
+instance Monad (Matcher t) where
+  (>>=) = Then
+
+-- | This matcher always succeeds.
+succeeds :: Matcher t ()
+succeeds = guard True
+
+-- | This matcher always fails.
+fails :: Matcher t ()
+fails = guard False
+
+-- | 'target' extracts the 't' that a given 'Matcher' is operating upon.
+--   Similar to a reader monad's 'ask' function.
+target :: Matcher t t
+target = Target
+
+-- | 'ensure' succeeds iff the provided predicate function returns true when applied to the matcher's 'target'.
+ensure :: (t -> Bool) -> Matcher t ()
+ensure f = target >>= \c -> guard (f c)
+
+-- | 'matchm' takes a modification function and a new matcher action the target parameter of which
+--   is the result of the modification function. If the modification function returns 'Just' when
+--   applied to the current 'target', the given matcher is executed with the result of that 'Just'
+--   as the new target; if 'Nothing' is returned, the action fails.
+matchM :: (t -> Maybe u) -> Matcher u a -> Matcher t a
+matchM = Match
+
+-- | 'match' is a more specific version of 'matchM' optimized for targeting union types. If the target
+--   can be projected to the type expected by the modification function, the provided matcher action will
+--   execute. An example:
+--
+-- @
+-- integerMatcher :: (Lit.Integer :< fs) => Matcher (Term (Sum fs) ann) ByteString
+-- integerMatcher = match Lit.integerContent target
+-- @
+--
+-- @integerMatcher@ accepts any union type that contains an integer literal, and only succeeds if the
+-- target in question is actually an integer literal.
+match :: (f :< fs)
+      => (f (Term (Sum fs) ann) -> b)
+      -> Matcher b a
+      -> Matcher (Term (Sum fs) ann) a
+match f = Match (fmap f . projectSum . termOut)
+
+-- | @narrow'@ attempts to project a union-type target to a more specific type.
+narrow' :: (f :< fs) => Matcher (Term (Sum fs) ann) (Maybe (f (Term (Sum fs) ann)))
+narrow' = fmap (projectSum . termOut) Target
+
+-- | 'narrow' behaves as @narrow'@, but fails if the target cannot be thus projected.
+narrow :: (f :< fs) => Matcher (Term (Sum fs) ann) (f (Term (Sum fs) ann))
+narrow = narrow' >>= foldMapA pure
+
+-- | The entry point for executing matchers.
+--   The Alternative parameter should be specialized by the calling context. If you want a single
+--   result, specialize it to 'Maybe'; if you want a list of all terms and subterms matched by the
+--   provided 'Matcher' action, specialize it to '[]'.
+runMatcher :: (Alternative m, Monad m, Corecursive t, Recursive t, Foldable (Base t))
+           => Matcher t a
+           -> t
+           -> m a
+runMatcher m = para (paraMatcher m)
+
+paraMatcher :: (Alternative m, Monad m, Corecursive t, Foldable (Base t)) => Matcher t a -> RAlgebra (Base t) t (m a)
+paraMatcher m t = interp (embedTerm t) m <|> foldMapA snd t
+
+-- Simple interpreter.
+interp :: (Alternative m, Monad m) => t -> Matcher t a -> m a
+interp t (Choice a b) = interp t a <|> interp t b
+interp t Target       = pure t
+interp t (Match f m)  = foldMapA (`interp` m) (f t)
+interp _ (Pure a)     = pure a
+interp _ Empty        = empty
+interp t (Then m f)   = interp t m >>= interp t . f

src/Control/Abstract/Modules.hs

@@ -0,0 +1,159 @@
+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-}
+module Control.Abstract.Modules
+( lookupModule
+, resolve
+, listModulesInDir
+, require
+, load
+, Modules(..)
+, runModules
+, LoadError(..)
+, moduleNotFound
+, resumeLoadError
+, runLoadError
+, runLoadErrorWith
+, ResolutionError(..)
+, runResolutionError
+, runResolutionErrorWith
+, ModuleTable
+) where
+
+import Control.Abstract.Evaluator
+import Data.Abstract.Environment
+import Data.Abstract.Module
+import Data.Abstract.ModuleTable as ModuleTable
+import Data.Language
+import Prologue
+
+-- | Retrieve an evaluated module, if any. The outer 'Maybe' indicates whether we’ve begun loading the module or not, while the inner 'Maybe' indicates whether we’ve completed loading it or not. Thus, @Nothing@ means we’ve never tried to load it, @Just Nothing@ means we’ve started but haven’t yet finished loading it, and @Just (Just (env, value))@ indicates the result of a completed load.
+lookupModule :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Maybe (Environment location value, value)))
+lookupModule = send . Lookup
+
+-- Resolve a list of module paths to a possible module table entry.
+resolve :: Member (Modules location value) effects => [FilePath] -> Evaluator location value effects (Maybe ModulePath)
+resolve = sendModules . Resolve
+
+listModulesInDir :: Member (Modules location value) effects => FilePath -> Evaluator location value effects [ModulePath]
+listModulesInDir = sendModules . List
+
+
+-- | Require/import another module by name and return its environment and value.
+--
+-- Looks up the module's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module.
+require :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location value, value))
+require path = lookupModule path >>= maybeM (load path)
+
+-- | Load another module by name and return its environment and value.
+--
+-- Always loads/evaluates.
+load :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location value, value))
+load = send . Load
+
+
+data Modules location value return where
+  Load    :: ModulePath -> Modules location value (Maybe (Environment location value, value))
+  Lookup  :: ModulePath -> Modules location value (Maybe (Maybe (Environment location value, value)))
+  Resolve :: [FilePath] -> Modules location value (Maybe ModulePath)
+  List    :: FilePath   -> Modules location value [ModulePath]
+
+sendModules :: Member (Modules location value) effects => Modules location value return -> Evaluator location value effects return
+sendModules = send
+
+runModules :: forall term location value effects a
+           .  Members '[ Resumable (LoadError location value)
+                       , State (ModuleTable (Maybe (Environment location value, value)))
+                       , Trace
+                       ] effects
+           => (Module term -> Evaluator location value (Modules location value ': effects) (Environment location value, value))
+           -> Evaluator location value (Modules location value ': effects) a
+           -> Evaluator location value (Reader (ModuleTable [Module term]) ': effects) a
+runModules evaluateModule = go
+  where go :: forall a . Evaluator location value (Modules location value ': effects) a -> Evaluator location value (Reader (ModuleTable [Module term]) ': effects) a
+        go = reinterpret (\ m -> case m of
+          Load name -> askModuleTable @term >>= maybe (moduleNotFound name) (runMerging . foldMap (Merging . evalAndCache)) . ModuleTable.lookup name
+            where
+              evalAndCache x = do
+                let mPath = modulePath (moduleInfo x)
+                loading <- loadingModule mPath
+                if loading
+                  then trace ("load (skip evaluating, circular load): " <> show mPath) $> Nothing
+                  else do
+                    _ <- cacheModule name Nothing
+                    result <- trace ("load (evaluating): " <> show mPath) *> go (evaluateModule x) <* trace ("load done:" <> show mPath)
+                    cacheModule name (Just result)
+
+              loadingModule path = isJust . ModuleTable.lookup path <$> getModuleTable
+          Lookup path -> ModuleTable.lookup path <$> get
+          Resolve names -> do
+            isMember <- flip ModuleTable.member <$> askModuleTable @term
+            pure (find isMember names)
+          List dir -> modulePathsInDir dir <$> askModuleTable @term)
+
+getModuleTable :: Member (State (ModuleTable (Maybe (Environment location value, value)))) effects => Evaluator location value effects (ModuleTable (Maybe (Environment location value, value)))
+getModuleTable = get
+
+cacheModule :: Member (State (ModuleTable (Maybe (Environment location value, value)))) effects => ModulePath -> Maybe (Environment location value, value) -> Evaluator location value effects (Maybe (Environment location value, value))
+cacheModule path result = modify' (ModuleTable.insert path result) $> result
+
+askModuleTable :: Member (Reader (ModuleTable [Module term])) effects => Evaluator location value effects (ModuleTable [Module term])
+askModuleTable = ask
+
+
+newtype Merging m location value = Merging { runMerging :: m (Maybe (Environment location value, value)) }
+
+instance Applicative m => Semigroup (Merging m location value) where
+  Merging a <> Merging b = Merging (merge <$> a <*> b)
+    where merge a b = mergeJusts <$> a <*> b <|> a <|> b
+          mergeJusts (env1, _) (env2, v) = (mergeEnvs env1 env2, v)
+
+instance Applicative m => Monoid (Merging m location value) where
+  mappend = (<>)
+  mempty = Merging (pure Nothing)
+
+
+-- | 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 location value resume where
+  ModuleNotFound :: ModulePath -> LoadError location value (Maybe (Environment location value, value))
+
+deriving instance Eq (LoadError location value resume)
+deriving instance Show (LoadError location value resume)
+instance Show1 (LoadError location value) where
+  liftShowsPrec _ _ = showsPrec
+instance Eq1 (LoadError location value) where
+  liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b
+
+moduleNotFound :: Member (Resumable (LoadError location value)) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location value, value))
+moduleNotFound = throwResumable . ModuleNotFound
+
+resumeLoadError :: Member (Resumable (LoadError location value)) effects => Evaluator location value effects a -> (forall resume . LoadError location value resume -> Evaluator location value effects resume) -> Evaluator location value effects a
+resumeLoadError = catchResumable
+
+runLoadError :: Evaluator location value (Resumable (LoadError location value) ': effects) a -> Evaluator location value effects (Either (SomeExc (LoadError location value)) a)
+runLoadError = runResumable
+
+runLoadErrorWith :: (forall resume . LoadError location value resume -> Evaluator location value effects resume) -> Evaluator location value (Resumable (LoadError location value) ': effects) a -> Evaluator location value effects a
+runLoadErrorWith = runResumableWith
+
+
+-- | An error thrown when we can't resolve a module from a qualified name.
+data ResolutionError resume where
+  NotFoundError :: String   -- ^ The path that was not found.
+                -> [String] -- ^ List of paths searched that shows where semantic looked for this module.
+                -> Language -- ^ Language.
+                -> ResolutionError ModulePath
+
+  GoImportError :: FilePath -> ResolutionError [ModulePath]
+
+deriving instance Eq (ResolutionError b)
+deriving instance Show (ResolutionError b)
+instance Show1 ResolutionError where liftShowsPrec _ _ = showsPrec
+instance Eq1 ResolutionError where
+  liftEq _ (NotFoundError a _ l1) (NotFoundError b _ l2) = a == b && l1 == l2
+  liftEq _ (GoImportError a) (GoImportError b) = a == b
+  liftEq _ _ _ = False
+
+runResolutionError :: Effectful m => m (Resumable ResolutionError ': effects) a -> m effects (Either (SomeExc ResolutionError) a)
+runResolutionError = runResumable
+
+runResolutionErrorWith :: Effectful m => (forall resume . ResolutionError resume -> m effects resume) -> m (Resumable ResolutionError ': effects) a -> m effects a
+runResolutionErrorWith = runResumableWith

src/Control/Abstract/Roots.hs

@@ -0,0 +1,17 @@
+module Control.Abstract.Roots
+( Live
+, askRoots
+, extraRoots
+) where
+
+import Control.Abstract.Evaluator
+import Data.Abstract.Live
+import Prologue
+
+-- | Retrieve the local 'Live' set.
+askRoots :: Member (Reader (Live location value)) effects => Evaluator location value effects (Live location value)
+askRoots = ask
+
+-- | Run a computation with the given 'Live' set added to the local root set.
+extraRoots :: (Member (Reader (Live location value)) effects, Ord location) => Live location value -> Evaluator location value effects a -> Evaluator location value effects a
+extraRoots roots = local (<> roots)

src/Control/Abstract/Value.hs

@@ -0,0 +1,205 @@
+{-# LANGUAGE Rank2Types #-}
+module Control.Abstract.Value
+( AbstractValue(..)
+, AbstractHole(..)
+, Comparator(..)
+, while
+, doWhile
+, forLoop
+, makeNamespace
+, ValueRoots(..)
+) where
+
+import Control.Abstract.Environment
+import Control.Abstract.Evaluator
+import Control.Abstract.Heap
+import Data.Abstract.Address (Address, Cell)
+import Data.Abstract.Environment as Env
+import Data.Abstract.FreeVariables
+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)
+
+-- | This datum is passed into liftComparison to handle the fact that Ruby and PHP
+--   have built-in generalized-comparison ("spaceship") operators. If you want to
+--   encapsulate a traditional, boolean-returning operator, wrap it in 'Concrete';
+--   if you want the generalized comparator, pass in 'Generalized'. In 'AbstractValue'
+--   instances, you can then then handle the different cases to return different
+--   types, if that's what you need.
+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 Show value => AbstractValue location value effects where
+  -- | Construct an abstract unit value.
+  --   TODO: This might be the same as the empty tuple for some value types
+  unit :: Evaluator location value effects value
+
+  -- | Construct an abstract integral value.
+  integer :: Prelude.Integer -> Evaluator location value effects value
+
+  -- | Lift a unary operator over a 'Num' to a function on 'value's.
+  liftNumeric  :: (forall a . Num a => a -> a)
+               -> (value -> Evaluator location value 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 -> Evaluator location value effects value)
+
+  -- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values.
+  liftComparison :: Comparator -> (value -> value -> Evaluator location value effects value)
+
+  -- | Lift a unary bitwise operator to values. This is usually 'complement'.
+  liftBitwise :: (forall a . Bits a => a -> a)
+              -> (value -> Evaluator location value 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 -> Evaluator location value effects value)
+
+  -- | Construct an abstract boolean value.
+  boolean :: Bool -> Evaluator location value effects value
+
+  -- | Construct an abstract string value.
+  string :: ByteString -> Evaluator location value effects value
+
+  -- | Construct a self-evaluating symbol value.
+  --   TODO: Should these be interned in some table to provide stronger uniqueness guarantees?
+  symbol :: ByteString -> Evaluator location value effects value
+
+  -- | Construct a floating-point value.
+  float :: Scientific -> Evaluator location value effects value
+
+  -- | Construct a rational value.
+  rational :: Prelude.Rational -> Evaluator location value effects value
+
+  -- | Construct an N-ary tuple of multiple (possibly-disjoint) values
+  multiple :: [value] -> Evaluator location value effects value
+
+  -- | Construct an array of zero or more values.
+  array :: [value] -> Evaluator location value effects value
+
+  -- | Construct a key-value pair for use in a hash.
+  kvPair :: value -> value -> Evaluator location value effects value
+
+  -- | Extract the contents of a key-value pair as a tuple.
+  asPair :: value -> Evaluator location value effects (value, value)
+
+  -- | Construct a hash out of pairs.
+  hash :: [(value, value)] -> Evaluator location value effects value
+
+  -- | Extract a 'ByteString' from a given value.
+  asString :: value -> Evaluator location value effects ByteString
+
+  -- | Eliminate boolean values. TODO: s/boolean/truthy
+  ifthenelse :: value -> Evaluator location value effects value -> Evaluator location value effects value -> Evaluator location value effects value
+
+  -- | Extract a 'Bool' from a given value.
+  asBool :: value -> Evaluator location value effects Bool
+
+  -- | Construct the nil/null datatype.
+  null :: Evaluator location value effects value
+
+  -- | @index x i@ computes @x[i]@, with zero-indexing.
+  index :: value -> value -> Evaluator location value effects value
+
+  -- | Determine whether the given datum is a 'Hole'.
+  isHole :: value -> Evaluator location value 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
+        -> Evaluator location value 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
+            -> Evaluator location value effects value
+
+  -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
+  scopedEnvironment :: value -> Evaluator location value effects (Maybe (Environment location value))
+
+  -- | Build a closure (a binder like a lambda or method definition).
+  closure :: [Name]                                      -- ^ The parameter names.
+          -> Set Name                                    -- ^ The set of free variables to close over.
+          -> Evaluator location value effects value -- ^ The evaluator for the body of the closure.
+          -> Evaluator location value effects value
+  -- | Evaluate an application (like a function call).
+  call :: value -> [Evaluator location value effects value] -> Evaluator location value 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 :: (Evaluator location value effects value -> Evaluator location value effects value) -> Evaluator location value effects value
+
+
+-- | Attempt to extract a 'Prelude.Bool' from a given value.
+forLoop :: ( AbstractValue location value effects
+           , Member (State (Environment location value)) effects
+           )
+        => Evaluator location value effects value -- ^ Initial statement
+        -> Evaluator location value effects value -- ^ Condition
+        -> Evaluator location value effects value -- ^ Increment/stepper
+        -> Evaluator location value effects value -- ^ Body
+        -> Evaluator location value effects value
+forLoop initial cond step body =
+  localize (initial *> while cond (body *> step))
+
+-- | The fundamental looping primitive, built on top of ifthenelse.
+while :: AbstractValue location value effects
+      => Evaluator location value effects value
+      -> Evaluator location value effects value
+      -> Evaluator location value effects value
+while cond body = loop $ \ continue -> do
+  this <- cond
+  ifthenelse this (body *> continue) unit
+
+-- | Do-while loop, built on top of while.
+doWhile :: AbstractValue location value effects
+        => Evaluator location value effects value
+        -> Evaluator location value effects value
+        -> Evaluator location value effects value
+doWhile body cond = loop $ \ continue -> body *> do
+  this <- cond
+  ifthenelse this continue unit
+
+makeNamespace :: ( AbstractValue location value effects
+                 , Member (State (Environment location value)) effects
+                 , Member (State (Heap location (Cell location) value)) effects
+                 , Ord location
+                 , Reducer value (Cell location value)
+                 )
+              => Name
+              -> Address location value
+              -> Maybe value
+              -> Evaluator location value effects value
+makeNamespace name addr super = do
+  superEnv <- maybe (pure (Just lowerBound)) scopedEnvironment super
+  let env' = fromMaybe lowerBound superEnv
+  namespaceEnv <- Env.head <$> getEnv
+  v <- namespace name (Env.mergeNewer env' namespaceEnv)
+  v <$ assign addr v
+
+
+-- | Value types, e.g. closures, which can root a set of addresses.
+class ValueRoots location value where
+  -- | Compute the set of addresses rooted by a given value.
+  valueRoots :: value -> Live location value

src/Control/Effect.hs

@@ -1,65 +0,0 @@
-{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-}
-module Control.Effect where
-
-import Prologue
-import qualified Control.Monad.Effect as Effect
-import Control.Monad.Effect.Fail
-import Control.Monad.Effect.Internal hiding (run)
-import Control.Monad.Effect.NonDetEff
-import Control.Monad.Effect.Reader
-import Control.Monad.Effect.State
-import Control.Monad.Effect.Writer
-
--- | Run a computation in 'Eff' to completion, interpreting each effect with some sensible defaults, and return the 'Final' result.
-run :: RunEffects fs a => Eff fs a -> Final fs a
-run = Effect.run . runEffects
-
--- | A typeclass to run a computation to completion, interpreting each effect with some sensible defaults.
-class RunEffects fs a where
-  -- | 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 -> Eff '[] (Final fs a)
-
-instance (RunEffect f1 a, RunEffects (f2 ': fs) (Result f1 a)) => RunEffects (f1 ': f2 ': fs) a where
-  type Final (f1 ': f2 ': fs) a = Final (f2 ': fs) (Result f1 a)
-  runEffects = runEffects . runEffect
-
-instance RunEffect f a => RunEffects '[f] a where
-  type Final '[f] a = Result f a
-  runEffects = runEffect
-
-
--- | 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
-
--- | 'NonDetEff' effects are interpreted into a nondeterministic set of result values.
-instance Ord a => RunEffect NonDetEff a where
-  type Result NonDetEff a = Set a
-  runEffect = relay (pure . point) (\ m k -> case m of
-    MZero -> pure mempty
-    MPlus -> mappend <$> k True <*> k False)

src/Control/Monad/Effect/Addressable.hs

@@ -1,91 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}
-module Control.Monad.Effect.Addressable where
-
-import Control.Applicative
-import Control.Monad ((<=<))
-import Control.Monad.Effect (Eff)
-import Control.Monad.Effect.Fail
-import Control.Monad.Effect.State
-import Data.Abstract.Address
-import Data.Abstract.Environment
-import Data.Abstract.FreeVariables
-import Data.Abstract.Store
-import Data.Abstract.Value
-import Data.Foldable (asum, toList)
-import Data.Pointed
-import Data.Semigroup
-import Data.Union
-import Prelude hiding (fail)
-
--- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store.
-class (Ord l, Pointed (Cell l)) => Addressable l es where
-  deref :: (Member (State (StoreFor a)) es , Member Fail es , l ~ LocationFor a)
-        => Address l a -> Eff es a
-
-  alloc :: (Member (State (StoreFor a)) es, l ~ LocationFor a)
-        => Name -> Eff es (Address l a)
-
--- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address.
---
---   The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers.
-lookupOrAlloc ::
-                 ( FreeVariables t
-                 , Semigroup (Cell (LocationFor a) a)
-                 , Member (State (StoreFor a)) es
-                 , Addressable (LocationFor a) es
-                 )
-                 => t
-                 -> a
-                 -> Environment (LocationFor a) a
-                 -> Eff es (Name, Address (LocationFor a) a)
-lookupOrAlloc term = let [name] = toList (freeVariables term) in
-                         lookupOrAlloc' name
-  where
-    -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address.
-    lookupOrAlloc' ::
-                      ( Semigroup (Cell (LocationFor a) a)
-                      , Member (State (StoreFor a)) es
-                      , Addressable (LocationFor a) es
-                      )
-                      => Name
-                      -> a
-                      -> Environment (LocationFor a) a
-                      -> Eff es (Name, Address (LocationFor a) a)
-    lookupOrAlloc' name v env = do
-      a <- maybe (alloc name) pure (envLookup name env)
-      assign a v
-      pure (name, a)
-
--- | Write a value to the given 'Address' in the 'Store'.
-assign ::
-       ( Ord (LocationFor a)
-       , Semigroup (Cell (LocationFor a) a)
-       , Pointed (Cell (LocationFor a))
-       , Member (State (StoreFor a)) es
-       )
-       => Address (LocationFor a) a
-       -> a
-       -> Eff es ()
-assign address = modify . storeInsert address
-
-
--- Instances
-
--- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
-instance Addressable Precise es where
-  deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap get . storeLookup
-    where
-      -- | 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).
-      uninitializedAddress :: Member Fail es => Eff es a
-      uninitializedAddress = fail "uninitialized address"
-
-  alloc _ = fmap allocPrecise get
-    where allocPrecise :: Store Precise a -> Address Precise a
-          allocPrecise = Address . Precise . storeSize
-
-
--- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
-instance (Alternative (Eff es)) => Addressable Monovariant es where
-  deref = asum . maybe [] (map pure . toList) <=< flip fmap get . storeLookup
-
-  alloc = pure . Address . Monovariant

src/Control/Monad/Effect/Cache.hs

@@ -1,63 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
-module Control.Monad.Effect.Cache where
-
-import Control.Monad.Effect
-import Control.Monad.Effect.Reader
-import Control.Monad.Effect.State
-import Data.Abstract.Cache
-import Data.Abstract.Value
-
--- | 'Monad's offering a readable 'Cache' of values & stores for each configuration in a program.
---
---   This (in-)cache is used as an oracle for the results of recursive computations, allowing us to finitize potentially nonterminating control flow by repeatedly computing the results until analysis converges on a stable value. Each iteration of this process must consult this cache only _after_ evaluating the configuration itself in order to ensure soundness (since it could otherwise produce stale results for some configurations).
---
---   Since finitization crucially depends on convergence, this cache should only be used with value abstractions that will converge for multiple disjoint assignments of a given variable, e.g. its type, and not with precisely-modelled values. To illustrate why, consider a simple incrementing recursive function:
---
---   > inc :: Integer -> a
---   > inc n = inc (n + 1)
---
---   @n@ differs at every iteration, and thus a precise modelling of the integral value will not converge in the store: each iteration will allocate a new address & write a distinct value into it. Modelling values with their types _will_ converge, however, as the type at each iteration is the same.
-class Monad m => MonadCacheIn t v m where
-  -- | Retrieve the local in-cache.
-  askCache :: m (Cache (LocationFor v) t v)
-
-  -- | Run a computation with a locally-modified in-cache.
-  localCache :: (Cache (LocationFor v) t v -> Cache (LocationFor v) t v) -> m a -> m a
-
-instance (Reader (Cache (LocationFor v) t v) :< fs) => MonadCacheIn t v (Eff fs) where
-  askCache = ask
-  localCache = local
-
--- | Project a value out of the in-cache.
-asksCache :: MonadCacheIn t v m => (Cache (LocationFor v) t v -> a) -> m a
-asksCache f = f <$> askCache
-
-
--- | 'Monad's offering a readable & writable 'Cache' of values & stores for each configuration in a program.
---
---   This (out-)cache is used to store the results of recursive computations, allowing us to finitize each iteration of an analysis by first looking up the current configuration in the cache and only evaluating:
---
---   1. If the configuration has not been visited before, and
---   2. _after_ copying the previous iteration’s results (from the in-cache, and defaulting to a 'mempty' set of results) into the out-cache.
---
---   Thus, visiting the same configuration twice recursively will terminate, since we’ll have consulted the in-cache as an oracle before evaluating, and after evaluating, the resulting value and store should be appended into the out-cache. Then, once the current iteration of the analysis has completed, the updated out-cache will be used as the oracle for the next iteration, until such time as the cache converges.
---
---   See also 'MonadCacheIn' for discussion of the conditions of finitization.
-class Monad m => MonadCacheOut t v m where
-  -- | Retrieve the current out-cache.
-  getCache :: m (Cache (LocationFor v) t v)
-
-  -- | Update the current out-cache.
-  putCache :: Cache (LocationFor v) t v -> m ()
-
-instance (State (Cache (LocationFor v) t v) :< fs) => MonadCacheOut t v (Eff fs) where
-  getCache = get
-  putCache = put
-
--- | Project a value out of the out-cache.
-getsCache :: MonadCacheOut t v m => (Cache (LocationFor v) t v -> a) -> m a
-getsCache f = f <$> getCache
-
--- | Modify the current out-cache using a given function.
-modifyCache :: MonadCacheOut t v m => (Cache (LocationFor v) t v -> Cache (LocationFor v) t v) -> m ()
-modifyCache f = fmap f getCache >>= putCache

src/Control/Monad/Effect/Dead.hs

@@ -1,23 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
-module Control.Monad.Effect.Dead where
-
-import Prologue
-import Data.Set (delete)
-import Control.Monad.Effect
-import Control.Monad.Effect.State
-
--- | A set of “dead” (unreachable) terms.
-newtype Dead a = Dead { unDead :: Set a }
-  deriving (Eq, Foldable, Semigroup, Monoid, Ord, Show)
-
--- | 'Monad's offering a readable & writable set of 'Dead' terms.
-class Monad m => MonadDead t m where
-  -- | Update the current 'Dead' set.
-  killAll :: Dead t -> m ()
-
-  -- | Revive a single term, removing it from the current 'Dead' set.
-  revive :: Ord t => t -> m ()
-
-instance (State (Dead t) :< fs) => MonadDead t (Eff fs) where
-  killAll = put
-  revive t = modify (Dead . delete t . unDead)

src/Control/Monad/Effect/Evaluatable.hs

@@ -1,70 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses, Rank2Types, GADTs, TypeOperators, DefaultSignatures, UndecidableInstances, ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-module Control.Monad.Effect.Evaluatable
-( Evaluatable(..)
-, Recursive(..)
-, Base
-, Subterm(..)
-) where
-
-import Control.Monad.Effect.Fail
-import Control.Monad.Effect.Internal
-import Control.Monad.Effect.Reader
-import Control.Monad.Effect.State
-import Data.Abstract.Environment
-import Data.Abstract.FreeVariables
-import Data.Abstract.Value
-import Data.Algebra
-import Data.Functor.Classes
-import Data.Functor.Foldable (Base, Recursive(..), project)
-import Data.Proxy
-import Data.Term
-import Data.Union (Apply)
-import Prelude hiding (fail)
-import qualified Data.Union as U
-
-
--- | 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 es term v constr where
-  eval :: SubtermAlgebra constr term (Eff es v)
-  default eval :: (Fail :< es, Show1 constr) => SubtermAlgebra constr term (Eff es v)
-  eval expr = fail $ "Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""
-
--- | If we can evaluate any syntax which can occur in a 'Union', we can evaluate the 'Union'.
-instance (Apply (Evaluatable es t v) fs) => Evaluatable es t v (Union fs) where
-  eval = U.apply (Proxy :: Proxy (Evaluatable es t v)) eval
-
--- | Evaluating a 'TermF' ignores its annotation, evaluating the underlying syntax.
-instance (Evaluatable es t v s) => Evaluatable es t v (TermF s a) where
-  eval In{..} = eval termFOut
-
-
--- Instances
-
--- | '[]' is treated as an imperative sequence of statements/declarations s.t.:
---
---   1. Each statement’s effects on the store are accumulated;
---   2. Each statement can affect the environment of later statements (e.g. by 'modify'-ing the environment); and
---   3. Only the last statement’s return value is returned.
-instance ( Ord (LocationFor v)
-         , Show (LocationFor v)
-         , (State (EnvironmentFor v) :< es)
-         , (Reader (EnvironmentFor v) :< es)
-         , AbstractValue v
-         , FreeVariables t
-         , Evaluatable es t v (Base t)
-         , Recursive t
-         )
-         => Evaluatable es t v [] where
-  eval []     = pure unit          -- Return unit value if this is an empty list of terms
-  eval [x]    = subtermValue x     -- Return the value for the last term
-  eval (x:xs) = do
-    _ <- subtermValue x            -- Evaluate the head term
-    env <- get @(EnvironmentFor v) -- Get the global environment after evaluation
-                                   -- since it might have been modified by the
-                                   -- evaluation above ^.
-
-    -- Finally, evaluate the rest of the terms, but do so by calculating a new
-    -- environment each time where the free variables in those terms are bound
-    -- to the global environment.
-    local (const (bindEnv (liftFreeVariables (freeVariables . subterm) xs) env)) (eval xs)

src/Control/Monad/Effect/Fresh.hs

@@ -1,31 +0,0 @@
-{-# LANGUAGE GADTs, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
-module Control.Monad.Effect.Fresh where
-
-import Control.Effect
-import Control.Monad.Effect.Internal
-
-type TName = Int
-
--- | An effect offering a (resettable) sequence of always-incrementing, and therefore “fresh,” type variables.
-data Fresh a where
-  Reset :: TName -> Fresh () -- ^ Request a reset of the sequence of variable names.
-  Fresh :: Fresh TName       -- ^ Request a fresh variable name.
-
--- | '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 TName
-
-  -- | Reset the sequence of variable names. Useful to avoid complicated alpha-equivalence comparisons when iteratively recomputing the results of an analysis til convergence.
-  reset :: TName -> 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 :: TName) (const pure) (\ s action k -> case action of
-    Fresh -> k (succ s) s
-    Reset s' -> k s' ())

src/Control/Monad/Effect/GC.hs

@@ -1,21 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
-module Control.Monad.Effect.GC where
-
-import Prologue
-import Control.Monad.Effect
-import Control.Monad.Effect.Reader
-import Data.Abstract.Live
-import Data.Abstract.Value
-
--- | 'Monad's offering a local set of 'Live' (rooted/reachable) addresses.
-class Monad m => MonadGC a m where
-  -- | Retrieve the local 'Live' set.
-  askRoots :: m (Live (LocationFor a) a)
-
-  -- | Run a computation with the given 'Live' set added to the local root set.
-  extraRoots :: Live (LocationFor a) a -> m b -> m b
-
-instance (Ord (LocationFor a), Reader (Live (LocationFor a) a) :< fs) => MonadGC a (Eff fs) where
-  askRoots = ask :: Eff fs (Live (LocationFor a) a)
-
-  extraRoots roots' = local (<> roots')

src/Control/Monad/Effect/NonDet.hs

@@ -1,23 +0,0 @@
-{-# LANGUAGE TypeFamilies, TypeOperators, UndecidableInstances #-}
-module Control.Monad.Effect.NonDet
-( MonadNonDet(..)
-, NonDetEff
-) where
-
-import Prologue
-import Control.Monad.Effect.Internal
-import Control.Monad.Effect.NonDetEff
-
--- | 'Monad's offering local isolation of nondeterminism effects.
-class (Alternative m, Monad m) => MonadNonDet m where
-  -- | Run a computation, gathering any nondeterministically produced results into a single 'Monoid'al value.
-  gather :: Monoid b
-         => (a -> b) -- ^ A function constructing a 'Monoid'al value from a single computed result. This might typically be @point@ (for @Pointed@ functors), 'pure' (for 'Applicative's), or some similar singleton constructor.
-         -> m a      -- ^ The computation to run locally-nondeterministically.
-         -> m b      -- ^ A _deterministic_ computation producing the 'Monoid'al accumulation of the _locally-nondeterministic_ result values.
-
--- | Effect stacks containing 'NonDetEff' offer a 'MonadNonDet' instance which implements 'gather' by interpreting the requests for nondeterminism locally, without removing 'NonDetEff' from the stack—i.e. the _capacity_ for nondeterminism is still present in the effect stack, but any local nondeterminism has been applied.
-instance (NonDetEff :< fs) => MonadNonDet (Eff fs) where
-  gather f = interpose (pure . f) (\ m k -> case m of
-    MZero -> pure mempty
-    MPlus -> mappend <$> k True <*> k False)

src/Control/Monad/Effect/Trace.hs

@@ -1,17 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
-module Control.Monad.Effect.Trace where
-
-import Control.Monad.Effect
-import Control.Monad.Effect.Writer
-import Data.Abstract.Configuration
-import Data.Abstract.Value
-
--- | 'Monad's offering a writable trace of configurations.
---
---   @t@ is the type of terms, @v@ the type of values, @g@ the type of the collection represented by the log (e.g. '[]' for regular traces, or @Set@ for the trace of reachable states).
-class Monad m => MonadTrace t v g m where
-  -- | Log the given collection of configurations.
-  trace :: g (Configuration (LocationFor v) t v) -> m ()
-
-instance (Writer (g (Configuration (LocationFor v) t v)) :< fs) => MonadTrace t v g (Eff fs) where
-  trace = tell

src/Data/AST.hs

@@ -6,6 +6,11 @@ import Data.Record
 import Data.Span
 import Data.Term
 
+import Data.Aeson
+import Data.ByteString.Char8 (pack)
+import Data.JSON.Fields
+import Data.Text.Encoding (decodeUtf8)
+
 -- | An AST node labelled with symbols and source location.
 type AST syntax grammar = Term syntax (Node grammar)
 
@@ -16,6 +21,12 @@ data Node grammar = Node
   }
   deriving (Eq, Show)
 
+
+instance Show grammar => ToJSONFields (Node grammar) where
+  toJSONFields Node{..} =
+    [ "symbol" .= decodeUtf8 (pack (show nodeSymbol))
+    , "span" .= nodeSpan ]
+
 -- | A location specified as possibly-empty intervals of bytes and line/column positions.
 type Location = '[Range, Span]
 

src/Data/Abstract/Address.hs

@@ -1,43 +1,74 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeFamilyDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}
 module Data.Abstract.Address where
 
-import Prologue
 import Data.Abstract.FreeVariables
+import Data.Abstract.Module (ModuleInfo)
+import Data.Abstract.Package (PackageInfo)
+import Data.Semigroup.Reducer
+import Data.Semilattice.Lower
+import Prologue
 
--- | An abstract address with a location of @l@ pointing to a variable of type @a@.
+-- | An abstract address with a @location@ pointing to a variable of type @value@.
-newtype Address l a = Address { unAddress :: l }
+newtype Address location value = Address location
-  deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
+  deriving (Eq, Ord, Show)
 
-instance Eq l => Eq1 (Address l) where liftEq = genericLiftEq
+unAddress :: Address location value -> location
-instance Ord l => Ord1 (Address l) where liftCompare = genericLiftCompare
+unAddress (Address location) = location
-instance Show l => Show1 (Address l) where liftShowsPrec = genericLiftShowsPrec
+
+instance Eq   location => Eq1   (Address location) where liftEq          _ a b = unAddress a    ==     unAddress b
+instance Ord  location => Ord1  (Address location) where liftCompare     _ a b = unAddress a `compare` unAddress b
+instance Show location => Show1 (Address location) where liftShowsPrec _ _     = showsPrec
+
+
+class Location location where
+  -- | The type into which stored values will be written for a given location type.
+  type family Cell location :: * -> *
 
 
 -- | 'Precise' models precise store semantics where only the 'Latest' value is taken. Everything gets it's own address (always makes a new allocation) which makes for a larger store.
-newtype Precise = Precise { unPrecise :: Int }
+newtype Precise = Precise Int
   deriving (Eq, Ord, Show)
 
+instance Location Precise where
+  type Cell Precise = Latest
+
+
 -- | 'Monovariant' models using one address for a particular name. It trackes the set of values that a particular address takes and uses it's name to lookup in the store and only allocation if new.
-newtype Monovariant = Monovariant { unMonovariant :: Name }
+newtype Monovariant = Monovariant Name
   deriving (Eq, Ord, Show)
 
+instance Location Monovariant where
+  type Cell Monovariant = Set
 
--- | The type into which stored values will be written for a given location type.
+
-type family Cell l = res | res -> l where
+data Located location = Located
-  Cell Precise = Latest
+  { location        :: location
-  Cell Monovariant = Set
+  , locationPackage :: {-# UNPACK #-} !PackageInfo
+  , locationModule  :: !ModuleInfo
+  }
+  deriving (Eq, Ord, Show)
+
+instance Location (Located location) where
+  type Cell (Located location) = Cell location
 
 
 -- | A cell holding a single value. Writes will replace any prior value.
-newtype Latest a = Latest { unLatest :: a }
+--   This is isomorphic to 'Last' from Data.Monoid, but is more convenient
-  deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
+--   because it has a 'Reducer' instance.
+newtype Latest value = Latest (Maybe value)
+  deriving (Eq, Foldable, Functor, Lower, Ord, Show, Traversable)
 
-instance Semigroup (Latest a) where
+unLatest :: Latest value -> Maybe value
-  (<>) = flip const
+unLatest (Latest value) = value
 
-instance Pointed Latest where
+instance Semigroup (Latest value) where
-  point = Latest
+  a <> Latest Nothing = a
+  _ <> b              = b
 
-instance Eq1 Latest where liftEq = genericLiftEq
+-- | 'Option' semantics rather than that of 'Maybe', which is broken.
-instance Ord1 Latest where liftCompare = genericLiftCompare
+instance Monoid (Latest value) where
-instance Show1 Latest where liftShowsPrec = genericLiftShowsPrec
+  mappend = (<>)
+  mempty  = Latest Nothing
+
+instance Reducer value (Latest value) where
+  unit = Latest . Just

src/Data/Abstract/Cache.hs

@@ -1,45 +1,26 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, TypeFamilies #-}
 module Data.Abstract.Cache where
 
-import Prologue
-import Data.Abstract.Address
 import Data.Abstract.Configuration
-import Data.Abstract.Store
+import Data.Abstract.Heap
-import Data.Map as Map
+import Data.Map.Monoidal as Monoidal
+import Data.Semilattice.Lower
+import Prologue
 
--- | A map of 'Configuration's to 'Set's of resulting values & 'Store's.
+-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.
-newtype Cache l t v = Cache { unCache :: Map.Map (Configuration l t v) (Set (v, Store l v)) }
+newtype Cache term location cell value = Cache { unCache :: Monoidal.Map (Configuration term location cell value) (Set (value, Heap location cell value)) }
+  deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term location cell value, (value, Heap location cell value)), Show, Semigroup)
 
-deriving instance (Eq l, Eq t, Eq v, Eq (Cell l v)) => Eq (Cache l t v)
+type Cacheable term location cell value = (Ord (cell value), Ord location, Ord term, Ord value)
-deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Ord (Cache l t v)
-deriving instance (Show l, Show t, Show v, Show (Cell l v)) => Show (Cache l t v)
-deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Semigroup (Cache l t v)
-deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Monoid (Cache l t v)
 
--- | Look up the resulting value & 'Store' for a given 'Configuration'.
+-- | Look up the resulting value & 'Heap' for a given 'Configuration'.
-cacheLookup :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Cache l t v -> Maybe (Set (v, Store l v))
+cacheLookup :: Cacheable term location cell value => Configuration term location cell value -> Cache term location cell value -> Maybe (Set (value, Heap location cell value))
-cacheLookup key = Map.lookup key . unCache
+cacheLookup key = Monoidal.lookup key . unCache
 
--- | Set the resulting value & 'Store' for a given 'Configuration', overwriting any previous entry.
+-- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry.
-cacheSet :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Set (v, Store l v) -> Cache l t v -> Cache l t v
+cacheSet :: Cacheable term location cell value => Configuration term location cell value -> Set (value, Heap location cell value) -> Cache term location cell value -> Cache term location cell value
-cacheSet key value = Cache . Map.insert key value . unCache
+cacheSet key value = Cache . Monoidal.insert key value . unCache
 
--- | Insert the resulting value & 'Store' for a given 'Configuration', appending onto any previous entry.
+-- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry.
-cacheInsert :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> (v, Store l v) -> Cache l t v -> Cache l t v
+cacheInsert :: Cacheable term location cell value => Configuration term location cell value -> (value, Heap location cell value) -> Cache term location cell value -> Cache term location cell value
-cacheInsert key value = Cache . Map.insertWith (<>) key (point value) . unCache
+cacheInsert = curry cons
-
-
-instance (Eq l, Eq t, Eq1 (Cell l)) => Eq1 (Cache l t) where
-  liftEq eqV (Cache c1) (Cache c2) = liftEq2 (liftEq eqV) (liftEq (liftEq2 eqV (liftEq eqV))) c1 c2
-
-instance (Ord l, Ord t, Ord1 (Cell l)) => Ord1 (Cache l t) where
-  liftCompare compareV (Cache c1) (Cache c2) = liftCompare2 (liftCompare compareV) (liftCompare (liftCompare2 compareV (liftCompare compareV))) c1 c2
-
-instance (Show l, Show t, Show1 (Cell l)) => Show1 (Cache l t) where
-  liftShowsPrec spV slV d = showsUnaryWith (liftShowsPrec2 spKey slKey (liftShowsPrec spPair slPair) (liftShowList spPair slPair)) "Cache" d . unCache
-      where spKey = liftShowsPrec spV slV
-            slKey = liftShowList spV slV
-            spPair = liftShowsPrec2 spV slV spStore slStore
-            slPair = liftShowList2 spV slV spStore slStore
-            spStore = liftShowsPrec spV slV
-            slStore = liftShowList  spV slV

src/Data/Abstract/Configuration.hs

@@ -1,26 +1,14 @@
-{-# LANGUAGE DeriveFoldable, DeriveGeneric, FlexibleContexts, StandaloneDeriving, UndecidableInstances #-}
 module Data.Abstract.Configuration where
 
-import Prologue
-import Data.Abstract.Address
 import Data.Abstract.Environment
+import Data.Abstract.Heap
 import Data.Abstract.Live
-import Data.Abstract.Store
 
 -- | A single point in a program’s execution.
-data Configuration l t v
+data Configuration term location cell value = Configuration
-  = Configuration
+  { configurationTerm        :: term                       -- ^ The “instruction,” i.e. the current term to evaluate.
-    { configurationTerm :: t                      -- ^ The “instruction,” i.e. the current term to evaluate.
+  , configurationRoots       :: Live location value        -- ^ The set of rooted addresses.
-    , configurationRoots :: Live l v              -- ^ The set of rooted addresses.
+  , configurationEnvironment :: Environment location value -- ^ The environment binding any free variables in 'configurationTerm'.
-    , configurationEnvironment :: Environment l v -- ^ The environment binding any free variables in 'configurationTerm'.
+  , configurationHeap        :: Heap location cell value   -- ^ The heap of values.
-    , configurationStore :: Store l v             -- ^ The store of values.
   }
-    deriving (Generic1)
+  deriving (Eq, Ord, Show)
-
-deriving instance (Eq l, Eq t, Eq v, Eq (Cell l v)) => Eq (Configuration l t v)
-deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Ord (Configuration l t v)
-deriving instance (Show l, Show t, Show v, Show (Cell l v)) => Show (Configuration l t v)
-deriving instance (Ord l, Foldable (Cell l)) => Foldable (Configuration l t)
-instance (Eq l, Eq t, Eq1 (Cell l)) => Eq1 (Configuration l t) where liftEq = genericLiftEq
-instance (Ord l, Ord t, Ord1 (Cell l)) => Ord1 (Configuration l t) where liftCompare = genericLiftCompare
-instance (Show l, Show t, Show1 (Cell l)) => Show1 (Configuration l t) where liftShowsPrec = genericLiftShowsPrec

src/Data/Abstract/Declarations.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Data.Abstract.Declarations  where
+
+import Data.Abstract.FreeVariables
+import Data.Sum
+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 (Sum fs) where
+  liftDeclaredName f = apply @Declarations1 (liftDeclaredName f)
+
+instance Declarations1 []

src/Data/Abstract/Environment.hs

@@ -1,43 +1,145 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
-module Data.Abstract.Environment where
+module Data.Abstract.Environment
+  ( Environment(..)
+  , addresses
+  , bind
+  , delete
+  , head
+  , emptyEnv
+  , mergeEnvs
+  , mergeNewer
+  , insert
+  , lookup
+  , names
+  , overwrite
+  , pairs
+  , unpairs
+  , pop
+  , push
+  , roots
+  ) where
 
-import Prologue
+import           Prelude hiding (head, lookup)
 import           Data.Abstract.Address
 import           Data.Abstract.FreeVariables
 import           Data.Abstract.Live
+import           Data.Align
 import qualified Data.Map as Map
-import qualified Data.Set as Set
+import           Data.Semilattice.Lower
+import           GHC.Exts (IsList (..))
+import           Prologue
+import qualified Data.List.NonEmpty as NonEmpty
 
--- | A map of names to addresses that represents the evaluation environment.
+-- $setup
-newtype Environment l a = Environment { unEnvironment :: Map.Map Name (Address l a) }
+-- >>> let bright = push (insert (name "foo") (Address (Precise 0)) emptyEnv)
-  deriving (Eq, Foldable, Functor, Generic1, Monoid, Ord, Semigroup, Show, Traversable)
+-- >>> let shadowed = insert (name "foo") (Address (Precise 1)) bright
+
+-- | A LIFO stack of maps of names to addresses, representing a lexically-scoped evaluation environment.
+--   All behaviors can be assumed to be frontmost-biased: looking up "a" will check the most specific
+--   scope for "a", then the next, and so on.
+newtype Environment location value = Environment (NonEmpty (Map.Map Name location))
+  deriving (Eq, Ord, Show)
+
+unEnvironment :: Environment location value -> NonEmpty (Map.Map Name location)
+unEnvironment (Environment env) = env
+
+instance Eq   location => Eq1   (Environment location) where liftEq      _ (Environment a) (Environment b) = a == b
+instance Ord  location => Ord1  (Environment location) where liftCompare _ (Environment a) (Environment b) = a `compare` b
+instance Show location => Show1 (Environment location) where liftShowsPrec _ _ = showsPrec
+
+-- | The provided list will be put into an Environment with one member, so fromList is total
+--   (despite NonEmpty's instance being partial). Don't pass in multiple Addresses for the
+--   same Name or you violate the axiom that toList . fromList == id.
+instance IsList (Environment location value) where
+  type Item (Environment location value) = (Name, Address location value)
+  fromList xs                   = Environment (Map.fromList (second unAddress <$> xs) :| [])
+  toList (Environment (x :| _)) = second Address <$> Map.toList x
+
+mergeEnvs :: Environment location value -> Environment location value -> Environment location value
+mergeEnvs (Environment (a :| as)) (Environment (b :| bs)) =
+  Environment ((<>) a b :| alignWith (mergeThese (<>)) as bs)
+
+emptyEnv :: Environment location value
+emptyEnv = Environment (lowerBound :| [])
+
+-- | Make and enter a new empty scope in the given environment.
+push :: Environment location value -> Environment location value
+push (Environment (a :| as)) = Environment (mempty :| a : as)
+
+-- | Remove the frontmost scope.
+pop :: Environment location value -> Environment location value
+pop (Environment (_ :| []))     = emptyEnv
+pop (Environment (_ :| a : as)) = Environment (a :| as)
+
+-- | Drop all scopes save for the frontmost one.
+head :: Environment location value -> Environment location value
+head (Environment (a :| _)) = Environment (a :| [])
+
+-- | Take the union of two environments. When duplicate keys are found in the
+--   name to address map, the second definition wins.
+mergeNewer :: Environment location value -> Environment location value -> Environment location value
+mergeNewer (Environment a) (Environment b) =
+    Environment (NonEmpty.fromList . reverse $ alignWith (mergeThese combine) (reverse as) (reverse bs))
+    where
+      combine = Map.unionWith (flip const)
+      as = NonEmpty.toList a
+      bs = NonEmpty.toList b
+
+-- | Extract an association list of bindings from an 'Environment'.
+--
+-- >>> pairs shadowed
+-- [(Name {unName = "foo"},Address (Precise 1))]
+pairs :: Environment location value -> [(Name, Address location value)]
+pairs = map (second Address) . Map.toList . fold . unEnvironment
+
+unpairs :: [(Name, Address location value)] -> Environment location value
+unpairs = fromList
 
 -- | Lookup a 'Name' in the environment.
-envLookup :: Name -> Environment l a -> Maybe (Address l a)
+--
-envLookup k = Map.lookup k . unEnvironment
+-- >>> lookup (name "foo") shadowed
+-- Just (Address (Precise 1))
+lookup :: Name -> Environment location value -> Maybe (Address location value)
+lookup k = fmap Address . foldMapA (Map.lookup k) . unEnvironment
 
 -- | Insert a 'Name' in the environment.
-envInsert :: Name -> Address l a -> Environment l a -> Environment l a
+insert :: Name -> Address location value -> Environment location value -> Environment location value
-envInsert name value (Environment m) = Environment (Map.insert name value m)
+insert name (Address value) (Environment (a :| as)) = Environment (Map.insert name value a :| as)
 
-envUnion :: Environment l a -> Environment l a -> Environment l a
+-- | Remove a 'Name' from the environment.
-envUnion (Environment e1) (Environment e2) = Environment $ Map.union e1 e2
+--
+-- >>> delete (name "foo") shadowed
+-- Environment (fromList [] :| [])
+delete :: Name -> Environment location value -> Environment location value
+delete name = trim . Environment . fmap (Map.delete name) . unEnvironment
 
-bindEnv :: (Show l, Show (t Name), Ord l, Foldable t) => t Name -> Environment l a -> Environment l a
+trim :: Environment location value -> Environment location value
-bindEnv names env = Environment (Map.fromList pairs)
+trim (Environment (a :| as)) = Environment (a :| filtered)
-  where pairs = foldr (\name b -> maybe b (\v -> (name, v) : b) (envLookup name env)) mempty names
+  where filtered = filter (not . Map.null) as
+
+bind :: Foldable t => t Name -> Environment location value -> Environment location value
+bind names env = fromList (mapMaybe lookupName (Prologue.toList names))
+  where
+    lookupName name = (,) name <$> lookup name env
+
+-- | Get all bound 'Name's in an environment.
+names :: Environment location value -> [Name]
+names = fmap fst . pairs
+
+-- | Lookup and alias name-value bindings from an environment.
+overwrite :: [(Name, Name)] -> Environment location value -> Environment location value
+overwrite pairs env = fromList $ mapMaybe lookupAndAlias pairs
+  where
+    lookupAndAlias (oldName, newName) = (,) newName <$> lookup oldName env
 
 -- | Retrieve the 'Live' set of addresses to which the given free variable names are bound.
 --
 --   Unbound names are silently dropped.
-envRoots :: (Ord l, Foldable t) => Environment l a -> t Name -> Live l a
+roots :: (Ord location, Foldable t) => Environment location value -> t Name -> Live location value
-envRoots env = foldr ((<>) . maybe mempty liveSingleton . flip envLookup env) mempty
+roots env = foldMap (maybe mempty liveSingleton . flip lookup env)
 
-envAll :: (Ord l) => Environment l a -> Live l a
+addresses :: Ord location => Environment location value -> Live location value
-envAll (Environment env) = Live $ Set.fromList (Map.elems env)
+addresses = fromAddresses . map snd . pairs
 
--- Instances
 
-instance Eq l => Eq1 (Environment l) where liftEq = genericLiftEq
+instance Lower (Environment location value) where lowerBound = emptyEnv
-instance Ord l => Ord1 (Environment l) where liftCompare = genericLiftCompare
-instance Show l => Show1 (Environment l) where liftShowsPrec = genericLiftShowsPrec

src/Data/Abstract/Evaluatable.hs

@@ -0,0 +1,257 @@
+{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
+module Data.Abstract.Evaluatable
+( module X
+, Evaluatable(..)
+, Unspecialized(..)
+, runUnspecialized
+, runUnspecializedWith
+, EvalError(..)
+, runEvalError
+, runEvalErrorWith
+, evaluateInScopedEnv
+, evaluatePackageWith
+, throwEvalError
+, traceResolve
+, builtin
+, isolate
+, Modules
+) where
+
+import Control.Abstract as X hiding (Goto(..), LoopControl(..), Modules(..), Return(..))
+import Control.Abstract.Evaluator (LoopControl, Return(..))
+import Control.Abstract.Goto (Goto(..))
+import Control.Abstract.Modules (Modules(..))
+import Data.Abstract.Declarations as X
+import Data.Abstract.Environment as X
+import Data.Abstract.Exports as Exports
+import Data.Abstract.FreeVariables as X
+import Data.Abstract.Module
+import Data.Abstract.ModuleTable as ModuleTable
+import Data.Abstract.Package as Package
+import Data.ByteString.Char8 (pack, unpack)
+import Data.Scientific (Scientific)
+import Data.Semigroup.App
+import Data.Semigroup.Foldable
+import Data.Semigroup.Reducer hiding (unit)
+import Data.Semilattice.Lower
+import Data.Sum
+import Data.Term
+import Prologue
+
+-- | 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 :: ( EvaluatableConstraints location term value effects
+          , Member Fail effects
+          )
+       => SubtermAlgebra constr term (Evaluator location value effects value)
+  default eval :: (Member (Resumable (Unspecialized value)) effects, Show1 constr) => SubtermAlgebra constr term (Evaluator location value effects value)
+  eval expr = throwResumable (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
+
+type EvaluatableConstraints location term value effects =
+  ( AbstractValue location value effects
+  , Addressable location effects
+  , Declarations term
+  , FreeVariables term
+  , Members '[ LoopControl value
+             , Modules location value
+             , Reader (Environment location value)
+             , Reader ModuleInfo
+             , Reader PackageInfo
+             , Reader Span
+             , Resumable (AddressError location value)
+             , Resumable (EnvironmentError value)
+             , Resumable (EvalError value)
+             , Resumable ResolutionError
+             , Resumable (Unspecialized value)
+             , Return value
+             , State (Environment location value)
+             , State (Exports location value)
+             , State (Heap location (Cell location) value)
+             , Trace
+             ] effects
+  , Reducer value (Cell location value)
+  )
+
+
+-- | The type of error thrown when failing to evaluate a term.
+data EvalError value resume where
+  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
+
+runEvalError :: Evaluator location value (Resumable (EvalError value) ': effects) a -> Evaluator location value effects (Either (SomeExc (EvalError value)) a)
+runEvalError = runResumable
+
+runEvalErrorWith :: (forall resume . EvalError value resume -> Evaluator location value effects resume) -> Evaluator location value (Resumable (EvalError value) ': effects) a -> Evaluator location value effects a
+runEvalErrorWith = runResumableWith
+
+-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
+--   Throws an 'EnvironmentLookupError' if @scopedEnvTerm@ does not have an environment.
+evaluateInScopedEnv :: ( AbstractValue location value effects
+                       , Members '[ Resumable (EvalError value)
+                                  , State (Environment location value)
+                                  ] effects
+                       )
+                    => Evaluator location value effects value
+                    -> Evaluator location value effects value
+                    -> Evaluator location value effects value
+evaluateInScopedEnv scopedEnvTerm term = do
+  value <- scopedEnvTerm
+  scopedEnv <- scopedEnvironment value
+  maybe (throwEvalError (EnvironmentLookupError value)) (flip localEnv term . mergeEnvs) scopedEnv
+
+deriving instance Eq a => Eq (EvalError a b)
+deriving instance Show a => Show (EvalError a b)
+instance Show value => Show1 (EvalError value) where
+  liftShowsPrec _ _ = showsPrec
+instance Eq term => Eq1 (EvalError term) where
+  liftEq _ (FreeVariablesError a) (FreeVariablesError b)   = a == b
+  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
+
+
+throwEvalError :: Member (Resumable (EvalError value)) effects => EvalError value resume -> Evaluator location value effects resume
+throwEvalError = throwResumable
+
+
+data Unspecialized a b where
+  Unspecialized :: Prelude.String -> Unspecialized value value
+
+instance Eq1 (Unspecialized a) where
+  liftEq _ (Unspecialized a) (Unspecialized b) = a == b
+
+deriving instance Eq (Unspecialized a b)
+deriving instance Show (Unspecialized a b)
+instance Show1 (Unspecialized a) where
+  liftShowsPrec _ _ = showsPrec
+
+runUnspecialized :: Evaluator location value (Resumable (Unspecialized value) ': effects) a -> Evaluator location value effects (Either (SomeExc (Unspecialized value)) a)
+runUnspecialized = runResumable
+
+runUnspecializedWith :: (forall resume . Unspecialized value resume -> Evaluator location value effects resume) -> Evaluator location value (Resumable (Unspecialized value) ': effects) a -> Evaluator location value effects a
+runUnspecializedWith = runResumableWith
+
+
+-- Instances
+
+-- | If we can evaluate any syntax which can occur in a 'Sum', we can evaluate the 'Sum'.
+instance Apply Evaluatable fs => Evaluatable (Sum fs) where
+  eval = apply @Evaluatable eval
+
+-- | Evaluating a 'TermF' ignores its annotation, evaluating the underlying syntax.
+instance Evaluatable s => Evaluatable (TermF s a) where
+  eval = eval . termFOut
+
+--- | '[]' is treated as an imperative sequence of statements/declarations s.t.:
+---
+---   1. Each statement’s effects on the store are accumulated;
+---   2. Each statement can affect the environment of later statements (e.g. by 'modify'-ing the environment); and
+---   3. Only the last statement’s return value is returned.
+instance Evaluatable [] where
+  -- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists.
+  eval = maybe unit (runApp . foldMap1 (App . subtermValue)) . nonEmpty
+
+
+traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator location value effects ()
+traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
+
+
+builtin :: ( Addressable location effects
+           , HasCallStack
+           , Members '[ Reader (Environment location value)
+                      , Reader ModuleInfo
+                      , Reader Span
+                      , State (Environment location value)
+                      , State (Heap location (Cell location) value)
+                      ] effects
+           , Reducer value (Cell location value)
+           )
+        => String
+        -> Evaluator location value effects value
+        -> Evaluator location value effects ()
+builtin n def = withCurrentCallStack callStack $ do
+  let name = X.name ("__semantic_" <> pack n)
+  addr <- alloc name
+  modifyEnv (X.insert name addr)
+  def >>= assign addr
+
+-- | Evaluate a given package.
+evaluatePackageWith :: forall location term value inner inner' outer
+                    .  ( Evaluatable (Base term)
+                       , EvaluatableConstraints location term value inner
+                       , Members '[ Fail
+                                  , Fresh
+                                  , Reader (Environment location value)
+                                  , Resumable (LoadError location value)
+                                  , State (Environment location value)
+                                  , State (Exports location value)
+                                  , State (ModuleTable (Maybe (Environment location value, value)))
+                                  , Trace
+                                  ] outer
+                       , Recursive term
+                       , inner ~ (Goto inner' value ': inner')
+                       , inner' ~ (LoopControl value ': Return value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer)
+                       )
+                    => (SubtermAlgebra Module      term (Evaluator location value inner value) -> SubtermAlgebra Module      term (Evaluator location value inner value))
+                    -> (SubtermAlgebra (Base term) term (Evaluator location value inner value) -> SubtermAlgebra (Base term) term (Evaluator location value inner value))
+                    -> Package term
+                    -> Evaluator location value outer [value]
+evaluatePackageWith analyzeModule analyzeTerm package
+  = runReader (packageInfo package)
+  . runReader lowerBound
+  . fmap fst
+  . runState (lowerBound :: Gotos location value (Reader Span ': Reader PackageInfo ': outer))
+  . runReader (packageModules (packageBody package))
+  . runModules evalModule
+  . withPrelude (packagePrelude (packageBody package))
+  $ traverse (uncurry evaluateEntryPoint) (ModuleTable.toPairs (packageEntryPoints (packageBody package)))
+  where evalModule m
+          = pairValueWithEnv
+          . runInModule (moduleInfo m)
+          . analyzeModule (subtermValue . moduleBody)
+          $ fmap (Subterm <*> foldSubterms (analyzeTerm eval)) m
+
+        runInModule info
+          = runReader info
+          . runReturn
+          . runLoopControl
+          . runGoto Gotos getGotos
+
+        evaluateEntryPoint :: ModulePath -> Maybe Name -> Evaluator location value (Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer) value
+        evaluateEntryPoint m sym = runInModule (ModuleInfo m) $ do
+          v <- maybe unit (pure . snd) <$> require m
+          maybe v ((`call` []) <=< variable) sym
+
+        withPrelude Nothing a = a
+        withPrelude (Just prelude) a = do
+          _ <- runInModule moduleInfoFromCallStack $ do
+            builtin "print" (closure ["s"] lowerBound (variable "s" >>= asString >>= trace . unpack >> unit))
+            unit
+          preludeEnv <- fst <$> evalModule prelude
+          withDefaultEnvironment preludeEnv a
+
+        -- 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
+        -- languages. We need better semantics rather than doing it ad-hoc.
+        filterEnv ports env
+          | Exports.null ports = env
+          | otherwise          = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env
+        pairValueWithEnv action = flip (,) <$> action <*> (filterEnv <$> getExports <*> getEnv)
+
+newtype Gotos location value outer = Gotos { getGotos :: GotoTable (LoopControl value ': Return value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value outer) ': outer) value }
+  deriving (Lower)
+
+
+-- | Isolate the given action with an empty global environment and exports.
+isolate :: Members '[State (Environment location value), State (Exports location value)] effects => Evaluator location value effects a -> Evaluator location value effects a
+isolate = withEnv lowerBound . withExports lowerBound

src/Data/Abstract/Exports.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Data.Abstract.Exports
+    ( Exports
+    , aliases
+    , insert
+    , null
+    , toEnvironment
+    ) where
+
+import Prelude hiding (null)
+import Prologue hiding (null)
+import Data.Abstract.Address
+import Data.Abstract.Environment (Environment, unpairs)
+import Data.Abstract.FreeVariables
+import qualified Data.Map as Map
+import Data.Semilattice.Lower
+
+-- | A map of export names to an alias & address tuple.
+newtype Exports location value = Exports (Map.Map Name (Name, Maybe (Address location value)))
+  deriving (Eq, Lower, Monoid, Ord, Semigroup, Show)
+
+unExports :: Exports location value -> Map.Map Name (Name, Maybe (Address location value))
+unExports (Exports exports) = exports
+
+null :: Exports location value -> Bool
+null = Map.null . unExports
+
+toEnvironment :: Exports location value -> Environment location value
+toEnvironment exports = unpairs (mapMaybe collectExport (toList (unExports exports)))
+  where
+    collectExport (_, Nothing) = Nothing
+    collectExport (n, Just value)  = Just (n, value)
+
+insert :: Name -> Name -> Maybe (Address location value) -> Exports location value -> Exports location value
+insert name alias address = Exports . Map.insert name (alias, address) . unExports
+
+-- TODO: Should we filter for duplicates here?
+aliases :: Exports location value -> [(Name, Name)]
+aliases = Map.toList . fmap fst . unExports

src/Data/Abstract/FreeVariables.hs

@@ -1,17 +1,27 @@
 {-# LANGUAGE DefaultSignatures, UndecidableInstances #-}
 module Data.Abstract.FreeVariables where
 
-import Prologue
+import qualified Data.ByteString.Char8 as BC
+import           Data.String
+import           Data.Sum
 import           Data.Term
+import           Prologue
 
 -- | The type of variable names.
-type Name = ByteString
+newtype Name = Name { unName :: ByteString }
+  deriving (Eq, Ord, Show)
+
+name :: ByteString -> Name
+name = Name
+
+instance IsString Name where
+  fromString = Name . BC.pack
 
 
 -- | Types which can contain unbound variables.
 class FreeVariables term where
   -- | The set of free variables in the given value.
-  freeVariables :: term -> Set Name
+  freeVariables :: term -> [Name]
 
 
 -- | A lifting of 'FreeVariables' to type constructors of kind @* -> *@.
@@ -19,14 +29,21 @@ class FreeVariables term where
 --   'Foldable' types requiring no additional semantics to the set of free variables (e.g. types which do not bind any variables) can use (and even derive, with @-XDeriveAnyClass@) the default implementation.
 class FreeVariables1 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.
-  liftFreeVariables :: (a -> Set Name) -> syntax a -> Set Name
+  liftFreeVariables :: (a -> [Name]) -> syntax a -> [Name]
-  default liftFreeVariables :: (Foldable syntax) => (a -> Set Name) -> syntax a -> Set Name
+  default liftFreeVariables :: (Foldable syntax) => (a -> [Name]) -> syntax a -> [Name]
   liftFreeVariables = foldMap
 
 -- | Lift the 'freeVariables' method through a containing structure.
-freeVariables1 :: (FreeVariables1 t, FreeVariables a) => t a -> Set Name
+freeVariables1 :: (FreeVariables1 t, FreeVariables a) => t a -> [Name]
 freeVariables1 = liftFreeVariables freeVariables
 
+freeVariable :: FreeVariables term => term -> Either [Name] Name
+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)
@@ -34,7 +51,7 @@ instance (FreeVariables1 syntax, Functor syntax) => FreeVariables (Term syntax a
 instance (FreeVariables1 syntax) => FreeVariables1 (TermF syntax ann) where
   liftFreeVariables f (In _ s) = liftFreeVariables f s
 
-instance (Apply FreeVariables1 fs) => FreeVariables1 (Union fs) where
+instance (Apply FreeVariables1 fs) => FreeVariables1 (Sum fs) where
-  liftFreeVariables f = apply (Proxy :: Proxy FreeVariables1) (liftFreeVariables f)
+  liftFreeVariables f = apply @FreeVariables1 (liftFreeVariables f)
 
 instance FreeVariables1 []

src/Data/Abstract/Heap.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Data.Abstract.Heap where
+
+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 location cell value = Heap (Monoidal.Map location (cell value))
+  deriving (Eq, Foldable, Functor, Lower, Monoid, Ord, Semigroup, Show, Traversable)
+
+unHeap :: Heap location cell value -> Monoidal.Map location (cell value)
+unHeap (Heap heap) = heap
+
+deriving instance (Ord location, Reducer value (cell value)) => Reducer (location, value) (Heap location cell value)
+
+-- | Look up the cell of values for an 'Address' in a 'Heap', if any.
+heapLookup :: Ord location => Address location value -> Heap location cell value -> Maybe (cell value)
+heapLookup (Address address) = Monoidal.lookup address . unHeap
+
+-- | Look up the list of values stored for a given address, if any.
+heapLookupAll :: (Ord location, Foldable cell) => Address location value -> Heap location cell value -> Maybe [value]
+heapLookupAll address = fmap toList . heapLookup address
+
+-- | Append a value onto the cell for a given address, inserting a new cell if none existed.
+heapInsert :: (Ord location, Reducer value (cell value)) => Address location value -> value -> Heap location cell value -> Heap location cell value
+heapInsert (Address address) value = flip snoc (address, value)
+
+-- | Manually insert a cell into the heap at a given address.
+heapInit :: Ord location => Address location value -> cell value -> Heap location cell value -> Heap location cell value
+heapInit (Address address) cell (Heap h) = Heap (Monoidal.insert address cell h)
+
+-- | The number of addresses extant in a 'Heap'.
+heapSize :: Heap location cell value -> Int
+heapSize = Monoidal.size . unHeap
+
+-- | Restrict a 'Heap' to only those 'Address'es in the given 'Live' set (in essence garbage collecting the rest).
+heapRestrict :: Ord location => Heap location cell value -> Live location value -> Heap location cell value
+heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> Address address `liveMember` roots) m)

src/Data/Abstract/Linker.hs

@@ -1,16 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Data.Abstract.Linker where
-
-import Data.Semigroup
-import GHC.Generics
-import qualified Data.Map as Map
-
-
-newtype Linker a = Linker { unLinker :: Map.Map FilePath a }
-  deriving (Eq, Foldable, Functor, Generic1, Monoid, Ord, Semigroup, Show, Traversable)
-
-linkerLookup :: FilePath -> Linker a -> Maybe a
-linkerLookup k = Map.lookup k . unLinker
-
-linkerInsert :: FilePath -> a -> Linker a -> Linker a
-linkerInsert k v Linker{..} = Linker (Map.insert k v unLinker)

src/Data/Abstract/Live.hs

@@ -1,60 +1,38 @@
 {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-}
 module Data.Abstract.Live where
 
-import Prologue
 import Data.Abstract.Address
+import Data.Semilattice.Lower
 import Data.Set as Set
-import Unsafe.Coerce
+import Prologue
 
 -- | A set of live addresses (whether roots or reachable).
-newtype Live l v = Live { unLive :: Set (Address l v) }
+newtype Live location value = Live { unLive :: Set location }
-  deriving (Eq, Foldable, Monoid, Ord, Semigroup, Show)
+  deriving (Eq, Lower, Monoid, Ord, Semigroup, Show)
+
+fromAddresses :: (Foldable t, Ord location) => t (Address location value) -> Live location value
+fromAddresses = Prologue.foldr liveInsert lowerBound
 
 -- | Construct a 'Live' set containing only the given address.
-liveSingleton :: Address l v -> Live l v
+liveSingleton :: Address location value -> Live location value
-liveSingleton = Live . Set.singleton
+liveSingleton = Live . Set.singleton . unAddress
 
 -- | Insert an address into a 'Live' set.
-liveInsert :: Ord l => Address l v -> Live l v -> Live l v
+liveInsert :: Ord location => Address location value -> Live location value -> Live location value
-liveInsert addr = Live . Set.insert addr . unLive
+liveInsert addr = Live . Set.insert (unAddress addr) . unLive
 
 -- | Delete an address from a 'Live' set, if present.
-liveDelete :: Ord l => Address l v -> Live l v -> Live l v
+liveDelete :: Ord location => Address location value -> Live location value -> Live location value
-liveDelete addr = Live . Set.delete addr . unLive
+liveDelete addr = Live . Set.delete (unAddress addr) . unLive
 
 -- | Compute the (asymmetric) difference of two 'Live' sets, i.e. delete every element of the second set from the first set.
-liveDifference :: Ord l => Live l v -> Live l v -> Live l v
+liveDifference :: Ord location => Live location value -> Live location value -> Live location value
 liveDifference = fmap Live . (Set.difference `on` unLive)
 
 -- | Test whether an 'Address' is in a 'Live' set.
-liveMember :: Ord l => Address l v -> Live l v -> Bool
+liveMember :: Ord location => Address location value -> Live location value -> Bool
-liveMember addr = Set.member addr . unLive
+liveMember addr = Set.member (unAddress addr) . unLive
 
 -- | Decompose a 'Live' set into a pair of one member address and the remaining set, or 'Nothing' if empty.
-liveSplit :: Ord l => Live l v -> Maybe (Address l v, Live l v)
+liveSplit :: Live location value -> Maybe (Address location value, Live location value)
-liveSplit = fmap (second Live) . Set.minView . unLive
+liveSplit = fmap (bimap Address Live) . Set.minView . unLive
-
-
-instance Generic1 (Live l) where
-  type Rep1 (Live l)
-    = D1
-        ('MetaData "Live" "Data.Abstract.Live" "main" 'True)
-        (C1
-           ('MetaCons "Live" 'PrefixI 'True)
-           (S1
-              ('MetaSel
-                 ('Just "unLive")
-                 'NoSourceUnpackedness
-                 'NoSourceStrictness
-                 'DecidedLazy)
-              (Set :.: Rec1 (Address l))))
-  -- NB: The value type @v@ in @'Address' l v@ is phantom; 'compare'ing 'Address'es is based solely on the location type @l@. Thus, we can safely coerce the values in the 'Set' without worrying about changing its shape. However, 'Set.map' would require that we add an extra 'Ord' constraint since it needs to account for the possibility of changing the shape of the set; so we use 'unsafeCoerce' to circumvent that possibility.
-  to1 = Live . unsafeCoerce . unComp1 . unM1 . unM1 . unM1
-  from1 = M1 . M1 . M1 . Comp1 . unsafeCoerce . unLive
-
-instance Ord l => Functor (Live l) where
-  fmap _ = Live . unsafeCoerce . unLive
-
-instance Eq l => Eq1 (Live l) where liftEq = genericLiftEq
-instance Ord l => Ord1 (Live l) where liftCompare = genericLiftCompare
-instance Show l => Show1 (Live l) where liftShowsPrec = genericLiftShowsPrec

src/Data/Abstract/Module.hs

@@ -0,0 +1,42 @@
+module Data.Abstract.Module
+( Module(..)
+, moduleForBlob
+, ModulePath
+, ModuleInfo(..)
+, moduleInfoFromSrcLoc
+, moduleInfoFromCallStack
+) where
+
+import Data.Blob
+import GHC.Stack
+import Prologue
+import System.FilePath.Posix
+
+data Module term = Module { moduleInfo :: ModuleInfo, moduleBody :: term }
+  deriving (Eq, Foldable, Functor, Ord, Traversable)
+
+instance Show (Module term) where
+  showsPrec _ Module{..} = shows moduleInfo
+
+
+-- | Construct a 'Module' for a 'Blob' and @term@, relative to some root 'FilePath'.
+moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the module will be resolved, if any.
+              -> Blob           -- ^ The 'Blob' containing the module.
+              -> 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 root = fromMaybe (takeDirectory blobPath) rootDir
+        info = ModuleInfo (makeRelative root blobPath)
+
+
+type ModulePath = FilePath
+
+newtype ModuleInfo = ModuleInfo { modulePath :: ModulePath }
+  deriving (Eq, Ord, Show)
+
+moduleInfoFromSrcLoc :: SrcLoc -> ModuleInfo
+moduleInfoFromSrcLoc = ModuleInfo . srcLocModule
+
+-- | Produce 'ModuleInfo' from the top location on the Haskell call stack (i.e. the file where the call to 'moduleInfoFromCallStack' was made).
+moduleInfoFromCallStack :: HasCallStack => ModuleInfo
+moduleInfoFromCallStack = maybe (ModuleInfo "?") (moduleInfoFromSrcLoc . snd) (listToMaybe (getCallStack callStack))

src/Data/Abstract/ModuleTable.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Data.Abstract.ModuleTable
+( ModulePath
+, ModuleTable (..)
+, singleton
+, lookup
+, member
+, modulePathsInDir
+, insert
+, keys
+, fromModules
+, toPairs
+) 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 (Map.Map ModulePath a)
+  deriving (Eq, Foldable, Functor, Generic1, Lower, Monoid, Ord, Semigroup, Show, Traversable)
+
+unModuleTable :: ModuleTable a -> Map.Map ModulePath a
+unModuleTable (ModuleTable table) = table
+
+singleton :: ModulePath -> a -> ModuleTable a
+singleton name = ModuleTable . Map.singleton name
+
+modulePathsInDir :: FilePath -> ModuleTable a -> [ModulePath]
+modulePathsInDir k = filter (\e -> k == takeDirectory e) . Map.keys . unModuleTable
+
+lookup :: ModulePath -> ModuleTable a -> Maybe a
+lookup k = Map.lookup k . unModuleTable
+
+member :: ModulePath -> ModuleTable a -> Bool
+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 = ModuleTable (Map.fromListWith (<>) (map toEntry modules))
+  where toEntry m = (modulePath (moduleInfo m), [m])
+
+toPairs :: ModuleTable a -> [(ModulePath, a)]
+toPairs = Map.toList . unModuleTable

src/Data/Abstract/Number.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE GADTs, StandaloneDeriving, Rank2Types #-}
+
+module Data.Abstract.Number
+    ( Number (..)
+    , SomeNumber (..)
+    , liftReal
+    , liftIntegralFrac
+    , liftedExponent
+    , liftedFloorDiv
+    ) where
+
+import Data.Scientific
+import qualified Prelude
+import Prelude hiding (Integer)
+import Prologue
+
+-- | A generalized number type that unifies all interpretable numeric types.
+--   This is a GADT, so you can specialize the 'a' parameter and be confident
+--   that, say, a @Number Scientific@ contains a 'Scientific' and not an integer
+--   in disguise. This unified type is used to provide mathematical operations
+--   that can change their representation based on an operation's operands—e.g.
+--   raising a rational number to a ratio may not produce another rational number.
+--   This also neatly encapsulates the "coalescing" behavior of adding numbers
+--   of different type in dynamic languages: operating on a whole and a rational
+--   produces a rational, operating on a rational and a decimal produces a decimal,
+--   and so on and so forth. When we add complex numbers, they will in turn subsume
+--   the other numeric types.
+data Number a where
+  Integer :: !Prelude.Integer  -> Number Prelude.Integer
+  Ratio   :: !Prelude.Rational -> Number Prelude.Rational
+  Decimal :: !Scientific       -> Number Scientific
+
+deriving instance Eq a => Eq (Number a)
+
+instance Show (Number a) where
+  show (Integer i) = show i
+  show (Ratio r) = show r
+  show (Decimal d) = show d
+
+-- | Every 'Number' can be coerced to a 'Scientific'. Used in the 'Ord' instance.
+toScientific :: Number a -> Scientific
+toScientific (Integer i) = fromInteger i
+toScientific (Ratio r) = fromRational r
+toScientific (Decimal s) = s
+
+instance Eq a => Ord (Number a) where compare = compare `on` toScientific
+
+-- | A box that hides the @a@ parameter to a given 'Number'. Pattern-match
+--   on it to extract the information contained; because there are only three
+--   possible constructors, pattern-matching all three cases is possible.
+data SomeNumber = forall a . SomeNumber (Number a)
+
+-- | Smart constructors for 'SomeNumber'.
+whole :: Prelude.Integer -> SomeNumber
+whole = SomeNumber . Integer
+
+ratio :: Prelude.Rational -> SomeNumber
+ratio = SomeNumber . Ratio
+
+decim :: Scientific -> SomeNumber
+decim = SomeNumber . Decimal
+
+-- | In order to provide truly generic math operations, where functions like
+--   exponentiation handle the fact that they are not closed over the rational
+--   numbers, we must promote standard Haskell math functions from operations
+--   on 'Real', 'Integral', and 'Fractional' numbers into functions that operate
+--   on two 'Number' values and return a temporarily-indeterminate 'SomeNumber'
+--   value. At the callsite, we can then unwrap the 'SomeNumber' and handle the
+--   specific cases.
+--
+--   Promote a function on 'Real' values into one operating on 'Number's.
+--   You pass things like @+@ and @-@ here.
+liftReal :: (forall n . Real n => n -> n -> n)
+         -> (Number a -> Number b -> SomeNumber)
+liftReal f = liftIntegralFrac f f
+
+-- | Promote two functions, one on 'Integral' and one on 'Fractional' and 'Real' values,
+--   to operate on 'Numbers'. Examples of this: 'mod' and 'mod'', 'div' and '/'.
+liftIntegralFrac :: (forall n . Integral n             => n -> n -> n)
+                 -> (forall f . (Fractional f, Real f) => f -> f -> f)
+                 -> (Number a -> Number b -> SomeNumber)
+liftIntegralFrac f _ (Integer i) (Integer j) = whole (f i j)
+liftIntegralFrac _ g (Integer i) (Ratio j)   = ratio (g (toRational i) j)
+liftIntegralFrac _ g (Integer i) (Decimal j) = decim (g (fromIntegral i) j)
+liftIntegralFrac _ g (Ratio i) (Ratio j)     = ratio (g i j)
+liftIntegralFrac _ g (Ratio i) (Integer j)   = ratio (g i (fromIntegral j))
+liftIntegralFrac _ g (Ratio i) (Decimal j)   = decim (g (fromRational i) j)
+liftIntegralFrac _ g (Decimal i) (Integer j) = decim (g i (fromIntegral j))
+liftIntegralFrac _ g (Decimal i) (Ratio j)   = decim (g i (fromRational j))
+liftIntegralFrac _ g (Decimal i) (Decimal j) = decim (g i j)
+
+-- | Exponential behavior is too hard to generalize, so here's a manually implemented version.
+--   TODO: Given a 'Ratio' raised to some 'Integer', we could check to see if it's an integer
+--   and round it before the exponentiation, giving back a 'Integer'.
+liftedExponent :: Number a -> Number b -> SomeNumber
+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/Package.hs

@@ -0,0 +1,40 @@
+{-# 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
+
+-- | Metadata for a package (name and version).
+data PackageInfo = PackageInfo
+  { packageName    :: PackageName
+  , packageVersion :: Maybe Version
+  }
+  deriving (Eq, Ord, Show)
+
+newtype Version = Version { versionString :: String }
+  deriving (Eq, Ord, Show)
+
+data PackageBody term = PackageBody
+  { packageModules     :: ModuleTable [Module term]
+  , packagePrelude     :: Maybe (Module term)
+  , packageEntryPoints :: ModuleTable (Maybe Name)
+  }
+  deriving (Eq, Functor, Ord, Show)
+
+
+-- | A package represents the unit of dependency, i.e. something which can depend upon, or be depended upon by, other packages. Packages have modules and may have entry points from which evaluation can proceed.
+data Package term = Package
+  { packageInfo :: PackageInfo
+  , packageBody :: PackageBody term
+  }
+  deriving (Eq, Functor, Ord, Show)
+
+fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> Int -> [Module term] -> Package term
+fromModules name version prelude entryPoints modules =
+  Package (PackageInfo name version) (PackageBody (ModuleTable.fromModules modules) prelude entryPoints')
+  where
+    entryPoints' = ModuleTable . Map.fromList $ (,Nothing) . modulePath . moduleInfo <$> if entryPoints == 0 then modules else take entryPoints modules

src/Data/Abstract/Path.hs

@@ -0,0 +1,26 @@
+module Data.Abstract.Path where
+
+import Prologue
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString as B
+import System.FilePath.Posix
+
+-- | Join two paths a and b. Handles walking up relative directories in b. e.g.
+--
+--     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 (== '.')

src/Data/Abstract/Store.hs

@@ -1,41 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, UndecidableInstances #-}
-module Data.Abstract.Store where
-
-import Prologue
-import Data.Abstract.Address
-import Data.Abstract.Live
-import qualified Data.Map as Map
-
--- | A map of addresses onto cells holding their values.
-newtype Store l a = Store { unStore :: Map.Map l (Cell l a) }
-  deriving (Generic1, Monoid, Semigroup)
-
-deriving instance (Eq l, Eq (Cell l a)) => Eq (Store l a)
-deriving instance (Ord l, Ord (Cell l a)) => Ord (Store l a)
-deriving instance (Show l, Show (Cell l a)) => Show (Store l a)
-instance (Eq l, Eq1 (Cell l)) => Eq1 (Store l) where liftEq = genericLiftEq
-instance (Ord l, Ord1 (Cell l)) => Ord1 (Store l) where liftCompare = genericLiftCompare
-instance (Show l, Show1 (Cell l)) => Show1 (Store l) where liftShowsPrec = genericLiftShowsPrec
-deriving instance Foldable (Cell l) => Foldable (Store l)
-deriving instance Functor (Cell l) => Functor (Store l)
-deriving instance Traversable (Cell l) => Traversable (Store l)
-
--- | Look up the cell of values for an 'Address' in a 'Store', if any.
-storeLookup :: Ord l => Address l a -> Store l a -> Maybe (Cell l a)
-storeLookup (Address address) = Map.lookup address . unStore
-
--- | Look up the list of values stored for a given address, if any.
-storeLookupAll :: (Ord l, Foldable (Cell l)) => Address l a -> Store l a -> Maybe [a]
-storeLookupAll address = fmap toList . storeLookup address
-
--- | Append a value onto the cell for a given address, inserting a new cell if none existed.
-storeInsert :: (Ord l, Semigroup (Cell l a), Pointed (Cell l)) => Address l a -> a -> Store l a -> Store l a
-storeInsert (Address address) value = Store . Map.insertWith (<>) address (point value) . unStore
-
--- | The number of addresses extant in a 'Store'.
-storeSize :: Store l a -> Int
-storeSize = Map.size . unStore
-
--- | Restrict a 'Store' to only those 'Address'es in the given 'Live' set (in essence garbage collecting the rest).
-storeRestrict :: Ord l => Store l a -> Live l a -> Store l a
-storeRestrict (Store m) roots = Store (Map.filterWithKey (\ address _ -> Address address `liveMember` roots) m)

src/Data/Abstract/Type.hs

@@ -1,33 +1,170 @@
-module Data.Abstract.Type where
+{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, UndecidableInstances #-}
+module Data.Abstract.Type
+  ( Type (..)
+  , TypeError (..)
+  , runTypeError
+  , unify
+  ) where
 
-import Prologue
+import Control.Abstract
+import Data.Abstract.Environment as Env
 import Data.Align (alignWith)
-import Prelude hiding (fail)
+import Data.Semigroup.Reducer (Reducer)
+import Prelude
+import Prologue hiding (TypeError)
 
--- | The type of type variable names.
 type TName = Int
 
 -- | A datatype representing primitive types and combinations thereof.
-data Type
+data Type location
   = Int                                   -- ^ Primitive int type.
   | Bool                                  -- ^ Primitive boolean type.
   | String                                -- ^ Primitive string type.
+  | Symbol                                -- ^ Type of unique symbols.
   | Unit                                  -- ^ The unit type.
-  | Type :-> Type  -- ^ Binary function types.
+  | Float                                 -- ^ Floating-point type.
+  | Rational                              -- ^ Rational type.
+  | Type location :-> Type location       -- ^ Binary function types.
   | Var TName                             -- ^ A type variable.
-  | Product [Type] -- ^ N-ary products.
+  | Product [Type location]               -- ^ N-ary products.
+  | Array [Type location]                 -- ^ Arrays. Note that this is heterogenous.
+  | Hash [(Type location, Type location)] -- ^ 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 location -> Type location -> TypeError (Type location)
+  BitOpError       :: Type location -> Type location -> TypeError (Type location)
+  UnificationError :: Type location -> Type location -> TypeError (Type location)
+  SubscriptError   :: Type location -> Type location -> TypeError (Type location)
+
+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 eq (BitOpError a b) (BitOpError c d)             = a `eq` c && b `eq` d
+  liftEq eq (NumOpError a b) (NumOpError c d)             = a `eq` c && b `eq` d
+  liftEq eq (UnificationError a b) (UnificationError c d) = a `eq` c && b `eq` d
+  liftEq _ _ _                                           = False
+
+runTypeError :: Evaluator location value (Resumable TypeError ': effects) a -> Evaluator location value effects (Either (SomeExc TypeError) a)
+runTypeError = runResumable
 
 -- | Unify two 'Type's.
-unify :: MonadFail m => Type -> Type -> m Type
+unify :: (Effectful m, Applicative (m effects), Member (Resumable TypeError) effects) => Type location -> Type location -> m effects (Type location)
-unify Int  Int  = pure Int
-unify Bool Bool = pure Bool
 unify (a1 :-> b1) (a2 :-> b2) = (:->) <$> unify a1 a2 <*> unify b1 b2
+unify a Null = pure a
+unify Null b = pure b
 -- FIXME: this should be constructing a substitution.
 unify (Var _) b = pure b
 unify a (Var _) = pure a
 unify (Product as) (Product bs) = Product <$> sequenceA (alignWith (these pure pure unify) as bs)
-unify t1 t2 = fail ("cannot unify " ++ show t1 ++ " with " ++ show t2)
+unify t1 t2
+  | t1 == t2  = pure t2
+  | otherwise = throwResumable (UnificationError t1 t2)
+
+instance Ord location => ValueRoots location (Type location) where
+  valueRoots _ = mempty
+
+
+instance AbstractHole (Type location) where
+  hole = Hole
+
+-- | Discard the value arguments (if any), constructing a 'Type' instead.
+instance ( Addressable location effects
+         , Members '[ Fresh
+                    , NonDet
+                    , Resumable TypeError
+                    , State (Environment location (Type location))
+                    , State (Heap location (Cell location) (Type location))
+                    ] effects
+         , Reducer (Type location) (Cell location (Type location))
+         )
+      => AbstractValue location (Type location) effects where
+  closure names _ body = do
+    (env, tvars) <- foldr (\ name rest -> do
+      a <- alloc name
+      tvar <- Var <$> fresh
+      assign a tvar
+      (env, tvars) <- rest
+      pure (Env.insert name a env, tvar : tvars)) (pure (emptyEnv, [])) names
+    ret <- localEnv (mergeEnvs env) body
+    pure (Product tvars :-> ret)
+
+  unit       = pure Unit
+  integer _  = pure Int
+  boolean _  = pure Bool
+  string _   = pure String
+  float _    = pure Float
+  symbol _   = pure Symbol
+  rational _ = pure Rational
+  multiple   = pure . Product
+  array      = pure . Array
+  hash       = pure . Hash
+  kvPair k v = pure (Product [k, v])
+
+  null          = pure Null
+
+  klass _ _ _   = pure Object
+  namespace _ _ = pure Unit
+
+  scopedEnvironment _ = pure (Just emptyEnv)
+
+  asString t = unify t String $> ""
+  asPair t   = do
+    t1 <- fresh
+    t2 <- 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 _ Int        = pure Int
+  liftNumeric _ t          = throwResumable (NumOpError t Hole)
+
+  liftNumeric2 _ left right = case (left, right) of
+    (Float, Int) -> pure Float
+    (Int, Float) -> pure Float
+    _            -> unify left right
+
+  liftBitwise _ Int = pure Int
+  liftBitwise _ t   = throwResumable (BitOpError t Hole)
+
+  liftBitwise2 _ Int Int = pure Int
+  liftBitwise2 _ t1 t2   = throwResumable (BitOpError t1 t2)
+
+  liftComparison (Concrete _) left right = case (left, right) of
+    (Float, Int) ->                     pure Bool
+    (Int, Float) ->                     pure Bool
+    _                 -> unify left right $> Bool
+  liftComparison Generalized left right = case (left, right) of
+    (Float, Int) ->                     pure Int
+    (Int, Float) ->                     pure Int
+    _                 -> unify left right $> Bool
+
+  call op params = do
+    tvar <- fresh
+    paramTypes <- sequenceA params
+    let needed = Product paramTypes :-> Var tvar
+    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,58 +1,86 @@
-{-# LANGUAGE ConstraintKinds, DataKinds, FunctionalDependencies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
+{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
 module Data.Abstract.Value where
 
-import Data.Abstract.Address
+import Control.Abstract
-import Data.Abstract.Environment
+import Data.Abstract.Environment (Environment, emptyEnv, mergeEnvs)
-import Data.Abstract.Store
+import qualified Data.Abstract.Environment as Env
 import Data.Abstract.FreeVariables
-import Data.Abstract.Live
+import qualified Data.Abstract.Number as Number
-import qualified Data.Abstract.Type as Type
+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
+import Data.Sum
-import Prelude hiding (Integer, String)
+import Prologue hiding (TypeError)
+import Prelude hiding (Float, Integer, String, Rational)
 import qualified Prelude
 
 type ValueConstructors location
-  = '[Closure location
+  = '[Array
-    , Interface location
-    , Unit
     , Boolean
+    , Class location
+    , Closure location
+    , Float
+    , Hash
     , Integer
+    , KVPair
+    , Namespace location
+    , Null
+    , Rational
     , String
+    , Symbol
+    , Tuple
+    , Unit
+    , Hole
     ]
 
 -- | Open union of primitive values that terms can be evaluated to.
-type Value location = Union (ValueConstructors location)
+--   Fix by another name.
+newtype Value location = Value (Sum (ValueConstructors location) (Value location))
+  deriving (Eq, Show, Ord)
+
+-- | Identical to 'inj', but wraps the resulting sub-entity in a 'Value'.
+injValue :: (f :< ValueConstructors location) => f (Value location) -> Value location
+injValue = Value . injectSum
+
+-- | Identical to 'prj', but unwraps the argument out of its 'Value' wrapper.
+prjValue :: (f :< ValueConstructors location) => Value location -> Maybe (f (Value location))
+prjValue (Value v) = projectSum v
+
+-- | Convenience function for projecting two values.
+prjPair :: (f :< ValueConstructors location , g :< ValueConstructors location)
+        => (Value location, Value location)
+        -> Maybe (f (Value location), g (Value location))
+prjPair = bitraverse prjValue prjValue
 
 -- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union.
--- TODO: Wrap the Value union in a newtype to differentiate from (eventual) à la carte Types.
 
--- | A function value consisting of a list of parameters, the body of the function, and an environment of bindings captured by the body.
+-- | A function value consisting of a package & module info, a list of parameter 'Name's, a 'Label' to jump to the body of the function, and an 'Environment' of bindings captured by the body.
-data Closure location term = Closure [Name] term (Environment location (Value location term))
+data Closure location value = Closure PackageInfo ModuleInfo [Name] Label (Environment location value)
   deriving (Eq, Generic1, Ord, Show)
 
-instance (Eq location) => Eq1 (Closure location) where liftEq = genericLiftEq
+instance Eq location => Eq1 (Closure location) where liftEq = genericLiftEq
-instance (Ord location) => Ord1 (Closure location) where liftCompare = genericLiftCompare
+instance Ord location => Ord1 (Closure location) where liftCompare = genericLiftCompare
-instance (Show location) => Show1 (Closure location) where liftShowsPrec = genericLiftShowsPrec
+instance Show location => Show1 (Closure location) where liftShowsPrec = genericLiftShowsPrec
-
--- | A program value consisting of the value of the program and it's enviornment of bindings.
-data Interface location term = Interface (Value location term) (Environment location (Value location term))
-  deriving (Eq, Generic1, Ord, Show)
-
-instance (Eq location) => Eq1 (Interface location) where liftEq = genericLiftEq
-instance (Ord location) => Ord1 (Interface location) where liftCompare = genericLiftCompare
-instance (Show location) => Show1 (Interface location) where liftShowsPrec = genericLiftShowsPrec
 
 -- | The unit value. Typically used to represent the result of imperative statements.
-data Unit term = Unit
+data Unit value = Unit
   deriving (Eq, Generic1, Ord, Show)
 
 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 term = Boolean Prelude.Bool
+newtype Boolean value = Boolean Prelude.Bool
   deriving (Eq, Generic1, Ord, Show)
 
 instance Eq1 Boolean where liftEq = genericLiftEq
@@ -60,74 +88,335 @@ instance Ord1 Boolean where liftCompare = genericLiftCompare
 instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
 
 -- | Arbitrary-width integral values.
-newtype Integer term = Integer Prelude.Integer
+newtype Integer value = Integer (Number.Number Prelude.Integer)
   deriving (Eq, Generic1, Ord, Show)
 
 instance Eq1 Integer where liftEq = genericLiftEq
 instance Ord1 Integer where liftCompare = genericLiftCompare
 instance Show1 Integer where liftShowsPrec = genericLiftShowsPrec
 
+-- | Arbitrary-width rational values values.
+newtype Rational value = Rational (Number.Number Prelude.Rational)
+  deriving (Eq, Generic1, Ord, Show)
+
+instance Eq1 Rational where liftEq = genericLiftEq
+instance Ord1 Rational where liftCompare = genericLiftCompare
+instance Show1 Rational where liftShowsPrec = genericLiftShowsPrec
+
 -- | String values.
-newtype String term = String ByteString
+newtype String value = String ByteString
   deriving (Eq, Generic1, Ord, Show)
 
 instance Eq1 String where liftEq = genericLiftEq
 instance Ord1 String where liftCompare = genericLiftCompare
 instance Show1 String where liftShowsPrec = genericLiftShowsPrec
 
--- | The environment for an abstract value type.
+-- | Possibly-interned Symbol values.
-type EnvironmentFor v = Environment (LocationFor v) v
+--   TODO: Should this store a 'Text'?
+newtype Symbol value = Symbol ByteString
+  deriving (Eq, Generic1, Ord, Show)
 
--- | The store for an abstract value type.
+instance Eq1 Symbol where liftEq = genericLiftEq
-type StoreFor v = Store (LocationFor v) v
+instance Ord1 Symbol where liftCompare = genericLiftCompare
+instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec
 
--- | The location type (the body of 'Address'es) which should be used for an abstract value type.
+-- | Float values.
-type family LocationFor value :: * where
+newtype Float value = Float (Number.Number Scientific)
-  LocationFor (Value location term) = location
+  deriving (Eq, Generic1, Ord, Show)
-  LocationFor Type.Type = Monovariant
+
+instance Eq1 Float where liftEq = genericLiftEq
+instance Ord1 Float where liftCompare = genericLiftCompare
+instance Show1 Float where liftShowsPrec = genericLiftShowsPrec
+
+-- | Zero or more values. Fixed-size at interpretation time.
+--   TODO: Investigate whether we should use Vector for this.
+--   TODO: Should we have a Some type over a nonemmpty list? Or does this merit one?
+newtype Tuple value = Tuple [value]
+  deriving (Eq, Generic1, Ord, Show)
+
+instance Eq1 Tuple where liftEq = genericLiftEq
+instance Ord1 Tuple where liftCompare = genericLiftCompare
+instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
+
+-- | Zero or more values. Dynamically resized as needed at interpretation time.
+--   TODO: Vector? Seq?
+newtype Array value = Array [value]
+  deriving (Eq, Generic1, Ord, Show)
+
+instance Eq1 Array where liftEq = genericLiftEq
+instance Ord1 Array where liftCompare = genericLiftCompare
+instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
+
+-- | Class values. There will someday be a difference between classes and objects,
+--   but for the time being we're pretending all languages have prototypical inheritance.
+data Class location value = Class
+  { _className  :: Name
+  , _classScope :: Environment location value
+  } deriving (Eq, Generic1, Ord, Show)
+
+instance Eq location => Eq1 (Class location) where liftEq = genericLiftEq
+instance Ord location => Ord1 (Class location) where liftCompare = genericLiftCompare
+instance Show location => Show1 (Class location) where liftShowsPrec = genericLiftShowsPrec
+
+data Namespace location value = Namespace
+  { namespaceName  :: Name
+  , namespaceScope :: Environment location value
+  } deriving (Eq, Generic1, Ord, Show)
+
+instance Eq location => Eq1 (Namespace location) where liftEq = genericLiftEq
+instance Ord location => Ord1 (Namespace location) where liftCompare = genericLiftCompare
+instance Show location => Show1 (Namespace location) where liftShowsPrec = genericLiftShowsPrec
+
+data KVPair value = KVPair value value
+  deriving (Eq, Generic1, Ord, Show)
+
+instance Eq1 KVPair where liftEq = genericLiftEq
+instance Ord1 KVPair where liftCompare = genericLiftCompare
+instance Show1 KVPair where liftShowsPrec = genericLiftShowsPrec
+
+-- You would think this would be a @Map value value@ or a @[(value, value)].
+-- You would be incorrect, as we can't derive a Generic1 instance for the above,
+-- and in addition a 'Map' representation would lose information given hash literals
+-- that assigned multiple values to one given key. Instead, this holds KVPair
+-- values. The smart constructor for hashes in 'AbstractValue' ensures that these are
+-- only populated with pairs.
+newtype Hash value = Hash [value]
+  deriving (Eq, Generic1, Ord, Show)
+
+instance Eq1 Hash where liftEq = genericLiftEq
+instance Ord1 Hash where liftCompare = genericLiftCompare
+instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec
+
+data Null value = Null
+  deriving (Eq, Generic1, Ord, Show)
+
+instance Eq1 Null where liftEq = genericLiftEq
+instance Ord1 Null where liftCompare = genericLiftCompare
+instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
 
 
--- | Value types, e.g. closures, which can root a set of addresses.
+instance Ord location => ValueRoots location (Value location) where
-class ValueRoots l v | v -> l where
-  -- | Compute the set of addresses rooted by a given value.
-  valueRoots :: v -> Live l v
-
--- | An interface for constructing abstract values.
-class AbstractValue v where
-  -- | Construct an abstract unit value.
-  unit :: v
-
-  -- | Construct an abstract integral value.
-  integer :: Prelude.Integer -> v
-
-  -- | Construct an abstract boolean value.
-  boolean :: Bool -> v
-
-  -- | Construct an abstract string value.
-  string :: ByteString -> v
-
-
--- Instances
-
-instance (FreeVariables term, Ord location) => ValueRoots location (Value location term) where
   valueRoots v
-    | Just (Closure names body env) <- prj v = envRoots env (foldr Set.delete (freeVariables body) names)
+    | Just (Closure _ _ _ _ env) <- prjValue v = Env.addresses env
-    | Just (Interface _ env) <- prj v        = envAll env
     | otherwise                                = mempty
 
+
+instance AbstractHole (Value location) where
+  hole = injValue Hole
+
 -- | Construct a 'Value' wrapping the value arguments (if any).
-instance AbstractValue (Value location term) where
+instance ( Addressable location (Goto effects (Value location) ': effects)
-  unit = inj Unit
+         , Members '[ Fail
-  integer = inj . Integer
+                    , LoopControl (Value location)
-  boolean = inj . Boolean
+                    , Reader (Environment location (Value location))
-  string = inj . String
+                    , Reader ModuleInfo
+                    , Reader PackageInfo
+                    , Resumable (AddressError location (Value location))
+                    , Resumable (ValueError location)
+                    , Return (Value location)
+                    , State (Environment location (Value location))
+                    , State (Heap location (Cell location) (Value location))
+                    ] effects
+         , Reducer (Value location) (Cell location (Value location))
+         , Show location
+         )
+      => AbstractValue location (Value location) (Goto effects (Value location) ': effects) where
+  unit     = pure . injValue $ Unit
+  integer  = pure . injValue . Integer . Number.Integer
+  boolean  = pure . injValue . Boolean
+  string   = pure . injValue . String
+  float    = pure . injValue . Float . Number.Decimal
+  symbol   = pure . injValue . Symbol
+  rational = pure . injValue . Rational . Number.Ratio
 
-instance ValueRoots Monovariant Type.Type where
+  multiple = pure . injValue . Tuple
-  valueRoots _ = mempty
+  array    = pure . injValue . Array
 
--- | Discard the value arguments (if any), constructing a 'Type.Type' instead.
+  kvPair k = pure . injValue . KVPair k
-instance AbstractValue Type.Type where
+
-  unit = Type.Unit
+  null     = pure . injValue $ Null
-  integer _ = Type.Int
+
-  boolean _ = Type.Bool
+  asPair val
-  string _ = Type.String
+    | Just (KVPair k v) <- prjValue val = pure (k, v)
+    | otherwise = throwValueError $ KeyValueError val
+
+  hash = pure . injValue . Hash . fmap (injValue . uncurry KVPair)
+
+  klass n [] env = pure . injValue $ Class n env
+  klass n supers env = do
+    product <- foldl mergeEnvs emptyEnv . catMaybes <$> traverse scopedEnvironment supers
+    pure . injValue $ Class n (mergeEnvs product env)
+
+  namespace n env = do
+    maybeAddr <- lookupEnv n
+    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                             = throwValueError $ NamespaceError ("expected " <> show v <> " to be a namespace")
+
+  scopedEnvironment o
+    | Just (Class _ env) <- prjValue o = pure (Just env)
+    | Just (Namespace _ env) <- prjValue o = pure (Just env)
+    | otherwise = pure Nothing
+
+  asString v
+    | Just (String n) <- prjValue v = pure n
+    | otherwise                     = throwValueError $ StringError v
+
+  ifthenelse cond if' else' = do
+    isHole <- isHole cond
+    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 = throwValueError $ 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 (Rational (Number.Ratio r))  <- prjValue arg = rational $ f r
+    | otherwise = throwValueError (NumericError arg)
+
+  liftNumeric2 f left right
+    | Just (Integer  i, Integer j)  <- prjPair pair = tentative f i j & specialize
+    | Just (Integer  i, Rational j) <- prjPair pair = tentative f i j & specialize
+    | Just (Integer  i, Float j)    <- prjPair pair = tentative f i j & specialize
+    | Just (Rational i, Integer j)  <- prjPair pair = tentative f i j & specialize
+    | Just (Rational i, Rational j) <- prjPair pair = tentative f i j & specialize
+    | Just (Rational i, Float j)    <- prjPair pair = tentative f i j & specialize
+    | Just (Float    i, Integer j)  <- prjPair pair = tentative f i j & specialize
+    | Just (Float    i, Rational j) <- prjPair pair = tentative 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 :: (AbstractValue location (Value location) effects, Member (Resumable (ValueError location)) effects) => Either ArithException Number.SomeNumber -> Evaluator location (Value location) effects (Value location)
+        specialize (Left exc) = throwValueError (ArithmeticError exc)
+        specialize (Right (Number.SomeNumber (Number.Integer i))) = integer i
+        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
+    | Just (Integer (Number.Integer i), Integer (Number.Integer j)) <- prjPair pair = go i j
+    | Just (Integer (Number.Integer i), Float   (Number.Decimal j)) <- prjPair pair = go (fromIntegral i) j
+    | Just (Float   (Number.Decimal i), Integer (Number.Integer j)) <- prjPair pair = go i                (fromIntegral j)
+    | Just (Float   (Number.Decimal i), Float   (Number.Decimal j)) <- prjPair pair = go i j
+    | 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 = throwValueError (ComparisonError left right)
+      where
+        -- Explicit type signature is necessary here because we're passing all sorts of things
+        -- to these comparison functions.
+        go :: (AbstractValue location (Value location) effects, Ord a) => a -> a -> Evaluator location (Value location) effects (Value location)
+        go l r = case comparator of
+          Concrete f  -> boolean (f l r)
+          Generalized -> integer (orderingToInt (compare l r))
+
+        -- Map from [LT, EQ, GT] to [-1, 0, 1]
+        orderingToInt :: Ordering -> Prelude.Integer
+        orderingToInt = toInteger . pred . fromEnum
+
+        pair = (left, right)
+
+
+  liftBitwise operator target
+    | Just (Integer (Number.Integer i)) <- prjValue target = integer $ operator i
+    | otherwise = throwValueError (BitwiseError target)
+
+  liftBitwise2 operator left right
+    | Just (Integer (Number.Integer i), Integer (Number.Integer j)) <- prjPair pair = integer $ operator i j
+    | otherwise = throwValueError (Bitwise2Error left right)
+      where pair = (left, right)
+
+  closure parameters freeVariables body = do
+    packageInfo <- currentPackage
+    moduleInfo <- currentModule
+    l <- label body
+    injValue . Closure packageInfo moduleInfo parameters l . Env.bind (foldr Set.delete freeVariables parameters) <$> getEnv
+
+  call op params = do
+    case prjValue op of
+      Just (Closure packageInfo moduleInfo names label env) -> do
+        body <- goto label
+        -- Evaluate the bindings and body with the closure’s package/module info in scope in order to
+        -- charge them to the closure's origin.
+        withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
+          bindings <- foldr (\ (name, param) rest -> do
+            v <- param
+            a <- alloc name
+            assign a v
+            Env.insert name a <$> rest) (pure env) (zip names params)
+          localEnv (mergeEnvs bindings) (catchReturn body (\ (Return value) -> pure value))
+      Nothing -> throwValueError (CallError op)
+
+  loop x = catchLoopControl (fix x) (\ control -> case control of
+    Break value -> pure value
+    -- FIXME: Figure out how to deal with this. Ruby treats this as the result of the current block iteration, while PHP specifies a breakout level and TypeScript appears to take a label.
+    Continue _  -> loop x)
+
+
+-- | The type of exceptions that can be thrown when constructing values in 'Value'’s 'MonadValue' instance.
+data ValueError location resume where
+  StringError            :: Value location                   -> ValueError location ByteString
+  BoolError              :: Value location                   -> ValueError location Bool
+  IndexError             :: Value location -> Value location -> ValueError location (Value location)
+  NamespaceError         :: Prelude.String                   -> ValueError location (Environment location (Value location))
+  CallError              :: Value location                   -> ValueError location (Value location)
+  NumericError           :: Value location                   -> ValueError location (Value location)
+  Numeric2Error          :: Value location -> Value location -> ValueError location (Value location)
+  ComparisonError        :: Value location -> Value location -> ValueError location (Value location)
+  BitwiseError           :: Value location                   -> ValueError location (Value location)
+  Bitwise2Error          :: Value location -> Value location -> ValueError location (Value location)
+  KeyValueError          :: Value location                   -> ValueError location (Value location, Value location)
+  -- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching.
+  ArithmeticError        :: ArithException                   -> ValueError location (Value location)
+  -- Out-of-bounds error
+  BoundsError            :: [Value location] -> Prelude.Integer -> ValueError location (Value location)
+
+
+instance Eq location => Eq1 (ValueError location) 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 location => Show (ValueError location resume)
+instance Show location => Show1 (ValueError location) where
+  liftShowsPrec _ _ = showsPrec
+
+throwValueError :: Member (Resumable (ValueError location)) effects => ValueError location resume -> Evaluator location value effects resume
+throwValueError = throwResumable
+
+runValueError :: Evaluator location value (Resumable (ValueError location) ': effects) a -> Evaluator location value effects (Either (SomeExc (ValueError location)) a)
+runValueError = runResumable
+
+runValueErrorWith :: (forall resume . ValueError location resume -> Evaluator location value effects resume) -> Evaluator location value (Resumable (ValueError location) ': effects) a -> Evaluator location value effects a
+runValueErrorWith = runResumableWith

src/Data/Algebra.hs

@@ -1,19 +1,27 @@
 {-# LANGUAGE RankNTypes #-}
 module Data.Algebra
-( FAlgebra
+  ( FAlgebra
-, RAlgebra
+  , RAlgebra
-, OpenFAlgebra
+  , OpenFAlgebra
-, OpenRAlgebra
+  , OpenRAlgebra
-, Subterm(..)
+  , Subterm(..)
-, SubtermAlgebra
+  , SubtermAlgebra
-, foldSubterms
+  , embedSubterm
-, fToR
+  , embedTerm
-, fToOpenR
+  , foldSubterms
-, rToOpenR
+  , fToR
-, openFToOpenR
+  , fToOpenR
-) where
+  , rToOpenR
+  , openFToOpenR
+  ) where
 
-import Data.Functor.Foldable (Base, Recursive(project))
+import Data.Bifunctor
+import Data.Functor.Classes.Generic as X
+import Data.Functor.Foldable ( Base
+                             , Corecursive(embed)
+                             , Recursive(project)
+                             )
+import GHC.Generics
 
 -- | An F-algebra on some 'Recursive' type @t@.
 --
@@ -41,6 +49,14 @@ type OpenRAlgebra f t a = forall b . (b -> (t, a)) -> f b -> a
 
 -- | A subterm and its computed value, used in 'SubtermAlgebra'.
 data Subterm t a = Subterm { subterm :: !t, subtermValue :: !a }
+  deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
+
+instance Bifunctor Subterm where
+  bimap f g (Subterm a b) = Subterm (f a) (g b)
+
+instance Eq t => Eq1 (Subterm t) where liftEq = genericLiftEq
+instance Ord t => Ord1 (Subterm t) where liftCompare = genericLiftCompare
+instance Show t => Show1 (Subterm t) where liftShowsPrec = genericLiftShowsPrec
 
 -- | Like an R-algebra, but using 'Subterm' to label the fields instead of an anonymous pair.
 type SubtermAlgebra f t a = f (Subterm t a) -> a
@@ -50,6 +66,13 @@ type SubtermAlgebra f t a = f (Subterm t a) -> a
 foldSubterms :: Recursive t => SubtermAlgebra (Base t) t a -> t -> a
 foldSubterms algebra = go where go = algebra . fmap (Subterm <*> go) . project
 
+-- | Extract a term from the carrier tuple associated with a paramorphism. See also 'embedSubterm'.
+embedTerm :: Corecursive t => Base t (t, a) -> t
+embedTerm e = embed (fst <$> e)
+
+-- | Extract a term from said term's 'Base' functor populated with 'Subterm' fields.
+embedSubterm :: Corecursive t => Base t (Subterm t a) -> t
+embedSubterm e = embed (subterm <$> e)
 
 -- | Promote an 'FAlgebra' into an 'RAlgebra' (by dropping the original parameter).
 fToR :: Functor (Base t) => FAlgebra (Base t) a -> RAlgebra (Base t) t a

src/Data/Align/Generic.hs

@@ -3,11 +3,11 @@ module Data.Align.Generic where
 
 import Control.Applicative
 import Control.Monad
+import Data.Functor (($>))
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Maybe (fromMaybe)
-import Data.Proxy
+import Data.Sum
 import Data.These
-import Data.Union
 import GHC.Generics
 
 -- | Functors which can be aligned (structure-unioning-ly zipped). The default implementation will operate generically over the constructors in the aligning type.
@@ -36,8 +36,8 @@ instance GAlign [] where
 instance GAlign NonEmpty where
   galignWith f (a1:|as1) (a2:|as2) = (:|) <$> f (These a1 a2) <*> galignWith f as1 as2
 
-instance Apply GAlign fs => GAlign (Union fs) where
+instance Apply GAlign fs => GAlign (Sum fs) where
-  galignWith f = (fromMaybe empty .) . apply2' (Proxy :: Proxy GAlign) (\ inj -> (fmap inj .) . galignWith f)
+  galignWith f = (fromMaybe empty .) . apply2' @GAlign (\ inj -> (fmap inj .) . galignWith f)
 
 
 -- Generics
@@ -52,7 +52,7 @@ instance GAlign Par1 where
 
 -- | 'GAlign' over non-parameter fields. Only equal values are aligned.
 instance Eq c => GAlign (K1 i c) where
-  galignWith _ (K1 a) (K1 b) = guard (a == b) *> pure (K1 b)
+  galignWith _ (K1 a) (K1 b) = guard (a == b) $> K1 b
 
 -- | 'GAlign' over applications over parameters.
 instance GAlign f => GAlign (Rec1 f) where

src/Data/Diff.hs

@@ -22,9 +22,9 @@ import Data.Aeson
 import Data.Bifoldable
 import Data.Bifunctor
 import Data.Bitraversable
-import Data.Foldable (asum, toList)
+import Data.Foldable (asum)
 import Data.Functor.Classes
-import Data.Functor.Foldable hiding (fold)
+import Data.Functor.Foldable
 import Data.JSON.Fields
 import Data.Mergeable (Mergeable(sequenceAlt))
 import Data.Patch
@@ -82,15 +82,10 @@ merging :: Functor syntax => Term syntax ann -> Diff syntax ann ann
 merging = cata (\ (In ann syntax) -> mergeF (In (ann, ann) syntax))
 
 
-diffPatch :: Diff syntax ann1 ann2 -> Maybe (Patch (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2)))
-diffPatch diff = case unDiff diff of
-  Patch patch -> Just patch
-  _ -> Nothing
-
 diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann1 ann2 -> [Patch (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2))]
 diffPatches = para $ \ diff -> case diff of
-  Patch patch -> bimap (fmap fst) (fmap fst) patch : bifoldMap (foldMap (toList . diffPatch . fst)) (foldMap (toList . diffPatch . fst)) patch
+  Patch patch -> bimap (fmap fst) (fmap fst) patch : bifoldMap (foldMap snd) (foldMap snd) patch
-  Merge merge ->                                                foldMap (toList . diffPatch . fst)  merge
+  Merge merge -> foldMap snd merge
 
 
 -- | Recover the before state of a diff.

src/Data/Error.hs

@@ -79,4 +79,4 @@ showCallStack :: Colourize -> CallStack -> ShowS
 showCallStack colourize callStack = foldr (.) id (intersperse (showChar '\n') (uncurry (showCallSite colourize) <$> getCallStack callStack))
 
 showCallSite :: Colourize -> String -> SrcLoc -> ShowS
-showCallSite colourize symbol SrcLoc{..} = showString symbol . showChar ' ' . withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showParen True (showSpan (Just srcLocFile) (Span (Pos srcLocStartLine srcLocStartCol) (Pos srcLocEndLine srcLocEndCol))))
+showCallSite colourize symbol loc@SrcLoc{..} = showString symbol . showChar ' ' . withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showParen True (showSpan (Just srcLocFile) (spanFromSrcLoc loc)))

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/Functor/Both.hs

@@ -3,16 +3,12 @@ module Data.Functor.Both
 ( Both
 , both
 , runBothWith
-, fst
-, snd
 , module X
 ) where
 
 import Data.Bifunctor.Join as X
 import Data.Functor.Classes
 import Data.Semigroup
-import Prelude hiding (fst, snd)
-import qualified Prelude
 
 -- | A computation over both sides of a pair.
 type Both = Join (,)
@@ -25,13 +21,6 @@ both = curry Join
 runBothWith :: (a -> a -> b) -> Both a -> b
 runBothWith f = uncurry f . runJoin
 
--- | Runs the left side of a `Both`.
-fst :: Both a -> a
-fst = Prelude.fst . runJoin
-
--- | Runs the right side of a `Both`.
-snd :: Both a -> a
-snd = Prelude.snd . runJoin
 
 instance (Semigroup a, Monoid a) => Monoid (Join (,) a) where
   mempty = pure mempty

src/Data/Functor/Classes/Generic.hs

@@ -46,7 +46,7 @@ class GShow1 f where
   -- | showsPrec function for an application of the type constructor based on showsPrec and showList functions for the argument type.
   gliftShowsPrec :: GShow1Options -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
 
-data GShow1Options = GShow1Options { optionsUseRecordSyntax :: Bool }
+newtype GShow1Options = GShow1Options { optionsUseRecordSyntax :: Bool }
 
 defaultGShow1Options :: GShow1Options
 defaultGShow1Options = GShow1Options { optionsUseRecordSyntax = False }

src/Data/JSON/Fields.hs

@@ -1,8 +1,9 @@
 {-# LANGUAGE MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
 module Data.JSON.Fields where
 
-import Prologue
 import Data.Aeson
+import Data.Sum (Apply(..), Sum)
+import Prologue
 
 class ToJSONFields a where
   toJSONFields :: KeyValue kv => a -> [kv]
@@ -23,8 +24,8 @@ instance ToJSON a => ToJSONFields [a] where
 instance ToJSONFields1 [] where
   toJSONFields1 list = [ "children" .= list ]
 
-instance Apply Foldable fs => ToJSONFields1 (Union fs) where
+instance Apply Foldable fs => ToJSONFields1 (Sum fs) where
-  toJSONFields1 = apply (Proxy :: Proxy Foldable) (\ r -> [ "children" .= toList r ])
+  toJSONFields1 r = [ "children" .= toList r ]
 
 instance (ToJSONFields a, ToJSONFields b) => ToJSONFields (a, b) where
   toJSONFields (a, b) = [ "before" .= JSONFields a, "after" .= JSONFields b ]

src/Data/Language.hs

@@ -24,7 +24,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
@@ -32,3 +32,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

@@ -0,0 +1,50 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-- | This module defines a 'Map' type whose 'Monoid' and 'Reducer' instances merge values using the 'Semigroup' instance for the underlying type.
+module Data.Map.Monoidal
+( Map
+, lookup
+, size
+, insert
+, filterWithKey
+, module Reducer
+) where
+
+import qualified Data.Map as Map
+import Data.Semigroup.Reducer as Reducer
+import Data.Semilattice.Lower
+import Prelude hiding (lookup)
+import Prologue hiding (Map)
+
+newtype Map key value = Map (Map.Map key value)
+  deriving (Eq, Eq1, Eq2, Foldable, Functor, Ord, Ord1, Ord2, Show, Show1, Show2, Traversable)
+
+unMap :: Map key value -> Map.Map key value
+unMap (Map map) = map
+
+
+lookup :: Ord key => key -> Map key value -> Maybe value
+lookup key = Map.lookup key . unMap
+
+size :: Map key value -> Int
+size = Map.size . unMap
+
+insert :: Ord key => key -> value -> Map key value -> Map key value
+insert key value = Map . Map.insert key value . unMap
+
+filterWithKey :: (key -> value -> Bool) -> Map key value -> Map key value
+filterWithKey f = Map . Map.filterWithKey f . unMap
+
+
+instance (Ord key, Semigroup value) => Semigroup (Map key value) where
+  Map a <> Map b = Map (Map.unionWith (<>) a b)
+
+instance (Ord key, Semigroup value) => Monoid (Map key value) where
+  mempty = Map Map.empty
+  mappend = (<>)
+
+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/Mergeable.hs

@@ -4,8 +4,7 @@ module Data.Mergeable where
 import Control.Applicative
 import Data.Functor.Identity
 import Data.List.NonEmpty
-import Data.Proxy
+import Data.Sum
-import Data.Union
 import GHC.Generics
 
 -- Classes
@@ -46,8 +45,8 @@ instance Mergeable Maybe where
 
 instance Mergeable Identity where merge f = fmap Identity . f . runIdentity
 
-instance (Apply Functor fs, Apply Mergeable fs) => Mergeable (Union fs) where
+instance (Apply Functor fs, Apply Mergeable fs) => Mergeable (Sum fs) where
-  merge f u = apply' (Proxy :: Proxy Mergeable) (\ reinj g -> reinj <$> merge f g) u
+  merge f = apply' @Mergeable (\ reinj g -> reinj <$> merge f g)
 
 
 -- Generics

src/Data/Patch.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveAnyClass #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 module Data.Patch
 ( Patch(..)

src/Data/Range.hs

@@ -1,20 +1,24 @@
-{-# LANGUAGE DeriveAnyClass #-}
 module Data.Range
 ( Range(..)
+, emptyRange
 , rangeLength
 , offsetRange
 , intersectsRange
 , 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 }
   deriving (Eq, Show, Generic)
 
+emptyRange :: Range
+emptyRange = Range 0 0
+
 -- | Return the length of the range.
 rangeLength :: Range -> Int
 rangeLength range = end range - start range
@@ -33,6 +37,13 @@ subtractRange range1 range2 = Range (start range1) (end range1 - rangeLength (Ra
 
 -- Instances
 
+-- $setup
+-- >>> import Test.QuickCheck
+-- >>> instance Arbitrary Range where arbitrary = Range <$> arbitrary <*> arbitrary
+
+-- $
+-- Associativity:
+-- prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: Range)
 instance Semigroup Range where
   Range start1 end1 <> Range start2 end2 = Range (min start1 start2) (max end1 end2)
 
@@ -41,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.
 -- |
@@ -50,7 +51,7 @@ instance {-# OVERLAPPABLE #-} HasField (field ': fields) field where
 
 
 instance (Show h, Show (Record t)) => Show (Record (h ': t)) where
-  showsPrec n (h :. t) = showParen (n > 0) $ showsPrec 1 h . showString " :. " . showsPrec 0 t
+  showsPrec n (h :. t) = showParen (n > 0) $ showsPrec 1 h . showString " :. " . shows t
 
 instance Show (Record '[]) where
   showsPrec _ Nil = showString "Nil"
@@ -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

@@ -0,0 +1,108 @@
+module Data.Scientific.Exts
+    ( module Data.Scientific
+    , attemptUnsafeArithmetic
+    , parseScientific
+    ) where
+
+import Control.Applicative
+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 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
+
+-- | This is a very flexible and forgiving parser for Scientific values.
+-- Unlike 'scientificP' or Scientific's 'Read' instance, this handles the myriad
+-- array of floating-point syntaxes across languages:
+-- * omitted whole parts, e.g. @.5@
+-- * omitted decimal parts, e.g. @5.@
+-- * numbers with trailing imaginary/length specifiers, @1.7j, 20L@
+-- * numeric parts, in whole or decimal or exponent parts, with @_@ characters
+-- * hexadecimal, octal, and binary literals (TypeScript needs this because all numbers are floats)
+-- You may either omit the whole or the leading part, not both; this parser also rejects the empty string.
+-- It does /not/ handle hexadecimal floating-point numbers yet, as no language we parse supports them.
+-- This will need to be changed when we support Java.
+-- Please note there are extant parser bugs where complex literals (e.g. @123j@) are parsed
+-- as floating-point rather than complex quantities. This parser discards all suffixes.
+-- This parser is unit-tested in Data.Scientific.Spec.
+
+parser :: Parser Scientific
+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.
+  attempt :: Read a => String -> Parser a
+  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)
+
+  -- We lean on Haskell's octal integer support, parsing
+  -- the given string as an integer then coercing it to a Scientific.
+  oct = do
+    void (char '0' <* optional (char 'o'))
+    digs <- takeWhile1 isOctDigit <* done
+    fromIntegral <$> attempt @Integer (unpack ("0o" <> digs))
+
+  -- The case for binary literals is somewhat baroque. Despite having binary literal support, Integer's
+  -- Read instance does not handle binary literals. So we have to shell out to Numeric.readInt, which
+  -- is a very strange API, but works for our use case. The use of 'error' looks partial, but if Attoparsec
+  -- and readInt do their jobs, it should never happen.
+  bin = do
+    void (string "0b")
+    let isBin = inClass "01"
+    digs <- unpack <$> (takeWhile1 isBin <* done)
+    let c2b c = case c of
+          '0' -> 0
+          '1' -> 1
+          x   -> error ("Invariant violated: both Attoparsec and readInt let a bad digit through: " <> [x])
+    let res = readInt 2 isBin c2b digs
+    case res of
+      []        -> fail ("No parse of binary literal: " <> digs)
+      [(x, "")] -> pure x
+      others    -> fail ("Too many parses of binary literal: " <> show others)
+
+  -- Compared to the binary parser, this is positively breezy.
+  dec = do
+    let notUnder = filter (/= '_')
+    let decOrUnder c = isDigit c || (c == '_')
+
+    -- Try getting the whole part of a floating literal.
+    leadings <- notUnder <$> takeWhile decOrUnder
+
+    -- Try reading a dot.
+    void (optional (char '.'))
+
+    -- The trailing part...
+    trailings <- notUnder <$> takeWhile decOrUnder
+
+    -- ...and the exponent.
+    exponent  <- notUnder <$> takeWhile (inClass "eE_0123456789+-")
+
+    done
+
+    -- Ensure we don't read an empty string, or one consisting only of a dot and/or an exponent.
+    when (null trailings && null leadings) (fail "Does not accept a single dot")
+
+    -- Replace empty parts with a zero.
+    let leads = if null leadings then "0" else leadings
+    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/Semigroup/App.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Data.Semigroup.App
+( App(..)
+, AppMerge(..)
+) where
+
+import Control.Applicative
+import Data.Semigroup
+
+-- $setup
+-- >>> import Test.QuickCheck
+-- >>> instance Arbitrary (f a) => Arbitrary (App f a) where arbitrary = App <$> arbitrary ; shrink = map App . shrink . runApp
+-- >>> instance Arbitrary (f a) => Arbitrary (AppMerge f a) where arbitrary = AppMerge <$> arbitrary ; shrink = map AppMerge . shrink . runAppMerge
+
+-- | 'Semigroup' under '*>'.
+newtype App f a = App { runApp :: f a }
+  deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable)
+
+-- $ Associativity:
+--   prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: App Maybe Integer)
+instance Applicative f => Semigroup (App f a) where
+  App a <> App b = App (a *> b)
+
+
+-- | 'Semigroup' and 'Monoid' under '<*>' and '<>'.
+newtype AppMerge f a = AppMerge { runAppMerge :: f a }
+  deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable)
+
+-- $ Associativity:
+--   prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: AppMerge Maybe String)
+instance (Applicative f, Semigroup a) => Semigroup (AppMerge f a) where
+  AppMerge a <> AppMerge b = AppMerge ((<>) <$> a <*> b)
+
+-- $ Identity:
+--   prop> \ a -> mempty <> a == (a :: AppMerge Maybe String)
+--   prop> \ a -> a <> mempty == (a :: AppMerge Maybe String)
+instance (Applicative f, Monoid a, Semigroup a) => Monoid (AppMerge f a) where
+  mempty = AppMerge (pure mempty)
+  mappend = (<>)

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/Source.hs

@@ -61,7 +61,7 @@ totalRange = Range 0 . B.length . sourceBytes
 totalSpan :: Source -> Span
 totalSpan source = Span (Pos 1 1) (Pos (length ranges) (succ (end lastRange - start lastRange)))
   where ranges = sourceLineRanges source
-        Just lastRange = getLast (foldMap (Last . Just) ranges)
+        lastRange = fromMaybe emptyRange (getLast (foldMap (Last . Just) ranges))
 
 
 -- En/decoding
@@ -150,8 +150,8 @@ rangeToSpan source (Range rangeStart rangeEnd) = Span startPos endPos
         firstLine = length before
         (before, rest) = span ((< rangeStart) . end) (sourceLineRanges source)
         (lineRanges, _) = span ((<= rangeEnd) . start) rest
-        Just firstRange = getFirst (foldMap (First . Just) lineRanges)
+        firstRange = fromMaybe emptyRange (getFirst (foldMap (First . Just) lineRanges))
-        Just lastRange  = getLast  (foldMap (Last  . Just) lineRanges)
+        lastRange  = fromMaybe firstRange (getLast (foldMap (Last . Just) lineRanges))
 
 
 -- Instances

src/Data/Span.hs

@@ -6,13 +6,16 @@
 module Data.Span
 ( Span(..)
 , Pos(..)
+, spanFromSrcLoc
 , emptySpan
 ) where
 
-import Prologue
 import Data.Aeson ((.=), (.:))
 import qualified Data.Aeson as A
 import Data.JSON.Fields
+import Data.Semilattice.Lower
+import GHC.Stack
+import Prologue
 
 -- | Source position information
 data Pos = Pos
@@ -36,6 +39,9 @@ data Span = Span
   }
   deriving (Show, Read, Eq, Ord, Generic, Hashable)
 
+spanFromSrcLoc :: SrcLoc -> Span
+spanFromSrcLoc = Span . (Pos . srcLocStartLine <*> srcLocStartCol) <*> (Pos . srcLocEndLine <*> srcLocEndCol)
+
 emptySpan :: Span
 emptySpan = Span (Pos 1 1) (Pos 1 1)
 
@@ -56,3 +62,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/SplitDiff.hs

@@ -13,7 +13,7 @@ data SplitPatch a
   deriving (Foldable, Eq, Functor, Show, Traversable)
 
 -- | Get the range of a SplitDiff.
-getRange :: Functor f => HasField fields Range => SplitDiff f (Record fields) -> Range
+getRange :: HasField fields Range => SplitDiff f (Record fields) -> Range
 getRange diff = getField $ case diff of
   Free annotated -> termFAnnotation annotated
   Pure patch -> termAnnotation (splitTerm patch)

src/Data/Syntax.hs

@@ -1,47 +1,39 @@
-{-# LANGUAGE DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, TypeApplications #-}
+{-# LANGUAGE DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack
 module Data.Syntax where
 
-import Prologue
+import Data.Abstract.Evaluatable
-import Control.Monad.Effect.Addressable
-import Control.Monad.Effect.Fail
-import Control.Monad.Effect.Reader
-import Control.Monad.Effect.State
-import Data.Abstract.Environment
-import Control.Monad.Effect.Evaluatable
-import Data.Abstract.FreeVariables
-import Data.Abstract.Value (LocationFor, EnvironmentFor, StoreFor, AbstractValue(..), Value)
 import Data.AST
-import Data.ByteString.Char8 (unpack)
 import Data.Range
 import Data.Record
 import Data.Span
+import Data.Sum
 import Data.Term
 import Diffing.Algorithm hiding (Empty)
-import Prelude hiding (fail)
+import Prelude
+import Prologue
 import qualified Assigning.Assignment as Assignment
-import qualified Data.Abstract.Type as Type
-import qualified Data.Abstract.Value as Value
 import qualified Data.Error as Error
 
 -- Combinators
 
 -- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children.
-makeTerm :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => a -> f (Term (Union fs) a) -> Term (Union fs) a
+makeTerm :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => a -> f (Term (Sum fs) a) -> Term (Sum fs) a
-makeTerm a = makeTerm' a . inj
+makeTerm a = makeTerm' a . injectSum
 
 -- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children.
 makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a
 makeTerm' a f = termIn (sconcat (a :| (termAnnotation <$> toList f))) f
 
 -- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children. Removes extra structure if term is a list of a single item.
-makeTerm'' :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs, Foldable f) => a -> f (Term (Union fs) a) -> Term (Union fs) a
+makeTerm'' :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs, Foldable f) => a -> f (Term (Sum fs) a) -> Term (Sum fs) a
 makeTerm'' a children = case toList children of
   [x] -> x
-  _ -> makeTerm' a (inj children)
+  _ -> makeTerm' a (injectSum children)
 
 -- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation.
-makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => f (Term (Union fs) a) -> Term (Union fs) a
+makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => f (Term (Sum fs) a) -> Term (Sum fs) a
-makeTerm1 = makeTerm1' . inj
+makeTerm1 = makeTerm1' . injectSum
 
 -- | Lift a non-empty union into a term, appending all subterms’.annotations to make the new term’s annotation.
 makeTerm1' :: (HasCallStack, Semigroup a, Foldable f) => f (Term f a) -> Term f a
@@ -50,24 +42,24 @@ makeTerm1' f = case toList f of
   _ -> error "makeTerm1': empty structure"
 
 -- | Construct an empty term at the current position.
-emptyTerm :: (HasCallStack, Empty :< fs, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Location))
+emptyTerm :: (HasCallStack, Empty :< fs, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Sum fs) (Record Location))
 emptyTerm = makeTerm . startLocation <$> Assignment.location <*> pure Empty
   where startLocation ann = Range (start (getField ann)) (start (getField ann)) :. Span (spanStart (getField ann)) (spanStart (getField ann)) :. Nil
 
 -- | Catch assignment errors into an error term.
-handleError :: (HasCallStack, Error :< fs, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Location)) -> Assignment.Assignment ast grammar (Term (Union fs) (Record Location))
+handleError :: (HasCallStack, Error :< fs, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Sum fs) (Record Location)) -> Assignment.Assignment ast grammar (Term (Sum fs) (Record Location))
 handleError = flip catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source)
 
 -- | Catch parse errors into an error term.
-parseError :: (HasCallStack, Error :< fs, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Union fs) (Record Location))
+parseError :: (HasCallStack, Error :< fs, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Sum fs) (Record Location))
 parseError = makeTerm <$> Assignment.token maxBound <*> pure (Error (ErrorStack (getCallStack (freezeCallStack callStack))) [] (Just "ParseError") [])
 
 
 -- | Match context terms before a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.
 contextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
-              => m (Term (Union fs) a)
+              => m (Term (Sum fs) a)
-              -> m (Term (Union fs) a)
+              -> m (Term (Sum fs) a)
-              -> m (Term (Union fs) a)
+              -> m (Term (Sum fs) a)
 contextualize context rule = make <$> Assignment.manyThrough context rule
   where make (cs, node) = case nonEmpty cs of
           Just cs -> makeTerm1 (Context cs node)
@@ -75,10 +67,10 @@ contextualize context rule = make <$> Assignment.manyThrough context rule
 
 -- | Match context terms after a subject term and before a delimiter, returning the delimiter paired with a Context term if any context terms matched, or the subject term otherwise.
 postContextualizeThrough :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
-                         => m (Term (Union fs) a)
+                         => m (Term (Sum fs) a)
-                         -> m (Term (Union fs) a)
+                         -> m (Term (Sum fs) a)
                          -> m b
-                         -> m (Term (Union fs) a, b)
+                         -> m (Term (Sum fs) a, b)
 postContextualizeThrough context rule end = make <$> rule <*> Assignment.manyThrough context end
   where make node (cs, end) = case nonEmpty cs of
           Just cs -> (makeTerm1 (Context cs node), end)
@@ -86,9 +78,9 @@ postContextualizeThrough context rule end = make <$> rule <*> Assignment.manyThr
 
 -- | Match context terms after a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.
 postContextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
-                  => m (Term (Union fs) a)
+                  => m (Term (Sum fs) a)
-                  -> m (Term (Union fs) a)
+                  -> m (Term (Sum fs) a)
-                  -> m (Term (Union fs) a)
+                  -> m (Term (Sum fs) a)
 postContextualize context rule = make <$> rule <*> many context
   where make node cs = case nonEmpty cs of
           Just cs -> makeTerm1 (Context cs node)
@@ -96,100 +88,77 @@ postContextualize context rule = make <$> rule <*> many context
 
 -- | Match infix terms separated by any of a list of operators, with optional context terms following each operand.
 infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack, Apply Foldable fs)
-             => m (Term (Union fs) a)
+             => m (Term (Sum fs) a)
-             -> m (Term (Union fs) a)
+             -> m (Term (Sum fs) a)
-             -> m (Term (Union fs) a)
+             -> m (Term (Sum fs) a)
-             -> [m (Term (Union fs) a -> Term (Union fs) a -> Union fs (Term (Union fs) a))]
+             -> [m (Term (Sum fs) a -> Term (Sum fs) a -> Sum fs (Term (Sum fs) a))]
-             -> m (Union fs (Term (Union fs) a))
+             -> m (Sum fs (Term (Sum fs) a))
 infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right
 
 
 -- Common
 
 -- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable).
-newtype Identifier a = Identifier ByteString
+newtype Identifier a = Identifier Name
   deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
 
 instance Eq1 Identifier where liftEq = genericLiftEq
 instance Ord1 Identifier where liftCompare = genericLiftCompare
 instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec
 
-instance ( Addressable (LocationFor v) es
+instance Evaluatable Identifier where
-         , Member Fail es
+  eval (Identifier name) = variable name
-         , Member (Reader (EnvironmentFor v)) es
-         , Member (State (StoreFor v)) es
-         ) => Evaluatable es t v Identifier where
-  eval (Identifier name) = do
-    env <- ask
-    maybe (fail ("free variable: " <> unpack name)) deref (envLookup name env)
 
 instance FreeVariables1 Identifier where
-  liftFreeVariables _ (Identifier x) = point x
+  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
 instance Show1 Program where liftShowsPrec = genericLiftShowsPrec
 
-instance ( Ord (LocationFor (Value l t))
+instance Evaluatable Program where
-         , Show (LocationFor (Value l t))
+  eval (Program xs) = eval xs
-         , Recursive t
-         , Evaluatable es t (Value l t) (Base t)
-         , FreeVariables t
-         , Member Fail es
-         , Member (State (EnvironmentFor (Value l t))) es
-         , Member (Reader (EnvironmentFor (Value l t))) es
-         )
-         => Evaluatable es t (Value l t) Program where
-  eval (Program xs) = eval' xs
-    where
-      interface val = inj . Value.Interface val <$> ask @(EnvironmentFor (Value l t))
-
-      eval' [] = interface unit
-      eval' [x] = subtermValue x >>= interface
-      eval' (x:xs) = do
-        _ <- subtermValue x
-        env <- get @(EnvironmentFor (Value l t))
-        local (envUnion env) (eval' xs)
-
-instance Member Fail es => Evaluatable es t Type.Type 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)
+  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
 instance Show1 AccessibilityModifier where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for AccessibilityModifier
-instance Member Fail es => Evaluatable es t v AccessibilityModifier
+instance Evaluatable AccessibilityModifier
 
 -- | Empty syntax, with essentially no-op semantics.
 --
 --   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
 instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
 
-instance (AbstractValue v) => Evaluatable es t v Empty where
+instance Evaluatable Empty where
-  eval _ = pure unit
+  eval _ = unit
 
 
 -- | 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
 instance Show1 Error where liftShowsPrec = genericLiftShowsPrec
 
-instance Member Fail es => Evaluatable es t v Error
+instance Evaluatable Error
 
 errorSyntax :: Error.Error String -> [a] -> Error a
 errorSyntax Error.Error{..} = Error (ErrorStack (getCallStack callStack)) errorExpected errorActual
@@ -214,7 +183,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
@@ -225,6 +194,5 @@ instance Eq1 Context where liftEq = genericLiftEq
 instance Ord1 Context where liftCompare = genericLiftCompare
 instance Show1 Context where liftShowsPrec = genericLiftShowsPrec
 
-instance (Evaluatable es t v (Base t), Recursive t)
+instance Evaluatable Context where
-         => Evaluatable es t v Context where
   eval Context{..} = subtermValue contextSubject

src/Data/Syntax/Comment.hs

@@ -2,21 +2,19 @@
 module Data.Syntax.Comment where
 
 import Prologue
-import Control.Monad.Effect.Evaluatable
+import Data.Abstract.Evaluatable
-import Data.Abstract.FreeVariables
-import Data.Abstract.Value as Value
 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
 instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec
 
-instance (AbstractValue v) => Evaluatable es t v Comment where
+instance Evaluatable Comment where
-  eval _ = pure unit
+  eval _ = unit
 
 -- TODO: nested comment types
 -- TODO: documentation comment types

src/Data/Syntax/Declaration.hs

@@ -1,24 +1,14 @@
-{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, UndecidableInstances #-}
+{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}
 module Data.Syntax.Declaration where
 
-import Prologue
+import qualified Data.Abstract.Environment as Env
-import Analysis.Abstract.Evaluating
+import Data.Abstract.Evaluatable
-import Control.Monad.Effect.Addressable
+import qualified Data.Set as Set (fromList)
-import Control.Monad.Effect.Fail
-import Control.Monad.Effect.Reader
-import Control.Monad.Effect.State
-import Data.Abstract.Address
-import Data.Abstract.Environment
-import Control.Monad.Effect.Evaluatable
-import Data.Abstract.FreeVariables
-import Data.Abstract.Value
 import Diffing.Algorithm
-import Prelude hiding (fail)
+import Prologue
-import qualified Data.Abstract.Type as Type
-import qualified Data.Abstract.Value as Value
 
 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,57 +17,23 @@ instance Eq1 Function where liftEq = genericLiftEq
 instance Ord1 Function where liftCompare = genericLiftCompare
 instance Show1 Function where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement evaluation under the binder for the typechecking evaluator.
 -- TODO: Filter the closed-over environment by the free variables in the term.
 -- TODO: How should we represent function types, where applicable?
 
-instance ( FreeVariables t
+instance Evaluatable Function where
-         , Semigroup (Cell l (Value l t))
-         , Addressable l es
-         , Member (State (EnvironmentFor (Value l t))) es
-         , Member (Reader (EnvironmentFor (Value l t))) es
-         , Member (State (StoreFor (Value l t))) es
-         ) => Evaluatable es t (Value l t) Function where
   eval Function{..} = do
-    env <- ask
+    name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm functionName)
-    let params = toList (liftFreeVariables (freeVariables . subterm) functionParameters)
+    (v, addr) <- letrec name (closure (paramNames functionParameters) (Set.fromList (freeVariables functionBody)) (subtermValue functionBody))
-    -- FIXME: Can we store the action evaluating the body in the Value instead of the body term itself?
+    modifyEnv (Env.insert name addr)
-    let v = inj (Closure params (subterm functionBody) env) :: Value l t
-
-    (name, addr) <- lookupOrAlloc (subterm functionName) v env
-    modify (envInsert name addr)
     pure v
+    where paramNames = foldMap (freeVariables . subterm)
 
--- TODO: Re-implement type checking with 'Evaluatable' approach.
+instance Declarations a => Declarations (Function a) where
-instance Member Fail es => Evaluatable es t Type.Type Function
+  declaredName Function{..} = declaredName functionName
--- instance ( Alternative m
---          , Monad m
---          , MonadFresh m
---          , MonadEnv Type.Type m
---          , MonadStore Type.Type m
---          , FreeVariables t
---          )
---          => Eval t Type.Type m Function where
---   eval recur yield Function{..} = do
---     env <- askEnv @Type.Type
---     let params = toList (foldMap freeVariables functionParameters)
---     tvars <- for params $ \name -> do
---       a <- alloc name
---       tvar <- Var <$> fresh
---       assign a tvar
---       pure (name, a, tvar)
---
---     outTy <- localEnv (const (foldr (\ (n, a, _) -> envInsert n a) env tvars)) (recur pure functionBody)
---     let tvars' = fmap (\(_, _, t) -> t) tvars
---     let v = Type.Product tvars' :-> outTy
---
---     (name, a) <- lookupOrAlloc functionName env v
---
---     localEnv (envInsert name a) (yield v)
 
 
 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
@@ -88,111 +44,112 @@ instance Show1 Method where liftShowsPrec = genericLiftShowsPrec
 
 -- Evaluating a Method creates a closure and makes that value available in the
 -- local environment.
-instance ( FreeVariables t                -- To get free variables from the function's parameters
+instance Evaluatable Method where
-         , Semigroup (Cell l (Value l t)) -- lookupOrAlloc
-         , Addressable l es              -- lookupOrAlloc
-         , Member (State (EnvironmentFor (Value l t))) es
-         , Member (Reader (EnvironmentFor (Value l t))) es
-         , Member (State (StoreFor (Value l t))) es
-         ) => Evaluatable es t (Value l t) Method where
   eval Method{..} = do
-    env <- ask
+    name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm methodName)
-    let params = toList (liftFreeVariables (freeVariables . subterm) methodParameters)
+    (v, addr) <- letrec name (closure (paramNames methodParameters) (Set.fromList (freeVariables methodBody)) (subtermValue methodBody))
-    -- FIXME: Can we store the action evaluating the body in the Value instead of the body term itself?
+    modifyEnv (Env.insert name addr)
-    let v = inj (Closure params (subterm methodBody) env) :: Value l t
-
-    (name, addr) <- lookupOrAlloc (subterm methodName) v env
-    modify (envInsert name addr)
     pure v
+    where paramNames = foldMap (freeVariables . subterm)
 
--- TODO: Implement Evaluatable instance for type checking
-instance Member Fail es => Evaluatable es t Type.Type Method
 
 -- | 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
 instance Show1 MethodSignature where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for MethodSignature
-instance Member Fail es => Evaluatable es t v MethodSignature
+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
 instance Show1 RequiredParameter where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for RequiredParameter
-instance Member Fail es => Evaluatable es t v RequiredParameter
+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
 instance Show1 OptionalParameter where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for OptionalParameter
-instance Member Fail es => Evaluatable es t v OptionalParameter
+instance Evaluatable OptionalParameter
 
 
 -- TODO: Should we replace this with Function and differentiate by context?
 -- TODO: How should we distinguish class/instance methods?
-
+-- 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
 instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for VariableDeclaration
+instance Evaluatable VariableDeclaration where
-instance Member Fail es => Evaluatable es t v VariableDeclaration
+  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
 instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for InterfaceDeclaration
-instance Member Fail es => Evaluatable es t v 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
 instance Show1 PublicFieldDefinition where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for PublicFieldDefinition
-instance Member Fail es => Evaluatable es t v PublicFieldDefinition
+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
 instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Variable
-instance Member Fail es => Evaluatable es t v Variable
+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
@@ -201,130 +158,94 @@ instance Eq1 Class where liftEq = genericLiftEq
 instance Ord1 Class where liftCompare = genericLiftCompare
 instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for Class
+instance Evaluatable Class where
-instance Member Fail es => Evaluatable es t v Class
+  eval Class{..} = do
-
+    name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm classIdentifier)
-
+    supers <- traverse subtermValue classSuperclasses
-data Module a = Module { moduleIdentifier :: !a, moduleScope :: ![a] }
+    (v, addr) <- letrec name $ do
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+      void $ subtermValue classBody
-
+      classEnv <- Env.head <$> getEnv
-instance Eq1 Module where liftEq = genericLiftEq
+      klass name supers classEnv
-instance Ord1 Module where liftCompare = genericLiftCompare
+    v <$ modifyEnv (Env.insert name addr)
-instance Show1 Module where liftShowsPrec = genericLiftShowsPrec
-
--- TODO: Implement Eval instance for Module
-instance Member Fail es => Evaluatable es t v Module
 
 -- | 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
 instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Decorator
-instance Member Fail es => Evaluatable es t v Decorator
+instance Evaluatable Decorator
 
 -- TODO: Generics, constraints.
 
 
 -- | 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
 instance Show1 Data.Syntax.Declaration.Datatype where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Datatype
-instance Member Fail es => Evaluatable es t v Data.Syntax.Declaration.Datatype
+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
 instance Show1 Data.Syntax.Declaration.Constructor where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Constructor
-instance Member Fail es => Evaluatable es t v Data.Syntax.Declaration.Constructor
+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
 instance Show1 Comprehension where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Comprehension
-instance Member Fail es => Evaluatable es t v Comprehension
+instance Evaluatable Comprehension
-
--- | Import declarations.
-data Import a = Import { importFrom :: !a, importAlias :: !a, importSymbols :: ![a] }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
-
-instance Eq1 Import where liftEq = genericLiftEq
-instance Ord1 Import where liftCompare = genericLiftCompare
-instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
-
-instance ( Show l
-         , Show t
-         , Members (Evaluating (Value l t)) es
-         , Evaluatable es t (Value l t) (Base t)
-         , Recursive t
-         , FreeVariables t
-         )
-         => Evaluatable es t (Value l t) Import where
-  eval (Import from _ _) = do
-    interface <- require @(Value l t) @t (subterm from)
-    -- TODO: Consider returning the value instead of the interface.
-    Interface _ env <- maybe
-                           (fail ("expected an interface, but got: " <> show interface))
-                           pure
-                           (prj interface :: Maybe (Value.Interface l t))
-
-    modify (envUnion env)
-    pure interface
---
-instance Member Fail es => Evaluatable es t Type.Type Import
-
-
--- | An imported symbol
-data ImportSymbol a = ImportSymbol { importSymbolName :: !a, importSymbolAlias :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
-
-instance Eq1 ImportSymbol where liftEq = genericLiftEq
-instance Ord1 ImportSymbol where liftCompare = genericLiftCompare
-instance Show1 ImportSymbol where liftShowsPrec = genericLiftShowsPrec
-
--- TODO: Implement Eval instance for ImportSymbol
-instance Member Fail es => Evaluatable es t v ImportSymbol
 
 
 -- | 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
 instance Show1 Type where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Type
-instance Member Fail es => Evaluatable es t v Type
+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 Member Fail es => Evaluatable es t v 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,32 @@
+{-# 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           Data.Span
+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
+
+
+-- A line directive like the Ruby constant `__LINE__`.
+data Line a = Line
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
+
+instance Eq1 Line where liftEq = genericLiftEq
+instance Ord1 Line where liftCompare = genericLiftCompare
+instance Show1 Line where liftShowsPrec = genericLiftShowsPrec
+
+instance Evaluatable Line where
+  eval Line = currentSpan >>= integer . fromIntegral . posLine . spanStart

src/Data/Syntax/Expression.hs

@@ -1,69 +1,24 @@
-{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, TypeApplications #-}
+{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, ViewPatterns #-}
 module Data.Syntax.Expression where
 
-import Control.Monad.Effect
+import Data.Abstract.Evaluatable
-import Control.Monad.Effect.Addressable
+import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv)
-import Control.Monad.Effect.Evaluatable
+import Data.Fixed
-import Control.Monad.Effect.Fail
-import Control.Monad.Effect.Reader
-import Control.Monad.Effect.State
-import Data.Algebra
-import Data.Abstract.Address
-import Data.Abstract.Environment
-import Data.Abstract.FreeVariables
-import Data.Abstract.Type as Type
-import Data.Abstract.Value (Value, Closure(..), EnvironmentFor, StoreFor)
 import Diffing.Algorithm
-import Prologue
+import Prologue hiding (index)
-import Prelude hiding (fail)
 
 -- | 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
 instance Show1 Call where liftShowsPrec = genericLiftShowsPrec
 
-
+instance Evaluatable Call where
-instance ( Ord l
-         , Semigroup (Cell l (Value l t))  -- 'assign'
-         , Addressable l es         -- 'alloc'
-         , Member Fail es
-         , Member (State (EnvironmentFor (Value l t))) es
-         , Member (Reader (EnvironmentFor (Value l t))) es
-         , Member (State (StoreFor (Value l t))) es
-         , Evaluatable es t (Value l t) (Base t)
-         , Recursive t
-         ) => Evaluatable es t (Value l t) Call where
   eval Call{..} = do
-    closure <- subtermValue callFunction
+    op <- subtermValue callFunction
-    Closure names body env <- maybe (fail "expected a closure") pure (prj closure :: Maybe (Closure l t))
+    call op (map subtermValue callParams)
-    bindings <- for (zip names callParams) $ \(name, param) -> do
-      v <- subtermValue param
-      a <- alloc name
-      assign a v
-      pure (name, a)
-
-    -- FIXME: `para eval` precludes custom evaluation à la dead code evaluation, gc, etc.
-    local (const (foldr (uncurry envInsert) env bindings)) (foldSubterms eval body)
-
--- TODO: Implement type checking for Call
-instance Member Fail es => Evaluatable es t Type.Type Call
--- TODO: extraRoots for evalCollect
--- instance ( MonadFail m
---          , MonadFresh m
---          , MonadGC Type m
---          , MonadEnv Type m
---          , FreeVariables t
---          )
---          => Eval t Type m Call where
---   eval recur yield Call{..} = do
---     opTy <- recur pure callFunction
---     tvar <- fresh
---     inTys <- traverse (recur pure) callParams
---     _ :-> outTy <- opTy `unify` (Type.Product inTys :-> Var tvar)
---     yield outTy
 
 data Comparison a
   = LessThan !a !a
@@ -72,15 +27,21 @@ 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
 instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for Comparison
+instance Evaluatable Comparison where
-instance Member Fail es => Evaluatable es t v Comparison
+  eval = traverse subtermValue >=> go where
-
+    go x = case x of
+      (LessThan a b)         -> liftComparison (Concrete (<)) a b
+      (LessThanEqual a b)    -> liftComparison (Concrete (<=)) a b
+      (GreaterThan a b)      -> liftComparison (Concrete (>)) a b
+      (GreaterThanEqual a b) -> liftComparison (Concrete (>=)) a b
+      (Equal a b)            -> liftComparison (Concrete (==)) a b
+      (Comparison a b)       -> liftComparison Generalized a b
 
 -- | Binary arithmetic operators.
 data Arithmetic a
@@ -88,18 +49,39 @@ 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
 instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for Arithmetic
+instance Evaluatable Arithmetic where
-instance Member Fail es => Evaluatable es t v Arithmetic
+  eval = traverse subtermValue >=> go where
+    go (Plus a b)          = liftNumeric2 add a b  where add    = liftReal (+)
+    go (Minus a b)         = liftNumeric2 sub a b  where sub    = 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 (Modulo a b)        = liftNumeric2 mod'' a b where mod'' = liftIntegralFrac mod mod'
+    go (Power a b)         = liftNumeric2 liftedExponent a b
+    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, Declarations1)
+
+instance Eq1 Match where liftEq = genericLiftEq
+instance Ord1 Match where liftCompare = genericLiftCompare
+instance Show1 Match where liftShowsPrec = genericLiftShowsPrec
+
+-- TODO: Implement Eval instance for Match
+instance Evaluatable Match
 
 -- | Boolean operators.
 data Boolean a
@@ -107,62 +89,70 @@ 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
 instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for Boolean
+instance Evaluatable Boolean where
-instance Member Fail es => Evaluatable es t v Boolean
+  -- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands
-
+  eval = go . fmap subtermValue where
+    go (And a b) = do
+      cond <- a
+      ifthenelse cond b (pure cond)
+    go (Or a b) = do
+      cond <- a
+      ifthenelse cond (pure cond) b
+    go (Not a) = a >>= asBool >>= boolean . not
+    go (XOr a b) = liftA2 (/=) (a >>= asBool) (b >>= asBool) >>= boolean
 
 -- | 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
 instance Show1 Delete where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Delete
-instance Member Fail es => Evaluatable es t v Delete
+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
 instance Show1 SequenceExpression where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for SequenceExpression
-instance Member Fail es => Evaluatable es t v SequenceExpression
+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
 instance Show1 Void where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Void
-instance Member Fail es => Evaluatable es t v Void
+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
 instance Show1 Typeof where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Typeof
-instance Member Fail es => Evaluatable es t v Typeof
+instance Evaluatable Typeof
 
 
 -- | Bitwise operators.
@@ -174,122 +164,133 @@ 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
 instance Show1 Bitwise where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for Bitwise
+instance Evaluatable Bitwise where
-instance Member Fail es => Evaluatable es t v Bitwise
+  eval = traverse subtermValue >=> go where
-
+    genLShift x y = shiftL x (fromIntegral y)
+    genRShift x y = shiftR x (fromIntegral y)
+    go x = case x of
+      (BOr a b)            -> liftBitwise2 (.|.) a b
+      (BAnd a b)           -> liftBitwise2 (.&.) a b
+      (BXOr a b)           -> liftBitwise2 xor a b
+      (LShift a b)         -> liftBitwise2 genLShift a b
+      (RShift a b)         -> liftBitwise2 genRShift a b
+      (UnsignedRShift a b) -> liftBitwise2 genRShift a b
+      (Complement a)       -> liftBitwise complement a
 
 -- | 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
 
--- TODO: Implement Eval instance for MemberAccess
+instance Evaluatable MemberAccess where
-instance Member Fail es => Evaluatable es t v MemberAccess
+  eval (fmap subtermValue -> MemberAccess mem acc) = evaluateInScopedEnv mem 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 Member Fail es => Evaluatable es t v 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
 instance Show1 Enumeration where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Enumeration
-instance Member Fail es => Evaluatable es t v Enumeration
+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
 instance Show1 InstanceOf where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for InstanceOf
-instance Member Fail es => Evaluatable es t v InstanceOf
+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
 instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for ScopeResolution
-instance Member Fail es => Evaluatable es t v ScopeResolution
+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
 instance Show1 NonNullExpression where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for NonNullExpression
-instance Member Fail es => Evaluatable es t v NonNullExpression
+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
 instance Show1 Await where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Await
-instance Member Fail es => Evaluatable es t v Await
+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
 instance Show1 New where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for New
-instance Member Fail es => Evaluatable es t v New
+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
 instance Show1 Cast where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Cast
-instance Member Fail es => Evaluatable es t v Cast
+instance Evaluatable Cast