github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-24 23:42:31 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into explicit-statements

Browse Source
This commit is contained in:
Timothy Clem 2018-06-01 08:54:55 -07:00
commit 5408e20ea8
66 changed files with 2075 additions and 562 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitmodules vendored
View File

@ -16,3 +16,9 @@
[submodule "vendor/fastsum"]
path = vendor/fastsum
url = git@github.com:patrickt/fastsum.git
[submodule "vendor/proto3-wire"]
path = vendor/proto3-wire
url = https://github.com/joshvera/proto3-wire
[submodule "vendor/proto3-suite"]
path = vendor/proto3-suite
url = https://github.com/joshvera/proto3-suite

6
HLint.hs
View File

@ -17,8 +17,8 @@ error "Avoid return" =
return ==> pure
where note = "return is obsolete as of GHC 7.10"
error "use extract" = termAnnotation . unTerm ==> extract
error "use unwrap" = termOut . unTerm ==> unwrap
error "use termAnnotation" = termFAnnotation . unTerm ==> termAnnotation
error "use termOut" = termFOut . unTerm ==> termOut
error "avoid head" = head
where note = "head is partial; consider using Data.Maybe.listToMaybe"
@ -31,3 +31,5 @@ error "avoid init" = init
error "avoid last" = last
where note = "last is partial; consider pattern-matching"
error "use maybeM" = maybe a pure ==> maybeM a

3
semantic.cabal
View File

@ -40,7 +40,6 @@ library
, Control.Abstract.Context
, Control.Abstract.Environment
, Control.Abstract.Evaluator
, Control.Abstract.Exports
, Control.Abstract.Heap
, Control.Abstract.Hole
, Control.Abstract.Matching
@ -209,6 +208,8 @@ library
, text >= 1.2.1.3
, these
, time
, proto3-suite
, proto3-wire
, unix
, unordered-containers
, haskell-tree-sitter

17
semantic.proto
View File

