mirror of
https://github.com/github/semantic.git
synced 2024-12-23 23:11:50 +03:00
Merge origin/master
This commit is contained in:
parent
be39373924
commit
9e2b7725a6
2
.ghci
2
.ghci
@ -25,7 +25,7 @@ assignmentExample lang = case lang of
|
|||||||
"Markdown" -> mk "md" "markdown"
|
"Markdown" -> mk "md" "markdown"
|
||||||
"JSON" -> mk "json" "json"
|
"JSON" -> mk "json" "json"
|
||||||
_ -> mk "" ""
|
_ -> 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
|
:undef assignment
|
||||||
:def assignment assignmentExample
|
:def assignment assignmentExample
|
||||||
|
7
.gitignore
vendored
7
.gitignore
vendored
@ -10,11 +10,16 @@ dist-newstyle
|
|||||||
.ghc.environment.*
|
.ghc.environment.*
|
||||||
|
|
||||||
tmp/
|
tmp/
|
||||||
|
|
||||||
bin/
|
bin/
|
||||||
|
|
||||||
|
/test/fixtures/*/examples
|
||||||
|
|
||||||
*.hp
|
*.hp
|
||||||
*.prof
|
*.prof
|
||||||
|
*.pyc
|
||||||
|
|
||||||
|
/test.*
|
||||||
|
/*.html
|
||||||
|
|
||||||
.bundle/
|
.bundle/
|
||||||
.licenses/vendor/gems
|
.licenses/vendor/gems
|
||||||
|
29
.gitmodules
vendored
29
.gitmodules
vendored
@ -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"]
|
[submodule "vendor/hspec-expectations-pretty-diff"]
|
||||||
path = vendor/hspec-expectations-pretty-diff
|
path = vendor/hspec-expectations-pretty-diff
|
||||||
url = https://github.com/rewinfrey/hspec-expectations-pretty-diff
|
url = https://github.com/rewinfrey/hspec-expectations-pretty-diff
|
||||||
[submodule "vendor/effects"]
|
[submodule "vendor/effects"]
|
||||||
path = vendor/effects
|
path = vendor/effects
|
||||||
url = https://github.com/joshvera/effects.git
|
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"]
|
[submodule "vendor/haskell-tree-sitter"]
|
||||||
path = vendor/haskell-tree-sitter
|
path = vendor/haskell-tree-sitter
|
||||||
url = https://github.com/tree-sitter/haskell-tree-sitter.git
|
url = https://github.com/tree-sitter/haskell-tree-sitter.git
|
||||||
[submodule "vendor/freer-cofreer"]
|
[submodule "vendor/freer-cofreer"]
|
||||||
path = vendor/freer-cofreer
|
path = vendor/freer-cofreer
|
||||||
url = https://github.com/robrix/freer-cofreer.git
|
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"]
|
[submodule "vendor/grpc-haskell"]
|
||||||
path = 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
|
|
||||||
|
234
.stylish-haskell.yaml
Normal file
234
.stylish-haskell.yaml
Normal file
@ -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
|
20
Dockerfile.release
Normal file
20
Dockerfile.release
Normal file
@ -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"]
|
3
HLint.hs
3
HLint.hs
@ -4,6 +4,9 @@ import "hint" HLint.Generalise
|
|||||||
|
|
||||||
ignore "Use mappend"
|
ignore "Use mappend"
|
||||||
ignore "Redundant do"
|
ignore "Redundant do"
|
||||||
|
-- TODO: investigate whether cost-center analysis is better with lambda-case than it was
|
||||||
|
ignore "Use lambda-case"
|
||||||
|
|
||||||
error "generalize ++" = (++) ==> (<>)
|
error "generalize ++" = (++) ==> (<>)
|
||||||
-- AMP fallout
|
-- AMP fallout
|
||||||
error "generalize mapM" = mapM ==> traverse
|
error "generalize mapM" = mapM ==> traverse
|
||||||
|
29
bench/Main.hs
Normal file
29
bench/Main.hs
Normal file
@ -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"
|
||||||
|
]
|
||||||
|
]
|
14
bench/bench-fixtures/python/function-definition.py
Normal file
14
bench/bench-fixtures/python/function-definition.py
Normal file
@ -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
|
12
bench/bench-fixtures/python/if-statement-functions.py
Normal file
12
bench/bench-fixtures/python/if-statement-functions.py
Normal file
@ -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()
|
5
bench/bench-fixtures/python/simple-assignment.py
Normal file
5
bench/bench-fixtures/python/simple-assignment.py
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
foo = 2
|
||||||
|
bar = foo
|
||||||
|
dang = 3
|
||||||
|
song = dang
|
||||||
|
song
|
19
bench/bench-fixtures/ruby/function-definition.rb
Normal file
19
bench/bench-fixtures/ruby/function-definition.rb
Normal file
@ -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
|
21
bench/bench-fixtures/ruby/if-statement-functions.rb
Normal file
21
bench/bench-fixtures/ruby/if-statement-functions.rb
Normal file
@ -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
|
5
bench/bench-fixtures/ruby/simple-assignment.rb
Normal file
5
bench/bench-fixtures/ruby/simple-assignment.rb
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
foo = 2
|
||||||
|
bar = foo
|
||||||
|
dang = 3
|
||||||
|
song = dang
|
||||||
|
song
|
3
preludes/python.py
Normal file
3
preludes/python.py
Normal file
@ -0,0 +1,3 @@
|
|||||||
|
def print(x):
|
||||||
|
__semantic_print(x)
|
||||||
|
return x
|
13
preludes/ruby.rb
Normal file
13
preludes/ruby.rb
Normal file
@ -0,0 +1,13 @@
|
|||||||
|
class Object
|
||||||
|
def new
|
||||||
|
self
|
||||||
|
end
|
||||||
|
|
||||||
|
def inspect
|
||||||
|
return "<object>"
|
||||||
|
end
|
||||||
|
end
|
||||||
|
|
||||||
|
def puts(obj)
|
||||||
|
__semantic_print(obj)
|
||||||
|
end
|
@ -35,17 +35,23 @@ generate_example () {
|
|||||||
diffFileAB="${fileA%%.*}.diffA-B.txt"
|
diffFileAB="${fileA%%.*}.diffA-B.txt"
|
||||||
diffFileBA="${fileB%%.*}.diffB-A.txt"
|
diffFileBA="${fileB%%.*}.diffB-A.txt"
|
||||||
|
|
||||||
status $parseFileA
|
if [ -e "$fileA" ]; then
|
||||||
"$(dirname "$0")/run" semantic parse --sexpression $fileA > $parseFileA
|
status $parseFileA
|
||||||
|
"$(dirname "$0")/run" semantic parse --sexpression $fileA > $parseFileA
|
||||||
|
fi
|
||||||
|
|
||||||
status $parseFileB
|
if [ -e "$fileB" ]; then
|
||||||
"$(dirname "$0")/run" semantic parse --sexpression $fileB > $parseFileB
|
status $parseFileB
|
||||||
|
"$(dirname "$0")/run" semantic parse --sexpression $fileB > $parseFileB
|
||||||
|
fi
|
||||||
|
|
||||||
status $diffFileAB
|
if [ -e "$fileA" -a -e "$fileB" ]; then
|
||||||
"$(dirname "$0")/run" semantic diff --sexpression $fileA $fileB > $diffFileAB
|
status $diffFileAB
|
||||||
|
"$(dirname "$0")/run" semantic diff --sexpression $fileA $fileB > $diffFileAB
|
||||||
|
|
||||||
status $diffFileBA
|
status $diffFileBA
|
||||||
"$(dirname "$0")/run" semantic diff --sexpression $fileB $fileA > $diffFileBA
|
"$(dirname "$0")/run" semantic diff --sexpression $fileB $fileA > $diffFileBA
|
||||||
|
fi
|
||||||
}
|
}
|
||||||
|
|
||||||
if [[ -d $1 ]]; then
|
if [[ -d $1 ]]; then
|
||||||
|
149
semantic.cabal
149
semantic.cabal
@ -15,57 +15,75 @@ library
|
|||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
-- Analyses & term annotations
|
-- 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.ConstructorName
|
||||||
, Analysis.CyclomaticComplexity
|
, Analysis.CyclomaticComplexity
|
||||||
, Analysis.Decorator
|
, Analysis.Decorator
|
||||||
, Analysis.Declaration
|
, Analysis.Declaration
|
||||||
, Analysis.IdentifierName
|
, Analysis.IdentifierName
|
||||||
, Analysis.ModuleDef
|
, Analysis.PackageDef
|
||||||
-- Semantic assignment
|
-- Semantic assignment
|
||||||
, Assigning.Assignment
|
, Assigning.Assignment
|
||||||
, Assigning.Assignment.Table
|
, 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.Address
|
||||||
, Data.Abstract.Cache
|
, Data.Abstract.Cache
|
||||||
, Data.Abstract.Configuration
|
, Data.Abstract.Configuration
|
||||||
|
, Data.Abstract.Declarations
|
||||||
, Data.Abstract.Environment
|
, Data.Abstract.Environment
|
||||||
, Data.Abstract.Linker
|
, Data.Abstract.Evaluatable
|
||||||
|
, Data.Abstract.Exports
|
||||||
, Data.Abstract.FreeVariables
|
, Data.Abstract.FreeVariables
|
||||||
|
, Data.Abstract.Heap
|
||||||
, Data.Abstract.Live
|
, 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.Type
|
||||||
, Data.Abstract.Value
|
, Data.Abstract.Value
|
||||||
|
-- General datatype definitions & generic algorithms
|
||||||
, Data.Algebra
|
, Data.Algebra
|
||||||
, Data.Align.Generic
|
, Data.Align.Generic
|
||||||
, Data.AST
|
, Data.AST
|
||||||
, Data.Blob
|
, Data.Blob
|
||||||
, Data.Diff
|
, Data.Diff
|
||||||
, Data.Error
|
, Data.Error
|
||||||
|
, Data.File
|
||||||
, Data.Functor.Both
|
, Data.Functor.Both
|
||||||
, Data.Functor.Classes.Generic
|
, Data.Functor.Classes.Generic
|
||||||
, Data.JSON.Fields
|
, Data.JSON.Fields
|
||||||
, Data.Language
|
, Data.Language
|
||||||
|
, Data.Map.Monoidal
|
||||||
, Data.Mergeable
|
, Data.Mergeable
|
||||||
, Data.Output
|
, Data.Output
|
||||||
, Data.Patch
|
, Data.Patch
|
||||||
, Data.Range
|
, Data.Range
|
||||||
, Data.Record
|
, Data.Record
|
||||||
|
, Data.Semigroup.App
|
||||||
|
, Data.Semilattice.Lower
|
||||||
|
, Data.Scientific.Exts
|
||||||
, Data.Source
|
, Data.Source
|
||||||
, Data.Span
|
, Data.Span
|
||||||
, Data.SplitDiff
|
, Data.SplitDiff
|
||||||
@ -73,6 +91,7 @@ library
|
|||||||
, Data.Syntax
|
, Data.Syntax
|
||||||
, Data.Syntax.Comment
|
, Data.Syntax.Comment
|
||||||
, Data.Syntax.Declaration
|
, Data.Syntax.Declaration
|
||||||
|
, Data.Syntax.Directive
|
||||||
, Data.Syntax.Expression
|
, Data.Syntax.Expression
|
||||||
, Data.Syntax.Literal
|
, Data.Syntax.Literal
|
||||||
, Data.Syntax.Statement
|
, Data.Syntax.Statement
|
||||||
@ -95,12 +114,14 @@ library
|
|||||||
, Language.JSON.Assignment
|
, Language.JSON.Assignment
|
||||||
, Language.Ruby.Grammar
|
, Language.Ruby.Grammar
|
||||||
, Language.Ruby.Assignment
|
, Language.Ruby.Assignment
|
||||||
|
, Language.Ruby.Syntax
|
||||||
, Language.TypeScript.Assignment
|
, Language.TypeScript.Assignment
|
||||||
, Language.TypeScript.Grammar
|
, Language.TypeScript.Grammar
|
||||||
, Language.TypeScript.Syntax
|
, Language.TypeScript.Syntax
|
||||||
, Language.PHP.Assignment
|
, Language.PHP.Assignment
|
||||||
, Language.PHP.Grammar
|
, Language.PHP.Grammar
|
||||||
, Language.PHP.Syntax
|
, Language.PHP.Syntax
|
||||||
|
, Language.Preluded
|
||||||
, Language.Python.Assignment
|
, Language.Python.Assignment
|
||||||
, Language.Python.Grammar
|
, Language.Python.Grammar
|
||||||
, Language.Python.Syntax
|
, Language.Python.Syntax
|
||||||
@ -118,13 +139,17 @@ library
|
|||||||
, Rendering.Symbol
|
, Rendering.Symbol
|
||||||
, Rendering.TOC
|
, Rendering.TOC
|
||||||
-- High-level flow & operational functionality (logging, stats, etc.)
|
-- High-level flow & operational functionality (logging, stats, etc.)
|
||||||
, Semantic
|
|
||||||
, Semantic.CLI
|
, Semantic.CLI
|
||||||
|
, Semantic.Diff
|
||||||
|
, Semantic.Distribute
|
||||||
|
, Semantic.Graph
|
||||||
, Semantic.IO
|
, Semantic.IO
|
||||||
, Semantic.Log
|
, Semantic.Log
|
||||||
|
, Semantic.Parse
|
||||||
|
, Semantic.Queue
|
||||||
, Semantic.Stat
|
, Semantic.Stat
|
||||||
, Semantic.Task
|
, Semantic.Task
|
||||||
, Semantic.Queue
|
, Semantic.Telemetry
|
||||||
, Semantic.Util
|
, Semantic.Util
|
||||||
-- Custom Prelude
|
-- Custom Prelude
|
||||||
, Prologue
|
, Prologue
|
||||||
@ -134,13 +159,15 @@ library
|
|||||||
, ansi-terminal
|
, ansi-terminal
|
||||||
, array
|
, array
|
||||||
, async
|
, async
|
||||||
|
, attoparsec
|
||||||
, bifunctors
|
, bifunctors
|
||||||
, bytestring
|
, bytestring
|
||||||
, cmark-gfm
|
, cmark-gfm
|
||||||
, comonad
|
|
||||||
, containers
|
, containers
|
||||||
, directory
|
, directory
|
||||||
|
, directory-tree
|
||||||
, effects
|
, effects
|
||||||
|
, fastsum
|
||||||
, filepath
|
, filepath
|
||||||
, free
|
, free
|
||||||
, freer-cofreer
|
, freer-cofreer
|
||||||
@ -156,9 +183,10 @@ library
|
|||||||
, optparse-applicative
|
, optparse-applicative
|
||||||
, parallel
|
, parallel
|
||||||
, parsers
|
, parsers
|
||||||
, pointed
|
|
||||||
, recursion-schemes
|
, recursion-schemes
|
||||||
, semigroups
|
, reducers
|
||||||
|
, scientific
|
||||||
|
, semigroupoids
|
||||||
, split
|
, split
|
||||||
, stm-chans
|
, stm-chans
|
||||||
, template-haskell
|
, template-haskell
|
||||||
@ -174,16 +202,20 @@ library
|
|||||||
, tree-sitter-ruby
|
, tree-sitter-ruby
|
||||||
, tree-sitter-typescript
|
, tree-sitter-typescript
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
default-extensions: DeriveFoldable
|
default-extensions: DataKinds
|
||||||
, DeriveFunctor
|
, DeriveFoldable
|
||||||
, DeriveGeneric
|
, DeriveFunctor
|
||||||
, DeriveTraversable
|
, DeriveGeneric
|
||||||
, FlexibleContexts
|
, DeriveTraversable
|
||||||
, FlexibleInstances
|
, FlexibleContexts
|
||||||
, OverloadedStrings
|
, FlexibleInstances
|
||||||
, RecordWildCards
|
, MultiParamTypeClasses
|
||||||
, StrictData
|
, OverloadedStrings
|
||||||
ghc-options: -Wall -fno-warn-name-shadowing -O -j
|
, RecordWildCards
|
||||||
|
, StandaloneDeriving
|
||||||
|
, StrictData
|
||||||
|
, TypeApplications
|
||||||
|
ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -O -j
|
||||||
ghc-prof-options: -fprof-auto
|
ghc-prof-options: -fprof-auto
|
||||||
|
|
||||||
executable semantic
|
executable semantic
|
||||||
@ -201,18 +233,26 @@ test-suite test
|
|||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
hs-source-dirs: test
|
hs-source-dirs: test
|
||||||
main-is: Spec.hs
|
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.Diff.Spec
|
||||||
|
, Data.Abstract.Path.Spec
|
||||||
, Data.Functor.Classes.Generic.Spec
|
, Data.Functor.Classes.Generic.Spec
|
||||||
, Data.Functor.Listable
|
, Data.Functor.Listable
|
||||||
, Data.Mergeable.Spec
|
, Data.Mergeable.Spec
|
||||||
|
, Data.Scientific.Spec
|
||||||
, Data.Source.Spec
|
, Data.Source.Spec
|
||||||
, Data.Term.Spec
|
, Data.Term.Spec
|
||||||
, Diffing.Algorithm.RWS.Spec
|
, Diffing.Algorithm.RWS.Spec
|
||||||
, Diffing.Algorithm.SES.Spec
|
, Diffing.Algorithm.SES.Spec
|
||||||
, Diffing.Interpreter.Spec
|
, Diffing.Interpreter.Spec
|
||||||
, Integration.Spec
|
, Integration.Spec
|
||||||
, Rendering.Imports.Spec
|
, Matching.Go.Spec
|
||||||
, Rendering.TOC.Spec
|
, Rendering.TOC.Spec
|
||||||
, Semantic.Spec
|
, Semantic.Spec
|
||||||
, Semantic.CLI.Spec
|
, Semantic.CLI.Spec
|
||||||
@ -227,6 +267,7 @@ test-suite test
|
|||||||
, bytestring
|
, bytestring
|
||||||
, comonad
|
, comonad
|
||||||
, effects
|
, effects
|
||||||
|
, fastsum
|
||||||
, filepath
|
, filepath
|
||||||
, free
|
, free
|
||||||
, Glob
|
, Glob
|
||||||
@ -245,7 +286,39 @@ test-suite test
|
|||||||
, these
|
, these
|
||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N -j
|
ghc-options: -threaded -rtsopts -with-rtsopts=-N -j
|
||||||
default-language: Haskell2010
|
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
|
source-repository head
|
||||||
type: git
|
type: git
|
||||||
|
@ -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.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
|
|
||||||
, MonadGC v m
|
|
||||||
, Alternative m
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
-- | Coinductively-cached evaluation.
|
-- | Look up the set of values for a given configuration in the out-cache.
|
||||||
evalCache :: forall v term
|
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)))
|
||||||
. ( Ord v
|
lookupCache configuration = cacheLookup configuration <$> get
|
||||||
, Ord term
|
|
||||||
, Ord (LocationFor v)
|
-- | Run an action, caching its result and 'Heap' under the given configuration.
|
||||||
, Ord (Cell (LocationFor v) v)
|
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
|
||||||
, Foldable (Cell (LocationFor v))
|
cachingConfiguration configuration values action = do
|
||||||
, Functor (Base term)
|
modify' (cacheSet configuration values)
|
||||||
, Recursive term
|
result <- (,) <$> action <*> get
|
||||||
, Addressable (LocationFor v) (Eff (Caching term v))
|
fst result <$ modify' (cacheInsert configuration result)
|
||||||
, Semigroup (Cell (LocationFor v) v)
|
|
||||||
, ValueRoots (LocationFor v) v
|
putCache :: Member (State (Cache term location (Cell location) value)) effects => Cache term location (Cell location) value -> Evaluator location value effects ()
|
||||||
, Eval term v (Eff (Caching term v)) (Base term)
|
putCache = put
|
||||||
)
|
|
||||||
=> term
|
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
|
||||||
-> Final (Caching term v) v
|
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)
|
||||||
evalCache e = run @(Caching term v) (fixCache (fix (evCache (evCollect (\ recur yield -> eval recur yield . project)))) pure e)
|
isolateCache action = putCache @term lowerBound *> action *> get
|
||||||
|
|
||||||
|
|
||||||
-- | 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.
|
-- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
|
||||||
evCache :: forall t v m
|
cachingTerms :: ( Cacheable term location (Cell location) value
|
||||||
. ( Ord (LocationFor v)
|
, Corecursive term
|
||||||
, Ord t
|
, Members '[ Fresh
|
||||||
, Ord v
|
, NonDet
|
||||||
, Ord (Cell (LocationFor v) v)
|
, Reader (Cache term location (Cell location) value)
|
||||||
, MonadCaching t v m
|
, Reader (Live location value)
|
||||||
)
|
, State (Cache term location (Cell location) value)
|
||||||
=> (((v -> m v) -> t -> m v) -> (v -> m v) -> t -> m v)
|
, State (Environment location value)
|
||||||
-> ((v -> m v) -> t -> m v)
|
, State (Heap location (Cell location) value)
|
||||||
-> (v -> m v) -> t -> m v
|
] effects
|
||||||
evCache ev0 ev' yield e = do
|
)
|
||||||
c <- getConfiguration e
|
=> SubtermAlgebra (Base term) term (Evaluator location value effects value)
|
||||||
cached <- getsCache (cacheLookup c)
|
-> SubtermAlgebra (Base term) term (Evaluator location value effects value)
|
||||||
|
cachingTerms recur term = do
|
||||||
|
c <- getConfiguration (embedSubterm term)
|
||||||
|
cached <- lookupCache c
|
||||||
case cached of
|
case cached of
|
||||||
Just pairs -> scatter pairs
|
Just pairs -> scatter pairs
|
||||||
Nothing -> do
|
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)
|
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.
|
-- | Iterate a monadic action starting from some initial seed until the results converge.
|
||||||
--
|
--
|
||||||
@ -135,3 +104,14 @@ converge f = loop
|
|||||||
pure x
|
pure x
|
||||||
else
|
else
|
||||||
loop x'
|
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
|
||||||
|
@ -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.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
|
where go seen set = case liveSplit set of
|
||||||
Nothing -> seen
|
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
|
Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen
|
||||||
_ -> seen)
|
_ -> seen)
|
||||||
|
|
||||||
|
|
||||||
|
providingLiveSet :: Evaluator location value (Reader (Live location value) ': effects) a -> Evaluator location value effects a
|
||||||
|
providingLiveSet = runReader lowerBound
|
||||||
|
@ -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 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
|
||||||
, Ord term
|
)
|
||||||
, Foldable (Base term)
|
=> SubtermAlgebra (Base term) term (Evaluator location value effects a)
|
||||||
, Recursive term
|
-> SubtermAlgebra (Base term) term (Evaluator location value effects a)
|
||||||
, Eval term v (Eff (DeadCodeEvaluating term v)) (Base term)
|
revivingTerms recur term = revive (embedSubterm term) *> recur term
|
||||||
, Addressable (LocationFor v) (Eff (DeadCodeEvaluating term v))
|
|
||||||
, Semigroup (Cell (LocationFor v) v)
|
|
||||||
)
|
|
||||||
=> term
|
|
||||||
-> Final (DeadCodeEvaluating term v) v
|
|
||||||
evalDead e0 = run @(DeadCodeEvaluating term v) $ do
|
|
||||||
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
|
||||||
|
@ -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))
|
|
||||||
|
196
src/Analysis/Abstract/Graph.hs
Normal file
196
src/Analysis/Abstract/Graph.hs
Normal file
@ -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
|
@ -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 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))
|
||||||
|
] effects
|
||||||
|
, Reducer (Configuration term location (Cell location) value) (trace (Configuration term location (Cell location) value))
|
||||||
|
)
|
||||||
|
=> trace (Configuration term location (Cell location) value)
|
||||||
|
-> 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
|
||||||
|
|
||||||
-- | Linear trace analysis.
|
trace :: Member (Writer (trace (Configuration term location (Cell location) value))) effects => trace (Configuration term location (Cell location) value) -> Evaluator location value effects ()
|
||||||
evalTrace :: forall v term
|
trace = tell
|
||||||
. ( 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
|
|
||||||
evalTrace = run @(Tracing [] term v) . fix (evTell @[] (\ recur yield -> eval recur yield . project)) pure
|
|
||||||
|
|
||||||
-- | Reachable configuration analysis.
|
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))
|
||||||
evalReach :: forall v term
|
tracing = runWriter
|
||||||
. ( 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
|
|
||||||
|
|
||||||
|
|
||||||
-- | Small-step evaluation which records every visited configuration.
|
|
||||||
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
|
|
||||||
|
111
src/Analysis/CallGraph.hs
Normal file
111
src/Analysis/CallGraph.hs
Normal file
@ -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
|
@ -1,16 +1,17 @@
|
|||||||
{-# LANGUAGE DataKinds, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||||
module Analysis.ConstructorName
|
module Analysis.ConstructorName
|
||||||
( ConstructorName(..)
|
( ConstructorName(..)
|
||||||
, ConstructorLabel(..)
|
, ConstructorLabel(..)
|
||||||
, constructorLabel
|
, constructorLabel
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Prologue
|
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.ByteString.Char8 (ByteString, pack, unpack)
|
import Data.ByteString.Char8 (ByteString, pack, unpack)
|
||||||
import Data.JSON.Fields
|
import Data.JSON.Fields
|
||||||
|
import Data.Sum
|
||||||
import Data.Term
|
import Data.Term
|
||||||
import Data.Text.Encoding (decodeUtf8)
|
import Data.Text.Encoding (decodeUtf8)
|
||||||
|
import Prologue
|
||||||
|
|
||||||
-- | Compute a 'ConstructorLabel' label for a 'Term'.
|
-- | Compute a 'ConstructorLabel' label for a 'Term'.
|
||||||
constructorLabel :: ConstructorName syntax => TermF syntax a b -> ConstructorLabel
|
constructorLabel :: ConstructorName syntax => TermF syntax a b -> ConstructorLabel
|
||||||
@ -38,8 +39,8 @@ instance (ConstructorNameStrategy syntax ~ strategy, ConstructorNameWithStrategy
|
|||||||
class CustomConstructorName syntax where
|
class CustomConstructorName syntax where
|
||||||
customConstructorName :: syntax a -> String
|
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
|
instance CustomConstructorName [] where
|
||||||
customConstructorName [] = "[]"
|
customConstructorName [] = "[]"
|
||||||
@ -48,9 +49,9 @@ instance CustomConstructorName [] where
|
|||||||
data Strategy = Default | Custom
|
data Strategy = Default | Custom
|
||||||
|
|
||||||
type family ConstructorNameStrategy syntax where
|
type family ConstructorNameStrategy syntax where
|
||||||
ConstructorNameStrategy (Union _) = 'Custom
|
ConstructorNameStrategy (Sum _) = 'Custom
|
||||||
ConstructorNameStrategy [] = 'Custom
|
ConstructorNameStrategy [] = 'Custom
|
||||||
ConstructorNameStrategy syntax = 'Default
|
ConstructorNameStrategy syntax = 'Default
|
||||||
|
|
||||||
class ConstructorNameWithStrategy (strategy :: Strategy) syntax where
|
class ConstructorNameWithStrategy (strategy :: Strategy) syntax where
|
||||||
constructorNameWithStrategy :: proxy strategy -> syntax a -> String
|
constructorNameWithStrategy :: proxy strategy -> syntax a -> String
|
||||||
|
@ -5,11 +5,12 @@ module Analysis.CyclomaticComplexity
|
|||||||
, cyclomaticComplexityAlgebra
|
, cyclomaticComplexityAlgebra
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Prologue
|
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
|
import Data.Sum
|
||||||
import qualified Data.Syntax.Declaration as Declaration
|
import qualified Data.Syntax.Declaration as Declaration
|
||||||
import qualified Data.Syntax.Statement as Statement
|
import qualified Data.Syntax.Statement as Statement
|
||||||
import Data.Term
|
import Data.Term
|
||||||
|
import Prologue
|
||||||
|
|
||||||
-- | The cyclomatic complexity of a (sub)term.
|
-- | The cyclomatic complexity of a (sub)term.
|
||||||
newtype CyclomaticComplexity = CyclomaticComplexity Int
|
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 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.
|
-- 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
|
cyclomaticComplexityAlgebra (In _ syntax) = toCyclomaticComplexity syntax
|
||||||
|
|
||||||
|
|
||||||
@ -71,9 +72,9 @@ instance CustomHasCyclomaticComplexity Statement.If
|
|||||||
instance CustomHasCyclomaticComplexity Statement.Pattern
|
instance CustomHasCyclomaticComplexity Statement.Pattern
|
||||||
instance CustomHasCyclomaticComplexity Statement.While
|
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@.
|
-- | 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.If = 'Custom
|
||||||
CyclomaticComplexityStrategy Statement.Pattern = 'Custom
|
CyclomaticComplexityStrategy Statement.Pattern = 'Custom
|
||||||
CyclomaticComplexityStrategy Statement.While = 'Custom
|
CyclomaticComplexityStrategy Statement.While = 'Custom
|
||||||
CyclomaticComplexityStrategy (Union fs) = 'Custom
|
CyclomaticComplexityStrategy (Sum fs) = 'Custom
|
||||||
CyclomaticComplexityStrategy a = 'Default
|
CyclomaticComplexityStrategy a = 'Default
|
||||||
|
|
||||||
|
|
||||||
|
@ -1,11 +1,11 @@
|
|||||||
{-# LANGUAGE DataKinds, MultiParamTypeClasses, TypeOperators, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
|
{-# LANGUAGE TypeOperators, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
|
||||||
module Analysis.Declaration
|
module Analysis.Declaration
|
||||||
( Declaration(..)
|
( Declaration(..)
|
||||||
, HasDeclaration
|
, HasDeclaration
|
||||||
, declarationAlgebra
|
, declarationAlgebra
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Prologue
|
import Data.Abstract.FreeVariables (Name(..))
|
||||||
import Data.Blob
|
import Data.Blob
|
||||||
import Data.Error (Error(..), showExpectation)
|
import Data.Error (Error(..), showExpectation)
|
||||||
import Data.Language as Language
|
import Data.Language as Language
|
||||||
@ -13,21 +13,25 @@ import Data.Range
|
|||||||
import Data.Record
|
import Data.Record
|
||||||
import Data.Source as Source
|
import Data.Source as Source
|
||||||
import Data.Span
|
import Data.Span
|
||||||
import Data.Term
|
import Data.Sum
|
||||||
import qualified Data.Syntax as Syntax
|
import qualified Data.Syntax as Syntax
|
||||||
import qualified Data.Syntax.Declaration as Declaration
|
import qualified Data.Syntax.Declaration as Declaration
|
||||||
import qualified Data.Syntax.Expression as Expression
|
import qualified Data.Syntax.Expression as Expression
|
||||||
|
import Data.Term
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
import qualified Data.Text.Encoding as T
|
||||||
import qualified Language.Markdown.Syntax as Markdown
|
import qualified Language.Markdown.Syntax as Markdown
|
||||||
|
import qualified Language.Ruby.Syntax as Ruby.Syntax
|
||||||
|
import Prologue
|
||||||
|
|
||||||
-- | A declaration’s identifier and type.
|
-- | A declaration’s identifier and type.
|
||||||
data Declaration
|
data Declaration
|
||||||
= MethodDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language, declarationReceiver :: Maybe T.Text }
|
= MethodDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language, declarationReceiver :: Maybe T.Text }
|
||||||
| ClassDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language }
|
| 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 }
|
| FunctionDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language }
|
||||||
| HeadingDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language, declarationLevel :: Int }
|
| 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 }
|
| ErrorDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Maybe Language }
|
||||||
deriving (Eq, Generic, Show)
|
deriving (Eq, Generic, Show)
|
||||||
|
|
||||||
@ -96,58 +100,48 @@ instance CustomHasDeclaration whole Declaration.Function where
|
|||||||
-- Do not summarize anonymous functions
|
-- Do not summarize anonymous functions
|
||||||
| isEmpty identifierAnn = Nothing
|
| isEmpty identifierAnn = Nothing
|
||||||
-- Named functions
|
-- 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'.
|
-- | 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
|
instance CustomHasDeclaration whole Declaration.Method where
|
||||||
customToDeclaration blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _)
|
customToDeclaration blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _)
|
||||||
-- Methods without a receiver
|
-- 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).
|
-- Methods with a receiver type and an identifier (e.g. (a *Type) in Go).
|
||||||
| blobLanguage == Just 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`
|
-- 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.
|
-- | Produce a 'ClassDeclaration' for 'Declaration.Class' nodes.
|
||||||
instance CustomHasDeclaration whole Declaration.Class where
|
instance CustomHasDeclaration whole Declaration.Class where
|
||||||
customToDeclaration blob@Blob{..} ann decl@(Declaration.Class _ (Term (In identifierAnn _), _) _ _)
|
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), _) _ _)
|
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
|
where
|
||||||
memberAccess modAnn termFOut
|
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
|
= memberAccess leftAnn leftF <> memberAccess rightAnn rightF
|
||||||
| otherwise = [getSource modAnn]
|
| otherwise = [getSource modAnn]
|
||||||
getSource = toText . flip Source.slice blobSource . getField
|
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@.
|
-- | 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.
|
-- 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
|
type family DeclarationStrategy syntax where
|
||||||
DeclarationStrategy Declaration.Class = 'Custom
|
DeclarationStrategy Declaration.Class = 'Custom
|
||||||
|
DeclarationStrategy Ruby.Syntax.Class = 'Custom
|
||||||
DeclarationStrategy Declaration.Function = 'Custom
|
DeclarationStrategy Declaration.Function = 'Custom
|
||||||
DeclarationStrategy Declaration.Import = 'Custom
|
|
||||||
DeclarationStrategy Declaration.Method = 'Custom
|
DeclarationStrategy Declaration.Method = 'Custom
|
||||||
DeclarationStrategy Markdown.Heading = 'Custom
|
DeclarationStrategy Markdown.Heading = 'Custom
|
||||||
DeclarationStrategy Expression.Call = 'Custom
|
DeclarationStrategy Expression.Call = 'Custom
|
||||||
DeclarationStrategy Syntax.Error = 'Custom
|
DeclarationStrategy Syntax.Error = 'Custom
|
||||||
DeclarationStrategy (Union fs) = 'Custom
|
DeclarationStrategy (Sum fs) = 'Custom
|
||||||
DeclarationStrategy a = 'Default
|
DeclarationStrategy a = 'Default
|
||||||
|
|
||||||
|
|
||||||
@ -206,3 +200,10 @@ getClassSource Blob{..} (In a r)
|
|||||||
bodyRange = getField <$> case r of
|
bodyRange = getField <$> case r of
|
||||||
Declaration.Class _ _ _ (Term (In a' _), _) -> Just a'
|
Declaration.Class _ _ _ (Term (In a' _), _) -> Just a'
|
||||||
in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange
|
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
|
||||||
|
@ -1,20 +1,22 @@
|
|||||||
{-# LANGUAGE DataKinds, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||||
module Analysis.IdentifierName
|
module Analysis.IdentifierName
|
||||||
( IdentifierName(..)
|
( IdentifierName(..)
|
||||||
, IdentifierLabel(..)
|
, IdentifierLabel(..)
|
||||||
, identifierLabel
|
, identifierLabel
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Prologue
|
import Data.Abstract.FreeVariables (Name (..))
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.JSON.Fields
|
import Data.JSON.Fields
|
||||||
import Data.Term
|
import Data.Sum
|
||||||
import Data.Text.Encoding (decodeUtf8)
|
|
||||||
import qualified Data.Syntax
|
import qualified Data.Syntax
|
||||||
|
import Data.Term
|
||||||
|
import Data.Text.Encoding (decodeUtf8)
|
||||||
|
import Prologue
|
||||||
|
|
||||||
-- | Compute a 'IdentifierLabel' label for a 'Term'.
|
-- | Compute a 'IdentifierLabel' label for a 'Term'.
|
||||||
identifierLabel :: IdentifierName syntax => TermF syntax a b -> Maybe IdentifierLabel
|
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
|
newtype IdentifierLabel = IdentifierLabel ByteString
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
@ -35,16 +37,16 @@ instance (IdentifierNameStrategy syntax ~ strategy, IdentifierNameWithStrategy s
|
|||||||
class CustomIdentifierName syntax where
|
class CustomIdentifierName syntax where
|
||||||
customIdentifierName :: syntax a -> Maybe ByteString
|
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
|
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
|
data Strategy = Default | Custom
|
||||||
|
|
||||||
type family IdentifierNameStrategy syntax where
|
type family IdentifierNameStrategy syntax where
|
||||||
IdentifierNameStrategy (Union _) = 'Custom
|
IdentifierNameStrategy (Sum _) = 'Custom
|
||||||
IdentifierNameStrategy Data.Syntax.Identifier = 'Custom
|
IdentifierNameStrategy Data.Syntax.Identifier = 'Custom
|
||||||
IdentifierNameStrategy syntax = 'Default
|
IdentifierNameStrategy syntax = 'Default
|
||||||
|
|
||||||
|
@ -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
|
|
95
src/Analysis/PackageDef.hs
Normal file
95
src/Analysis/PackageDef.hs
Normal file
@ -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
|
@ -1,4 +1,5 @@
|
|||||||
{-# LANGUAGE DataKinds, GADTs, InstanceSigs, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators #-}
|
{-# 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).
|
-- | 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.
|
-- 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:
|
-- 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).
|
-- 2. 'symbol' rules construct a committed choice (with only a single alternative).
|
||||||
--
|
--
|
||||||
@ -78,6 +77,8 @@ module Assigning.Assignment
|
|||||||
, while
|
, while
|
||||||
, until
|
, until
|
||||||
, manyThrough
|
, manyThrough
|
||||||
|
, getRubyLocals
|
||||||
|
, putRubyLocals
|
||||||
-- Results
|
-- Results
|
||||||
, Error(..)
|
, Error(..)
|
||||||
, errorCallStack
|
, errorCallStack
|
||||||
@ -122,6 +123,8 @@ data AssignmentF ast grammar a where
|
|||||||
Alt :: [a] -> AssignmentF ast grammar a
|
Alt :: [a] -> AssignmentF ast grammar a
|
||||||
Label :: Assignment ast grammar a -> String -> AssignmentF ast grammar a
|
Label :: Assignment ast grammar a -> String -> AssignmentF ast grammar a
|
||||||
Fail :: 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
|
data Tracing f a where
|
||||||
Tracing :: { tracingCallSite :: Maybe (String, SrcLoc), runTracing :: f a } -> Tracing f a
|
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 :: HasCallStack => Assignment ast grammar (Record Location)
|
||||||
location = tracing Location `Then` return
|
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.
|
-- | Zero-width production of the current node.
|
||||||
currentNode :: HasCallStack => Assignment ast grammar (TermF ast (Node grammar) ())
|
currentNode :: HasCallStack => Assignment ast grammar (TermF ast (Node grammar) ())
|
||||||
currentNode = tracing CurrentNode `Then` return
|
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)
|
run yield t initialState = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes)
|
||||||
where atNode (Term (In node f)) = case runTracing t of
|
where atNode (Term (In node f)) = case runTracing t of
|
||||||
Location -> yield (nodeLocation node) state
|
Location -> yield (nodeLocation node) state
|
||||||
|
GetRubyLocals -> yield stateRubyLocals state
|
||||||
|
PutRubyLocals l -> yield () (state { stateRubyLocals = l })
|
||||||
CurrentNode -> yield (In node (() <$ f)) state
|
CurrentNode -> yield (In node (() <$ f)) state
|
||||||
Source -> yield (Source.sourceBytes (Source.slice (nodeByteRange node) source)) (advanceState state)
|
Source -> yield (Source.sourceBytes (Source.slice (nodeByteRange node) source)) (advanceState state)
|
||||||
Children child -> do
|
Children child -> do
|
||||||
(a, state') <- go child state { stateNodes = toList f, stateCallSites = maybe id (:) (tracingCallSite t) stateCallSites } >>= requireExhaustive (tracingCallSite t)
|
(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 })
|
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 (Just node)
|
||||||
|
|
||||||
anywhere node = case runTracing t of
|
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))
|
Term (In node _) : _ -> Left (withStateCallStack callSite state (nodeError [] node))
|
||||||
|
|
||||||
withStateCallStack :: Maybe (String, SrcLoc) -> State ast grammar -> (HasCallStack => a) -> a
|
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 :: Symbol grammar => State ast grammar -> State ast grammar
|
||||||
skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . termAnnotation) (stateNodes state) }
|
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.
|
-- | 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 ast grammar -> State ast grammar
|
||||||
advanceState state@State{..}
|
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
|
| otherwise = state
|
||||||
|
|
||||||
-- | State kept while running 'Assignment's.
|
-- | 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.
|
, 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.
|
, 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.”
|
, 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 (Eq grammar, Eq1 ast) => Eq (State ast grammar)
|
||||||
deriving instance (Show grammar, Show1 ast) => Show (State ast grammar)
|
deriving instance (Show grammar, Show1 ast) => Show (State ast grammar)
|
||||||
|
|
||||||
makeState :: [AST ast grammar] -> 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
|
-- 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
|
instance (Enum grammar, Eq1 ast, Ix grammar) => Monoid (Assignment ast grammar a) where
|
||||||
mempty = empty
|
mempty = empty
|
||||||
mappend = (<|>)
|
mappend = (<>)
|
||||||
|
|
||||||
instance (Enum grammar, Eq1 ast, Ix grammar) => Alternative (Assignment ast grammar) where
|
instance (Enum grammar, Eq1 ast, Ix grammar) => Alternative (Assignment ast grammar) where
|
||||||
empty :: HasCallStack => Assignment ast grammar a
|
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)
|
Alt as -> showsUnaryWith (const sl) "Alt" d (toList as)
|
||||||
Label child string -> showsBinaryWith (liftShowsPrec sp sl) showsPrec "Label" d child string
|
Label child string -> showsBinaryWith (liftShowsPrec sp sl) showsPrec "Label" d child string
|
||||||
Fail s -> showsUnaryWith showsPrec "Fail" d s
|
Fail s -> showsUnaryWith showsPrec "Fail" d s
|
||||||
|
GetRubyLocals -> showString "GetRubyLocals"
|
||||||
|
PutRubyLocals _ -> showString "PutRubyLocals _"
|
||||||
where showChild = liftShowsPrec sp sl
|
where showChild = liftShowsPrec sp sl
|
||||||
showChildren = liftShowList sp sl
|
showChildren = liftShowList sp sl
|
||||||
|
|
||||||
|
{-# ANN module ("HLint: ignore Avoid return" :: String) #-}
|
||||||
|
@ -6,7 +6,7 @@ module Assigning.Assignment.Table
|
|||||||
, lookup
|
, lookup
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Prologue hiding (toList)
|
import Prologue
|
||||||
import Prelude hiding (lookup)
|
import Prelude hiding (lookup)
|
||||||
import qualified Data.IntMap as IntMap
|
import qualified Data.IntMap as IntMap
|
||||||
import qualified Data.IntSet as IntSet
|
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 :: Enum i => i -> a -> Table i a
|
||||||
singleton i a = Table [i] (IntMap.singleton (fromEnum 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))
|
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)]
|
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
|
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
|
instance (Enum i, Monoid a) => Monoid (Table i a) where
|
||||||
mempty = Table mempty mempty
|
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
|
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)
|
liftShowsPrec spA slA d t = showsBinaryWith showsPrec (const (liftShowList spA slA)) "Table" d (tableAddresses t) (toPairs t)
|
||||||
|
15
src/Control/Abstract.hs
Normal file
15
src/Control/Abstract.hs
Normal file
@ -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
|
129
src/Control/Abstract/Addressable.hs
Normal file
129
src/Control/Abstract/Addressable.hs
Normal file
@ -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
|
15
src/Control/Abstract/Configuration.hs
Normal file
15
src/Control/Abstract/Configuration.hs
Normal file
@ -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
|
55
src/Control/Abstract/Context.hs
Normal file
55
src/Control/Abstract/Context.hs
Normal file
@ -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
|
89
src/Control/Abstract/Environment.hs
Normal file
89
src/Control/Abstract/Environment.hs
Normal file
@ -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
|
84
src/Control/Abstract/Evaluator.hs
Normal file
84
src/Control/Abstract/Evaluator.hs
Normal file
@ -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)
|
33
src/Control/Abstract/Exports.hs
Normal file
33
src/Control/Abstract/Exports.hs
Normal file
@ -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
|
77
src/Control/Abstract/Goto.hs
Normal file
77
src/Control/Abstract/Goto.hs
Normal file
@ -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
|
40
src/Control/Abstract/Heap.hs
Normal file
40
src/Control/Abstract/Heap.hs
Normal file
@ -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
|
125
src/Control/Abstract/Matching.hs
Normal file
125
src/Control/Abstract/Matching.hs
Normal file
@ -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
|
159
src/Control/Abstract/Modules.hs
Normal file
159
src/Control/Abstract/Modules.hs
Normal file
@ -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
|
17
src/Control/Abstract/Roots.hs
Normal file
17
src/Control/Abstract/Roots.hs
Normal file
@ -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)
|
205
src/Control/Abstract/Value.hs
Normal file
205
src/Control/Abstract/Value.hs
Normal file
@ -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
|
@ -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)
|
|
@ -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
|
|
@ -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
|
|
@ -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)
|
|
@ -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)
|
|
@ -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' ())
|
|
@ -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')
|
|
@ -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)
|
|
@ -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
|
|
@ -6,6 +6,11 @@ import Data.Record
|
|||||||
import Data.Span
|
import Data.Span
|
||||||
import Data.Term
|
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.
|
-- | An AST node labelled with symbols and source location.
|
||||||
type AST syntax grammar = Term syntax (Node grammar)
|
type AST syntax grammar = Term syntax (Node grammar)
|
||||||
|
|
||||||
@ -16,6 +21,12 @@ data Node grammar = Node
|
|||||||
}
|
}
|
||||||
deriving (Eq, Show)
|
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.
|
-- | A location specified as possibly-empty intervals of bytes and line/column positions.
|
||||||
type Location = '[Range, Span]
|
type Location = '[Range, Span]
|
||||||
|
|
||||||
|
@ -1,43 +1,74 @@
|
|||||||
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeFamilyDependencies #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}
|
||||||
module Data.Abstract.Address where
|
module Data.Abstract.Address where
|
||||||
|
|
||||||
import Prologue
|
|
||||||
import Data.Abstract.FreeVariables
|
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.
|
-- | '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)
|
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.
|
-- | '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)
|
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.
|
-- | 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
|
||||||
|
@ -1,45 +1,26 @@
|
|||||||
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, UndecidableInstances #-}
|
{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, TypeFamilies #-}
|
||||||
module Data.Abstract.Cache where
|
module Data.Abstract.Cache where
|
||||||
|
|
||||||
import Prologue
|
|
||||||
import Data.Abstract.Address
|
|
||||||
import Data.Abstract.Configuration
|
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
|
|
||||||
|
@ -1,26 +1,14 @@
|
|||||||
{-# LANGUAGE DeriveFoldable, DeriveGeneric, FlexibleContexts, StandaloneDeriving, UndecidableInstances #-}
|
|
||||||
module Data.Abstract.Configuration where
|
module Data.Abstract.Configuration where
|
||||||
|
|
||||||
import Prologue
|
|
||||||
import Data.Abstract.Address
|
|
||||||
import Data.Abstract.Environment
|
import Data.Abstract.Environment
|
||||||
|
import Data.Abstract.Heap
|
||||||
import Data.Abstract.Live
|
import Data.Abstract.Live
|
||||||
import Data.Abstract.Store
|
|
||||||
|
|
||||||
-- | A single point in a program’s execution.
|
-- | 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 (Eq, Ord, Show)
|
||||||
deriving (Generic1)
|
|
||||||
|
|
||||||
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
|
|
||||||
|
27
src/Data/Abstract/Declarations.hs
Normal file
27
src/Data/Abstract/Declarations.hs
Normal file
@ -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 []
|
@ -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.Address
|
||||||
import Data.Abstract.FreeVariables
|
import Data.Abstract.FreeVariables
|
||||||
import Data.Abstract.Live
|
import Data.Abstract.Live
|
||||||
|
import Data.Align
|
||||||
import qualified Data.Map as Map
|
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.
|
-- | 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.
|
-- | 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.
|
-- | Retrieve the 'Live' set of addresses to which the given free variable names are bound.
|
||||||
--
|
--
|
||||||
-- Unbound names are silently dropped.
|
-- 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
|
|
||||||
|
257
src/Data/Abstract/Evaluatable.hs
Normal file
257
src/Data/Abstract/Evaluatable.hs
Normal file
@ -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
|
39
src/Data/Abstract/Exports.hs
Normal file
39
src/Data/Abstract/Exports.hs
Normal file
@ -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
|
@ -1,17 +1,27 @@
|
|||||||
{-# LANGUAGE DefaultSignatures, UndecidableInstances #-}
|
{-# LANGUAGE DefaultSignatures, UndecidableInstances #-}
|
||||||
module Data.Abstract.FreeVariables where
|
module Data.Abstract.FreeVariables where
|
||||||
|
|
||||||
import Prologue
|
import qualified Data.ByteString.Char8 as BC
|
||||||
import Data.Term
|
import Data.String
|
||||||
|
import Data.Sum
|
||||||
|
import Data.Term
|
||||||
|
import Prologue
|
||||||
|
|
||||||
-- | The type of variable names.
|
-- | 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.
|
-- | Types which can contain unbound variables.
|
||||||
class FreeVariables term where
|
class FreeVariables term where
|
||||||
-- | The set of free variables in the given value.
|
-- | 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 @* -> *@.
|
-- | 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.
|
-- '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
|
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.
|
-- | 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
|
liftFreeVariables = foldMap
|
||||||
|
|
||||||
-- | Lift the 'freeVariables' method through a containing structure.
|
-- | 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
|
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
|
instance (FreeVariables1 syntax, Functor syntax) => FreeVariables (Term syntax ann) where
|
||||||
freeVariables = cata (liftFreeVariables id)
|
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
|
instance (FreeVariables1 syntax) => FreeVariables1 (TermF syntax ann) where
|
||||||
liftFreeVariables f (In _ s) = liftFreeVariables f s
|
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 []
|
instance FreeVariables1 []
|
||||||
|
42
src/Data/Abstract/Heap.hs
Normal file
42
src/Data/Abstract/Heap.hs
Normal file
@ -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)
|
@ -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)
|
|
@ -1,60 +1,38 @@
|
|||||||
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-}
|
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-}
|
||||||
module Data.Abstract.Live where
|
module Data.Abstract.Live where
|
||||||
|
|
||||||
import Prologue
|
|
||||||
import Data.Abstract.Address
|
import Data.Abstract.Address
|
||||||
|
import Data.Semilattice.Lower
|
||||||
import Data.Set as Set
|
import Data.Set as Set
|
||||||
import Unsafe.Coerce
|
import Prologue
|
||||||
|
|
||||||
-- | A set of live addresses (whether roots or reachable).
|
-- | 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.
|
-- | 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.
|
-- | 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.
|
-- | 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.
|
-- | 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)
|
liveDifference = fmap Live . (Set.difference `on` unLive)
|
||||||
|
|
||||||
-- | Test whether an 'Address' is in a 'Live' set.
|
-- | 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.
|
-- | 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
|
|
||||||
|
42
src/Data/Abstract/Module.hs
Normal file
42
src/Data/Abstract/Module.hs
Normal file
@ -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))
|
54
src/Data/Abstract/ModuleTable.hs
Normal file
54
src/Data/Abstract/ModuleTable.hs
Normal file
@ -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
|
104
src/Data/Abstract/Number.hs
Normal file
104
src/Data/Abstract/Number.hs
Normal file
@ -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
|
40
src/Data/Abstract/Package.hs
Normal file
40
src/Data/Abstract/Package.hs
Normal file
@ -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
|
26
src/Data/Abstract/Path.hs
Normal file
26
src/Data/Abstract/Path.hs
Normal file
@ -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 (== '.')
|
@ -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)
|
|
@ -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 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
|
type TName = Int
|
||||||
|
|
||||||
-- | A datatype representing primitive types and combinations thereof.
|
-- | A datatype representing primitive types and combinations thereof.
|
||||||
data Type
|
data Type location
|
||||||
= Int -- ^ Primitive int type.
|
= Int -- ^ Primitive int type.
|
||||||
| Bool -- ^ Primitive boolean type.
|
| Bool -- ^ Primitive boolean type.
|
||||||
| String -- ^ Primitive string type.
|
| String -- ^ Primitive string type.
|
||||||
| Unit -- ^ The unit type.
|
| Symbol -- ^ Type of unique symbols.
|
||||||
| Type :-> Type -- ^ Binary function types.
|
| Unit -- ^ The unit type.
|
||||||
| Var TName -- ^ A type variable.
|
| Float -- ^ Floating-point type.
|
||||||
| Product [Type] -- ^ N-ary products.
|
| Rational -- ^ Rational type.
|
||||||
|
| Type location :-> Type location -- ^ Binary function types.
|
||||||
|
| Var TName -- ^ A type variable.
|
||||||
|
| 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)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
-- TODO: À la carte representation of types.
|
-- 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 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 (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.
|
-- FIXME: this should be constructing a substitution.
|
||||||
unify (Var _) b = pure b
|
unify (Var _) b = pure b
|
||||||
unify a (Var _) = pure a
|
unify a (Var _) = pure a
|
||||||
unify (Product as) (Product bs) = Product <$> sequenceA (alignWith (these pure pure unify) as bs)
|
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
|
||||||
|
@ -1,58 +1,86 @@
|
|||||||
{-# LANGUAGE ConstraintKinds, DataKinds, FunctionalDependencies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
|
{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
|
||||||
module Data.Abstract.Value where
|
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.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 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
|
import qualified Prelude
|
||||||
|
|
||||||
type ValueConstructors location
|
type ValueConstructors location
|
||||||
= '[Closure location
|
= '[Array
|
||||||
, Interface location
|
|
||||||
, Unit
|
|
||||||
, Boolean
|
, Boolean
|
||||||
|
, Class location
|
||||||
|
, Closure location
|
||||||
|
, Float
|
||||||
|
, Hash
|
||||||
, Integer
|
, Integer
|
||||||
|
, KVPair
|
||||||
|
, Namespace location
|
||||||
|
, Null
|
||||||
|
, Rational
|
||||||
, String
|
, String
|
||||||
|
, Symbol
|
||||||
|
, Tuple
|
||||||
|
, Unit
|
||||||
|
, Hole
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | Open union of primitive values that terms can be evaluated to.
|
-- | 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: 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)
|
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.
|
-- | 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)
|
deriving (Eq, Generic1, Ord, Show)
|
||||||
|
|
||||||
instance Eq1 Unit where liftEq = genericLiftEq
|
instance Eq1 Unit where liftEq = genericLiftEq
|
||||||
instance Ord1 Unit where liftCompare = genericLiftCompare
|
instance Ord1 Unit where liftCompare = genericLiftCompare
|
||||||
instance Show1 Unit where liftShowsPrec = genericLiftShowsPrec
|
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.
|
-- | Boolean values.
|
||||||
newtype Boolean term = Boolean Prelude.Bool
|
newtype Boolean value = Boolean Prelude.Bool
|
||||||
deriving (Eq, Generic1, Ord, Show)
|
deriving (Eq, Generic1, Ord, Show)
|
||||||
|
|
||||||
instance Eq1 Boolean where liftEq = genericLiftEq
|
instance Eq1 Boolean where liftEq = genericLiftEq
|
||||||
@ -60,74 +88,335 @@ instance Ord1 Boolean where liftCompare = genericLiftCompare
|
|||||||
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- | Arbitrary-width integral values.
|
-- | Arbitrary-width integral values.
|
||||||
newtype Integer term = Integer Prelude.Integer
|
newtype Integer value = Integer (Number.Number Prelude.Integer)
|
||||||
deriving (Eq, Generic1, Ord, Show)
|
deriving (Eq, Generic1, Ord, Show)
|
||||||
|
|
||||||
instance Eq1 Integer where liftEq = genericLiftEq
|
instance Eq1 Integer where liftEq = genericLiftEq
|
||||||
instance Ord1 Integer where liftCompare = genericLiftCompare
|
instance Ord1 Integer where liftCompare = genericLiftCompare
|
||||||
instance Show1 Integer where liftShowsPrec = genericLiftShowsPrec
|
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.
|
-- | String values.
|
||||||
newtype String term = String ByteString
|
newtype String value = String ByteString
|
||||||
deriving (Eq, Generic1, Ord, Show)
|
deriving (Eq, Generic1, Ord, Show)
|
||||||
|
|
||||||
instance Eq1 String where liftEq = genericLiftEq
|
instance Eq1 String where liftEq = genericLiftEq
|
||||||
instance Ord1 String where liftCompare = genericLiftCompare
|
instance Ord1 String where liftCompare = genericLiftCompare
|
||||||
instance Show1 String where liftShowsPrec = genericLiftShowsPrec
|
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
|
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
|
||||||
| otherwise = mempty
|
|
||||||
|
|
||||||
|
instance AbstractHole (Value location) where
|
||||||
|
hole = injValue Hole
|
||||||
|
|
||||||
-- | Construct a 'Value' wrapping the value arguments (if any).
|
-- | 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
|
||||||
|
@ -1,19 +1,27 @@
|
|||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
module Data.Algebra
|
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@.
|
-- | 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'.
|
-- | A subterm and its computed value, used in 'SubtermAlgebra'.
|
||||||
data Subterm t a = Subterm { subterm :: !t, subtermValue :: !a }
|
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.
|
-- | 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
|
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 :: Recursive t => SubtermAlgebra (Base t) t a -> t -> a
|
||||||
foldSubterms algebra = go where go = algebra . fmap (Subterm <*> go) . project
|
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).
|
-- | Promote an 'FAlgebra' into an 'RAlgebra' (by dropping the original parameter).
|
||||||
fToR :: Functor (Base t) => FAlgebra (Base t) a -> RAlgebra (Base t) t a
|
fToR :: Functor (Base t) => FAlgebra (Base t) a -> RAlgebra (Base t) t a
|
||||||
|
@ -3,11 +3,11 @@ module Data.Align.Generic where
|
|||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import Data.Functor (($>))
|
||||||
import Data.List.NonEmpty (NonEmpty(..))
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Proxy
|
import Data.Sum
|
||||||
import Data.These
|
import Data.These
|
||||||
import Data.Union
|
|
||||||
import GHC.Generics
|
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.
|
-- | 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
|
instance GAlign NonEmpty where
|
||||||
galignWith f (a1:|as1) (a2:|as2) = (:|) <$> f (These a1 a2) <*> galignWith f as1 as2
|
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
|
-- Generics
|
||||||
@ -52,7 +52,7 @@ instance GAlign Par1 where
|
|||||||
|
|
||||||
-- | 'GAlign' over non-parameter fields. Only equal values are aligned.
|
-- | 'GAlign' over non-parameter fields. Only equal values are aligned.
|
||||||
instance Eq c => GAlign (K1 i c) where
|
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.
|
-- | 'GAlign' over applications over parameters.
|
||||||
instance GAlign f => GAlign (Rec1 f) where
|
instance GAlign f => GAlign (Rec1 f) where
|
||||||
|
@ -22,9 +22,9 @@ import Data.Aeson
|
|||||||
import Data.Bifoldable
|
import Data.Bifoldable
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
import Data.Bitraversable
|
import Data.Bitraversable
|
||||||
import Data.Foldable (asum, toList)
|
import Data.Foldable (asum)
|
||||||
import Data.Functor.Classes
|
import Data.Functor.Classes
|
||||||
import Data.Functor.Foldable hiding (fold)
|
import Data.Functor.Foldable
|
||||||
import Data.JSON.Fields
|
import Data.JSON.Fields
|
||||||
import Data.Mergeable (Mergeable(sequenceAlt))
|
import Data.Mergeable (Mergeable(sequenceAlt))
|
||||||
import Data.Patch
|
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))
|
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 :: (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
|
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.
|
-- | Recover the before state of a diff.
|
||||||
|
@ -79,4 +79,4 @@ showCallStack :: Colourize -> CallStack -> ShowS
|
|||||||
showCallStack colourize callStack = foldr (.) id (intersperse (showChar '\n') (uncurry (showCallSite colourize) <$> getCallStack callStack))
|
showCallStack colourize callStack = foldr (.) id (intersperse (showChar '\n') (uncurry (showCallSite colourize) <$> getCallStack callStack))
|
||||||
|
|
||||||
showCallSite :: Colourize -> String -> SrcLoc -> ShowS
|
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)))
|
||||||
|
30
src/Data/File.hs
Normal file
30
src/Data/File.hs
Normal file
@ -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
|
@ -3,16 +3,12 @@ module Data.Functor.Both
|
|||||||
( Both
|
( Both
|
||||||
, both
|
, both
|
||||||
, runBothWith
|
, runBothWith
|
||||||
, fst
|
|
||||||
, snd
|
|
||||||
, module X
|
, module X
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Bifunctor.Join as X
|
import Data.Bifunctor.Join as X
|
||||||
import Data.Functor.Classes
|
import Data.Functor.Classes
|
||||||
import Data.Semigroup
|
import Data.Semigroup
|
||||||
import Prelude hiding (fst, snd)
|
|
||||||
import qualified Prelude
|
|
||||||
|
|
||||||
-- | A computation over both sides of a pair.
|
-- | A computation over both sides of a pair.
|
||||||
type Both = Join (,)
|
type Both = Join (,)
|
||||||
@ -25,13 +21,6 @@ both = curry Join
|
|||||||
runBothWith :: (a -> a -> b) -> Both a -> b
|
runBothWith :: (a -> a -> b) -> Both a -> b
|
||||||
runBothWith f = uncurry f . runJoin
|
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
|
instance (Semigroup a, Monoid a) => Monoid (Join (,) a) where
|
||||||
mempty = pure mempty
|
mempty = pure mempty
|
||||||
|
@ -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.
|
-- | 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
|
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
|
||||||
defaultGShow1Options = GShow1Options { optionsUseRecordSyntax = False }
|
defaultGShow1Options = GShow1Options { optionsUseRecordSyntax = False }
|
||||||
|
@ -1,8 +1,9 @@
|
|||||||
{-# LANGUAGE MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
|
{-# LANGUAGE MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
|
||||||
module Data.JSON.Fields where
|
module Data.JSON.Fields where
|
||||||
|
|
||||||
import Prologue
|
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
|
import Data.Sum (Apply(..), Sum)
|
||||||
|
import Prologue
|
||||||
|
|
||||||
class ToJSONFields a where
|
class ToJSONFields a where
|
||||||
toJSONFields :: KeyValue kv => a -> [kv]
|
toJSONFields :: KeyValue kv => a -> [kv]
|
||||||
@ -23,8 +24,8 @@ instance ToJSON a => ToJSONFields [a] where
|
|||||||
instance ToJSONFields1 [] where
|
instance ToJSONFields1 [] where
|
||||||
toJSONFields1 list = [ "children" .= list ]
|
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
|
instance (ToJSONFields a, ToJSONFields b) => ToJSONFields (a, b) where
|
||||||
toJSONFields (a, b) = [ "before" .= JSONFields a, "after" .= JSONFields b ]
|
toJSONFields (a, b) = [ "before" .= JSONFields a, "after" .= JSONFields b ]
|
||||||
|
@ -24,7 +24,7 @@ languageForType mediaType = case mediaType of
|
|||||||
".md" -> Just Markdown
|
".md" -> Just Markdown
|
||||||
".rb" -> Just Ruby
|
".rb" -> Just Ruby
|
||||||
".go" -> Just Go
|
".go" -> Just Go
|
||||||
".js" -> Just TypeScript
|
".js" -> Just JavaScript
|
||||||
".ts" -> Just TypeScript
|
".ts" -> Just TypeScript
|
||||||
".tsx" -> Just TypeScript
|
".tsx" -> Just TypeScript
|
||||||
".jsx" -> Just JSX
|
".jsx" -> Just JSX
|
||||||
@ -32,3 +32,13 @@ languageForType mediaType = case mediaType of
|
|||||||
".php" -> Just PHP
|
".php" -> Just PHP
|
||||||
".phpt" -> Just PHP
|
".phpt" -> Just PHP
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
|
extensionsForLanguage :: Language -> [String]
|
||||||
|
extensionsForLanguage language = case language of
|
||||||
|
Go -> [".go"]
|
||||||
|
JavaScript -> [".js"]
|
||||||
|
PHP -> [".php"]
|
||||||
|
Python -> [".py"]
|
||||||
|
Ruby -> [".rb"]
|
||||||
|
TypeScript -> [".ts", ".tsx", ".d.tsx"]
|
||||||
|
_ -> []
|
||||||
|
50
src/Data/Map/Monoidal.hs
Normal file
50
src/Data/Map/Monoidal.hs
Normal file
@ -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
|
@ -4,8 +4,7 @@ module Data.Mergeable where
|
|||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Data.Functor.Identity
|
import Data.Functor.Identity
|
||||||
import Data.List.NonEmpty
|
import Data.List.NonEmpty
|
||||||
import Data.Proxy
|
import Data.Sum
|
||||||
import Data.Union
|
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
|
|
||||||
-- Classes
|
-- Classes
|
||||||
@ -46,8 +45,8 @@ instance Mergeable Maybe where
|
|||||||
|
|
||||||
instance Mergeable Identity where merge f = fmap Identity . f . runIdentity
|
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
|
-- Generics
|
||||||
|
@ -1,4 +1,3 @@
|
|||||||
{-# LANGUAGE DeriveAnyClass #-}
|
|
||||||
{-# OPTIONS_GHC -funbox-strict-fields #-}
|
{-# OPTIONS_GHC -funbox-strict-fields #-}
|
||||||
module Data.Patch
|
module Data.Patch
|
||||||
( Patch(..)
|
( Patch(..)
|
||||||
|
@ -1,20 +1,24 @@
|
|||||||
{-# LANGUAGE DeriveAnyClass #-}
|
|
||||||
module Data.Range
|
module Data.Range
|
||||||
( Range(..)
|
( Range(..)
|
||||||
|
, emptyRange
|
||||||
, rangeLength
|
, rangeLength
|
||||||
, offsetRange
|
, offsetRange
|
||||||
, intersectsRange
|
, intersectsRange
|
||||||
, subtractRange
|
, subtractRange
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Prologue
|
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.JSON.Fields
|
import Data.JSON.Fields
|
||||||
|
import Data.Semilattice.Lower
|
||||||
|
import Prologue
|
||||||
|
|
||||||
-- | A half-open interval of integers, defined by start & end indices.
|
-- | A half-open interval of integers, defined by start & end indices.
|
||||||
data Range = Range { start :: {-# UNPACK #-} !Int, end :: {-# UNPACK #-} !Int }
|
data Range = Range { start :: {-# UNPACK #-} !Int, end :: {-# UNPACK #-} !Int }
|
||||||
deriving (Eq, Show, Generic)
|
deriving (Eq, Show, Generic)
|
||||||
|
|
||||||
|
emptyRange :: Range
|
||||||
|
emptyRange = Range 0 0
|
||||||
|
|
||||||
-- | Return the length of the range.
|
-- | Return the length of the range.
|
||||||
rangeLength :: Range -> Int
|
rangeLength :: Range -> Int
|
||||||
rangeLength range = end range - start range
|
rangeLength range = end range - start range
|
||||||
@ -33,6 +37,13 @@ subtractRange range1 range2 = Range (start range1) (end range1 - rangeLength (Ra
|
|||||||
|
|
||||||
-- Instances
|
-- 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
|
instance Semigroup Range where
|
||||||
Range start1 end1 <> Range start2 end2 = Range (min start1 start2) (max end1 end2)
|
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
|
instance ToJSONFields Range where
|
||||||
toJSONFields Range{..} = ["sourceRange" .= [ start, end ]]
|
toJSONFields Range{..} = ["sourceRange" .= [ start, end ]]
|
||||||
|
|
||||||
|
instance Lower Range where
|
||||||
|
lowerBound = Range 0 0
|
||||||
|
@ -1,10 +1,11 @@
|
|||||||
{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||||
module Data.Record where
|
module Data.Record where
|
||||||
|
|
||||||
import Prologue
|
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.JSON.Fields
|
import Data.JSON.Fields
|
||||||
import Data.Kind
|
import Data.Kind
|
||||||
|
import Data.Semilattice.Lower
|
||||||
|
import Prologue
|
||||||
|
|
||||||
-- | A type-safe, extensible record structure.
|
-- | 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
|
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
|
instance Show (Record '[]) where
|
||||||
showsPrec _ Nil = showString "Nil"
|
showsPrec _ Nil = showString "Nil"
|
||||||
@ -87,3 +88,10 @@ instance ToJSONFields (Record '[]) where
|
|||||||
instance ToJSONFields (Record fs) => ToJSON (Record fs) where
|
instance ToJSONFields (Record fs) => ToJSON (Record fs) where
|
||||||
toJSON = object . toJSONFields
|
toJSON = object . toJSONFields
|
||||||
toEncoding = pairs . mconcat . 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
|
||||||
|
108
src/Data/Scientific/Exts.hs
Normal file
108
src/Data/Scientific/Exts.hs
Normal file
@ -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 #-}
|
39
src/Data/Semigroup/App.hs
Normal file
39
src/Data/Semigroup/App.hs
Normal file
@ -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 = (<>)
|
40
src/Data/Semilattice/Lower.hs
Normal file
40
src/Data/Semilattice/Lower.hs
Normal file
@ -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
|
@ -61,7 +61,7 @@ totalRange = Range 0 . B.length . sourceBytes
|
|||||||
totalSpan :: Source -> Span
|
totalSpan :: Source -> Span
|
||||||
totalSpan source = Span (Pos 1 1) (Pos (length ranges) (succ (end lastRange - start lastRange)))
|
totalSpan source = Span (Pos 1 1) (Pos (length ranges) (succ (end lastRange - start lastRange)))
|
||||||
where ranges = sourceLineRanges source
|
where ranges = sourceLineRanges source
|
||||||
Just lastRange = getLast (foldMap (Last . Just) ranges)
|
lastRange = fromMaybe emptyRange (getLast (foldMap (Last . Just) ranges))
|
||||||
|
|
||||||
|
|
||||||
-- En/decoding
|
-- En/decoding
|
||||||
@ -150,8 +150,8 @@ rangeToSpan source (Range rangeStart rangeEnd) = Span startPos endPos
|
|||||||
firstLine = length before
|
firstLine = length before
|
||||||
(before, rest) = span ((< rangeStart) . end) (sourceLineRanges source)
|
(before, rest) = span ((< rangeStart) . end) (sourceLineRanges source)
|
||||||
(lineRanges, _) = span ((<= rangeEnd) . start) rest
|
(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
|
-- Instances
|
||||||
|
@ -6,17 +6,20 @@
|
|||||||
module Data.Span
|
module Data.Span
|
||||||
( Span(..)
|
( Span(..)
|
||||||
, Pos(..)
|
, Pos(..)
|
||||||
|
, spanFromSrcLoc
|
||||||
, emptySpan
|
, emptySpan
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Prologue
|
|
||||||
import Data.Aeson ((.=), (.:))
|
import Data.Aeson ((.=), (.:))
|
||||||
import qualified Data.Aeson as A
|
import qualified Data.Aeson as A
|
||||||
import Data.JSON.Fields
|
import Data.JSON.Fields
|
||||||
|
import Data.Semilattice.Lower
|
||||||
|
import GHC.Stack
|
||||||
|
import Prologue
|
||||||
|
|
||||||
-- | Source position information
|
-- | Source position information
|
||||||
data Pos = Pos
|
data Pos = Pos
|
||||||
{ posLine :: !Int
|
{ posLine :: !Int
|
||||||
, posColumn :: !Int
|
, posColumn :: !Int
|
||||||
}
|
}
|
||||||
deriving (Show, Read, Eq, Ord, Generic, Hashable)
|
deriving (Show, Read, Eq, Ord, Generic, Hashable)
|
||||||
@ -32,10 +35,13 @@ instance A.FromJSON Pos where
|
|||||||
|
|
||||||
data Span = Span
|
data Span = Span
|
||||||
{ spanStart :: Pos
|
{ spanStart :: Pos
|
||||||
, spanEnd :: Pos
|
, spanEnd :: Pos
|
||||||
}
|
}
|
||||||
deriving (Show, Read, Eq, Ord, Generic, Hashable)
|
deriving (Show, Read, Eq, Ord, Generic, Hashable)
|
||||||
|
|
||||||
|
spanFromSrcLoc :: SrcLoc -> Span
|
||||||
|
spanFromSrcLoc = Span . (Pos . srcLocStartLine <*> srcLocStartCol) <*> (Pos . srcLocEndLine <*> srcLocEndCol)
|
||||||
|
|
||||||
emptySpan :: Span
|
emptySpan :: Span
|
||||||
emptySpan = Span (Pos 1 1) (Pos 1 1)
|
emptySpan = Span (Pos 1 1) (Pos 1 1)
|
||||||
|
|
||||||
@ -56,3 +62,6 @@ instance A.FromJSON Span where
|
|||||||
|
|
||||||
instance ToJSONFields Span where
|
instance ToJSONFields Span where
|
||||||
toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ]
|
toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ]
|
||||||
|
|
||||||
|
instance Lower Span where
|
||||||
|
lowerBound = Span (Pos 1 1) (Pos 1 1)
|
||||||
|
@ -13,7 +13,7 @@ data SplitPatch a
|
|||||||
deriving (Foldable, Eq, Functor, Show, Traversable)
|
deriving (Foldable, Eq, Functor, Show, Traversable)
|
||||||
|
|
||||||
-- | Get the range of a SplitDiff.
|
-- | 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
|
getRange diff = getField $ case diff of
|
||||||
Free annotated -> termFAnnotation annotated
|
Free annotated -> termFAnnotation annotated
|
||||||
Pure patch -> termAnnotation (splitTerm patch)
|
Pure patch -> termAnnotation (splitTerm patch)
|
||||||
|
@ -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
|
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.AST
|
||||||
import Data.ByteString.Char8 (unpack)
|
|
||||||
import Data.Range
|
import Data.Range
|
||||||
import Data.Record
|
import Data.Record
|
||||||
import Data.Span
|
import Data.Span
|
||||||
|
import Data.Sum
|
||||||
import Data.Term
|
import Data.Term
|
||||||
import Diffing.Algorithm hiding (Empty)
|
import Diffing.Algorithm hiding (Empty)
|
||||||
import Prelude hiding (fail)
|
import Prelude
|
||||||
|
import Prologue
|
||||||
import qualified Assigning.Assignment as Assignment
|
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
|
import qualified Data.Error as Error
|
||||||
|
|
||||||
-- Combinators
|
-- Combinators
|
||||||
|
|
||||||
-- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children.
|
-- | 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.
|
-- | 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' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a
|
||||||
makeTerm' a f = termIn (sconcat (a :| (termAnnotation <$> toList f))) f
|
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.
|
-- | 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
|
makeTerm'' a children = case toList children of
|
||||||
[x] -> x
|
[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.
|
-- | 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.
|
-- | Lift a non-empty union into a term, appending all subterms’.annotations to make the new term’s annotation.
|
||||||
makeTerm1' :: (HasCallStack, Semigroup a, Foldable f) => f (Term f a) -> Term f a
|
makeTerm1' :: (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"
|
_ -> error "makeTerm1': empty structure"
|
||||||
|
|
||||||
-- | Construct an empty term at the current position.
|
-- | 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
|
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
|
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.
|
-- | 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)
|
handleError = flip catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source)
|
||||||
|
|
||||||
-- | Catch parse errors into an error term.
|
-- | 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") [])
|
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.
|
-- | 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)
|
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
|
contextualize context rule = make <$> Assignment.manyThrough context rule
|
||||||
where make (cs, node) = case nonEmpty cs of
|
where make (cs, node) = case nonEmpty cs of
|
||||||
Just cs -> makeTerm1 (Context cs node)
|
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.
|
-- | 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)
|
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 b
|
||||||
-> m (Term (Union fs) a, b)
|
-> m (Term (Sum fs) a, b)
|
||||||
postContextualizeThrough context rule end = make <$> rule <*> Assignment.manyThrough context end
|
postContextualizeThrough context rule end = make <$> rule <*> Assignment.manyThrough context end
|
||||||
where make node (cs, end) = case nonEmpty cs of
|
where make node (cs, end) = case nonEmpty cs of
|
||||||
Just cs -> (makeTerm1 (Context cs node), end)
|
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.
|
-- | 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)
|
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
|
postContextualize context rule = make <$> rule <*> many context
|
||||||
where make node cs = case nonEmpty cs of
|
where make node cs = case nonEmpty cs of
|
||||||
Just cs -> makeTerm1 (Context cs node)
|
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.
|
-- | 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)
|
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
|
infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right
|
||||||
|
|
||||||
|
|
||||||
-- Common
|
-- Common
|
||||||
|
|
||||||
-- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable).
|
-- | 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)
|
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Identifier where liftEq = genericLiftEq
|
instance Eq1 Identifier where liftEq = genericLiftEq
|
||||||
instance Ord1 Identifier where liftCompare = genericLiftCompare
|
instance Ord1 Identifier where liftCompare = genericLiftCompare
|
||||||
instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec
|
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
|
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]
|
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 Eq1 Program where liftEq = genericLiftEq
|
||||||
instance Ord1 Program where liftCompare = genericLiftCompare
|
instance Ord1 Program where liftCompare = genericLiftCompare
|
||||||
instance Show1 Program where liftShowsPrec = genericLiftShowsPrec
|
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.
|
-- | An accessibility modifier, e.g. private, public, protected, etc.
|
||||||
newtype AccessibilityModifier a = AccessibilityModifier ByteString
|
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 Eq1 AccessibilityModifier where liftEq = genericLiftEq
|
||||||
instance Ord1 AccessibilityModifier where liftCompare = genericLiftCompare
|
instance Ord1 AccessibilityModifier where liftCompare = genericLiftCompare
|
||||||
instance Show1 AccessibilityModifier where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 AccessibilityModifier where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for AccessibilityModifier
|
-- 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.
|
-- | 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'.
|
-- 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
|
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 Eq1 Empty where liftEq _ _ _ = True
|
||||||
instance Ord1 Empty where liftCompare _ _ _ = EQ
|
instance Ord1 Empty where liftCompare _ _ _ = EQ
|
||||||
instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
|
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.
|
-- | Syntax representing a parsing or assignment error.
|
||||||
data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] }
|
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 Eq1 Error where liftEq = genericLiftEq
|
||||||
instance Ord1 Error where liftCompare = genericLiftCompare
|
instance Ord1 Error where liftCompare = genericLiftCompare
|
||||||
instance Show1 Error where liftShowsPrec = genericLiftShowsPrec
|
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 String -> [a] -> Error a
|
||||||
errorSyntax Error.Error{..} = Error (ErrorStack (getCallStack callStack)) errorExpected errorActual
|
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 }
|
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
|
instance Diffable Context where
|
||||||
subalgorithmFor blur focus (Context n s) = Context <$> traverse blur n <*> focus s
|
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 Ord1 Context where liftCompare = genericLiftCompare
|
||||||
instance Show1 Context where liftShowsPrec = genericLiftShowsPrec
|
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
|
eval Context{..} = subtermValue contextSubject
|
||||||
|
@ -2,21 +2,19 @@
|
|||||||
module Data.Syntax.Comment where
|
module Data.Syntax.Comment where
|
||||||
|
|
||||||
import Prologue
|
import Prologue
|
||||||
import Control.Monad.Effect.Evaluatable
|
import Data.Abstract.Evaluatable
|
||||||
import Data.Abstract.FreeVariables
|
|
||||||
import Data.Abstract.Value as Value
|
|
||||||
import Diffing.Algorithm
|
import Diffing.Algorithm
|
||||||
|
|
||||||
-- | An unnested comment (line or block).
|
-- | An unnested comment (line or block).
|
||||||
newtype Comment a = Comment { commentContent :: ByteString }
|
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 Eq1 Comment where liftEq = genericLiftEq
|
||||||
instance Ord1 Comment where liftCompare = genericLiftCompare
|
instance Ord1 Comment where liftCompare = genericLiftCompare
|
||||||
instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec
|
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: nested comment types
|
||||||
-- TODO: documentation comment types
|
-- TODO: documentation comment types
|
||||||
|
@ -1,24 +1,14 @@
|
|||||||
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, UndecidableInstances #-}
|
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}
|
||||||
module Data.Syntax.Declaration where
|
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 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 }
|
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
|
instance Diffable Function where
|
||||||
equivalentBySubterm = Just . functionName
|
equivalentBySubterm = Just . functionName
|
||||||
@ -27,57 +17,23 @@ instance Eq1 Function where liftEq = genericLiftEq
|
|||||||
instance Ord1 Function where liftCompare = genericLiftCompare
|
instance Ord1 Function where liftCompare = genericLiftCompare
|
||||||
instance Show1 Function where liftShowsPrec = genericLiftShowsPrec
|
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: Filter the closed-over environment by the free variables in the term.
|
||||||
-- TODO: How should we represent function types, where applicable?
|
-- 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
|
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
|
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 }
|
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
|
instance Diffable Method where
|
||||||
equivalentBySubterm = Just . methodName
|
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
|
-- Evaluating a Method creates a closure and makes that value available in the
|
||||||
-- local environment.
|
-- 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
|
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
|
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.
|
-- | A method signature in TypeScript or a method spec in Go.
|
||||||
data MethodSignature a = MethodSignature { _methodSignatureContext :: ![a], _methodSignatureName :: !a, _methodSignatureParameters :: ![a] }
|
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 Eq1 MethodSignature where liftEq = genericLiftEq
|
||||||
instance Ord1 MethodSignature where liftCompare = genericLiftCompare
|
instance Ord1 MethodSignature where liftCompare = genericLiftCompare
|
||||||
instance Show1 MethodSignature where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 MethodSignature where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for MethodSignature
|
-- TODO: Implement Eval instance for MethodSignature
|
||||||
instance Member Fail es => Evaluatable es t v MethodSignature
|
instance Evaluatable MethodSignature
|
||||||
|
|
||||||
|
|
||||||
newtype RequiredParameter a = RequiredParameter { requiredParameter :: a }
|
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 Eq1 RequiredParameter where liftEq = genericLiftEq
|
||||||
instance Ord1 RequiredParameter where liftCompare = genericLiftCompare
|
instance Ord1 RequiredParameter where liftCompare = genericLiftCompare
|
||||||
instance Show1 RequiredParameter where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 RequiredParameter where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for RequiredParameter
|
-- TODO: Implement Eval instance for RequiredParameter
|
||||||
instance Member Fail es => Evaluatable es t v RequiredParameter
|
instance Evaluatable RequiredParameter
|
||||||
|
|
||||||
|
|
||||||
newtype OptionalParameter a = OptionalParameter { optionalParameter :: a }
|
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 Eq1 OptionalParameter where liftEq = genericLiftEq
|
||||||
instance Ord1 OptionalParameter where liftCompare = genericLiftCompare
|
instance Ord1 OptionalParameter where liftCompare = genericLiftCompare
|
||||||
instance Show1 OptionalParameter where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 OptionalParameter where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for OptionalParameter
|
-- 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: Should we replace this with Function and differentiate by context?
|
||||||
-- TODO: How should we distinguish class/instance methods?
|
-- 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.
|
-- | A declaration of possibly many variables such as var foo = 5, bar = 6 in JavaScript.
|
||||||
newtype VariableDeclaration a = VariableDeclaration { variableDeclarations :: [a] }
|
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 Eq1 VariableDeclaration where liftEq = genericLiftEq
|
||||||
instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare
|
instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare
|
||||||
instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec
|
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.
|
-- | A TypeScript/Java style interface declaration to implement.
|
||||||
data InterfaceDeclaration a = InterfaceDeclaration { interfaceDeclarationContext :: ![a], interfaceDeclarationIdentifier :: !a, interfaceDeclarationBody :: !a }
|
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 Eq1 InterfaceDeclaration where liftEq = genericLiftEq
|
||||||
instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare
|
instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare
|
||||||
instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for InterfaceDeclaration
|
-- 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.
|
-- | A public field definition such as a field definition in a JavaScript class.
|
||||||
data PublicFieldDefinition a = PublicFieldDefinition { publicFieldContext :: ![a], publicFieldPropertyName :: !a, publicFieldValue :: !a }
|
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 Eq1 PublicFieldDefinition where liftEq = genericLiftEq
|
||||||
instance Ord1 PublicFieldDefinition where liftCompare = genericLiftCompare
|
instance Ord1 PublicFieldDefinition where liftCompare = genericLiftCompare
|
||||||
instance Show1 PublicFieldDefinition where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 PublicFieldDefinition where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for PublicFieldDefinition
|
-- 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 }
|
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 Eq1 Variable where liftEq = genericLiftEq
|
||||||
instance Ord1 Variable where liftCompare = genericLiftCompare
|
instance Ord1 Variable where liftCompare = genericLiftCompare
|
||||||
instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for Variable
|
-- 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 }
|
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
|
instance Diffable Class where
|
||||||
equivalentBySubterm = Just . classIdentifier
|
equivalentBySubterm = Just . classIdentifier
|
||||||
@ -201,130 +158,94 @@ instance Eq1 Class where liftEq = genericLiftEq
|
|||||||
instance Ord1 Class where liftCompare = genericLiftCompare
|
instance Ord1 Class where liftCompare = genericLiftCompare
|
||||||
instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
|
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
|
-- | A decorator in Python
|
||||||
data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a }
|
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 Eq1 Decorator where liftEq = genericLiftEq
|
||||||
instance Ord1 Decorator where liftCompare = genericLiftCompare
|
instance Ord1 Decorator where liftCompare = genericLiftCompare
|
||||||
instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for Decorator
|
-- TODO: Implement Eval instance for Decorator
|
||||||
instance Member Fail es => Evaluatable es t v Decorator
|
instance Evaluatable Decorator
|
||||||
|
|
||||||
-- TODO: Generics, constraints.
|
-- TODO: Generics, constraints.
|
||||||
|
|
||||||
|
|
||||||
-- | An ADT, i.e. a disjoint sum of products, like 'data' in Haskell, or 'enum' in Rust or Swift.
|
-- | 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] }
|
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 Eq1 Data.Syntax.Declaration.Datatype where liftEq = genericLiftEq
|
||||||
instance Ord1 Data.Syntax.Declaration.Datatype where liftCompare = genericLiftCompare
|
instance Ord1 Data.Syntax.Declaration.Datatype where liftCompare = genericLiftCompare
|
||||||
instance Show1 Data.Syntax.Declaration.Datatype where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Data.Syntax.Declaration.Datatype where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for Datatype
|
-- 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.
|
-- | A single constructor in a datatype, or equally a 'struct' in C, Rust, or Swift.
|
||||||
data Constructor a = Constructor { constructorName :: !a, constructorFields :: ![a] }
|
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 Eq1 Data.Syntax.Declaration.Constructor where liftEq = genericLiftEq
|
||||||
instance Ord1 Data.Syntax.Declaration.Constructor where liftCompare = genericLiftCompare
|
instance Ord1 Data.Syntax.Declaration.Constructor where liftCompare = genericLiftCompare
|
||||||
instance Show1 Data.Syntax.Declaration.Constructor where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Data.Syntax.Declaration.Constructor where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for Constructor
|
-- 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)
|
-- | Comprehension (e.g. ((a for b in c if a()) in Python)
|
||||||
data Comprehension a = Comprehension { comprehensionValue :: !a, comprehensionBody :: !a }
|
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 Eq1 Comprehension where liftEq = genericLiftEq
|
||||||
instance Ord1 Comprehension where liftCompare = genericLiftCompare
|
instance Ord1 Comprehension where liftCompare = genericLiftCompare
|
||||||
instance Show1 Comprehension where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Comprehension where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for Comprehension
|
-- 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).
|
-- | A declared type (e.g. `a []int` in Go).
|
||||||
data Type a = Type { typeName :: !a, typeKind :: !a }
|
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 Eq1 Type where liftEq = genericLiftEq
|
||||||
instance Ord1 Type where liftCompare = genericLiftCompare
|
instance Ord1 Type where liftCompare = genericLiftCompare
|
||||||
instance Show1 Type where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Type where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for Type
|
-- 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.
|
-- | Type alias declarations in Javascript/Haskell, etc.
|
||||||
data TypeAlias a = TypeAlias { typeAliasContext :: ![a], typeAliasIdentifier :: !a, typeAliasKind :: !a }
|
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 Eq1 TypeAlias where liftEq = genericLiftEq
|
||||||
instance Ord1 TypeAlias where liftCompare = genericLiftCompare
|
instance Ord1 TypeAlias where liftCompare = genericLiftCompare
|
||||||
instance Show1 TypeAlias where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 TypeAlias where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for TypeAlias
|
-- 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
|
||||||
|
32
src/Data/Syntax/Directive.hs
Normal file
32
src/Data/Syntax/Directive.hs
Normal file
@ -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
|
@ -1,69 +1,24 @@
|
|||||||
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, TypeApplications #-}
|
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, ViewPatterns #-}
|
||||||
module Data.Syntax.Expression where
|
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 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.
|
-- | 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 }
|
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 Eq1 Call where liftEq = genericLiftEq
|
||||||
instance Ord1 Call where liftCompare = genericLiftCompare
|
instance Ord1 Call where liftCompare = genericLiftCompare
|
||||||
instance Show1 Call where liftShowsPrec = genericLiftShowsPrec
|
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
|
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
|
data Comparison a
|
||||||
= LessThan !a !a
|
= LessThan !a !a
|
||||||
@ -72,15 +27,21 @@ data Comparison a
|
|||||||
| GreaterThanEqual !a !a
|
| GreaterThanEqual !a !a
|
||||||
| Equal !a !a
|
| Equal !a !a
|
||||||
| Comparison !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 Eq1 Comparison where liftEq = genericLiftEq
|
||||||
instance Ord1 Comparison where liftCompare = genericLiftCompare
|
instance Ord1 Comparison where liftCompare = genericLiftCompare
|
||||||
instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec
|
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.
|
-- | Binary arithmetic operators.
|
||||||
data Arithmetic a
|
data Arithmetic a
|
||||||
@ -88,18 +49,39 @@ data Arithmetic a
|
|||||||
| Minus !a !a
|
| Minus !a !a
|
||||||
| Times !a !a
|
| Times !a !a
|
||||||
| DividedBy !a !a
|
| DividedBy !a !a
|
||||||
|
| FloorDivision !a !a
|
||||||
| Modulo !a !a
|
| Modulo !a !a
|
||||||
| Power !a !a
|
| Power !a !a
|
||||||
| Negate !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 Eq1 Arithmetic where liftEq = genericLiftEq
|
||||||
instance Ord1 Arithmetic where liftCompare = genericLiftCompare
|
instance Ord1 Arithmetic where liftCompare = genericLiftCompare
|
||||||
instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec
|
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.
|
-- | Boolean operators.
|
||||||
data Boolean a
|
data Boolean a
|
||||||
@ -107,62 +89,70 @@ data Boolean a
|
|||||||
| And !a !a
|
| And !a !a
|
||||||
| Not !a
|
| Not !a
|
||||||
| XOr !a !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 Eq1 Boolean where liftEq = genericLiftEq
|
||||||
instance Ord1 Boolean where liftCompare = genericLiftCompare
|
instance Ord1 Boolean where liftCompare = genericLiftCompare
|
||||||
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
|
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
|
-- | Javascript delete operator
|
||||||
newtype Delete a = Delete a
|
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 Eq1 Delete where liftEq = genericLiftEq
|
||||||
instance Ord1 Delete where liftCompare = genericLiftCompare
|
instance Ord1 Delete where liftCompare = genericLiftCompare
|
||||||
instance Show1 Delete where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Delete where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for Delete
|
-- 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.
|
-- | A sequence expression such as Javascript or C's comma operator.
|
||||||
data SequenceExpression a = SequenceExpression { _firstExpression :: !a, _secondExpression :: !a }
|
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 Eq1 SequenceExpression where liftEq = genericLiftEq
|
||||||
instance Ord1 SequenceExpression where liftCompare = genericLiftCompare
|
instance Ord1 SequenceExpression where liftCompare = genericLiftCompare
|
||||||
instance Show1 SequenceExpression where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 SequenceExpression where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for SequenceExpression
|
-- TODO: Implement Eval instance for SequenceExpression
|
||||||
instance Member Fail es => Evaluatable es t v SequenceExpression
|
instance Evaluatable SequenceExpression
|
||||||
|
|
||||||
|
|
||||||
-- | Javascript void operator
|
-- | Javascript void operator
|
||||||
newtype Void a = Void a
|
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 Eq1 Void where liftEq = genericLiftEq
|
||||||
instance Ord1 Void where liftCompare = genericLiftCompare
|
instance Ord1 Void where liftCompare = genericLiftCompare
|
||||||
instance Show1 Void where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Void where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for Void
|
-- TODO: Implement Eval instance for Void
|
||||||
instance Member Fail es => Evaluatable es t v Void
|
instance Evaluatable Void
|
||||||
|
|
||||||
|
|
||||||
-- | Javascript typeof operator
|
-- | Javascript typeof operator
|
||||||
newtype Typeof a = Typeof a
|
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 Eq1 Typeof where liftEq = genericLiftEq
|
||||||
instance Ord1 Typeof where liftCompare = genericLiftCompare
|
instance Ord1 Typeof where liftCompare = genericLiftCompare
|
||||||
instance Show1 Typeof where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Typeof where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for Typeof
|
-- TODO: Implement Eval instance for Typeof
|
||||||
instance Member Fail es => Evaluatable es t v Typeof
|
instance Evaluatable Typeof
|
||||||
|
|
||||||
|
|
||||||
-- | Bitwise operators.
|
-- | Bitwise operators.
|
||||||
@ -174,122 +164,133 @@ data Bitwise a
|
|||||||
| RShift !a !a
|
| RShift !a !a
|
||||||
| UnsignedRShift !a !a
|
| UnsignedRShift !a !a
|
||||||
| Complement 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 Eq1 Bitwise where liftEq = genericLiftEq
|
||||||
instance Ord1 Bitwise where liftCompare = genericLiftCompare
|
instance Ord1 Bitwise where liftCompare = genericLiftCompare
|
||||||
instance Show1 Bitwise where liftShowsPrec = genericLiftShowsPrec
|
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)
|
-- | Member Access (e.g. a.b)
|
||||||
data MemberAccess a
|
data MemberAccess a
|
||||||
= MemberAccess !a !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 Eq1 MemberAccess where liftEq = genericLiftEq
|
||||||
instance Ord1 MemberAccess where liftCompare = genericLiftCompare
|
instance Ord1 MemberAccess where liftCompare = genericLiftCompare
|
||||||
instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec
|
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])
|
-- | Subscript (e.g a[1])
|
||||||
data Subscript a
|
data Subscript a
|
||||||
= Subscript !a ![a]
|
= Subscript !a ![a]
|
||||||
| Member !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 Eq1 Subscript where liftEq = genericLiftEq
|
||||||
instance Ord1 Subscript where liftCompare = genericLiftCompare
|
instance Ord1 Subscript where liftCompare = genericLiftCompare
|
||||||
instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for Subscript
|
-- 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))
|
-- | 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 }
|
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 Eq1 Enumeration where liftEq = genericLiftEq
|
||||||
instance Ord1 Enumeration where liftCompare = genericLiftCompare
|
instance Ord1 Enumeration where liftCompare = genericLiftCompare
|
||||||
instance Show1 Enumeration where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Enumeration where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for Enumeration
|
-- 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
|
-- | InstanceOf (e.g. a instanceof b in JavaScript
|
||||||
data InstanceOf a = InstanceOf { instanceOfSubject :: !a, instanceOfObject :: !a }
|
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 Eq1 InstanceOf where liftEq = genericLiftEq
|
||||||
instance Ord1 InstanceOf where liftCompare = genericLiftCompare
|
instance Ord1 InstanceOf where liftCompare = genericLiftCompare
|
||||||
instance Show1 InstanceOf where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 InstanceOf where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for InstanceOf
|
-- 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++)
|
-- | ScopeResolution (e.g. import a.b in Python or a::b in C++)
|
||||||
newtype ScopeResolution a = ScopeResolution [a]
|
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 Eq1 ScopeResolution where liftEq = genericLiftEq
|
||||||
instance Ord1 ScopeResolution where liftCompare = genericLiftCompare
|
instance Ord1 ScopeResolution where liftCompare = genericLiftCompare
|
||||||
instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for ScopeResolution
|
-- 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.
|
-- | A non-null expression such as Typescript or Swift's ! expression.
|
||||||
newtype NonNullExpression a = NonNullExpression { nonNullExpression :: a }
|
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 Eq1 NonNullExpression where liftEq = genericLiftEq
|
||||||
instance Ord1 NonNullExpression where liftCompare = genericLiftCompare
|
instance Ord1 NonNullExpression where liftCompare = genericLiftCompare
|
||||||
instance Show1 NonNullExpression where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 NonNullExpression where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for NonNullExpression
|
-- 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#.
|
-- | An await expression in Javascript or C#.
|
||||||
newtype Await a = Await { awaitSubject :: a }
|
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 Eq1 Await where liftEq = genericLiftEq
|
||||||
instance Ord1 Await where liftCompare = genericLiftCompare
|
instance Ord1 Await where liftCompare = genericLiftCompare
|
||||||
instance Show1 Await where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Await where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for Await
|
-- 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.
|
-- | An object constructor call in Javascript, Java, etc.
|
||||||
newtype New a = New { newSubject :: [a] }
|
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 Eq1 New where liftEq = genericLiftEq
|
||||||
instance Ord1 New where liftCompare = genericLiftCompare
|
instance Ord1 New where liftCompare = genericLiftCompare
|
||||||
instance Show1 New where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 New where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for New
|
-- 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.
|
-- | A cast expression to a specified type.
|
||||||
data Cast a = Cast { castSubject :: !a, castType :: !a }
|
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 Eq1 Cast where liftEq = genericLiftEq
|
||||||
instance Ord1 Cast where liftCompare = genericLiftCompare
|
instance Ord1 Cast where liftCompare = genericLiftCompare
|
||||||
instance Show1 Cast where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Cast where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Implement Eval instance for Cast
|
-- TODO: Implement Eval instance for Cast
|
||||||
instance Member Fail es => Evaluatable es t v Cast
|
instance Evaluatable Cast
|
||||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user