@ -1,4 +1,5 @@
syntax = "proto3";
import "types.proto";
package semantic;
message HealthCheckRequest {
@ -33,12 +34,6 @@ message BlobPair {
Blob after = 2;
}
message Blob {
string source = 1;
string path = 2;
string language = 3;
}
message SummariesResponse {
repeated Summary changes = 1;
repeated Error errors = 2;
@ -61,13 +56,3 @@ message Error {
Span span = 2;
string language = 3;
}
message Span {
Pos start = 1;
Pos end = 2;
}
message Pos {
int32 line = 1;
int32 column = 2;
}

8
src/Analysis/Abstract/Caching.hs
View File

@ -62,7 +62,7 @@ cachingTerms :: ( Cacheable term address (Cell address) value
, Member (Reader (Cache term address (Cell address) value)) effects
, Member (Reader (Live address)) effects
, Member (State (Cache term address (Cell address) value)) effects
, Member (State (Environment address)) effects
, Member (Env address) effects
, Member (State (Heap address (Cell address) value)) effects
)
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef value))
@ -82,11 +82,10 @@ convergingModules :: ( AbstractValue address value effects
, Member Fresh effects
, Member NonDet effects
, Member (Reader (Cache term address (Cell address) value)) effects
, Member (Reader (Environment address)) effects
, Member (Reader (Live address)) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (State (Cache term address (Cell address) value)) effects
, Member (State (Environment address)) effects
, Member (Env address) effects
, Member (State (Heap address (Cell address) value)) effects
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects value)
@ -94,8 +93,7 @@ convergingModules :: ( AbstractValue address value effects
convergingModules recur m = do
c <- getConfiguration (subterm (moduleBody m))
-- Convergence here is predicated upon an Eq instance, not α-equivalence
cache <- converge lowerBound (\ prevCache -> isolateCache $ do
TermEvaluator (putEnv (configurationEnvironment c))
cache <- converge lowerBound (\ prevCache -> isolateCache $ raiseHandler locally $ do
TermEvaluator (putHeap (configurationHeap c))
-- We need to reset fresh generation so that this invocation converges.
resetFresh 0 $

34
src/Analysis/Abstract/Collecting.hs
View File

@ -5,15 +5,12 @@ module Analysis.Abstract.Collecting
) where
import Control.Abstract
import Data.Abstract.Heap
import Data.Abstract.Live
import Data.Semilattice.Lower
import Prologue
-- | An analysis performing GC after every instruction.
collectingTerms :: ( Foldable (Cell address)
, Member (Reader (Live address)) effects
, Member (State (Heap address (Cell address) value)) effects
collectingTerms :: ( Member (Reader (Live address)) effects
, Member (Allocator address value) effects
, Ord address
, ValueRoots address value
)
@ -22,32 +19,7 @@ collectingTerms :: ( Foldable (Cell address)
collectingTerms recur term = do
roots <- TermEvaluator askRoots
v <- recur term
v <$ TermEvaluator (modifyHeap (gc (roots <> valueRoots v)))
-- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
gc :: ( Ord address
, Foldable (Cell address)
, ValueRoots address value
)
=> Live address -- ^ The set of addresses to consider rooted.
-> Heap address (Cell address) value -- ^ A heap to collect unreachable addresses within.
-> Heap address (Cell address) value -- ^ A garbage-collected heap.
gc roots heap = heapRestrict heap (reachable roots heap)
-- | Compute the set of addresses reachable from a given root set in a given heap.
reachable :: ( Ord address
, Foldable (Cell address)
, ValueRoots address value
)
=> Live address -- ^ The set of root addresses.
-> Heap address (Cell address) value -- ^ The heap to trace addresses through.
-> Live address -- ^ The set of addresses reachable from the root set.
reachable roots heap = go mempty roots
where go seen set = case liveSplit set of
Nothing -> seen
Just (a, as) -> go (liveInsert a seen) (case heapLookupAll a heap of
Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen
_ -> seen)
v <$ TermEvaluator (gc (roots <> valueRoots v))
providingLiveSet :: Effectful (m address value) => m address value (Reader (Live address) ': effects) a -> m address value effects a

19
src/Analysis/Abstract/Evaluating.hs
View File

@ -5,14 +5,13 @@ module Analysis.Abstract.Evaluating
) where
import Control.Abstract
import Control.Monad.Effect.Fail
import Data.Semilattice.Lower
-- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@.
data EvaluatingState address value = EvaluatingState
{ environment :: Environment address
, heap :: Heap address (Cell address) value
, modules :: ModuleTable (Maybe (Environment address, value))
, exports :: Exports address
{ heap :: Heap address (Cell address) value
, modules :: ModuleTable (Maybe (value, Environment address))
}
deriving instance (Eq (Cell address value), Eq address, Eq value) => Eq (EvaluatingState address value)
@ -23,19 +22,13 @@ deriving instance (Show (Cell address value), Show address, Show value) => Show
evaluating :: Evaluator address value
( Fail
': Fresh
': Reader (Environment address)
': State (Environment address)
': State (Heap address (Cell address) value)
': State (ModuleTable (Maybe (Environment address, value)))
': State (Exports address)
': State (ModuleTable (Maybe (value, Environment address)))
': effects) result
-> Evaluator address value effects (Either String result, EvaluatingState address value)
evaluating
= fmap (\ ((((result, env), heap), modules), exports) -> (result, EvaluatingState env heap modules exports))
. runState lowerBound -- State (Exports address)
. runState lowerBound -- State (ModuleTable (Maybe (Environment address, value)))
= fmap (\ ((result, heap), modules) -> (result, EvaluatingState heap modules))
. runState lowerBound -- State (ModuleTable (Maybe (value, Environment address)))
. runState lowerBound -- State (Heap address (Cell address) value)
. runState lowerBound -- State (Environment address)
. runReader lowerBound -- Reader (Environment address)
. runFresh 0
. runFail

6
src/Analysis/Abstract/Graph.hs
View File

@ -52,9 +52,8 @@ style = (defaultStyle (byteString . vertexName))
-- | Add vertices to the graph for evaluated identifiers.
graphingTerms :: ( Element Syntax.Identifier syntax
, Member (Reader (Environment (Hole (Located address)))) effects
, Member (Reader ModuleInfo) effects
, Member (State (Environment (Hole (Located address)))) effects
, Member (Env (Hole (Located address))) effects
, Member (State (Graph Vertex)) effects
, term ~ Term (Sum syntax) ann
)
@ -121,8 +120,7 @@ moduleInclusion v = do
appendGraph (vertex (moduleVertex m) `connect` vertex v)
-- | Add an edge from the passed variable name to the module it originated within.
variableDefinition :: ( Member (Reader (Environment (Hole (Located address)))) effects
, Member (State (Environment (Hole (Located address)))) effects
variableDefinition :: ( Member (Env (Hole (Located address))) effects
, Member (State (Graph Vertex)) effects
)
=> Name

2
src/Analysis/Abstract/Tracing.hs
View File

@ -14,7 +14,7 @@ import Prologue
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
tracingTerms :: ( Corecursive term
, Member (Reader (Live address)) effects
, Member (State (Environment address)) effects
, Member (Env address) effects
, Member (State (Heap address (Cell address) value)) effects
, Member (Writer (trace (Configuration term address (Cell address) value))) effects
, Reducer (Configuration term address (Cell address) value) (trace (Configuration term address (Cell address) value))

3
src/Control/Abstract.hs
View File

@ -5,9 +5,8 @@ module Control.Abstract
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.Environment as X hiding (Lookup)
import Control.Abstract.Evaluator as X
import Control.Abstract.Exports as X
import Control.Abstract.Heap as X
import Control.Abstract.Hole as X
import Control.Abstract.Modules as X

2
src/Control/Abstract/Configuration.hs
View File

@ -12,5 +12,5 @@ import Control.Abstract.TermEvaluator
import Data.Abstract.Configuration
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: (Member (Reader (Live address)) effects, Member (State (Environment address)) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value)
getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value)
getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEnv <*> TermEvaluator getHeap

106
src/Control/Abstract/Environment.hs
View File

@ -1,14 +1,17 @@
{-# LANGUAGE GADTs, RankNTypes, TypeOperators #-}
{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-}
module Control.Abstract.Environment
( Environment
, Exports
, getEnv
, putEnv
, withEnv
, withDefaultEnvironment
, export
, lookupEnv
, bind
, bindAll
, locally
, close
-- * Effects
, Env(..)
, runEnv
, EnvironmentError(..)
, freeVariableError
, runEnvironmentError
@ -16,54 +19,81 @@ module Control.Abstract.Environment
) where
import Control.Abstract.Evaluator
import Data.Abstract.Environment as Env
import Data.Abstract.Environment (Environment)
import qualified Data.Abstract.Environment as Env
import Data.Abstract.Exports as Exports
import Data.Abstract.Name
import Data.Semilattice.Lower
import Prologue
-- | Retrieve the environment.
getEnv :: Member (State (Environment address)) effects => Evaluator address value effects (Environment address)
getEnv = get
getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address)
getEnv = send GetEnv
-- | Set the environment.
putEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects ()
putEnv = put
-- | Add an export to the global export state.
export :: Member (Env address) effects => Name -> Name -> Maybe address -> Evaluator address value effects ()
export name alias addr = send (Export name alias addr)
-- | Update the global environment.
modifyEnv :: Member (State (Environment address)) effects => (Environment address -> Environment address) -> Evaluator address value effects ()
modifyEnv = modify'
-- | Sets the environment for the lifetime of the given action.
withEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a
withEnv = localState . const
-- | Retrieve the default environment.
defaultEnvironment :: Member (Reader (Environment address)) effects => Evaluator address value effects (Environment address)
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 address)) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a
withDefaultEnvironment e = local (const e)
-- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
lookupEnv :: (Member (Reader (Environment address)) effects, Member (State (Environment address)) effects) => Name -> Evaluator address value effects (Maybe address)
lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)
lookupEnv :: Member (Env address) effects => Name -> Evaluator address value effects (Maybe address)
lookupEnv name = send (Lookup name)
-- | Bind a 'Name' to an 'Address' in the current scope.
bind :: Member (State (Environment address)) effects => Name -> address -> Evaluator address value effects ()
bind name = modifyEnv . Env.insert name
-- | Bind a 'Name' to an address in the current scope.
bind :: Member (Env address) effects => Name -> address -> Evaluator address value effects ()
bind name addr = send (Bind name addr)
-- | Bind all of the names from an 'Environment' in the current scope.
bindAll :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects ()
bindAll = foldr ((>>) . uncurry bind) (pure ()) . pairs
bindAll :: Member (Env address) effects => Environment address -> Evaluator address value effects ()
bindAll = foldr ((>>) . uncurry bind) (pure ()) . Env.pairs
-- | Run an action in a new local environment.
locally :: Member (State (Environment address)) effects => Evaluator address value effects a -> Evaluator address value effects a
-- | Run an action in a new local scope.
locally :: forall address value effects a . Member (Env address) effects => Evaluator address value effects a -> Evaluator address value effects a
locally a = do
modifyEnv Env.push
send (Push @address)
a' <- a
a' <$ modifyEnv Env.pop
a' <$ send (Pop @address)
close :: Member (Env address) effects => Set Name -> Evaluator address value effects (Environment address)
close = send . Close
-- Effects
data Env address return where
Lookup :: Name -> Env address (Maybe address)
Bind :: Name -> address -> Env address ()
Close :: Set Name -> Env address (Environment address)
Push :: Env address ()
Pop :: Env address ()
GetEnv :: Env address (Environment address)
Export :: Name -> Name -> Maybe address -> Env address ()
handleEnv :: forall address effects value result
. ( Member (State (Environment address)) effects
, Member (State (Exports address)) effects
)
=> Env address result
-> Evaluator address value effects result
handleEnv = \case
Lookup name -> Env.lookup name <$> get
Bind name addr -> modify (Env.insert name addr)
Close names -> Env.intersect names <$> get
Push -> modify (Env.push @address)
Pop -> modify (Env.pop @address)
GetEnv -> get
Export name alias addr -> modify (Exports.insert name alias addr)
runEnv :: Environment address
-> Evaluator address value (Env address ': effects) a
-> Evaluator address value effects (a, Environment address)
runEnv initial = fmap (uncurry filterEnv . first (fmap Env.head)) . runState lowerBound . runState (Env.push initial) . reinterpret2 handleEnv
where -- 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 (a, env) ports
| Exports.null ports = (a, env)
| otherwise = (a, Exports.toEnvironment ports `Env.mergeEnvs` Env.overwrite (Exports.aliases ports) env)
-- | Errors involving the environment.

32
src/Control/Abstract/Exports.hs
View File

@ -1,32 +0,0 @@
module Control.Abstract.Exports
( Exports
, getExports
, putExports
, modifyExports
, addExport
, withExports
) where
import Control.Abstract.Evaluator
import Data.Abstract.Exports
import Data.Abstract.Name
-- | Get the global export state.
getExports :: Member (State (Exports address)) effects => Evaluator address value effects (Exports address)
getExports = get
-- | Set the global export state.
putExports :: Member (State (Exports address)) effects => Exports address -> Evaluator address value effects ()
putExports = put
-- | Update the global export state.
modifyExports :: Member (State (Exports address)) effects => (Exports address -> Exports address) -> Evaluator address value effects ()
modifyExports = modify'
-- | Add an export to the global export state.
addExport :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address 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 address)) effects => Exports address -> Evaluator address value effects a -> Evaluator address value effects a
withExports = localState . const

91
src/Control/Abstract/Heap.hs
View File

@ -1,9 +1,8 @@
{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Control.Abstract.Heap
( Heap
, getHeap
, putHeap
, modifyHeap
, alloc
, deref
, assign
@ -11,6 +10,8 @@ module Control.Abstract.Heap
, letrec
, letrec'
, variable
-- * Garbage collection
, gc
-- * Effects
, Allocator(..)
, runAllocator
@ -22,8 +23,9 @@ module Control.Abstract.Heap
import Control.Abstract.Addressable
import Control.Abstract.Environment
import Control.Abstract.Evaluator
import Control.Monad.Effect.Internal
import Control.Abstract.Roots
import Data.Abstract.Heap
import Data.Abstract.Live
import Data.Abstract.Name
import Data.Semigroup.Reducer
import Prologue
@ -41,41 +43,33 @@ modifyHeap :: Member (State (Heap address (Cell address) value)) effects => (Hea
modifyHeap = modify'
alloc :: forall address value effects . Member (Allocator address value) effects => Name -> Evaluator address value effects address
alloc = send . Alloc @address @value
alloc :: Member (Allocator address value) effects => Name -> Evaluator address value effects address
alloc = sendAllocator . Alloc
-- | Dereference the given address in the heap, or fail if the address is uninitialized.
deref :: Member (Allocator address value) effects => address -> Evaluator address value effects value
deref = send . Deref
-- | Write a value to the given address in the 'Store'.
assign :: ( Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer value (Cell address value)
)
-- | Write a value to the given address in the 'Allocator'.
assign :: Member (Allocator address value) effects
=> address
-> value
-> Evaluator address value effects ()
assign address = modifyHeap . heapInsert address
assign address = send . Assign address
-- | Look up or allocate an address for a 'Name'.
lookupOrAlloc :: ( Member (Allocator address value) effects
, Member (Reader (Environment address)) effects
, Member (State (Environment address)) effects
, Member (Env address) effects
)
=> Name
-> Evaluator address value effects address
lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure
lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name)
letrec :: ( Member (Allocator address value) effects
, Member (Reader (Environment address)) effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer value (Cell address value)
, Member (Env address) effects
)
=> Name
-> Evaluator address value effects value
@ -88,8 +82,7 @@ letrec name body = do
-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
letrec' :: ( Member (Allocator address value) effects
, Member (Reader (Environment address)) effects
, Member (State (Environment address)) effects
, Member (Env address) effects
)
=> Name
-> (address -> Evaluator address value effects value)
@ -102,25 +95,63 @@ letrec' name body = do
-- | Look up and dereference the given 'Name', throwing an exception for free variables.
variable :: ( Member (Allocator address value) effects
, Member (Reader (Environment address)) effects
, Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (State (Environment address)) effects
)
=> Name
-> Evaluator address value effects value
variable name = lookupEnv name >>= maybeM (freeVariableError name) >>= deref
-- Garbage collection
-- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
gc :: Member (Allocator address value) effects
=> Live address -- ^ The set of addresses to consider rooted.
-> Evaluator address value effects ()
gc roots = sendAllocator (GC roots)
-- | Compute the set of addresses reachable from a given root set in a given heap.
reachable :: ( Ord address
, Foldable (Cell address)
, ValueRoots address value
)
=> Live address -- ^ The set of root addresses.
-> Heap address (Cell address) value -- ^ The heap to trace addresses through.
-> Live address -- ^ The set of addresses reachable from the root set.
reachable roots heap = go mempty roots
where go seen set = case liveSplit set of
Nothing -> seen
Just (a, as) -> go (liveInsert a seen) $ case heapLookupAll a heap of
Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen
_ -> seen
-- Effects
data Allocator address value return where
Alloc :: Name -> Allocator address value address
Deref :: address -> Allocator address value value
sendAllocator :: Member (Allocator address value) effects => Allocator address value return -> Evaluator address value effects return
sendAllocator = send
runAllocator :: (Addressable address effects, Effectful (m address value), Member (Resumable (AddressError address value)) effects, Member (State (Heap address (Cell address) value)) effects) => m address value (Allocator address value ': effects) a -> m address value effects a
runAllocator = raiseHandler (interpret (\ eff -> case eff of
Alloc name -> lowerEff $ allocCell name
Deref addr -> lowerEff $ heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr))))
data Allocator address value return where
Alloc :: Name -> Allocator address value address
Deref :: address -> Allocator address value value
Assign :: address -> value -> Allocator address value ()
GC :: Live address -> Allocator address value ()
runAllocator :: ( Addressable address effects
, Foldable (Cell address)
, Member (Resumable (AddressError address value)) effects
, Member (State (Heap address (Cell address) value)) effects
, Reducer value (Cell address value)
, ValueRoots address value
)
=> Evaluator address value (Allocator address value ': effects) a
-> Evaluator address value effects a
runAllocator = interpret $ \ eff -> case eff of
Alloc name -> allocCell name
Deref addr -> heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr))
Assign addr value -> modifyHeap (heapInsert addr value)
GC roots -> modifyHeap (heapRestrict <*> reachable roots)
data AddressError address value resume where

28
src/Control/Abstract/Modules.hs
View File

@ -26,7 +26,7 @@ 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 address value) effects => ModulePath -> Evaluator address value effects (Maybe (Maybe (Environment address, value)))
lookupModule :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Maybe (value, Environment address)))
lookupModule = send . Lookup
-- | Resolve a list of module paths to a possible module table entry.
@ -40,19 +40,19 @@ 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 address value) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value))
require :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (value, Environment address))
require path = lookupModule path >>= maybeM (load path)
-- | Load another module by name and return its environment and value.
--
-- Always loads/evaluates.
load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value))
load = send . Load
load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (value, Environment address))
load path = send (Load path)
data Modules address value return where
Load :: ModulePath -> Modules address value (Maybe (Environment address, value))
Lookup :: ModulePath -> Modules address value (Maybe (Maybe (Environment address, value)))
Load :: ModulePath -> Modules address value (Maybe (value, Environment address))
Lookup :: ModulePath -> Modules address value (Maybe (Maybe (value, Environment address)))
Resolve :: [FilePath] -> Modules address value (Maybe ModulePath)
List :: FilePath -> Modules address value [ModulePath]
@ -61,10 +61,10 @@ sendModules = send
runModules :: forall term address value effects a
. ( Member (Resumable (LoadError address value)) effects
, Member (State (ModuleTable (Maybe (Environment address, value)))) effects
, Member (State (ModuleTable (Maybe (value, Environment address)))) effects
, Member Trace effects
)
=> (Module term -> Evaluator address value (Modules address value ': effects) (Environment address, value))
=> (Module term -> Evaluator address value (Modules address value ': effects) (value, Environment address))
-> Evaluator address value (Modules address value ': effects) a
-> Evaluator address value (Reader (ModuleTable [Module term]) ': effects) a
runModules evaluateModule = go
@ -89,22 +89,22 @@ runModules evaluateModule = go
pure (find isMember names)
List dir -> modulePathsInDir dir <$> askModuleTable @term)
getModuleTable :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => Evaluator address value effects (ModuleTable (Maybe (Environment address, value)))
getModuleTable :: Member (State (ModuleTable (Maybe (value, Environment address)))) effects => Evaluator address value effects (ModuleTable (Maybe (value, Environment address)))
getModuleTable = get
cacheModule :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => ModulePath -> Maybe (Environment address, value) -> Evaluator address value effects (Maybe (Environment address, value))
cacheModule :: Member (State (ModuleTable (Maybe (value, Environment address)))) effects => ModulePath -> Maybe (value, Environment address) -> Evaluator address value effects (Maybe (value, Environment address))
cacheModule path result = modify' (ModuleTable.insert path result) $> result
askModuleTable :: Member (Reader (ModuleTable [Module term])) effects => Evaluator address value effects (ModuleTable [Module term])
askModuleTable = ask
newtype Merging m address value = Merging { runMerging :: m (Maybe (Environment address, value)) }
newtype Merging m address value = Merging { runMerging :: m (Maybe (value, Environment address)) }
instance Applicative m => Semigroup (Merging m address 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)
mergeJusts (_, env1) (v, env2) = (v, mergeEnvs env1 env2)
instance Applicative m => Monoid (Merging m address value) where
mappend = (<>)
@ -113,7 +113,7 @@ instance Applicative m => Monoid (Merging m address value) where
-- | 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 address value resume where
ModuleNotFound :: ModulePath -> LoadError address value (Maybe (Environment address, value))
ModuleNotFound :: ModulePath -> LoadError address value (Maybe (value, Environment address))
deriving instance Eq (LoadError address value resume)
deriving instance Show (LoadError address value resume)
@ -122,7 +122,7 @@ instance Show1 (LoadError address value) where
instance Eq1 (LoadError address value) where
liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b
moduleNotFound :: Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value))
moduleNotFound :: Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (value, Environment address))
moduleNotFound = throwResumable . ModuleNotFound
resumeLoadError :: Member (Resumable (LoadError address value)) effects => Evaluator address value effects a -> (forall resume . LoadError address value resume -> Evaluator address value effects resume) -> Evaluator address value effects a

13
src/Control/Abstract/Primitive.hs
View File

@ -1,6 +1,5 @@
module Control.Abstract.Primitive where
import Control.Abstract.Addressable
import Control.Abstract.Context
import Control.Abstract.Environment
import Control.Abstract.Evaluator
@ -8,18 +7,14 @@ import Control.Abstract.Heap
import Control.Abstract.Value
import Data.Abstract.Name
import Data.ByteString.Char8 (pack, unpack)
import Data.Semigroup.Reducer hiding (unit)
import Data.Semilattice.Lower
import Prologue
builtin :: ( HasCallStack
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer value (Cell address value)
)
=> String
-> Evaluator address value effects value
@ -40,16 +35,12 @@ lambda body = do
defineBuiltins :: ( AbstractValue address value effects
, HasCallStack
, Member (Allocator address value) effects
, Member (Env address) effects
, Member Fresh effects
, Member (Reader (Environment address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Member Trace effects
, Ord address
, Reducer value (Cell address value)
)
=> Evaluator address value effects ()
defineBuiltins =

10
src/Control/Abstract/Roots.hs
View File

@ -1,5 +1,6 @@
module Control.Abstract.Roots
( Live
( ValueRoots(..)
, Live
, askRoots
, extraRoots
) where
@ -8,6 +9,13 @@ import Control.Abstract.Evaluator
import Data.Abstract.Live
import Prologue
-- | Value types, e.g. closures, which can root a set of addresses.
class ValueRoots address value where
-- | Compute the set of addresses rooted by a given value.
valueRoots :: value -> Live address
-- | Retrieve the local 'Live' set.
askRoots :: Member (Reader (Live address)) effects => Evaluator address value effects (Live address)
askRoots = ask

1
src/Control/Abstract/TermEvaluator.hs
View File

@ -7,7 +7,6 @@ module Control.Abstract.TermEvaluator
import Control.Abstract.Evaluator
import Control.Monad.Effect as X
import Control.Monad.Effect.Fail as X
import Control.Monad.Effect.Fresh as X
import Control.Monad.Effect.NonDet as X
import Control.Monad.Effect.Reader as X

26
src/Control/Abstract/Value.hs
View File

@ -12,20 +12,16 @@ module Control.Abstract.Value
, evaluateInScopedEnv
, value
, subtermValue
, ValueRoots(..)
) where
import Control.Abstract.Addressable
import Control.Abstract.Environment
import Control.Abstract.Evaluator
import Control.Abstract.Heap
import Data.Abstract.Environment as Env
import Data.Abstract.Live (Live)
import Data.Abstract.Name
import Data.Abstract.Number as Number
import Data.Abstract.Ref
import Data.Scientific (Scientific)
import Data.Semigroup.Reducer hiding (unit)
import Data.Semilattice.Lower
import Prelude
import Prologue hiding (TypeError)
@ -158,7 +154,7 @@ asBool value = ifthenelse value (pure True) (pure False)
-- | C-style for loops.
forLoop :: ( AbstractValue address value effects
, Member (State (Environment address)) effects
, Member (Env address) effects
)
=> Evaluator address value effects value -- ^ Initial statement
-> Evaluator address value effects value -- ^ Condition
@ -187,10 +183,8 @@ doWhile body cond = loop $ \ continue -> body *> do
ifthenelse this continue (pure unit)
makeNamespace :: ( AbstractValue address value effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer value (Cell address value)
, Member (Env address) effects
, Member (Allocator address value) effects
)
=> Name
-> address
@ -206,7 +200,7 @@ makeNamespace name addr super = do
-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
evaluateInScopedEnv :: ( AbstractValue address value effects
, Member (State (Environment address)) effects
, Member (Env address) effects
)
=> Evaluator address value effects value
-> Evaluator address value effects value
@ -219,9 +213,8 @@ evaluateInScopedEnv scopedEnvTerm term = do
-- | Evaluates a 'Value' returning the referenced value
value :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Reader (Environment address)) effects
, Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (State (Environment address)) effects
)
=> ValueRef value
-> Evaluator address value effects value
@ -232,16 +225,9 @@ value (Rval val) = pure val
-- | Evaluates a 'Subterm' to its rval
subtermValue :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Reader (Environment address)) effects
, Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (State (Environment address)) effects
)
=> Subterm term (Evaluator address value effects (ValueRef value))
-> Evaluator address value effects value
subtermValue = value <=< subtermRef
-- | Value types, e.g. closures, which can root a set of addresses.
class ValueRoots address value where
-- | Compute the set of addresses rooted by a given value.
valueRoots :: value -> Live address

2
src/Data/Abstract/Environment.hs
View File

@ -1,7 +1,6 @@
module Data.Abstract.Environment
( Environment(..)
, addresses
, intersect
, delete
, head
, emptyEnv
@ -10,6 +9,7 @@ module Data.Abstract.Environment
, insert
, lookup
, names
, intersect
, overwrite
, pairs
, unpairs

85
src/Data/Abstract/Evaluatable.hs
View File

@ -3,7 +3,6 @@ module Data.Abstract.Evaluatable
( module X
, Evaluatable(..)
, evaluatePackageWith
, isolate
, traceResolve
-- | Effects
, EvalError(..)
@ -20,13 +19,11 @@ import Control.Abstract
import Control.Abstract.Context as X
import Control.Abstract.Environment as X hiding (runEnvironmentError, runEnvironmentErrorWith)
import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn)
import Control.Abstract.Exports as X
import Control.Abstract.Heap as X hiding (AddressError(..), runAddressError, runAddressErrorWith)
import Control.Abstract.Modules as X (Modules, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve)
import Control.Abstract.Value as X
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
@ -44,21 +41,21 @@ 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 address term value effects
eval :: ( EvaluatableConstraints term address value effects
, Member Fail effects
)
=> SubtermAlgebra constr term (Evaluator address value effects (ValueRef value))
default eval :: (Member (Resumable (Unspecialized value)) effects, Show1 constr) => SubtermAlgebra constr term (Evaluator address value effects (ValueRef value))
eval expr = throwResumable (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
type EvaluatableConstraints address term value effects =
type EvaluatableConstraints term address value effects =
( AbstractValue address value effects
, Declarations term
, FreeVariables term
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (LoopControl value) effects
, Member (Modules address value) effects
, Member (Reader (Environment address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
@ -67,85 +64,73 @@ type EvaluatableConstraints address term value effects =
, Member (Resumable ResolutionError) effects
, Member (Resumable (Unspecialized value)) effects
, Member (Return value) effects
, Member (State (Environment address)) effects
, Member (State (Exports address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Member Trace effects
, Ord address
, Reducer value (Cell address value)
)
-- | Evaluate a given package.
evaluatePackageWith :: forall address term value inner outer
-- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' addresses require knowledge of 'currentModule' to run. Can we fix that? If not, can we factor this effect list out?
. ( Addressable address (Reader ModuleInfo ': Modules address value ': Reader Span ': Reader PackageInfo ': outer)
evaluatePackageWith :: forall address term value inner inner' inner'' outer
-- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' locations require knowledge of 'currentModule' to run. Can we fix that?
. ( Addressable address inner'
, Evaluatable (Base term)
, EvaluatableConstraints address term value inner
, EvaluatableConstraints term address value inner
, Foldable (Cell address)
, Member Fail outer
, Member Fresh outer
, Member (Reader (Environment address)) outer
, Member (Resumable (AddressError address value)) outer
, Member (Resumable (LoadError address value)) outer
, Member (State (Environment address)) outer
, Member (State (Exports address)) outer
, Member (State (Heap address (Cell address) value)) outer
, Member (State (ModuleTable (Maybe (Environment address, value)))) outer
, Member (State (ModuleTable (Maybe (value, Environment address)))) outer
, Member Trace outer
, Recursive term
, inner ~ (LoopControl value ': Return value ': Allocator address value ': Reader ModuleInfo ': Modules address value ': Reader Span ': Reader PackageInfo ': outer)
, Reducer value (Cell address value)
, ValueRoots address value
, inner ~ (LoopControl value ': Return value ': Env address ': Allocator address value ': inner')
, inner' ~ (Reader ModuleInfo ': inner'')
, inner'' ~ (Modules address value ': Reader Span ': Reader PackageInfo ': outer)
)
=> (SubtermAlgebra Module term (TermEvaluator term address value inner value) -> SubtermAlgebra Module term (TermEvaluator term address value inner value))
-> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value)))
-> Package term
-> TermEvaluator term address value outer [value]
-> TermEvaluator term address value outer [(value, Environment address)]
evaluatePackageWith analyzeModule analyzeTerm package
= runReader (packageInfo package)
. runReader lowerBound
. runReader (packageModules (packageBody package))
. withPrelude (packagePrelude (packageBody package))
. raiseHandler (runModules (runTermEvaluator . evalModule))
$ traverse (uncurry evaluateEntryPoint) (ModuleTable.toPairs (packageEntryPoints (packageBody package)))
$ \ preludeEnv
-> raiseHandler (runModules (runTermEvaluator . evalModule preludeEnv))
. traverse (uncurry (evaluateEntryPoint preludeEnv))
$ ModuleTable.toPairs (packageEntryPoints (packageBody package))
where
evalModule m
= pairValueWithEnv
. runInModule (moduleInfo m)
evalModule preludeEnv m
= runInModule preludeEnv (moduleInfo m)
. analyzeModule (subtermRef . moduleBody)
$ evalTerm <$> m
evalTerm term = Subterm term (TermEvaluator (value =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term)))
runInModule info
runInModule preludeEnv info
= runReader info
. raiseHandler runAllocator
. raiseHandler (runEnv preludeEnv)
. raiseHandler runReturn
. raiseHandler runLoopControl
evaluateEntryPoint :: ModulePath -> Maybe Name -> TermEvaluator term address value (Modules address value ': Reader Span ': Reader PackageInfo ': outer) value
evaluateEntryPoint m sym = runInModule (ModuleInfo m) . TermEvaluator $ do
v <- maybe unit snd <$> require m
maybe (pure v) ((`call` []) <=< variable) sym
evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' (value, Environment address)
evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do
(value, env) <- fromMaybe (unit, emptyEnv) <$> require m
bindAll env
maybe (pure value) ((`call` []) <=< variable) sym
evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule)) $ do
_ <- runInModule moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit))
fst <$> evalModule prelude
evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule emptyEnv)) $ do
(_, builtinsEnv) <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit))
second (mergeEnvs builtinsEnv) <$> evalModule builtinsEnv prelude
withPrelude Nothing a = a
withPrelude (Just prelude) a = do
preludeEnv <- evalPrelude prelude
raiseHandler (withDefaultEnvironment preludeEnv) a
withPrelude Nothing f = f emptyEnv
withPrelude (Just prelude) f = do
(_, preludeEnv) <- evalPrelude prelude
f preludeEnv
-- 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 <$> TermEvaluator getExports <*> TermEvaluator getEnv)
-- | Isolate the given action with an empty global environment and exports.
isolate :: (Member (State (Environment address)) effects, Member (State (Exports address)) effects) => Evaluator address value effects a -> Evaluator address value effects a
isolate = withEnv lowerBound . withExports lowerBound
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects ()
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)

4
src/Data/Abstract/Live.hs
View File

@ -36,6 +36,10 @@ liveMember addr = Set.member addr . unLive
liveSplit :: Live address -> Maybe (address, Live address)
liveSplit = fmap (fmap Live) . Set.minView . unLive
-- | Map a function over the addresses in a 'Live' set.
liveMap :: Ord b => (a -> b) -> Live a -> Live b
liveMap f = Live . Set.map f . unLive
instance Show address => Show (Live address) where
showsPrec d = showsUnaryWith showsPrec "Live" d . Set.toList . unLive

3
src/Data/Abstract/Ref.hs
View File

@ -12,3 +12,6 @@ data ValueRef value where
-- | An object member.
LvalMember :: value -> Name -> ValueRef value
deriving (Eq, Ord, Show)
newtype Ref address value = Ref address

17
src/Data/Abstract/Type.hs
View File

@ -10,7 +10,6 @@ module Data.Abstract.Type
import Control.Abstract
import Data.Abstract.Environment as Env
import Data.Semigroup.Foldable (foldMap1)
import Data.Semigroup.Reducer (Reducer)
import Prologue hiding (TypeError)
type TName = Int
@ -117,21 +116,18 @@ instance AbstractIntro Type where
instance ( Member (Allocator address Type) effects
, Member (Env address) effects
, Member Fresh effects
, Member (Resumable TypeError) effects
, Member (Return Type) effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) Type)) effects
, Ord address
, Reducer Type (Cell address Type)
)
=> AbstractFunction address Type effects where
closure names _ body = do
(env, tvars) <- foldr (\ name rest -> do
a <- alloc name
addr <- alloc name
tvar <- Var <$> fresh
assign a tvar
bimap (Env.insert name a) (tvar :) <$> rest) (pure (emptyEnv, [])) names
assign addr tvar
bimap (Env.insert name addr) (tvar :) <$> rest) (pure (emptyEnv, [])) names
(zeroOrMoreProduct tvars :->) <$> locally (bindAll env *> body `catchReturn` \ (Return value) -> pure value)
call op params = do
@ -146,14 +142,11 @@ instance ( Member (Allocator address Type) effects
-- | Discard the value arguments (if any), constructing a 'Type' instead.
instance ( Member (Allocator address Type) effects
, Member (Env address) effects
, Member Fresh effects
, Member NonDet effects
, Member (Resumable TypeError) effects
, Member (Return Type) effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) Type)) effects
, Ord address
, Reducer Type (Cell address Type)
)
=> AbstractValue address Type effects where
array fields = do

24
src/Data/Abstract/Value.hs
View File

@ -10,7 +10,6 @@ import Data.Coerce
import Data.List (genericIndex, genericLength)
import Data.Scientific (Scientific)
import Data.Scientific.Exts
import Data.Semigroup.Reducer
import qualified Data.Set as Set
import Prologue
@ -42,7 +41,7 @@ instance Ord (ClosureBody address body) where
compare = compare `on` closureBodyId
instance Show (ClosureBody address body) where
showsPrec d (ClosureBody i _) = showsBinaryWith showsPrec (const showChar) "ClosureBody" d i '_'
showsPrec d (ClosureBody i _) = showsUnaryWith showsPrec "ClosureBody" d i
instance Ord address => ValueRoots address (Value address body) where
@ -56,15 +55,12 @@ instance AbstractHole (Value address body) where
instance ( Coercible body (Eff effects)
, Member (Allocator address (Value address body)) effects
, Member (Env address) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable (ValueError address body)) effects
, Member (Return (Value address body)) effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) (Value address body))) effects
, Ord address
, Reducer (Value address body) (Cell address (Value address body))
, Show address
)
=> AbstractFunction address (Value address body) effects where
@ -72,7 +68,7 @@ instance ( Coercible body (Eff effects)
packageInfo <- currentPackage
moduleInfo <- currentModule
i <- fresh
Closure packageInfo moduleInfo parameters (ClosureBody i (coerce (lowerEff body))) . Env.intersect (foldr Set.delete freeVariables parameters) <$> getEnv
Closure packageInfo moduleInfo parameters (ClosureBody i (coerce (lowerEff body))) <$> close (foldr Set.delete freeVariables parameters)
call op params = do
case op of
@ -81,10 +77,10 @@ instance ( Coercible body (Eff effects)
-- 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)
value <- param
addr <- alloc name
assign addr value
Env.insert name addr <$> rest) (pure env) (zip names params)
locally (bindAll bindings *> raiseEff (coerce body) `catchReturn` \ (Return value) -> pure value)
_ -> throwValueError (CallError op)
@ -109,17 +105,13 @@ instance Show address => AbstractIntro (Value address body) where
-- | Construct a 'Value' wrapping the value arguments (if any).
instance ( Coercible body (Eff effects)
, Member (Allocator address (Value address body)) effects
, Member (Env address) effects
, Member Fresh effects
, Member (LoopControl (Value address body)) effects
, Member (Reader (Environment address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable (ValueError address body)) effects
, Member (Return (Value address body)) effects
, Member (State (Environment address)) effects
, Member (State (Heap address (Cell address) (Value address body))) effects
, Ord address
, Reducer (Value address body) (Cell address (Value address body))
, Show address
)
=> AbstractValue address (Value address body) effects where

4
src/Data/Blob.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DeriveAnyClass #-}
module Data.Blob
( Blob(..)
, nullBlob
@ -14,6 +15,7 @@ module Data.Blob
) where
import Prologue
import Proto3.Suite
import Data.Aeson
import Data.JSON.Fields
import Data.Language
@ -26,7 +28,7 @@ data Blob = Blob
, blobPath :: FilePath -- ^ The file path to the blob.
, blobLanguage :: Maybe Language -- ^ The language of this blob. Nothing denotes a langauge we don't support yet.
}
deriving (Show, Eq)
deriving (Show, Eq, Generic, Message, Named)
nullBlob :: Blob -> Bool
nullBlob Blob{..} = nullSource blobSource

3
src/Data/Language.hs
View File

@ -3,6 +3,7 @@ module Data.Language where
import Prologue
import Data.Aeson
import Proto3.Suite
-- | A programming language.
data Language
@ -16,7 +17,7 @@ data Language
| Ruby
| TypeScript
| PHP
deriving (Eq, Generic, Ord, Read, Show, ToJSON)
deriving (Eq, Generic, Ord, Read, Show, ToJSON, Named, Enum, Finite, Message)
-- | Returns a Language based on the file extension (including the ".").
languageForType :: String -> Maybe Language

5
src/Data/Source.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.Source
( Source
, sourceBytes
@ -36,10 +36,11 @@ import Data.Span
import Data.String (IsString(..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Proto3.Suite
-- | The contents of a source file, represented as a 'ByteString'.
newtype Source = Source { sourceBytes :: B.ByteString }
deriving (Eq, IsString, Show)
deriving (Eq, IsString, Show, Generic, MessageField)
fromBytes :: B.ByteString -> Source
fromBytes = Source

15
src/Data/Span.hs
View File

@ -11,6 +11,9 @@ module Data.Span
) where
import Data.Aeson ((.=), (.:))
import Proto3.Suite
import Proto3.Wire.Decode as Decode
import Proto3.Wire.Encode as Encode
import qualified Data.Aeson as A
import Data.JSON.Fields
import Data.Semilattice.Lower
@ -22,7 +25,15 @@ data Pos = Pos
{ posLine :: !Int
, posColumn :: !Int
}
deriving (Show, Read, Eq, Ord, Generic, Hashable)
deriving (Show, Read, Eq, Ord, Generic, Hashable, Named, Message)
instance MessageField Pos where
encodeMessageField num = Encode.embedded num . encodeMessage (fieldNumber 1)
decodeMessageField = fromMaybe def <$> Decode.embedded (decodeMessage (fieldNumber 1))
protoType pr = messageField (Prim $ Named (Single (nameOf pr))) Nothing
instance HasDefault Pos where
def = Pos 1 1
instance A.ToJSON Pos where
toJSON Pos{..} =
@ -37,7 +48,7 @@ data Span = Span
{ spanStart :: Pos
, spanEnd :: Pos
}
deriving (Show, Read, Eq, Ord, Generic, Hashable)
deriving (Show, Read, Eq, Ord, Generic, Hashable, Named, Message)
spanFromSrcLoc :: SrcLoc -> Span
spanFromSrcLoc = Span . (Pos . srcLocStartLine <*> srcLocStartCol) <*> (Pos . srcLocEndLine <*> srcLocEndCol)

42
src/Data/Syntax.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, TypeFamilies #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack
{-# LANGUAGE AllowAmbiguousTypes, DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, KindSignatures, RankNTypes, ConstraintKinds #-}
{-# OPTIONS_GHC -Wno-redundant-constraints -fno-warn-orphans #-} -- For HasCallStack
module Data.Syntax where
import Data.Abstract.Evaluatable
@ -18,7 +18,13 @@ import Prelude
import Prologue
import qualified Assigning.Assignment as Assignment
import qualified Data.Error as Error
import Proto3.Suite.Class
import Proto3.Wire.Decode
import Proto3.Wire.Types
import GHC.Types (Constraint)
import GHC.TypeLits
import qualified Proto3.Suite.DotProto as Proto
import Data.Char (toLower)
-- Combinators
-- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children.
@ -99,12 +105,37 @@ infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack,
-> m (Sum fs (Term (Sum fs) a))
infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right
instance (Apply Message1 fs, Generate Message1 fs fs, Generate Named1 fs fs) => Message1 (Sum fs) where
liftEncodeMessage encodeMessage num = apply @Message1 (liftEncodeMessage encodeMessage num)
liftDecodeMessage decodeMessage _ = oneof undefined listOfParsers
where
listOfParsers =
generate @Message1 @fs @fs (\ (_ :: proxy f) i -> let num = FieldNumber (fromInteger (succ i)) in [(num, fromJust <$> embedded (inject @f @fs <$> liftDecodeMessage decodeMessage num))])
liftDotProto _ =
[Proto.DotProtoMessageOneOf (Proto.Single "syntax") (generate @Named1 @fs @fs (\ (_ :: proxy f) i ->
let
num = FieldNumber (fromInteger (succ i))
fieldType = Proto.Prim (Proto.Named . Proto.Single $ nameOf1 (Proxy @f))
fieldName = Proto.Single (camelCase $ nameOf1 (Proxy @f))
camelCase (x : xs) = toLower x : xs
camelCase [] = []
in
[ Proto.DotProtoField num fieldType fieldName [] Nothing ]))]
class Generate (c :: (* -> *) -> Constraint) (all :: [* -> *]) (fs :: [* -> *]) where
generate :: Monoid b => (forall f proxy. (Element f all, c f) => proxy f -> Integer -> b) -> b
instance Generate c all '[] where
generate _ = mempty
instance (Element f all, c f, Generate c all fs) => Generate c all (f ': fs) where
generate each = each (Proxy @f) (natVal (Proxy @(ElemIndex f all))) `mappend` generate @c @all @fs each
-- Common
-- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable).
newtype Identifier a = Identifier { name :: Name }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, ToJSONFields1)
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, Named1, ToJSONFields1)
instance Eq1 Identifier where liftEq = genericLiftEq
instance Ord1 Identifier where liftCompare = genericLiftCompare
@ -162,7 +193,7 @@ instance Evaluatable AccessibilityModifier
--
-- This can be used to represent an implicit no-op, e.g. the alternative in an 'if' statement without an 'else'.
data Empty a = Empty
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1)
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1)
instance Eq1 Empty where liftEq _ _ _ = True
instance Ord1 Empty where liftCompare _ _ _ = EQ
@ -171,7 +202,6 @@ instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
instance Evaluatable Empty where
eval _ = pure (Rval unit)
-- | Syntax representing a parsing or assignment error.
data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)

6
src/Data/Syntax/Declaration.hs
View File

@ -27,8 +27,7 @@ instance Evaluatable Function where
eval Function{..} = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm functionName)
(v, addr) <- letrec name (closure (paramNames functionParameters) (Set.fromList (freeVariables functionBody)) (subtermValue functionBody))
bind name addr
pure (Rval v)
Rval v <$ bind name addr
where paramNames = foldMap (freeVariables . subterm)
instance Declarations a => Declarations (Function a) where
@ -53,8 +52,7 @@ instance Evaluatable Method where
eval Method{..} = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm methodName)
(v, addr) <- letrec name (closure (paramNames methodParameters) (Set.fromList (freeVariables methodBody)) (subtermValue methodBody))
bind name addr
pure (Rval v)
Rval v <$ bind name addr
where paramNames = foldMap (freeVariables . subterm)

47
src/Data/Syntax/Literal.hs
View File

@ -1,20 +1,21 @@
{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, ViewPatterns #-}
{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, ViewPatterns, ScopedTypeVariables #-}
module Data.Syntax.Literal where
import Data.JSON.Fields
import Data.Abstract.Evaluatable
import Data.ByteString.Char8 (readInteger, unpack)
import Data.Abstract.Evaluatable
import Data.ByteString.Char8 (readInteger, unpack)
import qualified Data.ByteString.Char8 as B
import Data.Scientific.Exts
import Diffing.Algorithm
import Prelude hiding (Float, null)
import Prologue hiding (Set, hash, null)
import Text.Read (readMaybe)
import Data.JSON.Fields
import Data.Scientific.Exts
import Diffing.Algorithm
import Prelude hiding (Float, null)
import Prologue hiding (Set, hash, null)
import Proto3.Suite.Class
import Text.Read (readMaybe)
-- Boolean
newtype Boolean a = Boolean Bool
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
newtype Boolean a = Boolean { booleanContent :: Bool }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1)
true :: Boolean a
true = Boolean True
@ -57,7 +58,7 @@ instance ToJSONFields1 Data.Syntax.Literal.Integer where
-- | A literal float of unspecified width.
newtype Float a = Float { floatContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1)
instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare
@ -118,6 +119,17 @@ instance Evaluatable Data.Syntax.Literal.String
instance ToJSONFields1 Data.Syntax.Literal.String
newtype Character a = Character { characterContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Data.Syntax.Literal.Character where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.Character where liftCompare = genericLiftCompare
instance Show1 Data.Syntax.Literal.Character where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Data.Syntax.Literal.Character
instance ToJSONFields1 Data.Syntax.Literal.Character
-- | An interpolation element within a string literal.
newtype InterpolationElement a = InterpolationElement { interpolationBody :: a }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
@ -133,7 +145,7 @@ instance ToJSONFields1 InterpolationElement
-- | A sequence of textual contents within a string literal.
newtype TextElement a = TextElement { textElementContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1)
instance Eq1 TextElement where liftEq = genericLiftEq
instance Ord1 TextElement where liftCompare = genericLiftCompare
@ -146,7 +158,7 @@ instance Evaluatable TextElement where
eval (TextElement x) = pure (Rval (string x))
data Null a = Null
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1)
instance Eq1 Null where liftEq = genericLiftEq
instance Ord1 Null where liftCompare = genericLiftCompare
@ -176,7 +188,6 @@ instance Ord1 Regex where liftCompare = genericLiftCompare
instance Show1 Regex where liftShowsPrec = genericLiftShowsPrec
-- TODO: Heredoc-style string literals?
-- TODO: Character literals.
instance ToJSONFields1 Regex where
toJSONFields1 (Regex r) = noChildren ["asString" .= unpack r]
@ -189,7 +200,7 @@ instance Evaluatable Regex
-- Collections
newtype Array a = Array { arrayElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1)
instance Eq1 Array where liftEq = genericLiftEq
instance Ord1 Array where liftCompare = genericLiftCompare
@ -201,7 +212,7 @@ instance Evaluatable Array where
eval (Array a) = Rval <$> (array =<< traverse subtermValue a)
newtype Hash a = Hash { hashElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1)
instance Eq1 Hash where liftEq = genericLiftEq
instance Ord1 Hash where liftCompare = genericLiftCompare
@ -213,7 +224,7 @@ instance Evaluatable Hash where
eval t = Rval . hash <$> traverse (subtermValue >=> asPair) (hashElements t)
data KeyValue a = KeyValue { key :: !a, value :: !a }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1)
instance Eq1 KeyValue where liftEq = genericLiftEq
instance Ord1 KeyValue where liftCompare = genericLiftCompare

11
src/Data/Term.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators #-}
{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators, ScopedTypeVariables #-}
module Data.Term
( Term(..)
, termIn
@ -16,6 +16,7 @@ import Data.Aeson
import Data.JSON.Fields
import Data.Record
import Text.Show
import Proto3.Suite.Class
-- | A Term with an abstract syntax tree and an annotation.
newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) }
@ -78,6 +79,14 @@ instance Show1 f => Show1 (Term f) where
instance (Show1 f, Show a) => Show (Term f a) where
showsPrec = showsPrec1
instance Message1 f => Message (Term f ()) where
encodeMessage num (Term (In _ f)) = liftEncodeMessage encodeMessage num f
decodeMessage num = termIn () <$> liftDecodeMessage decodeMessage num
dotProto _ = liftDotProto (Proxy @(f (Term f ())))
instance Named (Term f a) where
nameOf _ = "Term"
instance Ord1 f => Ord1 (Term f) where
liftCompare comp = go where go t1 t2 = liftCompare2 comp go (unTerm t1) (unTerm t2)

2
src/Diffing/Algorithm.hs
View File

@ -221,7 +221,7 @@ instance Diffable [] where
-- | Diff two non-empty lists using RWS.
instance Diffable NonEmpty where
algorithmFor (a1:|as1) (a2:|as2) = nonEmpty <$> byRWS (a1:as1) (a2:as2) >>= maybe empty pure
algorithmFor (a1:|as1) (a2:|as2) = nonEmpty <$> byRWS (a1:as1) (a2:as2) >>= maybeM empty
tryAlignWith f (a1:|as1) (a2:|as2) = (:|) <$> f (These a1 a2) <*> tryAlignWith f as1 as2

6
src/Language/Go/Syntax.hs
View File

@ -70,7 +70,7 @@ instance Evaluatable Import where
paths <- resolveGoImport importPath
for_ paths $ \path -> do
traceResolve (unPath importPath) path
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
importedEnv <- maybe emptyEnv snd <$> require path
bindAll importedEnv
pure (Rval unit)
@ -94,7 +94,7 @@ instance Evaluatable QualifiedImport where
void $ letrec' alias $ \addr -> do
for_ paths $ \p -> do
traceResolve (unPath importPath) p
importedEnv <- maybe emptyEnv fst <$> isolate (require p)
importedEnv <- maybe emptyEnv snd <$> require p
bindAll importedEnv
makeNamespace alias addr Nothing
pure (Rval unit)
@ -113,7 +113,7 @@ instance Evaluatable SideEffectImport where
eval (SideEffectImport importPath _) = do
paths <- resolveGoImport importPath
traceResolve (unPath importPath) paths
for_ paths $ \path -> isolate (require path)
for_ paths require
pure (Rval unit)
-- A composite literal in Go

85
src/Language/Haskell/Assignment.hs
View File

@ -6,7 +6,8 @@ module Language.Haskell.Assignment
, Term
) where
import Assigning.Assignment hiding (Assignment, Error)
import Assigning.Assignment hiding (Assignment, Error, count)
import Data.ByteString.Char8 (count)
import Data.Record
import Data.Sum
import Data.Syntax (emptyTerm, handleError, parseError, makeTerm, makeTerm'', contextualize, postContextualize)
@ -17,6 +18,7 @@ import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Comment as Comment
import qualified Data.Syntax.Declaration as Declaration
import qualified Data.Syntax.Literal as Literal
import qualified Data.Syntax.Type as Type
import qualified Data.Term as Term
import qualified Language.Haskell.Syntax as Syntax
import Prologue
@ -24,13 +26,23 @@ import Prologue
type Syntax = '[
Comment.Comment
, Declaration.Function
, Literal.Array
, Literal.Character
, Literal.Float
, Literal.Integer
, Literal.TextElement
, Syntax.Context
, Syntax.Empty
, Syntax.Error
, Syntax.FunctionConstructor
, Syntax.Identifier
, Syntax.ListConstructor
, Syntax.Module
, Syntax.TupleConstructor
, Syntax.Type
, Syntax.TypeSynonym
, Syntax.UnitConstructor
, Type.TypeParameters
, []
]
@ -55,12 +67,24 @@ expression = term (handleError (choice expressionChoices))
expressionChoices :: [Assignment.Assignment [] Grammar Term]
expressionChoices = [
comment
character
, comment
, constructorIdentifier
, float
, functionConstructor
, functionDeclaration
, integer
, listConstructor
, listExpression
, listType
, moduleIdentifier
, string
, type'
, typeConstructorIdentifier
, typeSynonymDeclaration
, typeVariableIdentifier
, tuplingConstructor
, unitConstructor
, variableIdentifier
, where'
]
@ -80,12 +104,21 @@ constructorIdentifier = makeTerm <$> symbol ConstructorIdentifier <*> (Syntax.Id
moduleIdentifier :: Assignment
moduleIdentifier = makeTerm <$> symbol ModuleIdentifier <*> (Syntax.Identifier . Name.name <$> source)
typeConstructorIdentifier :: Assignment
typeConstructorIdentifier = makeTerm <$> symbol TypeConstructorIdentifier <*> (Syntax.Identifier . Name.name <$> source)
typeVariableIdentifier :: Assignment
typeVariableIdentifier = makeTerm <$> symbol TypeVariableIdentifier <*> (Syntax.Identifier . Name.name <$> source)
where' :: Assignment
where' = makeTerm <$> (symbol Where <|> symbol Where') <*> children (many expression)
functionBody :: Assignment
functionBody = makeTerm <$> symbol FunctionBody <*> children (many expression)
functionConstructor :: Assignment
functionConstructor = makeTerm <$> token FunctionConstructor <*> pure Syntax.FunctionConstructor
functionDeclaration :: Assignment
functionDeclaration = makeTerm
<$> symbol FunctionDeclaration
@ -98,9 +131,57 @@ functionDeclaration = makeTerm
integer :: Assignment
integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source)
listConstructor :: Assignment
listConstructor = makeTerm <$> token ListConstructor <*> pure Syntax.ListConstructor
unitConstructor :: Assignment
unitConstructor = makeTerm <$> token UnitConstructor <*> pure Syntax.UnitConstructor
listExpression :: Assignment
listExpression = makeTerm <$> symbol ListExpression <*> children (Literal.Array <$> many listElement)
where listElement = symbol Expression *> children expression
listType :: Assignment
listType = makeTerm <$> symbol ListType <*> children (Literal.Array <$> many type')
tuplingConstructor :: Assignment
tuplingConstructor = makeTerm <$> symbol TuplingConstructor <*> (tupleWithArity <$> source)
-- a tuple (,) has arity two, but only one comma, so apply the successor to the count of commas for the correct arity.
where tupleWithArity = Syntax.TupleConstructor . succ . count ','
type' :: Assignment
type' = (makeTerm <$> symbol Type <*> children (Syntax.Type <$> typeConstructor <*> typeParameters))
<|> (makeTerm <$> symbol TypePattern <*> children (Syntax.Type <$> typeConstructor <*> typeParameters))
typeParameters :: Assignment
typeParameters = makeTerm <$> location <*> (Type.TypeParameters <$> many expression)
float :: Assignment
float = makeTerm <$> symbol Float <*> (Literal.Float <$> source)
character :: Assignment
character = makeTerm <$> symbol Char <*> (Literal.Character <$> source)
string :: Assignment
string = makeTerm <$> symbol String <*> (Literal.TextElement <$> source)
typeConstructor :: Assignment
typeConstructor = typeConstructorIdentifier
<|> functionConstructor
<|> listConstructor
<|> listType
<|> tuplingConstructor
<|> unitConstructor
typeSynonymDeclaration :: Assignment
typeSynonymDeclaration = makeTerm
<$> symbol TypeSynonymDeclaration
<*> children (Syntax.TypeSynonym <$> typeLeft <*> typeRight)
where
typeLeft = makeTerm <$> location <*> (Syntax.Type <$> typeConstructor <*> typeParametersLeft)
typeParametersLeft = makeTerm <$> location <*> (Type.TypeParameters <$> manyTill expression (symbol TypeSynonymBody))
typeRight = symbol TypeSynonymBody *> children type'
-- | Match a series of terms or comments until a delimiter is matched.
manyTermsTill :: Assignment.Assignment [] Grammar Term -> Assignment.Assignment [] Grammar b -> Assignment.Assignment [] Grammar [Term]
manyTermsTill step = manyTill (step <|> comment)

64
src/Language/Haskell/Syntax.hs
View File

@ -19,4 +19,66 @@ instance Show1 Module where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Module
instance Evaluatable Module where
instance Evaluatable Module
data Type a = Type { typeIdentifier :: !a, typeParameters :: !a }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Type where liftEq = genericLiftEq
instance Ord1 Type where liftCompare = genericLiftCompare
instance Show1 Type where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Type
instance Evaluatable Type
data TypeSynonym a = TypeSynonym { typeSynonymLeft :: !a, typeSynonymRight :: !a }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 TypeSynonym where liftEq = genericLiftEq
instance Ord1 TypeSynonym where liftCompare = genericLiftCompare
instance Show1 TypeSynonym where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 TypeSynonym
instance Evaluatable TypeSynonym
data UnitConstructor a = UnitConstructor deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 UnitConstructor where liftEq = genericLiftEq
instance Ord1 UnitConstructor where liftCompare = genericLiftCompare
instance Show1 UnitConstructor where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 UnitConstructor
instance Evaluatable UnitConstructor
newtype TupleConstructor a = TupleConstructor { tupleConstructorArity :: Int } deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 TupleConstructor where liftEq = genericLiftEq
instance Ord1 TupleConstructor where liftCompare = genericLiftCompare
instance Show1 TupleConstructor where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 TupleConstructor
instance Evaluatable TupleConstructor
data ListConstructor a = ListConstructor deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ListConstructor where liftEq = genericLiftEq
instance Ord1 ListConstructor where liftCompare = genericLiftCompare
instance Show1 ListConstructor where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 ListConstructor
instance Evaluatable ListConstructor
data FunctionConstructor a = FunctionConstructor deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 FunctionConstructor where liftEq = genericLiftEq
instance Ord1 FunctionConstructor where liftCompare = genericLiftCompare
instance Show1 FunctionConstructor where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 FunctionConstructor
instance Evaluatable FunctionConstructor

10
src/Language/PHP/Syntax.hs
View File

@ -48,28 +48,26 @@ resolvePHPName :: ( Member (Modules address value) effects
-> Evaluator address value effects ModulePath
resolvePHPName n = do
modulePath <- resolve [name]
maybe (throwResumable $ NotFoundError name [name] Language.PHP) pure modulePath
maybeM (throwResumable $ NotFoundError name [name] Language.PHP) modulePath
where name = toName n
toName = BC.unpack . dropRelativePrefix . stripQuotes
include :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (Modules address value) effects
, Member (Reader (Environment address)) effects
, Member (Resumable ResolutionError) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (State (Environment address)) effects
, Member (State (Exports address)) effects
, Member Trace effects
)
=> Subterm term (Evaluator address value effects (ValueRef value))
-> (ModulePath -> Evaluator address value effects (Maybe (Environment address, value)))
-> (ModulePath -> Evaluator address value effects (Maybe (value, Environment address)))
-> Evaluator address value effects (ValueRef value)
include pathTerm f = do
name <- subtermValue pathTerm >>= asString
path <- resolvePHPName name
traceResolve name path
(importedEnv, v) <- isolate (f path) >>= maybeM (pure (emptyEnv, unit))
(v, importedEnv) <- fromMaybe (unit, emptyEnv) <$> f path
bindAll importedEnv
pure (Rval v)

22
src/Language/Python/Syntax.hs
View File

@ -16,7 +16,6 @@ import System.FilePath.Posix
import qualified Data.ByteString.Char8 as BC
import qualified Data.Language as Language
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Semigroup.Reducer as Reducer
data QualifiedName
= QualifiedName (NonEmpty FilePath)
@ -82,7 +81,7 @@ resolvePythonModules q = do
, path <.> ".py"
]
modulePath <- resolve searchPaths
maybe (throwResumable $ NotFoundError path searchPaths Language.Python) pure modulePath
maybeM (throwResumable $ NotFoundError path searchPaths Language.Python) modulePath
-- | Import declarations (symbols are added directly to the calling environment).
@ -113,11 +112,11 @@ instance Evaluatable Import where
modulePaths <- resolvePythonModules name
-- Eval parent modules first
for_ (NonEmpty.init modulePaths) (isolate . require)
for_ (NonEmpty.init modulePaths) require
-- Last module path is the one we want to import
let path = NonEmpty.last modulePaths
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
importedEnv <- maybe emptyEnv snd <$> require path
bindAll (select importedEnv)
pure (Rval unit)
where
@ -129,17 +128,12 @@ instance Evaluatable Import where
-- Evaluate a qualified import
evalQualifiedImport :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (Modules address value) effects
, Member (Reader (Environment address)) effects
, Member (State (Environment address)) effects
, Member (State (Exports address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer.Reducer value (Cell address value)
)
=> Name -> ModulePath -> Evaluator address value effects value
evalQualifiedImport name path = letrec' name $ \addr -> do
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
importedEnv <- maybe emptyEnv snd <$> require path
bindAll importedEnv
unit <$ makeNamespace name addr Nothing
@ -163,7 +157,7 @@ instance Evaluatable QualifiedImport where
go ((name, path) :| []) = evalQualifiedImport name path
-- Evaluate each parent module, just creating a namespace
go ((name, path) :| xs) = letrec' name $ \addr -> do
void $ isolate (require path)
void $ require path
void $ go (NonEmpty.fromList xs)
makeNamespace name addr Nothing
@ -182,13 +176,13 @@ instance Evaluatable QualifiedAliasedImport where
modulePaths <- resolvePythonModules name
-- Evaluate each parent module
for_ (NonEmpty.init modulePaths) (isolate . require)
for_ (NonEmpty.init modulePaths) require
-- Evaluate and import the last module, aliasing and updating the environment
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
Rval <$> letrec' alias (\addr -> do
let path = NonEmpty.last modulePaths
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
importedEnv <- maybe emptyEnv snd <$> require path
bindAll importedEnv
unit <$ makeNamespace alias addr Nothing)

17
src/Language/Ruby/Syntax.hs
View File

@ -26,7 +26,7 @@ resolveRubyName name = do
let name' = cleanNameOrPath name
let paths = [name' <.> "rb"]
modulePath <- resolve paths
maybe (throwResumable $ NotFoundError name' paths Language.Ruby) pure modulePath
maybeM (throwResumable $ NotFoundError name' paths Language.Ruby) modulePath
-- load "/root/src/file.rb"
resolveRubyPath :: ( Member (Modules address value) effects
@ -37,7 +37,7 @@ resolveRubyPath :: ( Member (Modules address value) effects
resolveRubyPath path = do
let name' = cleanNameOrPath path
modulePath <- resolve [name']
maybe (throwResumable $ NotFoundError name' [name'] Language.Ruby) pure modulePath
maybeM (throwResumable $ NotFoundError name' [name'] Language.Ruby) modulePath
cleanNameOrPath :: ByteString -> String
cleanNameOrPath = BC.unpack . dropRelativePrefix . stripQuotes
@ -73,7 +73,7 @@ instance Evaluatable Require where
name <- subtermValue x >>= asString
path <- resolveRubyName name
traceResolve name path
(importedEnv, v) <- isolate (doRequire path)
(v, importedEnv) <- doRequire path
bindAll importedEnv
pure (Rval v) -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
@ -81,12 +81,12 @@ doRequire :: ( AbstractValue address value effects
, Member (Modules address value) effects
)
=> M.ModulePath
-> Evaluator address value effects (Environment address, value)
-> Evaluator address value effects (value, Environment address)
doRequire path = do
result <- join <$> lookupModule path
case result of
Nothing -> (,) . maybe emptyEnv fst <$> load path <*> pure (boolean True)
Just (env, _) -> pure (env, boolean False)
Nothing -> (,) (boolean True) . maybe emptyEnv snd <$> load path
Just (_, env) -> pure (boolean False, env)
newtype Load a = Load { loadArgs :: [a] }
@ -109,10 +109,9 @@ instance Evaluatable Load where
eval (Load _) = raiseEff (fail "invalid argument supplied to load, path is required")
doLoad :: ( AbstractValue address value effects
, Member (Env address) effects
, Member (Modules address value) effects
, Member (Resumable ResolutionError) effects
, Member (State (Environment address)) effects
, Member (State (Exports address)) effects
, Member Trace effects
)
=> ByteString
@ -121,7 +120,7 @@ doLoad :: ( AbstractValue address value effects
doLoad path shouldWrap = do
path' <- resolveRubyPath path
traceResolve path path'
importedEnv <- maybe emptyEnv fst <$> isolate (load path')
importedEnv <- maybe emptyEnv snd <$> load path'
unless shouldWrap $ bindAll importedEnv
pure (boolean Prelude.True) -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load

24
src/Language/TypeScript/Syntax.hs
View File

@ -12,7 +12,6 @@ import qualified Data.ByteString.Char8 as BC
import Data.JSON.Fields
import qualified Data.Language as Language
import qualified Data.Map as Map
import Data.Semigroup.Reducer (Reducer)
import Diffing.Algorithm
import Prelude
import Prologue
@ -135,19 +134,14 @@ javascriptExtensions = ["js"]
evalRequire :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (Modules address value) effects
, Member (Reader (Environment address)) effects
, Member (State (Environment address)) effects
, Member (State (Exports address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer value (Cell address value)
)
=> M.ModulePath
-> Name
-> Evaluator address value effects value
evalRequire modulePath alias = letrec' alias $ \addr -> do
importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath)
importedEnv <- maybe emptyEnv snd <$> require modulePath
bindAll importedEnv
unit <$ makeNamespace alias addr Nothing
@ -164,7 +158,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Import where
eval (Import symbols importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath)
importedEnv <- maybe emptyEnv snd <$> require modulePath
bindAll (renamed importedEnv) $> Rval unit
where
renamed importedEnv
@ -214,7 +208,7 @@ instance ToJSONFields1 SideEffectImport
instance Evaluatable SideEffectImport where
eval (SideEffectImport importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
void $ isolate (require modulePath)
void $ require modulePath
pure (Rval unit)
@ -232,7 +226,7 @@ instance Evaluatable QualifiedExport where
eval (QualifiedExport exportSymbols) = do
-- Insert the aliases with no addresses.
for_ exportSymbols $ \(name, alias) ->
addExport name alias Nothing
export name alias Nothing
pure (Rval unit)
@ -249,11 +243,11 @@ instance ToJSONFields1 QualifiedExportFrom
instance Evaluatable QualifiedExportFrom where
eval (QualifiedExportFrom importPath exportSymbols) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath)
importedEnv <- maybe emptyEnv snd <$> require modulePath
-- Look up addresses in importedEnv and insert the aliases with addresses into the exports.
for_ exportSymbols $ \(name, alias) -> do
let address = Env.lookup name importedEnv
maybe (throwEvalError $ ExportError modulePath name) (addExport name alias . Just) address
maybe (throwEvalError $ ExportError modulePath name) (export name alias . Just) address
pure (Rval unit)
newtype DefaultExport a = DefaultExport { defaultExport :: a }
@ -272,8 +266,8 @@ instance Evaluatable DefaultExport where
Just name -> do
addr <- lookupOrAlloc name
assign addr v
addExport name name Nothing
void $ bind name addr
export name name Nothing
bind name addr
Nothing -> throwEvalError DefaultExportError
pure (Rval unit)

4
src/Semantic/Graph.hs
View File

@ -129,7 +129,7 @@ resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> s
UnallocatedAddress _ -> pure lowerBound
UninitializedAddress _ -> pure hole)
resumingValueError :: (Member (State (Environment address)) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a
resumingValueError :: (Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a
resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of
CallError val -> pure val
StringError val -> pure (pack (show val))
@ -139,7 +139,7 @@ resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err
NumericError{} -> pure hole
Numeric2Error{} -> pure hole
ComparisonError{} -> pure hole
NamespaceError{} -> getEnv
NamespaceError{} -> pure emptyEnv
BitwiseError{} -> pure hole
Bitwise2Error{} -> pure hole
KeyValueError{} -> pure (hole, hole)

2
src/Semantic/IO.hs
View File

@ -96,7 +96,7 @@ readBlobsFromHandle = fmap toBlobs . readFromHandle
readBlobFromPath :: MonadIO m => File -> m Blob.Blob
readBlobFromPath file = do
maybeFile <- readFile file
maybe (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) pure maybeFile
maybeM (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile
readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
readProjectFromPaths maybeRoot path lang excludeDirs = do

12
test/Analysis/Go/Spec.hs
View File

@ -11,16 +11,16 @@ spec :: Spec
spec = parallel $ do
describe "evaluates Go" $ do
it "imports and wildcard imports" $ do
((_, state), _) <- evaluate "main.go"
Env.names (environment state) `shouldBe` [ "Bar", "Rab", "foo", "main" ]
((Right [(_, env)], state), _) <- evaluate "main.go"
Env.names env `shouldBe` [ "Bar", "Rab", "foo", "main" ]
(derefQName (heap state) ("foo" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("foo", ["New"])
(derefQName (heap state) ("foo" :| []) env >>= deNamespace) `shouldBe` Just ("foo", ["New"])
it "imports with aliases (and side effects only)" $ do
((_, state), _) <- evaluate "main1.go"
Env.names (environment state) `shouldBe` [ "f", "main" ]
((Right [(_, env)], state), _) <- evaluate "main1.go"
Env.names env `shouldBe` [ "f", "main" ]
(derefQName (heap state) ("f" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("f", ["New"])
(derefQName (heap state) ("f" :| []) env >>= deNamespace) `shouldBe` Just ("f", ["New"])
where
fixtures = "test/fixtures/go/analysis/"

22
test/Analysis/PHP/Spec.hs
View File

@ -12,22 +12,22 @@ spec :: Spec
spec = parallel $ do
describe "PHP" $ do
it "evaluates include and require" $ do
((res, state), _) <- evaluate "main.php"
res `shouldBe` Right [unit]
Env.names (environment state) `shouldBe` [ "bar", "foo" ]
((Right [(res, env)], state), _) <- evaluate "main.php"
res `shouldBe` unit
Env.names env `shouldBe` [ "bar", "foo" ]
it "evaluates include_once and require_once" $ do
((res, state), _) <- evaluate "main_once.php"
res `shouldBe` Right [unit]
Env.names (environment state) `shouldBe` [ "bar", "foo" ]
((Right [(res, env)], state), _) <- evaluate "main_once.php"
res `shouldBe` unit
Env.names env `shouldBe` [ "bar", "foo" ]
it "evaluates namespaces" $ do
((_, state), _) <- evaluate "namespaces.php"
Env.names (environment state) `shouldBe` [ "Foo", "NS1" ]
((Right [(_, env)], state), _) <- evaluate "namespaces.php"
Env.names env `shouldBe` [ "Foo", "NS1" ]
(derefQName (heap state) ("NS1" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"])
(derefQName (heap state) ("NS1" :| ["Sub1"]) (environment state) >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"])
(derefQName (heap state) ("NS1" :| ["Sub1", "Sub2"]) (environment state) >>= deNamespace) `shouldBe` Just ("Sub2", ["f"])
(derefQName (heap state) ("NS1" :| []) env >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"])
(derefQName (heap state) ("NS1" :| ["Sub1"]) env >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"])
(derefQName (heap state) ("NS1" :| ["Sub1", "Sub2"]) env >>= deNamespace) `shouldBe` Just ("Sub2", ["f"])
where
fixtures = "test/fixtures/php/analysis/"

24
test/Analysis/Python/Spec.hs
View File

@ -14,33 +14,33 @@ spec :: Spec
spec = parallel $ do
describe "evaluates Python" $ do
it "imports" $ do
((_, state), _) <- evaluate "main.py"
Env.names (environment state) `shouldContain` [ "a", "b" ]
((Right [(_, env)], state), _) <- evaluate "main.py"
Env.names env `shouldContain` [ "a", "b" ]
(derefQName (heap state) ("a" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("a", ["foo"])
(derefQName (heap state) ("b" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("b", ["c"])
(derefQName (heap state) ("b" :| ["c"]) (environment state) >>= deNamespace) `shouldBe` Just ("c", ["baz"])
(derefQName (heap state) ("a" :| []) env >>= deNamespace) `shouldBe` Just ("a", ["foo"])
(derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", ["c"])
(derefQName (heap state) ("b" :| ["c"]) env >>= deNamespace) `shouldBe` Just ("c", ["baz"])
it "imports with aliases" $ do
env <- environment . snd . fst <$> evaluate "main1.py"
((Right [(_, env)], _), _) <- evaluate "main1.py"
Env.names env `shouldContain` [ "b", "e" ]
it "imports using 'from' syntax" $ do
env <- environment . snd . fst <$> evaluate "main2.py"
((Right [(_, env)], _), _) <- evaluate "main2.py"
Env.names env `shouldContain` [ "bar", "foo" ]
it "imports with relative syntax" $ do
((_, state), _) <- evaluate "main3.py"
Env.names (environment state) `shouldContain` [ "utils" ]
(derefQName (heap state) ("utils" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("utils", ["to_s"])
((Right [(_, env)], state), _) <- evaluate "main3.py"
Env.names env `shouldContain` [ "utils" ]
(derefQName (heap state) ("utils" :| []) env >>= deNamespace) `shouldBe` Just ("utils", ["to_s"])
it "subclasses" $ do
((res, _), _) <- evaluate "subclass.py"
res `shouldBe` Right [String "\"bar\""]
fmap fst <$> res `shouldBe` Right [String "\"bar\""]
it "handles multiple inheritance left-to-right" $ do
((res, _), _) <- evaluate "multiple_inheritance.py"
res `shouldBe` Right [String "\"foo!\""]
fmap fst <$> res `shouldBe` Right [String "\"foo!\""]
where
ns n = Just . Latest . Last . Just . Namespace n

37
test/Analysis/Ruby/Spec.hs
View File

@ -20,58 +20,57 @@ spec :: Spec
spec = parallel $ do
describe "Ruby" $ do
it "evaluates require_relative" $ do
((res, state), _) <- evaluate "main.rb"
res `shouldBe` Right [Value.Integer (Number.Integer 1)]
Env.names (environment state) `shouldContain` ["foo"]
((Right [(res, env)], state), _) <- evaluate "main.rb"
res `shouldBe` Value.Integer (Number.Integer 1)
Env.names env `shouldContain` ["foo"]
it "evaluates load" $ do
env <- environment . snd . fst <$> evaluate "load.rb"
((Right [(_, env)], _), _) <- evaluate "load.rb"
Env.names env `shouldContain` ["foo"]
it "evaluates load with wrapper" $ do
((res, state), _) <- evaluate "load-wrap.rb"
res `shouldBe` Left (SomeExc (inject @(EnvironmentError Precise) (FreeVariable "foo")))
Env.names (environment state) `shouldContain` [ "Object" ]
it "evaluates subclass" $ do
((res, state), _) <- evaluate "subclass.rb"
res `shouldBe` Right [String "\"<bar>\""]
Env.names (environment state) `shouldContain` [ "Bar", "Foo" ]
((Right [(res, env)], state), _) <- evaluate "subclass.rb"
res `shouldBe` String "\"<bar>\""
Env.names env `shouldContain` [ "Bar", "Foo" ]
(derefQName (heap state) ("Bar" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"])
(derefQName (heap state) ("Bar" :| []) env >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"])
it "evaluates modules" $ do
((res, state), _) <- evaluate "modules.rb"
res `shouldBe` Right [String "\"<hello>\""]
Env.names (environment state) `shouldContain` [ "Bar" ]
((Right [(res, env)], state), _) <- evaluate "modules.rb"
res `shouldBe` String "\"<hello>\""
Env.names env `shouldContain` [ "Bar" ]
it "handles break correctly" $ do
((res, _), _) <- evaluate "break.rb"
res `shouldBe` Right [Value.Integer (Number.Integer 3)]
fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 3)]
it "handles break correctly" $ do
((res, _), _) <- evaluate "next.rb"
res `shouldBe` Right [Value.Integer (Number.Integer 8)]
fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 8)]
it "calls functions with arguments" $ do
((res, _), _) <- evaluate "call.rb"
res `shouldBe` Right [Value.Integer (Number.Integer 579)]
fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 579)]
it "evaluates early return statements" $ do
((res, _), _) <- evaluate "early-return.rb"
res `shouldBe` Right [Value.Integer (Number.Integer 123)]
fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 123)]
it "has prelude" $ do
((res, _), _) <- evaluate "preluded.rb"
res `shouldBe` Right [String "\"<foo>\""]
fmap fst <$> res `shouldBe` Right [String "\"<foo>\""]
it "evaluates __LINE__" $ do
((res, _), _) <- evaluate "line.rb"
res `shouldBe` Right [Value.Integer (Number.Integer 4)]
fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 4)]
it "resolves builtins used in the prelude" $ do
((res, _), traces) <- evaluate "puts.rb"
res `shouldBe` Right [Unit]
fmap fst <$> res `shouldBe` Right [Unit]
traces `shouldContain` [ "\"hello\"" ]
where

16
test/Analysis/TypeScript/Spec.hs
View File

@ -15,19 +15,19 @@ spec :: Spec
spec = parallel $ do
describe "evaluates TypeScript" $ do
it "imports with aliased symbols" $ do
env <- environment . snd . fst <$> evaluate "main.ts"
((Right [(_, env)], _), _) <- evaluate "main.ts"
Env.names env `shouldBe` [ "bar", "quz" ]
it "imports with qualified names" $ do
((_, state), _) <- evaluate "main1.ts"
Env.names (environment state) `shouldBe` [ "b", "z" ]
((Right [(_, env)], state), _) <- evaluate "main1.ts"
Env.names env `shouldBe` [ "b", "z" ]
(derefQName (heap state) ("b" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ])
(derefQName (heap state) ("z" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ])
(derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ])
(derefQName (heap state) ("z" :| []) env >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ])
it "side effect only imports" $ do
env <- environment . snd . fst <$> evaluate "main2.ts"
env `shouldBe` emptyEnv
((res, _), _) <- evaluate "main2.ts"
fmap snd <$> res `shouldBe` Right [emptyEnv]
it "fails exporting symbols not defined in the module" $ do
((res, _), _) <- evaluate "bad-export.ts"
@ -35,7 +35,7 @@ spec = parallel $ do
it "evaluates early return statements" $ do
((res, _), _) <- evaluate "early-return.ts"
res `shouldBe` Right [Value.Float (Number.Decimal 123.0)]
fmap fst <$> res `shouldBe` Right [Value.Float (Number.Decimal 123.0)]
where
fixtures = "test/fixtures/typescript/analysis/"

5
test/Control/Abstract/Evaluator/Spec.hs
View File

@ -20,13 +20,13 @@ spec :: Spec
spec = parallel $ do
it "constructs integers" $ do
(expected, _) <- evaluate (pure (integer 123))
expected `shouldBe` Right (Value.Integer (Number.Integer 123))
fst <$> expected `shouldBe` Right (Value.Integer (Number.Integer 123))
it "calls functions" $ do
(expected, _) <- evaluate $ do
identity <- closure [name "x"] lowerBound (variable (name "x"))
call identity [pure (integer 123)]
expected `shouldBe` Right (Value.Integer (Number.Integer 123))
fst <$> expected `shouldBe` Right (Value.Integer (Number.Integer 123))
evaluate
= runM
@ -38,6 +38,7 @@ evaluate
. runEnvironmentError
. runAddressError
. runAllocator
. runEnv lowerBound
. runReturn
. runLoopControl

1
test/SpecHelpers.hs
View File

@ -34,7 +34,6 @@ import Data.Project as X
import Data.Functor.Listable as X
import Data.Language as X
import Data.List.NonEmpty as X (NonEmpty(..))
import Data.Monoid as X (Last(..))
import Data.Range as X
import Data.Record as X
import Data.Source as X

69
test/fixtures/haskell/corpus/literals.A.hs vendored
View File

@ -35,3 +35,72 @@ aZ' = undefined
a = True
a = False
a = 'a'
a = 'b'
a = '0'
a = '1'
a = '_'
a = 'A'
a = 'B'
a = ','
a = '!'
a = '#'
a = '$'
a = '%'
a = '&'
a = '⋆'
a = '+'
a = '.'
a = '/'
a = '<'
a = '='
a = '>'
a = '?'
a = '^'
a = '|'
a = '-'
a = '~'
a = ':'
a = '"'
a = [ "\NUL"
, "\SOH"
, "\STX"
, "\ETX"
, "\EOT"
, "\ENQ"
, "\ACK"
, "\BEL"
, "\BS"
, "\HT"
, "\LF"
, "\VT"
, "\FF"
, "\CR"
, "\SO"
, "\SI"
, "\DLE"
, "\DC1"
, "\DC2"
, "\DC3"
, "\DC4"
, "\NAK"
, "\SYN"
, "\ETB"
, "\CAN"
, "\EM"
, "\SUB"
, "\ESC"
, "\FS"
, "\GS"
, "\RS"
, "\US"
, "\SP"
, "\DEL"
]

69
test/fixtures/haskell/corpus/literals.B.hs vendored
View File

@ -35,3 +35,72 @@ bZ' = undefined
b = True
b = False
b = 'a'
b = 'b'
b = '0'
b = '1'
b = '_'
b = 'A'
b = 'B'
b = ','
b = '!'
b = '#'
b = '$'
b = '%'
b = '&'
b = '⋆'
b = '+'
b = '.'
b = '/'
b = '<'
b = '='
b = '>'
b = '?'
b = '^'
b = '|'
b = '-'
b = '~'
b = ':'
b = '"'
b = [ "\NUL"
, "\SOH"
, "\STX"
, "\ETX"
, "\EOT"
, "\ENQ"
, "\ACK"
, "\BEL"
, "\BS"
, "\HT"
, "\LF"
, "\VT"
, "\FF"
, "\CR"
, "\SO"
, "\SI"
, "\DLE"
, "\DC1"
, "\DC2"
, "\DC3"
, "\DC4"
, "\NAK"
, "\SYN"
, "\ETB"
, "\CAN"
, "\EM"
, "\SUB"
, "\ESC"
, "\FS"
, "\GS"
, "\RS"
, "\US"
, "\SP"
, "\DEL"
]

307
test/fixtures/haskell/corpus/literals.diffA-B.txt vendored
View File

@ -1,11 +1,10 @@
(Module
(Identifier)
(
(Function
{ (Identifier)
->(Identifier) }
(
(Integer)))
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
@ -118,6 +117,156 @@
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Array
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+})+})+})+}
{-(Function
{-(Identifier)-}
{-(
{-(Integer)-})-})-}
{-(Function
{-(Identifier)-}
{-(
@ -229,4 +378,150 @@
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}))
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Array
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-})-})-})-}))

501
test/fixtures/haskell/corpus/literals.diffB-A.txt vendored
View File

@ -1,113 +1,92 @@
(Module
(Identifier)
(
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
(Function
{ (Identifier)
->(Identifier) }
(
(Integer)))
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
(Function
{ (Identifier)
->(Identifier) }
(
{+(Identifier)+}
{+(Float)+}
{-(Integer)-}))
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
@ -120,6 +99,176 @@
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Character)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Array
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+}
{+(TextElement)+})+})+})+}
{-(Function
{-(Identifier)-}
{-(
{-(Integer)-})-})-}
{-(Function
{-(Identifier)-}
{-(
@ -227,4 +376,150 @@
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}))
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Character)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Array
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-}
{-(TextElement)-})-})-})-}))

148
test/fixtures/haskell/corpus/literals.parseA.txt vendored
View File

@ -116,4 +116,150 @@
(Function
(Identifier)
(
(Identifier)))))
(Identifier)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Array
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement))))))

148
test/fixtures/haskell/corpus/literals.parseB.txt vendored
View File

@ -116,4 +116,150 @@
(Function
(Identifier)
(
(Identifier)))))
(Identifier)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Character)))
(Function
(Identifier)
(
(Array
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement)
(TextElement))))))

8
test/fixtures/haskell/corpus/type-synonyms.A.hs vendored Normal file
View File

@ -0,0 +1,8 @@
type Foo = Bar
type List = []
type Foo a = Bar a
type Rec a = [Circ a]
type V = ()
type X = (,)
type Y = (,,)
type Z = (->)

8
test/fixtures/haskell/corpus/type-synonyms.B.hs vendored Normal file
View File

@ -0,0 +1,8 @@
type Bar = Foo
type List' = []
type Foo a b = Bar a b
type Rec a = [Triangle a]
type X = ()
type Y = (,,)
type Z = (,)
type T = (->)

81
test/fixtures/haskell/corpus/type-synonyms.diffA-B.txt vendored Normal file
View File

@ -0,0 +1,81 @@
(Module
(Empty)
(
(TypeSynonym
(Type
{ (Identifier)
->(Identifier) }
(TypeParameters))
(Type
{ (Identifier)
->(Identifier) }
(TypeParameters)))
(TypeSynonym
(Type
{ (Identifier)
->(Identifier) }
(TypeParameters))
(Type
(ListConstructor)
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters
(Identifier)
{+(Identifier)+}))
(Type
(Identifier)
(TypeParameters
(Identifier)
{+(Identifier)+})))
(TypeSynonym
(Type
(Identifier)
(TypeParameters
(Identifier)))
(Type
(Array
(Type
{ (Identifier)
->(Identifier) }
(TypeParameters
(Identifier))))
(TypeParameters)))
(TypeSynonym
(Type
{ (Identifier)
->(Identifier) }
(TypeParameters))
(Type
(UnitConstructor)
(TypeParameters)))
{-(TypeSynonym
{-(Type
{-(Identifier)-}
{-(TypeParameters)-})-}
{-(Type
{-(TupleConstructor)-}
{-(TypeParameters)-})-})-}
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
(TupleConstructor)
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
{ (FunctionConstructor)
->(TupleConstructor) }
(TypeParameters)))
{+(TypeSynonym
{+(Type
{+(Identifier)+}
{+(TypeParameters)+})+}
{+(Type
{+(FunctionConstructor)+}
{+(TypeParameters)+})+})+}))

81
test/fixtures/haskell/corpus/type-synonyms.diffB-A.txt vendored Normal file
View File

@ -0,0 +1,81 @@
(Module
(Empty)
(
(TypeSynonym
(Type
{ (Identifier)
->(Identifier) }
(TypeParameters))
(Type
{ (Identifier)
->(Identifier) }
(TypeParameters)))
(TypeSynonym
(Type
{ (Identifier)
->(Identifier) }
(TypeParameters))
(Type
(ListConstructor)
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters
(Identifier)
{-(Identifier)-}))
(Type
(Identifier)
(TypeParameters
(Identifier)
{-(Identifier)-})))
(TypeSynonym
(Type
(Identifier)
(TypeParameters
(Identifier)))
(Type
(Array
(Type
{ (Identifier)
->(Identifier) }
(TypeParameters
(Identifier))))
(TypeParameters)))
(TypeSynonym
(Type
{ (Identifier)
->(Identifier) }
(TypeParameters))
(Type
(UnitConstructor)
(TypeParameters)))
{+(TypeSynonym
{+(Type
{+(Identifier)+}
{+(TypeParameters)+})+}
{+(Type
{+(TupleConstructor)+}
{+(TypeParameters)+})+})+}
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
(TupleConstructor)
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
{ (TupleConstructor)
->(FunctionConstructor) }
(TypeParameters)))
{-(TypeSynonym
{-(Type
{-(Identifier)-}
{-(TypeParameters)-})-}
{-(Type
{-(FunctionConstructor)-}
{-(TypeParameters)-})-})-}))

66
test/fixtures/haskell/corpus/type-synonyms.parseA.txt vendored Normal file
View File

@ -0,0 +1,66 @@
(Module
(Empty)
(
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
(Identifier)
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
(ListConstructor)
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters
(Identifier)))
(Type
(Identifier)
(TypeParameters
(Identifier))))
(TypeSynonym
(Type
(Identifier)
(TypeParameters
(Identifier)))
(Type
(Array
(Type
(Identifier)
(TypeParameters
(Identifier))))
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
(UnitConstructor)
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
(TupleConstructor)
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
(TupleConstructor)
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
(FunctionConstructor)
(TypeParameters)))))

68
test/fixtures/haskell/corpus/type-synonyms.parseB.txt vendored Normal file
View File

@ -0,0 +1,68 @@
(Module
(Empty)
(
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
(Identifier)
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
(ListConstructor)
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters
(Identifier)
(Identifier)))
(Type
(Identifier)
(TypeParameters
(Identifier)
(Identifier))))
(TypeSynonym
(Type
(Identifier)
(TypeParameters
(Identifier)))
(Type
(Array
(Type
(Identifier)
(TypeParameters
(Identifier))))
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
(UnitConstructor)
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
(TupleConstructor)
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
(TupleConstructor)
(TypeParameters)))
(TypeSynonym
(Type
(Identifier)
(TypeParameters))
(Type
(FunctionConstructor)
(TypeParameters)))))

45
types.proto Normal file
View File

@ -0,0 +1,45 @@
syntax = "proto3";
package semantic;
enum Language {Go = 0;
Haskell = 1;
JavaScript = 2;
JSON = 3;
JSX = 4;
Markdown = 5;
Python = 6;
Ruby = 7;
TypeScript = 8;
PHP = 9;}
message Blob { bytes blobSource = 1;
string blobPath = 2;
Language blobLanguage = 3;
}
message Pos { int64 posLine = 1;
int64 posColumn = 2;
}
message Span { Pos spanStart = 1;
Pos spanEnd = 2;
}
message Array { repeated Term arrayElements = 1;
}
message Boolean { bool booleanContent = 1;
}
message Hash { repeated Term hashElements = 1;
}
message Float { bytes floatContent = 1;
}
message KeyValue { Term key = 1;
Term value = 2;
}
message Null {
}
message TextElement { bytes textElementContent = 1;
}
message Term { oneof syntax {Array array = 1;
Boolean boolean = 2;
Hash hash = 3;
Float float = 4;
KeyValue keyValue = 5;
Null null = 6;
TextElement textElement = 7;}
}

2
vendor/fastsum vendored

@ -1 +1 @@
Subproject commit 2310af6de3d3c337d671cdf9fe3e007990fdb1e4
Subproject commit dbeff0af57fcea85bca07ff5a8149301dd3b084c

1
vendor/proto3-suite vendored Submodule

@ -0,0 +1 @@
Subproject commit c75b250e82481e23d2ff586b3e841834b5d93ff9

1
vendor/proto3-wire vendored Submodule

@ -0,0 +1 @@
Subproject commit c8792bc33154e849239b1c91ffe06af2e765d734