mirror of
https://github.com/github/semantic.git
synced 2024-12-26 00:12:29 +03:00
Merge remote-tracking branch 'origin/master' into explicit-statements
This commit is contained in:
commit
5408e20ea8
6
.gitmodules
vendored
6
.gitmodules
vendored
@ -16,3 +16,9 @@
|
|||||||
[submodule "vendor/fastsum"]
|
[submodule "vendor/fastsum"]
|
||||||
path = vendor/fastsum
|
path = vendor/fastsum
|
||||||
url = git@github.com:patrickt/fastsum.git
|
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
6
HLint.hs
@ -17,8 +17,8 @@ error "Avoid return" =
|
|||||||
return ==> pure
|
return ==> pure
|
||||||
where note = "return is obsolete as of GHC 7.10"
|
where note = "return is obsolete as of GHC 7.10"
|
||||||
|
|
||||||
error "use extract" = termAnnotation . unTerm ==> extract
|
error "use termAnnotation" = termFAnnotation . unTerm ==> termAnnotation
|
||||||
error "use unwrap" = termOut . unTerm ==> unwrap
|
error "use termOut" = termFOut . unTerm ==> termOut
|
||||||
|
|
||||||
error "avoid head" = head
|
error "avoid head" = head
|
||||||
where note = "head is partial; consider using Data.Maybe.listToMaybe"
|
where note = "head is partial; consider using Data.Maybe.listToMaybe"
|
||||||
@ -31,3 +31,5 @@ error "avoid init" = init
|
|||||||
|
|
||||||
error "avoid last" = last
|
error "avoid last" = last
|
||||||
where note = "last is partial; consider pattern-matching"
|
where note = "last is partial; consider pattern-matching"
|
||||||
|
|
||||||
|
error "use maybeM" = maybe a pure ==> maybeM a
|
||||||
|
@ -40,7 +40,6 @@ library
|
|||||||
, Control.Abstract.Context
|
, Control.Abstract.Context
|
||||||
, Control.Abstract.Environment
|
, Control.Abstract.Environment
|
||||||
, Control.Abstract.Evaluator
|
, Control.Abstract.Evaluator
|
||||||
, Control.Abstract.Exports
|
|
||||||
, Control.Abstract.Heap
|
, Control.Abstract.Heap
|
||||||
, Control.Abstract.Hole
|
, Control.Abstract.Hole
|
||||||
, Control.Abstract.Matching
|
, Control.Abstract.Matching
|
||||||
@ -209,6 +208,8 @@ library
|
|||||||
, text >= 1.2.1.3
|
, text >= 1.2.1.3
|
||||||
, these
|
, these
|
||||||
, time
|
, time
|
||||||
|
, proto3-suite
|
||||||
|
, proto3-wire
|
||||||
, unix
|
, unix
|
||||||
, unordered-containers
|
, unordered-containers
|
||||||
, haskell-tree-sitter
|
, haskell-tree-sitter
|
||||||
|
@ -1,4 +1,5 @@
|
|||||||
syntax = "proto3";
|
syntax = "proto3";
|
||||||
|
import "types.proto";
|
||||||
package semantic;
|
package semantic;
|
||||||
|
|
||||||
message HealthCheckRequest {
|
message HealthCheckRequest {
|
||||||
@ -33,12 +34,6 @@ message BlobPair {
|
|||||||
Blob after = 2;
|
Blob after = 2;
|
||||||
}
|
}
|
||||||
|
|
||||||
message Blob {
|
|
||||||
string source = 1;
|
|
||||||
string path = 2;
|
|
||||||
string language = 3;
|
|
||||||
}
|
|
||||||
|
|
||||||
message SummariesResponse {
|
message SummariesResponse {
|
||||||
repeated Summary changes = 1;
|
repeated Summary changes = 1;
|
||||||
repeated Error errors = 2;
|
repeated Error errors = 2;
|
||||||
@ -61,13 +56,3 @@ message Error {
|
|||||||
Span span = 2;
|
Span span = 2;
|
||||||
string language = 3;
|
string language = 3;
|
||||||
}
|
}
|
||||||
|
|
||||||
message Span {
|
|
||||||
Pos start = 1;
|
|
||||||
Pos end = 2;
|
|
||||||
}
|
|
||||||
|
|
||||||
message Pos {
|
|
||||||
int32 line = 1;
|
|
||||||
int32 column = 2;
|
|
||||||
}
|
|
||||||
|
@ -62,7 +62,7 @@ cachingTerms :: ( Cacheable term address (Cell address) value
|
|||||||
, Member (Reader (Cache term address (Cell address) value)) effects
|
, Member (Reader (Cache term address (Cell address) value)) effects
|
||||||
, Member (Reader (Live address)) effects
|
, Member (Reader (Live address)) effects
|
||||||
, Member (State (Cache term address (Cell address) value)) 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
|
, Member (State (Heap address (Cell address) value)) effects
|
||||||
)
|
)
|
||||||
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef value))
|
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef value))
|
||||||
@ -82,11 +82,10 @@ convergingModules :: ( AbstractValue address value effects
|
|||||||
, Member Fresh effects
|
, Member Fresh effects
|
||||||
, Member NonDet effects
|
, Member NonDet effects
|
||||||
, Member (Reader (Cache term address (Cell address) value)) effects
|
, Member (Reader (Cache term address (Cell address) value)) effects
|
||||||
, Member (Reader (Environment address)) effects
|
|
||||||
, Member (Reader (Live address)) effects
|
, Member (Reader (Live address)) effects
|
||||||
, Member (Resumable (EnvironmentError address)) effects
|
, Member (Resumable (EnvironmentError address)) effects
|
||||||
, Member (State (Cache term address (Cell address) value)) 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
|
, Member (State (Heap address (Cell address) value)) effects
|
||||||
)
|
)
|
||||||
=> SubtermAlgebra Module term (TermEvaluator term address value effects value)
|
=> SubtermAlgebra Module term (TermEvaluator term address value effects value)
|
||||||
@ -94,8 +93,7 @@ convergingModules :: ( AbstractValue address value effects
|
|||||||
convergingModules recur m = do
|
convergingModules recur m = do
|
||||||
c <- getConfiguration (subterm (moduleBody m))
|
c <- getConfiguration (subterm (moduleBody m))
|
||||||
-- Convergence here is predicated upon an Eq instance, not α-equivalence
|
-- Convergence here is predicated upon an Eq instance, not α-equivalence
|
||||||
cache <- converge lowerBound (\ prevCache -> isolateCache $ do
|
cache <- converge lowerBound (\ prevCache -> isolateCache $ raiseHandler locally $ do
|
||||||
TermEvaluator (putEnv (configurationEnvironment c))
|
|
||||||
TermEvaluator (putHeap (configurationHeap c))
|
TermEvaluator (putHeap (configurationHeap c))
|
||||||
-- We need to reset fresh generation so that this invocation converges.
|
-- We need to reset fresh generation so that this invocation converges.
|
||||||
resetFresh 0 $
|
resetFresh 0 $
|
||||||
|
@ -5,15 +5,12 @@ module Analysis.Abstract.Collecting
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Abstract
|
import Control.Abstract
|
||||||
import Data.Abstract.Heap
|
|
||||||
import Data.Abstract.Live
|
|
||||||
import Data.Semilattice.Lower
|
import Data.Semilattice.Lower
|
||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- | An analysis performing GC after every instruction.
|
-- | An analysis performing GC after every instruction.
|
||||||
collectingTerms :: ( Foldable (Cell address)
|
collectingTerms :: ( Member (Reader (Live address)) effects
|
||||||
, Member (Reader (Live address)) effects
|
, Member (Allocator address value) effects
|
||||||
, Member (State (Heap address (Cell address) value)) effects
|
|
||||||
, Ord address
|
, Ord address
|
||||||
, ValueRoots address value
|
, ValueRoots address value
|
||||||
)
|
)
|
||||||
@ -22,32 +19,7 @@ collectingTerms :: ( Foldable (Cell address)
|
|||||||
collectingTerms recur term = do
|
collectingTerms recur term = do
|
||||||
roots <- TermEvaluator askRoots
|
roots <- TermEvaluator askRoots
|
||||||
v <- recur term
|
v <- recur term
|
||||||
v <$ TermEvaluator (modifyHeap (gc (roots <> valueRoots v)))
|
v <$ TermEvaluator (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)
|
|
||||||
|
|
||||||
|
|
||||||
providingLiveSet :: Effectful (m address value) => m address value (Reader (Live address) ': effects) a -> m address value effects a
|
providingLiveSet :: Effectful (m address value) => m address value (Reader (Live address) ': effects) a -> m address value effects a
|
||||||
|
@ -5,14 +5,13 @@ module Analysis.Abstract.Evaluating
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Abstract
|
import Control.Abstract
|
||||||
|
import Control.Monad.Effect.Fail
|
||||||
import Data.Semilattice.Lower
|
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@.
|
-- | 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
|
data EvaluatingState address value = EvaluatingState
|
||||||
{ environment :: Environment address
|
{ heap :: Heap address (Cell address) value
|
||||||
, heap :: Heap address (Cell address) value
|
, modules :: ModuleTable (Maybe (value, Environment address))
|
||||||
, modules :: ModuleTable (Maybe (Environment address, value))
|
|
||||||
, exports :: Exports address
|
|
||||||
}
|
}
|
||||||
|
|
||||||
deriving instance (Eq (Cell address value), Eq address, Eq value) => Eq (EvaluatingState address value)
|
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
|
evaluating :: Evaluator address value
|
||||||
( Fail
|
( Fail
|
||||||
': Fresh
|
': Fresh
|
||||||
': Reader (Environment address)
|
|
||||||
': State (Environment address)
|
|
||||||
': State (Heap address (Cell address) value)
|
': State (Heap address (Cell address) value)
|
||||||
': State (ModuleTable (Maybe (Environment address, value)))
|
': State (ModuleTable (Maybe (value, Environment address)))
|
||||||
': State (Exports address)
|
|
||||||
': effects) result
|
': effects) result
|
||||||
-> Evaluator address value effects (Either String result, EvaluatingState address value)
|
-> Evaluator address value effects (Either String result, EvaluatingState address value)
|
||||||
evaluating
|
evaluating
|
||||||
= fmap (\ ((((result, env), heap), modules), exports) -> (result, EvaluatingState env heap modules exports))
|
= fmap (\ ((result, heap), modules) -> (result, EvaluatingState heap modules))
|
||||||
. runState lowerBound -- State (Exports address)
|
. runState lowerBound -- State (ModuleTable (Maybe (value, Environment address)))
|
||||||
. runState lowerBound -- State (ModuleTable (Maybe (Environment address, value)))
|
|
||||||
. runState lowerBound -- State (Heap address (Cell address) value)
|
. runState lowerBound -- State (Heap address (Cell address) value)
|
||||||
. runState lowerBound -- State (Environment address)
|
|
||||||
. runReader lowerBound -- Reader (Environment address)
|
|
||||||
. runFresh 0
|
. runFresh 0
|
||||||
. runFail
|
. runFail
|
||||||
|
@ -52,9 +52,8 @@ style = (defaultStyle (byteString . vertexName))
|
|||||||
|
|
||||||
-- | Add vertices to the graph for evaluated identifiers.
|
-- | Add vertices to the graph for evaluated identifiers.
|
||||||
graphingTerms :: ( Element Syntax.Identifier syntax
|
graphingTerms :: ( Element Syntax.Identifier syntax
|
||||||
, Member (Reader (Environment (Hole (Located address)))) effects
|
|
||||||
, Member (Reader ModuleInfo) effects
|
, Member (Reader ModuleInfo) effects
|
||||||
, Member (State (Environment (Hole (Located address)))) effects
|
, Member (Env (Hole (Located address))) effects
|
||||||
, Member (State (Graph Vertex)) effects
|
, Member (State (Graph Vertex)) effects
|
||||||
, term ~ Term (Sum syntax) ann
|
, term ~ Term (Sum syntax) ann
|
||||||
)
|
)
|
||||||
@ -121,8 +120,7 @@ moduleInclusion v = do
|
|||||||
appendGraph (vertex (moduleVertex m) `connect` vertex v)
|
appendGraph (vertex (moduleVertex m) `connect` vertex v)
|
||||||
|
|
||||||
-- | Add an edge from the passed variable name to the module it originated within.
|
-- | Add an edge from the passed variable name to the module it originated within.
|
||||||
variableDefinition :: ( Member (Reader (Environment (Hole (Located address)))) effects
|
variableDefinition :: ( Member (Env (Hole (Located address))) effects
|
||||||
, Member (State (Environment (Hole (Located address)))) effects
|
|
||||||
, Member (State (Graph Vertex)) effects
|
, Member (State (Graph Vertex)) effects
|
||||||
)
|
)
|
||||||
=> Name
|
=> Name
|
||||||
|
@ -14,7 +14,7 @@ import Prologue
|
|||||||
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
|
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
|
||||||
tracingTerms :: ( Corecursive term
|
tracingTerms :: ( Corecursive term
|
||||||
, Member (Reader (Live address)) effects
|
, Member (Reader (Live address)) effects
|
||||||
, Member (State (Environment address)) effects
|
, Member (Env address) effects
|
||||||
, Member (State (Heap address (Cell address) value)) effects
|
, Member (State (Heap address (Cell address) value)) effects
|
||||||
, Member (Writer (trace (Configuration term 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))
|
, Reducer (Configuration term address (Cell address) value) (trace (Configuration term address (Cell address) value))
|
||||||
|
@ -5,9 +5,8 @@ module Control.Abstract
|
|||||||
import Control.Abstract.Addressable as X
|
import Control.Abstract.Addressable as X
|
||||||
import Control.Abstract.Configuration as X
|
import Control.Abstract.Configuration as X
|
||||||
import Control.Abstract.Context 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.Evaluator as X
|
||||||
import Control.Abstract.Exports as X
|
|
||||||
import Control.Abstract.Heap as X
|
import Control.Abstract.Heap as X
|
||||||
import Control.Abstract.Hole as X
|
import Control.Abstract.Hole as X
|
||||||
import Control.Abstract.Modules as X
|
import Control.Abstract.Modules as X
|
||||||
|
@ -12,5 +12,5 @@ import Control.Abstract.TermEvaluator
|
|||||||
import Data.Abstract.Configuration
|
import Data.Abstract.Configuration
|
||||||
|
|
||||||
-- | Get the current 'Configuration' with a passed-in term.
|
-- | 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
|
getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEnv <*> TermEvaluator getHeap
|
||||||
|
@ -1,14 +1,17 @@
|
|||||||
{-# LANGUAGE GADTs, RankNTypes, TypeOperators #-}
|
{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-}
|
||||||
module Control.Abstract.Environment
|
module Control.Abstract.Environment
|
||||||
( Environment
|
( Environment
|
||||||
|
, Exports
|
||||||
, getEnv
|
, getEnv
|
||||||
, putEnv
|
, export
|
||||||
, withEnv
|
|
||||||
, withDefaultEnvironment
|
|
||||||
, lookupEnv
|
, lookupEnv
|
||||||
, bind
|
, bind
|
||||||
, bindAll
|
, bindAll
|
||||||
, locally
|
, locally
|
||||||
|
, close
|
||||||
|
-- * Effects
|
||||||
|
, Env(..)
|
||||||
|
, runEnv
|
||||||
, EnvironmentError(..)
|
, EnvironmentError(..)
|
||||||
, freeVariableError
|
, freeVariableError
|
||||||
, runEnvironmentError
|
, runEnvironmentError
|
||||||
@ -16,54 +19,81 @@ module Control.Abstract.Environment
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Abstract.Evaluator
|
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.Abstract.Name
|
||||||
|
import Data.Semilattice.Lower
|
||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- | Retrieve the environment.
|
-- | Retrieve the environment.
|
||||||
getEnv :: Member (State (Environment address)) effects => Evaluator address value effects (Environment address)
|
getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address)
|
||||||
getEnv = get
|
getEnv = send GetEnv
|
||||||
|
|
||||||
-- | Set the environment.
|
-- | Add an export to the global export state.
|
||||||
putEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects ()
|
export :: Member (Env address) effects => Name -> Name -> Maybe address -> Evaluator address value effects ()
|
||||||
putEnv = put
|
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.
|
-- | 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 :: Member (Env address) effects => Name -> Evaluator address value effects (Maybe address)
|
||||||
lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)
|
lookupEnv name = send (Lookup name)
|
||||||
|
|
||||||
-- | Bind a 'Name' to an 'Address' in the current scope.
|
-- | Bind a 'Name' to an address in the current scope.
|
||||||
bind :: Member (State (Environment address)) effects => Name -> address -> Evaluator address value effects ()
|
bind :: Member (Env address) effects => Name -> address -> Evaluator address value effects ()
|
||||||
bind name = modifyEnv . Env.insert name
|
bind name addr = send (Bind name addr)
|
||||||
|
|
||||||
-- | Bind all of the names from an 'Environment' in the current scope.
|
-- | 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 :: Member (Env address) effects => Environment address -> Evaluator address value effects ()
|
||||||
bindAll = foldr ((>>) . uncurry bind) (pure ()) . pairs
|
bindAll = foldr ((>>) . uncurry bind) (pure ()) . Env.pairs
|
||||||
|
|
||||||
-- | Run an action in a new local environment.
|
-- | Run an action in a new local scope.
|
||||||
locally :: Member (State (Environment address)) effects => Evaluator address value effects a -> Evaluator address value effects a
|
locally :: forall address value effects a . Member (Env address) effects => Evaluator address value effects a -> Evaluator address value effects a
|
||||||
locally a = do
|
locally a = do
|
||||||
modifyEnv Env.push
|
send (Push @address)
|
||||||
a' <- a
|
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.
|
-- | Errors involving the environment.
|
||||||
|
@ -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
|
|
@ -1,9 +1,8 @@
|
|||||||
{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||||
module Control.Abstract.Heap
|
module Control.Abstract.Heap
|
||||||
( Heap
|
( Heap
|
||||||
, getHeap
|
, getHeap
|
||||||
, putHeap
|
, putHeap
|
||||||
, modifyHeap
|
|
||||||
, alloc
|
, alloc
|
||||||
, deref
|
, deref
|
||||||
, assign
|
, assign
|
||||||
@ -11,6 +10,8 @@ module Control.Abstract.Heap
|
|||||||
, letrec
|
, letrec
|
||||||
, letrec'
|
, letrec'
|
||||||
, variable
|
, variable
|
||||||
|
-- * Garbage collection
|
||||||
|
, gc
|
||||||
-- * Effects
|
-- * Effects
|
||||||
, Allocator(..)
|
, Allocator(..)
|
||||||
, runAllocator
|
, runAllocator
|
||||||
@ -22,8 +23,9 @@ module Control.Abstract.Heap
|
|||||||
import Control.Abstract.Addressable
|
import Control.Abstract.Addressable
|
||||||
import Control.Abstract.Environment
|
import Control.Abstract.Environment
|
||||||
import Control.Abstract.Evaluator
|
import Control.Abstract.Evaluator
|
||||||
import Control.Monad.Effect.Internal
|
import Control.Abstract.Roots
|
||||||
import Data.Abstract.Heap
|
import Data.Abstract.Heap
|
||||||
|
import Data.Abstract.Live
|
||||||
import Data.Abstract.Name
|
import Data.Abstract.Name
|
||||||
import Data.Semigroup.Reducer
|
import Data.Semigroup.Reducer
|
||||||
import Prologue
|
import Prologue
|
||||||
@ -41,41 +43,33 @@ modifyHeap :: Member (State (Heap address (Cell address) value)) effects => (Hea
|
|||||||
modifyHeap = modify'
|
modifyHeap = modify'
|
||||||
|
|
||||||
|
|
||||||
alloc :: forall address value effects . Member (Allocator address value) effects => Name -> Evaluator address value effects address
|
alloc :: Member (Allocator address value) effects => Name -> Evaluator address value effects address
|
||||||
alloc = send . Alloc @address @value
|
alloc = sendAllocator . Alloc
|
||||||
|
|
||||||
-- | Dereference the given address in the heap, or fail if the address is uninitialized.
|
-- | 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 :: Member (Allocator address value) effects => address -> Evaluator address value effects value
|
||||||
deref = send . Deref
|
deref = send . Deref
|
||||||
|
|
||||||
|
|
||||||
-- | Write a value to the given address in the 'Store'.
|
-- | Write a value to the given address in the 'Allocator'.
|
||||||
assign :: ( Member (State (Heap address (Cell address) value)) effects
|
assign :: Member (Allocator address value) effects
|
||||||
, Ord address
|
|
||||||
, Reducer value (Cell address value)
|
|
||||||
)
|
|
||||||
=> address
|
=> address
|
||||||
-> value
|
-> value
|
||||||
-> Evaluator address value effects ()
|
-> Evaluator address value effects ()
|
||||||
assign address = modifyHeap . heapInsert address
|
assign address = send . Assign address
|
||||||
|
|
||||||
|
|
||||||
-- | Look up or allocate an address for a 'Name'.
|
-- | Look up or allocate an address for a 'Name'.
|
||||||
lookupOrAlloc :: ( Member (Allocator address value) effects
|
lookupOrAlloc :: ( Member (Allocator address value) effects
|
||||||
, Member (Reader (Environment address)) effects
|
, Member (Env address) effects
|
||||||
, Member (State (Environment address)) effects
|
|
||||||
)
|
)
|
||||||
=> Name
|
=> Name
|
||||||
-> Evaluator address value effects address
|
-> 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
|
letrec :: ( Member (Allocator address value) effects
|
||||||
, Member (Reader (Environment address)) effects
|
, Member (Env address) effects
|
||||||
, Member (State (Environment address)) effects
|
|
||||||
, Member (State (Heap address (Cell address) value)) effects
|
|
||||||
, Ord address
|
|
||||||
, Reducer value (Cell address value)
|
|
||||||
)
|
)
|
||||||
=> Name
|
=> Name
|
||||||
-> Evaluator address value effects value
|
-> 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.
|
-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
|
||||||
letrec' :: ( Member (Allocator address value) effects
|
letrec' :: ( Member (Allocator address value) effects
|
||||||
, Member (Reader (Environment address)) effects
|
, Member (Env address) effects
|
||||||
, Member (State (Environment address)) effects
|
|
||||||
)
|
)
|
||||||
=> Name
|
=> Name
|
||||||
-> (address -> Evaluator address value effects value)
|
-> (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.
|
-- | Look up and dereference the given 'Name', throwing an exception for free variables.
|
||||||
variable :: ( Member (Allocator address value) effects
|
variable :: ( Member (Allocator address value) effects
|
||||||
, Member (Reader (Environment address)) effects
|
, Member (Env address) effects
|
||||||
, Member (Resumable (EnvironmentError address)) effects
|
, Member (Resumable (EnvironmentError address)) effects
|
||||||
, Member (State (Environment address)) effects
|
|
||||||
)
|
)
|
||||||
=> Name
|
=> Name
|
||||||
-> Evaluator address value effects value
|
-> Evaluator address value effects value
|
||||||
variable name = lookupEnv name >>= maybeM (freeVariableError name) >>= deref
|
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
|
-- Effects
|
||||||
|
|
||||||
|
sendAllocator :: Member (Allocator address value) effects => Allocator address value return -> Evaluator address value effects return
|
||||||
|
sendAllocator = send
|
||||||
|
|
||||||
data Allocator address value return where
|
data Allocator address value return where
|
||||||
Alloc :: Name -> Allocator address value address
|
Alloc :: Name -> Allocator address value address
|
||||||
Deref :: address -> Allocator address value value
|
Deref :: address -> Allocator address value value
|
||||||
|
Assign :: address -> value -> Allocator address value ()
|
||||||
|
GC :: Live address -> Allocator address value ()
|
||||||
|
|
||||||
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 :: ( Addressable address effects
|
||||||
runAllocator = raiseHandler (interpret (\ eff -> case eff of
|
, Foldable (Cell address)
|
||||||
Alloc name -> lowerEff $ allocCell name
|
, Member (Resumable (AddressError address value)) effects
|
||||||
Deref addr -> lowerEff $ heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr))))
|
, 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
|
data AddressError address value resume where
|
||||||
|
@ -26,7 +26,7 @@ import Data.Language
|
|||||||
import Prologue
|
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.
|
-- | 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
|
lookupModule = send . Lookup
|
||||||
|
|
||||||
-- | Resolve a list of module paths to a possible module table entry.
|
-- | 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.
|
-- | 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.
|
-- 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)
|
require path = lookupModule path >>= maybeM (load path)
|
||||||
|
|
||||||
-- | Load another module by name and return its environment and value.
|
-- | Load another module by name and return its environment and value.
|
||||||
--
|
--
|
||||||
-- Always loads/evaluates.
|
-- Always loads/evaluates.
|
||||||
load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value))
|
load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (value, Environment address))
|
||||||
load = send . Load
|
load path = send (Load path)
|
||||||
|
|
||||||
|
|
||||||
data Modules address value return where
|
data Modules address value return where
|
||||||
Load :: ModulePath -> Modules address value (Maybe (Environment address, value))
|
Load :: ModulePath -> Modules address value (Maybe (value, Environment address))
|
||||||
Lookup :: ModulePath -> Modules address value (Maybe (Maybe (Environment address, value)))
|
Lookup :: ModulePath -> Modules address value (Maybe (Maybe (value, Environment address)))
|
||||||
Resolve :: [FilePath] -> Modules address value (Maybe ModulePath)
|
Resolve :: [FilePath] -> Modules address value (Maybe ModulePath)
|
||||||
List :: FilePath -> Modules address value [ModulePath]
|
List :: FilePath -> Modules address value [ModulePath]
|
||||||
|
|
||||||
@ -61,10 +61,10 @@ sendModules = send
|
|||||||
|
|
||||||
runModules :: forall term address value effects a
|
runModules :: forall term address value effects a
|
||||||
. ( Member (Resumable (LoadError address value)) effects
|
. ( 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
|
, 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 (Modules address value ': effects) a
|
||||||
-> Evaluator address value (Reader (ModuleTable [Module term]) ': effects) a
|
-> Evaluator address value (Reader (ModuleTable [Module term]) ': effects) a
|
||||||
runModules evaluateModule = go
|
runModules evaluateModule = go
|
||||||
@ -89,22 +89,22 @@ runModules evaluateModule = go
|
|||||||
pure (find isMember names)
|
pure (find isMember names)
|
||||||
List dir -> modulePathsInDir dir <$> askModuleTable @term)
|
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
|
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
|
cacheModule path result = modify' (ModuleTable.insert path result) $> result
|
||||||
|
|
||||||
askModuleTable :: Member (Reader (ModuleTable [Module term])) effects => Evaluator address value effects (ModuleTable [Module term])
|
askModuleTable :: Member (Reader (ModuleTable [Module term])) effects => Evaluator address value effects (ModuleTable [Module term])
|
||||||
askModuleTable = ask
|
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
|
instance Applicative m => Semigroup (Merging m address value) where
|
||||||
Merging a <> Merging b = Merging (merge <$> a <*> b)
|
Merging a <> Merging b = Merging (merge <$> a <*> b)
|
||||||
where merge a b = mergeJusts <$> a <*> b <|> 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
|
instance Applicative m => Monoid (Merging m address value) where
|
||||||
mappend = (<>)
|
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.
|
-- | 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
|
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 Eq (LoadError address value resume)
|
||||||
deriving instance Show (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
|
instance Eq1 (LoadError address value) where
|
||||||
liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b
|
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
|
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
|
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
|
||||||
|
@ -1,6 +1,5 @@
|
|||||||
module Control.Abstract.Primitive where
|
module Control.Abstract.Primitive where
|
||||||
|
|
||||||
import Control.Abstract.Addressable
|
|
||||||
import Control.Abstract.Context
|
import Control.Abstract.Context
|
||||||
import Control.Abstract.Environment
|
import Control.Abstract.Environment
|
||||||
import Control.Abstract.Evaluator
|
import Control.Abstract.Evaluator
|
||||||
@ -8,18 +7,14 @@ import Control.Abstract.Heap
|
|||||||
import Control.Abstract.Value
|
import Control.Abstract.Value
|
||||||
import Data.Abstract.Name
|
import Data.Abstract.Name
|
||||||
import Data.ByteString.Char8 (pack, unpack)
|
import Data.ByteString.Char8 (pack, unpack)
|
||||||
import Data.Semigroup.Reducer hiding (unit)
|
|
||||||
import Data.Semilattice.Lower
|
import Data.Semilattice.Lower
|
||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
builtin :: ( HasCallStack
|
builtin :: ( HasCallStack
|
||||||
, Member (Allocator address value) effects
|
, Member (Allocator address value) effects
|
||||||
|
, Member (Env address) effects
|
||||||
, Member (Reader ModuleInfo) effects
|
, Member (Reader ModuleInfo) effects
|
||||||
, Member (Reader Span) 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
|
=> String
|
||||||
-> Evaluator address value effects value
|
-> Evaluator address value effects value
|
||||||
@ -40,16 +35,12 @@ lambda body = do
|
|||||||
defineBuiltins :: ( AbstractValue address value effects
|
defineBuiltins :: ( AbstractValue address value effects
|
||||||
, HasCallStack
|
, HasCallStack
|
||||||
, Member (Allocator address value) effects
|
, Member (Allocator address value) effects
|
||||||
|
, Member (Env address) effects
|
||||||
, Member Fresh effects
|
, Member Fresh effects
|
||||||
, Member (Reader (Environment address)) effects
|
|
||||||
, Member (Reader ModuleInfo) effects
|
, Member (Reader ModuleInfo) effects
|
||||||
, Member (Reader Span) effects
|
, Member (Reader Span) effects
|
||||||
, Member (Resumable (EnvironmentError address)) effects
|
, Member (Resumable (EnvironmentError address)) effects
|
||||||
, Member (State (Environment address)) effects
|
|
||||||
, Member (State (Heap address (Cell address) value)) effects
|
|
||||||
, Member Trace effects
|
, Member Trace effects
|
||||||
, Ord address
|
|
||||||
, Reducer value (Cell address value)
|
|
||||||
)
|
)
|
||||||
=> Evaluator address value effects ()
|
=> Evaluator address value effects ()
|
||||||
defineBuiltins =
|
defineBuiltins =
|
||||||
|
@ -1,5 +1,6 @@
|
|||||||
module Control.Abstract.Roots
|
module Control.Abstract.Roots
|
||||||
( Live
|
( ValueRoots(..)
|
||||||
|
, Live
|
||||||
, askRoots
|
, askRoots
|
||||||
, extraRoots
|
, extraRoots
|
||||||
) where
|
) where
|
||||||
@ -8,6 +9,13 @@ import Control.Abstract.Evaluator
|
|||||||
import Data.Abstract.Live
|
import Data.Abstract.Live
|
||||||
import Prologue
|
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.
|
-- | Retrieve the local 'Live' set.
|
||||||
askRoots :: Member (Reader (Live address)) effects => Evaluator address value effects (Live address)
|
askRoots :: Member (Reader (Live address)) effects => Evaluator address value effects (Live address)
|
||||||
askRoots = ask
|
askRoots = ask
|
||||||
|
@ -7,7 +7,6 @@ module Control.Abstract.TermEvaluator
|
|||||||
|
|
||||||
import Control.Abstract.Evaluator
|
import Control.Abstract.Evaluator
|
||||||
import Control.Monad.Effect as X
|
import Control.Monad.Effect as X
|
||||||
import Control.Monad.Effect.Fail as X
|
|
||||||
import Control.Monad.Effect.Fresh as X
|
import Control.Monad.Effect.Fresh as X
|
||||||
import Control.Monad.Effect.NonDet as X
|
import Control.Monad.Effect.NonDet as X
|
||||||
import Control.Monad.Effect.Reader as X
|
import Control.Monad.Effect.Reader as X
|
||||||
|
@ -12,20 +12,16 @@ module Control.Abstract.Value
|
|||||||
, evaluateInScopedEnv
|
, evaluateInScopedEnv
|
||||||
, value
|
, value
|
||||||
, subtermValue
|
, subtermValue
|
||||||
, ValueRoots(..)
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Abstract.Addressable
|
|
||||||
import Control.Abstract.Environment
|
import Control.Abstract.Environment
|
||||||
import Control.Abstract.Evaluator
|
import Control.Abstract.Evaluator
|
||||||
import Control.Abstract.Heap
|
import Control.Abstract.Heap
|
||||||
import Data.Abstract.Environment as Env
|
import Data.Abstract.Environment as Env
|
||||||
import Data.Abstract.Live (Live)
|
|
||||||
import Data.Abstract.Name
|
import Data.Abstract.Name
|
||||||
import Data.Abstract.Number as Number
|
import Data.Abstract.Number as Number
|
||||||
import Data.Abstract.Ref
|
import Data.Abstract.Ref
|
||||||
import Data.Scientific (Scientific)
|
import Data.Scientific (Scientific)
|
||||||
import Data.Semigroup.Reducer hiding (unit)
|
|
||||||
import Data.Semilattice.Lower
|
import Data.Semilattice.Lower
|
||||||
import Prelude
|
import Prelude
|
||||||
import Prologue hiding (TypeError)
|
import Prologue hiding (TypeError)
|
||||||
@ -158,7 +154,7 @@ asBool value = ifthenelse value (pure True) (pure False)
|
|||||||
|
|
||||||
-- | C-style for loops.
|
-- | C-style for loops.
|
||||||
forLoop :: ( AbstractValue address value effects
|
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 -- ^ Initial statement
|
||||||
-> Evaluator address value effects value -- ^ Condition
|
-> Evaluator address value effects value -- ^ Condition
|
||||||
@ -187,10 +183,8 @@ doWhile body cond = loop $ \ continue -> body *> do
|
|||||||
ifthenelse this continue (pure unit)
|
ifthenelse this continue (pure unit)
|
||||||
|
|
||||||
makeNamespace :: ( AbstractValue address value effects
|
makeNamespace :: ( AbstractValue address value effects
|
||||||
, Member (State (Environment address)) effects
|
, Member (Env address) effects
|
||||||
, Member (State (Heap address (Cell address) value)) effects
|
, Member (Allocator address value) effects
|
||||||
, Ord address
|
|
||||||
, Reducer value (Cell address value)
|
|
||||||
)
|
)
|
||||||
=> Name
|
=> Name
|
||||||
-> address
|
-> address
|
||||||
@ -206,7 +200,7 @@ makeNamespace name addr super = do
|
|||||||
|
|
||||||
-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
|
-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
|
||||||
evaluateInScopedEnv :: ( AbstractValue address value effects
|
evaluateInScopedEnv :: ( AbstractValue address value effects
|
||||||
, Member (State (Environment address)) effects
|
, Member (Env address) effects
|
||||||
)
|
)
|
||||||
=> Evaluator address value effects value
|
=> Evaluator address value effects value
|
||||||
-> 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
|
-- | Evaluates a 'Value' returning the referenced value
|
||||||
value :: ( AbstractValue address value effects
|
value :: ( AbstractValue address value effects
|
||||||
, Member (Allocator address value) effects
|
, Member (Allocator address value) effects
|
||||||
, Member (Reader (Environment address)) effects
|
, Member (Env address) effects
|
||||||
, Member (Resumable (EnvironmentError address)) effects
|
, Member (Resumable (EnvironmentError address)) effects
|
||||||
, Member (State (Environment address)) effects
|
|
||||||
)
|
)
|
||||||
=> ValueRef value
|
=> ValueRef value
|
||||||
-> Evaluator address value effects value
|
-> Evaluator address value effects value
|
||||||
@ -232,16 +225,9 @@ value (Rval val) = pure val
|
|||||||
-- | Evaluates a 'Subterm' to its rval
|
-- | Evaluates a 'Subterm' to its rval
|
||||||
subtermValue :: ( AbstractValue address value effects
|
subtermValue :: ( AbstractValue address value effects
|
||||||
, Member (Allocator address value) effects
|
, Member (Allocator address value) effects
|
||||||
, Member (Reader (Environment address)) effects
|
, Member (Env address) effects
|
||||||
, Member (Resumable (EnvironmentError address)) effects
|
, Member (Resumable (EnvironmentError address)) effects
|
||||||
, Member (State (Environment address)) effects
|
|
||||||
)
|
)
|
||||||
=> Subterm term (Evaluator address value effects (ValueRef value))
|
=> Subterm term (Evaluator address value effects (ValueRef value))
|
||||||
-> Evaluator address value effects value
|
-> Evaluator address value effects value
|
||||||
subtermValue = value <=< subtermRef
|
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
|
|
||||||
|
@ -1,7 +1,6 @@
|
|||||||
module Data.Abstract.Environment
|
module Data.Abstract.Environment
|
||||||
( Environment(..)
|
( Environment(..)
|
||||||
, addresses
|
, addresses
|
||||||
, intersect
|
|
||||||
, delete
|
, delete
|
||||||
, head
|
, head
|
||||||
, emptyEnv
|
, emptyEnv
|
||||||
@ -10,6 +9,7 @@ module Data.Abstract.Environment
|
|||||||
, insert
|
, insert
|
||||||
, lookup
|
, lookup
|
||||||
, names
|
, names
|
||||||
|
, intersect
|
||||||
, overwrite
|
, overwrite
|
||||||
, pairs
|
, pairs
|
||||||
, unpairs
|
, unpairs
|
||||||
|
@ -3,7 +3,6 @@ module Data.Abstract.Evaluatable
|
|||||||
( module X
|
( module X
|
||||||
, Evaluatable(..)
|
, Evaluatable(..)
|
||||||
, evaluatePackageWith
|
, evaluatePackageWith
|
||||||
, isolate
|
|
||||||
, traceResolve
|
, traceResolve
|
||||||
-- | Effects
|
-- | Effects
|
||||||
, EvalError(..)
|
, EvalError(..)
|
||||||
@ -20,13 +19,11 @@ import Control.Abstract
|
|||||||
import Control.Abstract.Context as X
|
import Control.Abstract.Context as X
|
||||||
import Control.Abstract.Environment as X hiding (runEnvironmentError, runEnvironmentErrorWith)
|
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.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.Heap as X hiding (AddressError(..), runAddressError, runAddressErrorWith)
|
||||||
import Control.Abstract.Modules as X (Modules, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve)
|
import Control.Abstract.Modules as X (Modules, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve)
|
||||||
import Control.Abstract.Value as X
|
import Control.Abstract.Value as X
|
||||||
import Data.Abstract.Declarations as X
|
import Data.Abstract.Declarations as X
|
||||||
import Data.Abstract.Environment as X
|
import Data.Abstract.Environment as X
|
||||||
import Data.Abstract.Exports as Exports
|
|
||||||
import Data.Abstract.FreeVariables as X
|
import Data.Abstract.FreeVariables as X
|
||||||
import Data.Abstract.Module
|
import Data.Abstract.Module
|
||||||
import Data.Abstract.ModuleTable as ModuleTable
|
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.
|
-- | 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
|
class Evaluatable constr where
|
||||||
eval :: ( EvaluatableConstraints address term value effects
|
eval :: ( EvaluatableConstraints term address value effects
|
||||||
, Member Fail effects
|
, Member Fail effects
|
||||||
)
|
)
|
||||||
=> SubtermAlgebra constr term (Evaluator address value effects (ValueRef value))
|
=> 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))
|
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 ""))
|
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
|
( AbstractValue address value effects
|
||||||
, Declarations term
|
, Declarations term
|
||||||
, FreeVariables term
|
, FreeVariables term
|
||||||
, Member (Allocator address value) effects
|
, Member (Allocator address value) effects
|
||||||
|
, Member (Env address) effects
|
||||||
, Member (LoopControl value) effects
|
, Member (LoopControl value) effects
|
||||||
, Member (Modules address value) effects
|
, Member (Modules address value) effects
|
||||||
, Member (Reader (Environment address)) effects
|
|
||||||
, Member (Reader ModuleInfo) effects
|
, Member (Reader ModuleInfo) effects
|
||||||
, Member (Reader PackageInfo) effects
|
, Member (Reader PackageInfo) effects
|
||||||
, Member (Reader Span) effects
|
, Member (Reader Span) effects
|
||||||
@ -67,85 +64,73 @@ type EvaluatableConstraints address term value effects =
|
|||||||
, Member (Resumable ResolutionError) effects
|
, Member (Resumable ResolutionError) effects
|
||||||
, Member (Resumable (Unspecialized value)) effects
|
, Member (Resumable (Unspecialized value)) effects
|
||||||
, Member (Return 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
|
, Member Trace effects
|
||||||
, Ord address
|
|
||||||
, Reducer value (Cell address value)
|
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
-- | Evaluate a given package.
|
-- | Evaluate a given package.
|
||||||
evaluatePackageWith :: forall address term value inner 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' addresses require knowledge of 'currentModule' to run. Can we fix that? If not, can we factor this effect list out?
|
-- 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 (Reader ModuleInfo ': Modules address value ': Reader Span ': Reader PackageInfo ': outer)
|
. ( Addressable address inner'
|
||||||
, Evaluatable (Base term)
|
, Evaluatable (Base term)
|
||||||
, EvaluatableConstraints address term value inner
|
, EvaluatableConstraints term address value inner
|
||||||
|
, Foldable (Cell address)
|
||||||
, Member Fail outer
|
, Member Fail outer
|
||||||
, Member Fresh outer
|
, Member Fresh outer
|
||||||
, Member (Reader (Environment address)) outer
|
|
||||||
, Member (Resumable (AddressError address value)) outer
|
, Member (Resumable (AddressError address value)) outer
|
||||||
, Member (Resumable (LoadError 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 (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
|
, Member Trace outer
|
||||||
, Recursive term
|
, 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 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)))
|
-> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value)))
|
||||||
-> Package term
|
-> Package term
|
||||||
-> TermEvaluator term address value outer [value]
|
-> TermEvaluator term address value outer [(value, Environment address)]
|
||||||
evaluatePackageWith analyzeModule analyzeTerm package
|
evaluatePackageWith analyzeModule analyzeTerm package
|
||||||
= runReader (packageInfo package)
|
= runReader (packageInfo package)
|
||||||
. runReader lowerBound
|
. runReader lowerBound
|
||||||
. runReader (packageModules (packageBody package))
|
. runReader (packageModules (packageBody package))
|
||||||
. withPrelude (packagePrelude (packageBody package))
|
. withPrelude (packagePrelude (packageBody package))
|
||||||
. raiseHandler (runModules (runTermEvaluator . evalModule))
|
$ \ preludeEnv
|
||||||
$ traverse (uncurry evaluateEntryPoint) (ModuleTable.toPairs (packageEntryPoints (packageBody package)))
|
-> raiseHandler (runModules (runTermEvaluator . evalModule preludeEnv))
|
||||||
|
. traverse (uncurry (evaluateEntryPoint preludeEnv))
|
||||||
|
$ ModuleTable.toPairs (packageEntryPoints (packageBody package))
|
||||||
where
|
where
|
||||||
evalModule m
|
evalModule preludeEnv m
|
||||||
= pairValueWithEnv
|
= runInModule preludeEnv (moduleInfo m)
|
||||||
. runInModule (moduleInfo m)
|
|
||||||
. analyzeModule (subtermRef . moduleBody)
|
. analyzeModule (subtermRef . moduleBody)
|
||||||
$ evalTerm <$> m
|
$ evalTerm <$> m
|
||||||
evalTerm term = Subterm term (TermEvaluator (value =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term)))
|
evalTerm term = Subterm term (TermEvaluator (value =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term)))
|
||||||
|
|
||||||
runInModule info
|
runInModule preludeEnv info
|
||||||
= runReader info
|
= runReader info
|
||||||
. raiseHandler runAllocator
|
. raiseHandler runAllocator
|
||||||
|
. raiseHandler (runEnv preludeEnv)
|
||||||
. raiseHandler runReturn
|
. raiseHandler runReturn
|
||||||
. raiseHandler runLoopControl
|
. raiseHandler runLoopControl
|
||||||
|
|
||||||
evaluateEntryPoint :: ModulePath -> Maybe Name -> TermEvaluator term address value (Modules address value ': Reader Span ': Reader PackageInfo ': outer) value
|
evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' (value, Environment address)
|
||||||
evaluateEntryPoint m sym = runInModule (ModuleInfo m) . TermEvaluator $ do
|
evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do
|
||||||
v <- maybe unit snd <$> require m
|
(value, env) <- fromMaybe (unit, emptyEnv) <$> require m
|
||||||
maybe (pure v) ((`call` []) <=< variable) sym
|
bindAll env
|
||||||
|
maybe (pure value) ((`call` []) <=< variable) sym
|
||||||
|
|
||||||
evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule)) $ do
|
evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule emptyEnv)) $ do
|
||||||
_ <- runInModule moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit))
|
(_, builtinsEnv) <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit))
|
||||||
fst <$> evalModule prelude
|
second (mergeEnvs builtinsEnv) <$> evalModule builtinsEnv prelude
|
||||||
|
|
||||||
withPrelude Nothing a = a
|
withPrelude Nothing f = f emptyEnv
|
||||||
withPrelude (Just prelude) a = do
|
withPrelude (Just prelude) f = do
|
||||||
preludeEnv <- evalPrelude prelude
|
(_, preludeEnv) <- evalPrelude prelude
|
||||||
raiseHandler (withDefaultEnvironment preludeEnv) a
|
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 :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects ()
|
||||||
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
|
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
|
||||||
|
@ -36,6 +36,10 @@ liveMember addr = Set.member addr . unLive
|
|||||||
liveSplit :: Live address -> Maybe (address, Live address)
|
liveSplit :: Live address -> Maybe (address, Live address)
|
||||||
liveSplit = fmap (fmap Live) . Set.minView . unLive
|
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
|
instance Show address => Show (Live address) where
|
||||||
showsPrec d = showsUnaryWith showsPrec "Live" d . Set.toList . unLive
|
showsPrec d = showsUnaryWith showsPrec "Live" d . Set.toList . unLive
|
||||||
|
@ -12,3 +12,6 @@ data ValueRef value where
|
|||||||
-- | An object member.
|
-- | An object member.
|
||||||
LvalMember :: value -> Name -> ValueRef value
|
LvalMember :: value -> Name -> ValueRef value
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
|
||||||
|
newtype Ref address value = Ref address
|
||||||
|
@ -10,7 +10,6 @@ module Data.Abstract.Type
|
|||||||
import Control.Abstract
|
import Control.Abstract
|
||||||
import Data.Abstract.Environment as Env
|
import Data.Abstract.Environment as Env
|
||||||
import Data.Semigroup.Foldable (foldMap1)
|
import Data.Semigroup.Foldable (foldMap1)
|
||||||
import Data.Semigroup.Reducer (Reducer)
|
|
||||||
import Prologue hiding (TypeError)
|
import Prologue hiding (TypeError)
|
||||||
|
|
||||||
type TName = Int
|
type TName = Int
|
||||||
@ -117,21 +116,18 @@ instance AbstractIntro Type where
|
|||||||
|
|
||||||
|
|
||||||
instance ( Member (Allocator address Type) effects
|
instance ( Member (Allocator address Type) effects
|
||||||
|
, Member (Env address) effects
|
||||||
, Member Fresh effects
|
, Member Fresh effects
|
||||||
, Member (Resumable TypeError) effects
|
, Member (Resumable TypeError) effects
|
||||||
, Member (Return Type) 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
|
=> AbstractFunction address Type effects where
|
||||||
closure names _ body = do
|
closure names _ body = do
|
||||||
(env, tvars) <- foldr (\ name rest -> do
|
(env, tvars) <- foldr (\ name rest -> do
|
||||||
a <- alloc name
|
addr <- alloc name
|
||||||
tvar <- Var <$> fresh
|
tvar <- Var <$> fresh
|
||||||
assign a tvar
|
assign addr tvar
|
||||||
bimap (Env.insert name a) (tvar :) <$> rest) (pure (emptyEnv, [])) names
|
bimap (Env.insert name addr) (tvar :) <$> rest) (pure (emptyEnv, [])) names
|
||||||
(zeroOrMoreProduct tvars :->) <$> locally (bindAll env *> body `catchReturn` \ (Return value) -> pure value)
|
(zeroOrMoreProduct tvars :->) <$> locally (bindAll env *> body `catchReturn` \ (Return value) -> pure value)
|
||||||
|
|
||||||
call op params = do
|
call op params = do
|
||||||
@ -146,14 +142,11 @@ instance ( Member (Allocator address Type) effects
|
|||||||
|
|
||||||
-- | Discard the value arguments (if any), constructing a 'Type' instead.
|
-- | Discard the value arguments (if any), constructing a 'Type' instead.
|
||||||
instance ( Member (Allocator address Type) effects
|
instance ( Member (Allocator address Type) effects
|
||||||
|
, Member (Env address) effects
|
||||||
, Member Fresh effects
|
, Member Fresh effects
|
||||||
, Member NonDet effects
|
, Member NonDet effects
|
||||||
, Member (Resumable TypeError) effects
|
, Member (Resumable TypeError) effects
|
||||||
, Member (Return Type) 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
|
=> AbstractValue address Type effects where
|
||||||
array fields = do
|
array fields = do
|
||||||
|
@ -10,7 +10,6 @@ import Data.Coerce
|
|||||||
import Data.List (genericIndex, genericLength)
|
import Data.List (genericIndex, genericLength)
|
||||||
import Data.Scientific (Scientific)
|
import Data.Scientific (Scientific)
|
||||||
import Data.Scientific.Exts
|
import Data.Scientific.Exts
|
||||||
import Data.Semigroup.Reducer
|
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
@ -42,7 +41,7 @@ instance Ord (ClosureBody address body) where
|
|||||||
compare = compare `on` closureBodyId
|
compare = compare `on` closureBodyId
|
||||||
|
|
||||||
instance Show (ClosureBody address body) where
|
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
|
instance Ord address => ValueRoots address (Value address body) where
|
||||||
@ -56,15 +55,12 @@ instance AbstractHole (Value address body) where
|
|||||||
|
|
||||||
instance ( Coercible body (Eff effects)
|
instance ( Coercible body (Eff effects)
|
||||||
, Member (Allocator address (Value address body)) effects
|
, Member (Allocator address (Value address body)) effects
|
||||||
|
, Member (Env address) effects
|
||||||
, Member Fresh effects
|
, Member Fresh effects
|
||||||
, Member (Reader ModuleInfo) effects
|
, Member (Reader ModuleInfo) effects
|
||||||
, Member (Reader PackageInfo) effects
|
, Member (Reader PackageInfo) effects
|
||||||
, Member (Resumable (ValueError address body)) effects
|
, Member (Resumable (ValueError address body)) effects
|
||||||
, Member (Return (Value 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
|
, Show address
|
||||||
)
|
)
|
||||||
=> AbstractFunction address (Value address body) effects where
|
=> AbstractFunction address (Value address body) effects where
|
||||||
@ -72,7 +68,7 @@ instance ( Coercible body (Eff effects)
|
|||||||
packageInfo <- currentPackage
|
packageInfo <- currentPackage
|
||||||
moduleInfo <- currentModule
|
moduleInfo <- currentModule
|
||||||
i <- fresh
|
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
|
call op params = do
|
||||||
case op of
|
case op of
|
||||||
@ -81,10 +77,10 @@ instance ( Coercible body (Eff effects)
|
|||||||
-- charge them to the closure's origin.
|
-- charge them to the closure's origin.
|
||||||
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
|
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
|
||||||
bindings <- foldr (\ (name, param) rest -> do
|
bindings <- foldr (\ (name, param) rest -> do
|
||||||
v <- param
|
value <- param
|
||||||
a <- alloc name
|
addr <- alloc name
|
||||||
assign a v
|
assign addr value
|
||||||
Env.insert name a <$> rest) (pure env) (zip names params)
|
Env.insert name addr <$> rest) (pure env) (zip names params)
|
||||||
locally (bindAll bindings *> raiseEff (coerce body) `catchReturn` \ (Return value) -> pure value)
|
locally (bindAll bindings *> raiseEff (coerce body) `catchReturn` \ (Return value) -> pure value)
|
||||||
_ -> throwValueError (CallError op)
|
_ -> throwValueError (CallError op)
|
||||||
|
|
||||||
@ -109,17 +105,13 @@ instance Show address => AbstractIntro (Value address body) where
|
|||||||
-- | Construct a 'Value' wrapping the value arguments (if any).
|
-- | Construct a 'Value' wrapping the value arguments (if any).
|
||||||
instance ( Coercible body (Eff effects)
|
instance ( Coercible body (Eff effects)
|
||||||
, Member (Allocator address (Value address body)) effects
|
, Member (Allocator address (Value address body)) effects
|
||||||
|
, Member (Env address) effects
|
||||||
, Member Fresh effects
|
, Member Fresh effects
|
||||||
, Member (LoopControl (Value address body)) effects
|
, Member (LoopControl (Value address body)) effects
|
||||||
, Member (Reader (Environment address)) effects
|
|
||||||
, Member (Reader ModuleInfo) effects
|
, Member (Reader ModuleInfo) effects
|
||||||
, Member (Reader PackageInfo) effects
|
, Member (Reader PackageInfo) effects
|
||||||
, Member (Resumable (ValueError address body)) effects
|
, Member (Resumable (ValueError address body)) effects
|
||||||
, Member (Return (Value 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
|
, Show address
|
||||||
)
|
)
|
||||||
=> AbstractValue address (Value address body) effects where
|
=> AbstractValue address (Value address body) effects where
|
||||||
|
@ -1,3 +1,4 @@
|
|||||||
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
module Data.Blob
|
module Data.Blob
|
||||||
( Blob(..)
|
( Blob(..)
|
||||||
, nullBlob
|
, nullBlob
|
||||||
@ -14,6 +15,7 @@ module Data.Blob
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Prologue
|
import Prologue
|
||||||
|
import Proto3.Suite
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.JSON.Fields
|
import Data.JSON.Fields
|
||||||
import Data.Language
|
import Data.Language
|
||||||
@ -26,7 +28,7 @@ data Blob = Blob
|
|||||||
, blobPath :: FilePath -- ^ The file path to the 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.
|
, 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 -> Bool
|
||||||
nullBlob Blob{..} = nullSource blobSource
|
nullBlob Blob{..} = nullSource blobSource
|
||||||
|
@ -3,6 +3,7 @@ module Data.Language where
|
|||||||
|
|
||||||
import Prologue
|
import Prologue
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
|
import Proto3.Suite
|
||||||
|
|
||||||
-- | A programming language.
|
-- | A programming language.
|
||||||
data Language
|
data Language
|
||||||
@ -16,7 +17,7 @@ data Language
|
|||||||
| Ruby
|
| Ruby
|
||||||
| TypeScript
|
| TypeScript
|
||||||
| PHP
|
| 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 ".").
|
-- | Returns a Language based on the file extension (including the ".").
|
||||||
languageForType :: String -> Maybe Language
|
languageForType :: String -> Maybe Language
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
module Data.Source
|
module Data.Source
|
||||||
( Source
|
( Source
|
||||||
, sourceBytes
|
, sourceBytes
|
||||||
@ -36,10 +36,11 @@ import Data.Span
|
|||||||
import Data.String (IsString(..))
|
import Data.String (IsString(..))
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.Encoding as T
|
import qualified Data.Text.Encoding as T
|
||||||
|
import Proto3.Suite
|
||||||
|
|
||||||
-- | The contents of a source file, represented as a 'ByteString'.
|
-- | The contents of a source file, represented as a 'ByteString'.
|
||||||
newtype Source = Source { sourceBytes :: B.ByteString }
|
newtype Source = Source { sourceBytes :: B.ByteString }
|
||||||
deriving (Eq, IsString, Show)
|
deriving (Eq, IsString, Show, Generic, MessageField)
|
||||||
|
|
||||||
fromBytes :: B.ByteString -> Source
|
fromBytes :: B.ByteString -> Source
|
||||||
fromBytes = Source
|
fromBytes = Source
|
||||||
|
@ -11,6 +11,9 @@ module Data.Span
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Aeson ((.=), (.:))
|
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 qualified Data.Aeson as A
|
||||||
import Data.JSON.Fields
|
import Data.JSON.Fields
|
||||||
import Data.Semilattice.Lower
|
import Data.Semilattice.Lower
|
||||||
@ -22,7 +25,15 @@ data Pos = Pos
|
|||||||
{ posLine :: !Int
|
{ posLine :: !Int
|
||||||
, posColumn :: !Int
|
, posColumn :: !Int
|
||||||
}
|
}
|
||||||
deriving (Show, Read, Eq, Ord, Generic, Hashable)
|
deriving (Show, Read, Eq, Ord, Generic, Hashable, 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
|
instance A.ToJSON Pos where
|
||||||
toJSON Pos{..} =
|
toJSON Pos{..} =
|
||||||
@ -37,7 +48,7 @@ data Span = Span
|
|||||||
{ spanStart :: Pos
|
{ spanStart :: Pos
|
||||||
, spanEnd :: Pos
|
, spanEnd :: Pos
|
||||||
}
|
}
|
||||||
deriving (Show, Read, Eq, Ord, Generic, Hashable)
|
deriving (Show, Read, Eq, Ord, Generic, Hashable, Named, Message)
|
||||||
|
|
||||||
spanFromSrcLoc :: SrcLoc -> Span
|
spanFromSrcLoc :: SrcLoc -> Span
|
||||||
spanFromSrcLoc = Span . (Pos . srcLocStartLine <*> srcLocStartCol) <*> (Pos . srcLocEndLine <*> srcLocEndCol)
|
spanFromSrcLoc = Span . (Pos . srcLocStartLine <*> srcLocStartCol) <*> (Pos . srcLocEndLine <*> srcLocEndCol)
|
||||||
|
@ -1,5 +1,5 @@
|
|||||||
{-# LANGUAGE DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, TypeFamilies #-}
|
{-# LANGUAGE AllowAmbiguousTypes, DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, KindSignatures, RankNTypes, ConstraintKinds #-}
|
||||||
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack
|
{-# OPTIONS_GHC -Wno-redundant-constraints -fno-warn-orphans #-} -- For HasCallStack
|
||||||
module Data.Syntax where
|
module Data.Syntax where
|
||||||
|
|
||||||
import Data.Abstract.Evaluatable
|
import Data.Abstract.Evaluatable
|
||||||
@ -18,7 +18,13 @@ import Prelude
|
|||||||
import Prologue
|
import Prologue
|
||||||
import qualified Assigning.Assignment as Assignment
|
import qualified Assigning.Assignment as Assignment
|
||||||
import qualified Data.Error as Error
|
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
|
-- Combinators
|
||||||
|
|
||||||
-- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children.
|
-- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children.
|
||||||
@ -99,12 +105,37 @@ infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack,
|
|||||||
-> m (Sum fs (Term (Sum fs) a))
|
-> m (Sum fs (Term (Sum fs) a))
|
||||||
infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right
|
infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right
|
||||||
|
|
||||||
|
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
|
-- Common
|
||||||
|
|
||||||
-- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable).
|
-- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable).
|
||||||
newtype Identifier a = Identifier { name :: Name }
|
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 Eq1 Identifier where liftEq = genericLiftEq
|
||||||
instance Ord1 Identifier where liftCompare = genericLiftCompare
|
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'.
|
-- This can be used to represent an implicit no-op, e.g. the alternative in an 'if' statement without an 'else'.
|
||||||
data Empty a = Empty
|
data Empty a = Empty
|
||||||
deriving (Diffable, Eq, Foldable, Functor, 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 Eq1 Empty where liftEq _ _ _ = True
|
||||||
instance Ord1 Empty where liftCompare _ _ _ = EQ
|
instance Ord1 Empty where liftCompare _ _ _ = EQ
|
||||||
@ -171,7 +202,6 @@ instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
|
|||||||
instance Evaluatable Empty where
|
instance Evaluatable Empty where
|
||||||
eval _ = pure (Rval unit)
|
eval _ = pure (Rval unit)
|
||||||
|
|
||||||
|
|
||||||
-- | Syntax representing a parsing or assignment error.
|
-- | Syntax representing a parsing or assignment error.
|
||||||
data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] }
|
data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
@ -27,8 +27,7 @@ instance Evaluatable Function where
|
|||||||
eval Function{..} = do
|
eval Function{..} = do
|
||||||
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm functionName)
|
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm functionName)
|
||||||
(v, addr) <- letrec name (closure (paramNames functionParameters) (Set.fromList (freeVariables functionBody)) (subtermValue functionBody))
|
(v, addr) <- letrec name (closure (paramNames functionParameters) (Set.fromList (freeVariables functionBody)) (subtermValue functionBody))
|
||||||
bind name addr
|
Rval v <$ bind name addr
|
||||||
pure (Rval v)
|
|
||||||
where paramNames = foldMap (freeVariables . subterm)
|
where paramNames = foldMap (freeVariables . subterm)
|
||||||
|
|
||||||
instance Declarations a => Declarations (Function a) where
|
instance Declarations a => Declarations (Function a) where
|
||||||
@ -53,8 +52,7 @@ instance Evaluatable Method where
|
|||||||
eval Method{..} = do
|
eval Method{..} = do
|
||||||
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm methodName)
|
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm methodName)
|
||||||
(v, addr) <- letrec name (closure (paramNames methodParameters) (Set.fromList (freeVariables methodBody)) (subtermValue methodBody))
|
(v, addr) <- letrec name (closure (paramNames methodParameters) (Set.fromList (freeVariables methodBody)) (subtermValue methodBody))
|
||||||
bind name addr
|
Rval v <$ bind name addr
|
||||||
pure (Rval v)
|
|
||||||
where paramNames = foldMap (freeVariables . subterm)
|
where paramNames = foldMap (freeVariables . subterm)
|
||||||
|
|
||||||
|
|
||||||
|
@ -1,20 +1,21 @@
|
|||||||
{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, ViewPatterns #-}
|
{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, ViewPatterns, ScopedTypeVariables #-}
|
||||||
module Data.Syntax.Literal where
|
module Data.Syntax.Literal where
|
||||||
|
|
||||||
import Data.JSON.Fields
|
|
||||||
import Data.Abstract.Evaluatable
|
import Data.Abstract.Evaluatable
|
||||||
import Data.ByteString.Char8 (readInteger, unpack)
|
import Data.ByteString.Char8 (readInteger, unpack)
|
||||||
import qualified Data.ByteString.Char8 as B
|
import qualified Data.ByteString.Char8 as B
|
||||||
|
import Data.JSON.Fields
|
||||||
import Data.Scientific.Exts
|
import Data.Scientific.Exts
|
||||||
import Diffing.Algorithm
|
import Diffing.Algorithm
|
||||||
import Prelude hiding (Float, null)
|
import Prelude hiding (Float, null)
|
||||||
import Prologue hiding (Set, hash, null)
|
import Prologue hiding (Set, hash, null)
|
||||||
|
import Proto3.Suite.Class
|
||||||
import Text.Read (readMaybe)
|
import Text.Read (readMaybe)
|
||||||
|
|
||||||
-- Boolean
|
-- Boolean
|
||||||
|
|
||||||
newtype Boolean a = Boolean Bool
|
newtype Boolean a = Boolean { booleanContent :: Bool }
|
||||||
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)
|
||||||
|
|
||||||
true :: Boolean a
|
true :: Boolean a
|
||||||
true = Boolean True
|
true = Boolean True
|
||||||
@ -57,7 +58,7 @@ instance ToJSONFields1 Data.Syntax.Literal.Integer where
|
|||||||
|
|
||||||
-- | A literal float of unspecified width.
|
-- | A literal float of unspecified width.
|
||||||
newtype Float a = Float { floatContent :: ByteString }
|
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 Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq
|
||||||
instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare
|
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
|
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.
|
-- | An interpolation element within a string literal.
|
||||||
newtype InterpolationElement a = InterpolationElement { interpolationBody :: a }
|
newtype InterpolationElement a = InterpolationElement { interpolationBody :: 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)
|
||||||
@ -133,7 +145,7 @@ instance ToJSONFields1 InterpolationElement
|
|||||||
|
|
||||||
-- | A sequence of textual contents within a string literal.
|
-- | A sequence of textual contents within a string literal.
|
||||||
newtype TextElement a = TextElement { textElementContent :: ByteString }
|
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 Eq1 TextElement where liftEq = genericLiftEq
|
||||||
instance Ord1 TextElement where liftCompare = genericLiftCompare
|
instance Ord1 TextElement where liftCompare = genericLiftCompare
|
||||||
@ -146,7 +158,7 @@ instance Evaluatable TextElement where
|
|||||||
eval (TextElement x) = pure (Rval (string x))
|
eval (TextElement x) = pure (Rval (string x))
|
||||||
|
|
||||||
data Null a = Null
|
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 Eq1 Null where liftEq = genericLiftEq
|
||||||
instance Ord1 Null where liftCompare = genericLiftCompare
|
instance Ord1 Null where liftCompare = genericLiftCompare
|
||||||
@ -176,7 +188,6 @@ instance Ord1 Regex where liftCompare = genericLiftCompare
|
|||||||
instance Show1 Regex where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Regex where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
-- TODO: Heredoc-style string literals?
|
-- TODO: Heredoc-style string literals?
|
||||||
-- TODO: Character literals.
|
|
||||||
|
|
||||||
instance ToJSONFields1 Regex where
|
instance ToJSONFields1 Regex where
|
||||||
toJSONFields1 (Regex r) = noChildren ["asString" .= unpack r]
|
toJSONFields1 (Regex r) = noChildren ["asString" .= unpack r]
|
||||||
@ -189,7 +200,7 @@ instance Evaluatable Regex
|
|||||||
-- Collections
|
-- Collections
|
||||||
|
|
||||||
newtype Array a = Array { arrayElements :: [a] }
|
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 Eq1 Array where liftEq = genericLiftEq
|
||||||
instance Ord1 Array where liftCompare = genericLiftCompare
|
instance Ord1 Array where liftCompare = genericLiftCompare
|
||||||
@ -201,7 +212,7 @@ instance Evaluatable Array where
|
|||||||
eval (Array a) = Rval <$> (array =<< traverse subtermValue a)
|
eval (Array a) = Rval <$> (array =<< traverse subtermValue a)
|
||||||
|
|
||||||
newtype Hash a = Hash { hashElements :: [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 Eq1 Hash where liftEq = genericLiftEq
|
||||||
instance Ord1 Hash where liftCompare = genericLiftCompare
|
instance Ord1 Hash where liftCompare = genericLiftCompare
|
||||||
@ -213,7 +224,7 @@ instance Evaluatable Hash where
|
|||||||
eval t = Rval . hash <$> traverse (subtermValue >=> asPair) (hashElements t)
|
eval t = Rval . hash <$> traverse (subtermValue >=> asPair) (hashElements t)
|
||||||
|
|
||||||
data KeyValue a = KeyValue { key :: !a, value :: !a }
|
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 Eq1 KeyValue where liftEq = genericLiftEq
|
||||||
instance Ord1 KeyValue where liftCompare = genericLiftCompare
|
instance Ord1 KeyValue where liftCompare = genericLiftCompare
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators #-}
|
{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators, ScopedTypeVariables #-}
|
||||||
module Data.Term
|
module Data.Term
|
||||||
( Term(..)
|
( Term(..)
|
||||||
, termIn
|
, termIn
|
||||||
@ -16,6 +16,7 @@ import Data.Aeson
|
|||||||
import Data.JSON.Fields
|
import Data.JSON.Fields
|
||||||
import Data.Record
|
import Data.Record
|
||||||
import Text.Show
|
import Text.Show
|
||||||
|
import Proto3.Suite.Class
|
||||||
|
|
||||||
-- | A Term with an abstract syntax tree and an annotation.
|
-- | A Term with an abstract syntax tree and an annotation.
|
||||||
newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) }
|
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
|
instance (Show1 f, Show a) => Show (Term f a) where
|
||||||
showsPrec = showsPrec1
|
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
|
instance Ord1 f => Ord1 (Term f) where
|
||||||
liftCompare comp = go where go t1 t2 = liftCompare2 comp go (unTerm t1) (unTerm t2)
|
liftCompare comp = go where go t1 t2 = liftCompare2 comp go (unTerm t1) (unTerm t2)
|
||||||
|
|
||||||
|
@ -221,7 +221,7 @@ instance Diffable [] where
|
|||||||
|
|
||||||
-- | Diff two non-empty lists using RWS.
|
-- | Diff two non-empty lists using RWS.
|
||||||
instance Diffable NonEmpty where
|
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
|
tryAlignWith f (a1:|as1) (a2:|as2) = (:|) <$> f (These a1 a2) <*> tryAlignWith f as1 as2
|
||||||
|
|
||||||
|
@ -70,7 +70,7 @@ instance Evaluatable Import where
|
|||||||
paths <- resolveGoImport importPath
|
paths <- resolveGoImport importPath
|
||||||
for_ paths $ \path -> do
|
for_ paths $ \path -> do
|
||||||
traceResolve (unPath importPath) path
|
traceResolve (unPath importPath) path
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
importedEnv <- maybe emptyEnv snd <$> require path
|
||||||
bindAll importedEnv
|
bindAll importedEnv
|
||||||
pure (Rval unit)
|
pure (Rval unit)
|
||||||
|
|
||||||
@ -94,7 +94,7 @@ instance Evaluatable QualifiedImport where
|
|||||||
void $ letrec' alias $ \addr -> do
|
void $ letrec' alias $ \addr -> do
|
||||||
for_ paths $ \p -> do
|
for_ paths $ \p -> do
|
||||||
traceResolve (unPath importPath) p
|
traceResolve (unPath importPath) p
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (require p)
|
importedEnv <- maybe emptyEnv snd <$> require p
|
||||||
bindAll importedEnv
|
bindAll importedEnv
|
||||||
makeNamespace alias addr Nothing
|
makeNamespace alias addr Nothing
|
||||||
pure (Rval unit)
|
pure (Rval unit)
|
||||||
@ -113,7 +113,7 @@ instance Evaluatable SideEffectImport where
|
|||||||
eval (SideEffectImport importPath _) = do
|
eval (SideEffectImport importPath _) = do
|
||||||
paths <- resolveGoImport importPath
|
paths <- resolveGoImport importPath
|
||||||
traceResolve (unPath importPath) paths
|
traceResolve (unPath importPath) paths
|
||||||
for_ paths $ \path -> isolate (require path)
|
for_ paths require
|
||||||
pure (Rval unit)
|
pure (Rval unit)
|
||||||
|
|
||||||
-- A composite literal in Go
|
-- A composite literal in Go
|
||||||
|
@ -6,7 +6,8 @@ module Language.Haskell.Assignment
|
|||||||
, Term
|
, Term
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Assigning.Assignment hiding (Assignment, Error)
|
import Assigning.Assignment hiding (Assignment, Error, count)
|
||||||
|
import Data.ByteString.Char8 (count)
|
||||||
import Data.Record
|
import Data.Record
|
||||||
import Data.Sum
|
import Data.Sum
|
||||||
import Data.Syntax (emptyTerm, handleError, parseError, makeTerm, makeTerm'', contextualize, postContextualize)
|
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.Comment as Comment
|
||||||
import qualified Data.Syntax.Declaration as Declaration
|
import qualified Data.Syntax.Declaration as Declaration
|
||||||
import qualified Data.Syntax.Literal as Literal
|
import qualified Data.Syntax.Literal as Literal
|
||||||
|
import qualified Data.Syntax.Type as Type
|
||||||
import qualified Data.Term as Term
|
import qualified Data.Term as Term
|
||||||
import qualified Language.Haskell.Syntax as Syntax
|
import qualified Language.Haskell.Syntax as Syntax
|
||||||
import Prologue
|
import Prologue
|
||||||
@ -24,13 +26,23 @@ import Prologue
|
|||||||
type Syntax = '[
|
type Syntax = '[
|
||||||
Comment.Comment
|
Comment.Comment
|
||||||
, Declaration.Function
|
, Declaration.Function
|
||||||
|
, Literal.Array
|
||||||
|
, Literal.Character
|
||||||
, Literal.Float
|
, Literal.Float
|
||||||
, Literal.Integer
|
, Literal.Integer
|
||||||
|
, Literal.TextElement
|
||||||
, Syntax.Context
|
, Syntax.Context
|
||||||
, Syntax.Empty
|
, Syntax.Empty
|
||||||
, Syntax.Error
|
, Syntax.Error
|
||||||
|
, Syntax.FunctionConstructor
|
||||||
, Syntax.Identifier
|
, Syntax.Identifier
|
||||||
|
, Syntax.ListConstructor
|
||||||
, Syntax.Module
|
, 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 :: [Assignment.Assignment [] Grammar Term]
|
||||||
expressionChoices = [
|
expressionChoices = [
|
||||||
comment
|
character
|
||||||
|
, comment
|
||||||
, constructorIdentifier
|
, constructorIdentifier
|
||||||
, float
|
, float
|
||||||
|
, functionConstructor
|
||||||
, functionDeclaration
|
, functionDeclaration
|
||||||
, integer
|
, integer
|
||||||
|
, listConstructor
|
||||||
|
, listExpression
|
||||||
|
, listType
|
||||||
, moduleIdentifier
|
, moduleIdentifier
|
||||||
|
, string
|
||||||
|
, type'
|
||||||
|
, typeConstructorIdentifier
|
||||||
|
, typeSynonymDeclaration
|
||||||
|
, typeVariableIdentifier
|
||||||
|
, tuplingConstructor
|
||||||
|
, unitConstructor
|
||||||
, variableIdentifier
|
, variableIdentifier
|
||||||
, where'
|
, where'
|
||||||
]
|
]
|
||||||
@ -80,12 +104,21 @@ constructorIdentifier = makeTerm <$> symbol ConstructorIdentifier <*> (Syntax.Id
|
|||||||
moduleIdentifier :: Assignment
|
moduleIdentifier :: Assignment
|
||||||
moduleIdentifier = makeTerm <$> symbol ModuleIdentifier <*> (Syntax.Identifier . Name.name <$> source)
|
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' :: Assignment
|
||||||
where' = makeTerm <$> (symbol Where <|> symbol Where') <*> children (many expression)
|
where' = makeTerm <$> (symbol Where <|> symbol Where') <*> children (many expression)
|
||||||
|
|
||||||
functionBody :: Assignment
|
functionBody :: Assignment
|
||||||
functionBody = makeTerm <$> symbol FunctionBody <*> children (many expression)
|
functionBody = makeTerm <$> symbol FunctionBody <*> children (many expression)
|
||||||
|
|
||||||
|
functionConstructor :: Assignment
|
||||||
|
functionConstructor = makeTerm <$> token FunctionConstructor <*> pure Syntax.FunctionConstructor
|
||||||
|
|
||||||
functionDeclaration :: Assignment
|
functionDeclaration :: Assignment
|
||||||
functionDeclaration = makeTerm
|
functionDeclaration = makeTerm
|
||||||
<$> symbol FunctionDeclaration
|
<$> symbol FunctionDeclaration
|
||||||
@ -98,9 +131,57 @@ functionDeclaration = makeTerm
|
|||||||
integer :: Assignment
|
integer :: Assignment
|
||||||
integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source)
|
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 :: Assignment
|
||||||
float = makeTerm <$> symbol Float <*> (Literal.Float <$> source)
|
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.
|
-- | 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 :: Assignment.Assignment [] Grammar Term -> Assignment.Assignment [] Grammar b -> Assignment.Assignment [] Grammar [Term]
|
||||||
manyTermsTill step = manyTill (step <|> comment)
|
manyTermsTill step = manyTill (step <|> comment)
|
||||||
|
@ -19,4 +19,66 @@ instance Show1 Module where liftShowsPrec = genericLiftShowsPrec
|
|||||||
|
|
||||||
instance ToJSONFields1 Module
|
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
|
||||||
|
@ -48,28 +48,26 @@ resolvePHPName :: ( Member (Modules address value) effects
|
|||||||
-> Evaluator address value effects ModulePath
|
-> Evaluator address value effects ModulePath
|
||||||
resolvePHPName n = do
|
resolvePHPName n = do
|
||||||
modulePath <- resolve [name]
|
modulePath <- resolve [name]
|
||||||
maybe (throwResumable $ NotFoundError name [name] Language.PHP) pure modulePath
|
maybeM (throwResumable $ NotFoundError name [name] Language.PHP) modulePath
|
||||||
where name = toName n
|
where name = toName n
|
||||||
toName = BC.unpack . dropRelativePrefix . stripQuotes
|
toName = BC.unpack . dropRelativePrefix . stripQuotes
|
||||||
|
|
||||||
include :: ( AbstractValue address value effects
|
include :: ( AbstractValue address value effects
|
||||||
, Member (Allocator address value) effects
|
, Member (Allocator address value) effects
|
||||||
|
, Member (Env address) effects
|
||||||
, Member (Modules address value) effects
|
, Member (Modules address value) effects
|
||||||
, Member (Reader (Environment address)) effects
|
|
||||||
, Member (Resumable ResolutionError) effects
|
, Member (Resumable ResolutionError) effects
|
||||||
, Member (Resumable (EnvironmentError address)) effects
|
, Member (Resumable (EnvironmentError address)) effects
|
||||||
, Member (State (Environment address)) effects
|
|
||||||
, Member (State (Exports address)) effects
|
|
||||||
, Member Trace effects
|
, Member Trace effects
|
||||||
)
|
)
|
||||||
=> Subterm term (Evaluator address value effects (ValueRef value))
|
=> 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)
|
-> Evaluator address value effects (ValueRef value)
|
||||||
include pathTerm f = do
|
include pathTerm f = do
|
||||||
name <- subtermValue pathTerm >>= asString
|
name <- subtermValue pathTerm >>= asString
|
||||||
path <- resolvePHPName name
|
path <- resolvePHPName name
|
||||||
traceResolve name path
|
traceResolve name path
|
||||||
(importedEnv, v) <- isolate (f path) >>= maybeM (pure (emptyEnv, unit))
|
(v, importedEnv) <- fromMaybe (unit, emptyEnv) <$> f path
|
||||||
bindAll importedEnv
|
bindAll importedEnv
|
||||||
pure (Rval v)
|
pure (Rval v)
|
||||||
|
|
||||||
|
@ -16,7 +16,6 @@ import System.FilePath.Posix
|
|||||||
import qualified Data.ByteString.Char8 as BC
|
import qualified Data.ByteString.Char8 as BC
|
||||||
import qualified Data.Language as Language
|
import qualified Data.Language as Language
|
||||||
import qualified Data.List.NonEmpty as NonEmpty
|
import qualified Data.List.NonEmpty as NonEmpty
|
||||||
import qualified Data.Semigroup.Reducer as Reducer
|
|
||||||
|
|
||||||
data QualifiedName
|
data QualifiedName
|
||||||
= QualifiedName (NonEmpty FilePath)
|
= QualifiedName (NonEmpty FilePath)
|
||||||
@ -82,7 +81,7 @@ resolvePythonModules q = do
|
|||||||
, path <.> ".py"
|
, path <.> ".py"
|
||||||
]
|
]
|
||||||
modulePath <- resolve searchPaths
|
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).
|
-- | Import declarations (symbols are added directly to the calling environment).
|
||||||
@ -113,11 +112,11 @@ instance Evaluatable Import where
|
|||||||
modulePaths <- resolvePythonModules name
|
modulePaths <- resolvePythonModules name
|
||||||
|
|
||||||
-- Eval parent modules first
|
-- 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
|
-- Last module path is the one we want to import
|
||||||
let path = NonEmpty.last modulePaths
|
let path = NonEmpty.last modulePaths
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
importedEnv <- maybe emptyEnv snd <$> require path
|
||||||
bindAll (select importedEnv)
|
bindAll (select importedEnv)
|
||||||
pure (Rval unit)
|
pure (Rval unit)
|
||||||
where
|
where
|
||||||
@ -129,17 +128,12 @@ instance Evaluatable Import where
|
|||||||
-- Evaluate a qualified import
|
-- Evaluate a qualified import
|
||||||
evalQualifiedImport :: ( AbstractValue address value effects
|
evalQualifiedImport :: ( AbstractValue address value effects
|
||||||
, Member (Allocator address value) effects
|
, Member (Allocator address value) effects
|
||||||
|
, Member (Env address) effects
|
||||||
, Member (Modules address value) 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
|
=> Name -> ModulePath -> Evaluator address value effects value
|
||||||
evalQualifiedImport name path = letrec' name $ \addr -> do
|
evalQualifiedImport name path = letrec' name $ \addr -> do
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
importedEnv <- maybe emptyEnv snd <$> require path
|
||||||
bindAll importedEnv
|
bindAll importedEnv
|
||||||
unit <$ makeNamespace name addr Nothing
|
unit <$ makeNamespace name addr Nothing
|
||||||
|
|
||||||
@ -163,7 +157,7 @@ instance Evaluatable QualifiedImport where
|
|||||||
go ((name, path) :| []) = evalQualifiedImport name path
|
go ((name, path) :| []) = evalQualifiedImport name path
|
||||||
-- Evaluate each parent module, just creating a namespace
|
-- Evaluate each parent module, just creating a namespace
|
||||||
go ((name, path) :| xs) = letrec' name $ \addr -> do
|
go ((name, path) :| xs) = letrec' name $ \addr -> do
|
||||||
void $ isolate (require path)
|
void $ require path
|
||||||
void $ go (NonEmpty.fromList xs)
|
void $ go (NonEmpty.fromList xs)
|
||||||
makeNamespace name addr Nothing
|
makeNamespace name addr Nothing
|
||||||
|
|
||||||
@ -182,13 +176,13 @@ instance Evaluatable QualifiedAliasedImport where
|
|||||||
modulePaths <- resolvePythonModules name
|
modulePaths <- resolvePythonModules name
|
||||||
|
|
||||||
-- Evaluate each parent module
|
-- 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
|
-- Evaluate and import the last module, aliasing and updating the environment
|
||||||
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
|
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
|
||||||
Rval <$> letrec' alias (\addr -> do
|
Rval <$> letrec' alias (\addr -> do
|
||||||
let path = NonEmpty.last modulePaths
|
let path = NonEmpty.last modulePaths
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
importedEnv <- maybe emptyEnv snd <$> require path
|
||||||
bindAll importedEnv
|
bindAll importedEnv
|
||||||
unit <$ makeNamespace alias addr Nothing)
|
unit <$ makeNamespace alias addr Nothing)
|
||||||
|
|
||||||
|
@ -26,7 +26,7 @@ resolveRubyName name = do
|
|||||||
let name' = cleanNameOrPath name
|
let name' = cleanNameOrPath name
|
||||||
let paths = [name' <.> "rb"]
|
let paths = [name' <.> "rb"]
|
||||||
modulePath <- resolve paths
|
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"
|
-- load "/root/src/file.rb"
|
||||||
resolveRubyPath :: ( Member (Modules address value) effects
|
resolveRubyPath :: ( Member (Modules address value) effects
|
||||||
@ -37,7 +37,7 @@ resolveRubyPath :: ( Member (Modules address value) effects
|
|||||||
resolveRubyPath path = do
|
resolveRubyPath path = do
|
||||||
let name' = cleanNameOrPath path
|
let name' = cleanNameOrPath path
|
||||||
modulePath <- resolve [name']
|
modulePath <- resolve [name']
|
||||||
maybe (throwResumable $ NotFoundError name' [name'] Language.Ruby) pure modulePath
|
maybeM (throwResumable $ NotFoundError name' [name'] Language.Ruby) modulePath
|
||||||
|
|
||||||
cleanNameOrPath :: ByteString -> String
|
cleanNameOrPath :: ByteString -> String
|
||||||
cleanNameOrPath = BC.unpack . dropRelativePrefix . stripQuotes
|
cleanNameOrPath = BC.unpack . dropRelativePrefix . stripQuotes
|
||||||
@ -73,7 +73,7 @@ instance Evaluatable Require where
|
|||||||
name <- subtermValue x >>= asString
|
name <- subtermValue x >>= asString
|
||||||
path <- resolveRubyName name
|
path <- resolveRubyName name
|
||||||
traceResolve name path
|
traceResolve name path
|
||||||
(importedEnv, v) <- isolate (doRequire path)
|
(v, importedEnv) <- doRequire path
|
||||||
bindAll importedEnv
|
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
|
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
|
, Member (Modules address value) effects
|
||||||
)
|
)
|
||||||
=> M.ModulePath
|
=> M.ModulePath
|
||||||
-> Evaluator address value effects (Environment address, value)
|
-> Evaluator address value effects (value, Environment address)
|
||||||
doRequire path = do
|
doRequire path = do
|
||||||
result <- join <$> lookupModule path
|
result <- join <$> lookupModule path
|
||||||
case result of
|
case result of
|
||||||
Nothing -> (,) . maybe emptyEnv fst <$> load path <*> pure (boolean True)
|
Nothing -> (,) (boolean True) . maybe emptyEnv snd <$> load path
|
||||||
Just (env, _) -> pure (env, boolean False)
|
Just (_, env) -> pure (boolean False, env)
|
||||||
|
|
||||||
|
|
||||||
newtype Load a = Load { loadArgs :: [a] }
|
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")
|
eval (Load _) = raiseEff (fail "invalid argument supplied to load, path is required")
|
||||||
|
|
||||||
doLoad :: ( AbstractValue address value effects
|
doLoad :: ( AbstractValue address value effects
|
||||||
|
, Member (Env address) effects
|
||||||
, Member (Modules address value) effects
|
, Member (Modules address value) effects
|
||||||
, Member (Resumable ResolutionError) effects
|
, Member (Resumable ResolutionError) effects
|
||||||
, Member (State (Environment address)) effects
|
|
||||||
, Member (State (Exports address)) effects
|
|
||||||
, Member Trace effects
|
, Member Trace effects
|
||||||
)
|
)
|
||||||
=> ByteString
|
=> ByteString
|
||||||
@ -121,7 +120,7 @@ doLoad :: ( AbstractValue address value effects
|
|||||||
doLoad path shouldWrap = do
|
doLoad path shouldWrap = do
|
||||||
path' <- resolveRubyPath path
|
path' <- resolveRubyPath path
|
||||||
traceResolve path path'
|
traceResolve path path'
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (load path')
|
importedEnv <- maybe emptyEnv snd <$> load path'
|
||||||
unless shouldWrap $ bindAll importedEnv
|
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
|
pure (boolean Prelude.True) -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load
|
||||||
|
|
||||||
|
@ -12,7 +12,6 @@ import qualified Data.ByteString.Char8 as BC
|
|||||||
import Data.JSON.Fields
|
import Data.JSON.Fields
|
||||||
import qualified Data.Language as Language
|
import qualified Data.Language as Language
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import Data.Semigroup.Reducer (Reducer)
|
|
||||||
import Diffing.Algorithm
|
import Diffing.Algorithm
|
||||||
import Prelude
|
import Prelude
|
||||||
import Prologue
|
import Prologue
|
||||||
@ -135,19 +134,14 @@ javascriptExtensions = ["js"]
|
|||||||
|
|
||||||
evalRequire :: ( AbstractValue address value effects
|
evalRequire :: ( AbstractValue address value effects
|
||||||
, Member (Allocator address value) effects
|
, Member (Allocator address value) effects
|
||||||
|
, Member (Env address) effects
|
||||||
, Member (Modules address value) 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
|
=> M.ModulePath
|
||||||
-> Name
|
-> Name
|
||||||
-> Evaluator address value effects value
|
-> Evaluator address value effects value
|
||||||
evalRequire modulePath alias = letrec' alias $ \addr -> do
|
evalRequire modulePath alias = letrec' alias $ \addr -> do
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath)
|
importedEnv <- maybe emptyEnv snd <$> require modulePath
|
||||||
bindAll importedEnv
|
bindAll importedEnv
|
||||||
unit <$ makeNamespace alias addr Nothing
|
unit <$ makeNamespace alias addr Nothing
|
||||||
|
|
||||||
@ -164,7 +158,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Import where
|
instance Evaluatable Import where
|
||||||
eval (Import symbols importPath) = do
|
eval (Import symbols importPath) = do
|
||||||
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
|
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath)
|
importedEnv <- maybe emptyEnv snd <$> require modulePath
|
||||||
bindAll (renamed importedEnv) $> Rval unit
|
bindAll (renamed importedEnv) $> Rval unit
|
||||||
where
|
where
|
||||||
renamed importedEnv
|
renamed importedEnv
|
||||||
@ -214,7 +208,7 @@ instance ToJSONFields1 SideEffectImport
|
|||||||
instance Evaluatable SideEffectImport where
|
instance Evaluatable SideEffectImport where
|
||||||
eval (SideEffectImport importPath) = do
|
eval (SideEffectImport importPath) = do
|
||||||
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
|
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
|
||||||
void $ isolate (require modulePath)
|
void $ require modulePath
|
||||||
pure (Rval unit)
|
pure (Rval unit)
|
||||||
|
|
||||||
|
|
||||||
@ -232,7 +226,7 @@ instance Evaluatable QualifiedExport where
|
|||||||
eval (QualifiedExport exportSymbols) = do
|
eval (QualifiedExport exportSymbols) = do
|
||||||
-- Insert the aliases with no addresses.
|
-- Insert the aliases with no addresses.
|
||||||
for_ exportSymbols $ \(name, alias) ->
|
for_ exportSymbols $ \(name, alias) ->
|
||||||
addExport name alias Nothing
|
export name alias Nothing
|
||||||
pure (Rval unit)
|
pure (Rval unit)
|
||||||
|
|
||||||
|
|
||||||
@ -249,11 +243,11 @@ instance ToJSONFields1 QualifiedExportFrom
|
|||||||
instance Evaluatable QualifiedExportFrom where
|
instance Evaluatable QualifiedExportFrom where
|
||||||
eval (QualifiedExportFrom importPath exportSymbols) = do
|
eval (QualifiedExportFrom importPath exportSymbols) = do
|
||||||
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
|
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.
|
-- Look up addresses in importedEnv and insert the aliases with addresses into the exports.
|
||||||
for_ exportSymbols $ \(name, alias) -> do
|
for_ exportSymbols $ \(name, alias) -> do
|
||||||
let address = Env.lookup name importedEnv
|
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)
|
pure (Rval unit)
|
||||||
|
|
||||||
newtype DefaultExport a = DefaultExport { defaultExport :: a }
|
newtype DefaultExport a = DefaultExport { defaultExport :: a }
|
||||||
@ -272,8 +266,8 @@ instance Evaluatable DefaultExport where
|
|||||||
Just name -> do
|
Just name -> do
|
||||||
addr <- lookupOrAlloc name
|
addr <- lookupOrAlloc name
|
||||||
assign addr v
|
assign addr v
|
||||||
addExport name name Nothing
|
export name name Nothing
|
||||||
void $ bind name addr
|
bind name addr
|
||||||
Nothing -> throwEvalError DefaultExportError
|
Nothing -> throwEvalError DefaultExportError
|
||||||
pure (Rval unit)
|
pure (Rval unit)
|
||||||
|
|
||||||
|
@ -129,7 +129,7 @@ resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> s
|
|||||||
UnallocatedAddress _ -> pure lowerBound
|
UnallocatedAddress _ -> pure lowerBound
|
||||||
UninitializedAddress _ -> pure hole)
|
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
|
resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of
|
||||||
CallError val -> pure val
|
CallError val -> pure val
|
||||||
StringError val -> pure (pack (show val))
|
StringError val -> pure (pack (show val))
|
||||||
@ -139,7 +139,7 @@ resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err
|
|||||||
NumericError{} -> pure hole
|
NumericError{} -> pure hole
|
||||||
Numeric2Error{} -> pure hole
|
Numeric2Error{} -> pure hole
|
||||||
ComparisonError{} -> pure hole
|
ComparisonError{} -> pure hole
|
||||||
NamespaceError{} -> getEnv
|
NamespaceError{} -> pure emptyEnv
|
||||||
BitwiseError{} -> pure hole
|
BitwiseError{} -> pure hole
|
||||||
Bitwise2Error{} -> pure hole
|
Bitwise2Error{} -> pure hole
|
||||||
KeyValueError{} -> pure (hole, hole)
|
KeyValueError{} -> pure (hole, hole)
|
||||||
|
@ -96,7 +96,7 @@ readBlobsFromHandle = fmap toBlobs . readFromHandle
|
|||||||
readBlobFromPath :: MonadIO m => File -> m Blob.Blob
|
readBlobFromPath :: MonadIO m => File -> m Blob.Blob
|
||||||
readBlobFromPath file = do
|
readBlobFromPath file = do
|
||||||
maybeFile <- readFile file
|
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 :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
|
||||||
readProjectFromPaths maybeRoot path lang excludeDirs = do
|
readProjectFromPaths maybeRoot path lang excludeDirs = do
|
||||||
|
@ -11,16 +11,16 @@ spec :: Spec
|
|||||||
spec = parallel $ do
|
spec = parallel $ do
|
||||||
describe "evaluates Go" $ do
|
describe "evaluates Go" $ do
|
||||||
it "imports and wildcard imports" $ do
|
it "imports and wildcard imports" $ do
|
||||||
((_, state), _) <- evaluate "main.go"
|
((Right [(_, env)], state), _) <- evaluate "main.go"
|
||||||
Env.names (environment state) `shouldBe` [ "Bar", "Rab", "foo", "main" ]
|
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
|
it "imports with aliases (and side effects only)" $ do
|
||||||
((_, state), _) <- evaluate "main1.go"
|
((Right [(_, env)], state), _) <- evaluate "main1.go"
|
||||||
Env.names (environment state) `shouldBe` [ "f", "main" ]
|
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
|
where
|
||||||
fixtures = "test/fixtures/go/analysis/"
|
fixtures = "test/fixtures/go/analysis/"
|
||||||
|
@ -12,22 +12,22 @@ spec :: Spec
|
|||||||
spec = parallel $ do
|
spec = parallel $ do
|
||||||
describe "PHP" $ do
|
describe "PHP" $ do
|
||||||
it "evaluates include and require" $ do
|
it "evaluates include and require" $ do
|
||||||
((res, state), _) <- evaluate "main.php"
|
((Right [(res, env)], state), _) <- evaluate "main.php"
|
||||||
res `shouldBe` Right [unit]
|
res `shouldBe` unit
|
||||||
Env.names (environment state) `shouldBe` [ "bar", "foo" ]
|
Env.names env `shouldBe` [ "bar", "foo" ]
|
||||||
|
|
||||||
it "evaluates include_once and require_once" $ do
|
it "evaluates include_once and require_once" $ do
|
||||||
((res, state), _) <- evaluate "main_once.php"
|
((Right [(res, env)], state), _) <- evaluate "main_once.php"
|
||||||
res `shouldBe` Right [unit]
|
res `shouldBe` unit
|
||||||
Env.names (environment state) `shouldBe` [ "bar", "foo" ]
|
Env.names env `shouldBe` [ "bar", "foo" ]
|
||||||
|
|
||||||
it "evaluates namespaces" $ do
|
it "evaluates namespaces" $ do
|
||||||
((_, state), _) <- evaluate "namespaces.php"
|
((Right [(_, env)], state), _) <- evaluate "namespaces.php"
|
||||||
Env.names (environment state) `shouldBe` [ "Foo", "NS1" ]
|
Env.names env `shouldBe` [ "Foo", "NS1" ]
|
||||||
|
|
||||||
(derefQName (heap state) ("NS1" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"])
|
(derefQName (heap state) ("NS1" :| []) env >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"])
|
||||||
(derefQName (heap state) ("NS1" :| ["Sub1"]) (environment state) >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"])
|
(derefQName (heap state) ("NS1" :| ["Sub1"]) env >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"])
|
||||||
(derefQName (heap state) ("NS1" :| ["Sub1", "Sub2"]) (environment state) >>= deNamespace) `shouldBe` Just ("Sub2", ["f"])
|
(derefQName (heap state) ("NS1" :| ["Sub1", "Sub2"]) env >>= deNamespace) `shouldBe` Just ("Sub2", ["f"])
|
||||||
|
|
||||||
where
|
where
|
||||||
fixtures = "test/fixtures/php/analysis/"
|
fixtures = "test/fixtures/php/analysis/"
|
||||||
|
@ -14,33 +14,33 @@ spec :: Spec
|
|||||||
spec = parallel $ do
|
spec = parallel $ do
|
||||||
describe "evaluates Python" $ do
|
describe "evaluates Python" $ do
|
||||||
it "imports" $ do
|
it "imports" $ do
|
||||||
((_, state), _) <- evaluate "main.py"
|
((Right [(_, env)], state), _) <- evaluate "main.py"
|
||||||
Env.names (environment state) `shouldContain` [ "a", "b" ]
|
Env.names env `shouldContain` [ "a", "b" ]
|
||||||
|
|
||||||
(derefQName (heap state) ("a" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("a", ["foo"])
|
(derefQName (heap state) ("a" :| []) env >>= deNamespace) `shouldBe` Just ("a", ["foo"])
|
||||||
(derefQName (heap state) ("b" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("b", ["c"])
|
(derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", ["c"])
|
||||||
(derefQName (heap state) ("b" :| ["c"]) (environment state) >>= deNamespace) `shouldBe` Just ("c", ["baz"])
|
(derefQName (heap state) ("b" :| ["c"]) env >>= deNamespace) `shouldBe` Just ("c", ["baz"])
|
||||||
|
|
||||||
it "imports with aliases" $ do
|
it "imports with aliases" $ do
|
||||||
env <- environment . snd . fst <$> evaluate "main1.py"
|
((Right [(_, env)], _), _) <- evaluate "main1.py"
|
||||||
Env.names env `shouldContain` [ "b", "e" ]
|
Env.names env `shouldContain` [ "b", "e" ]
|
||||||
|
|
||||||
it "imports using 'from' syntax" $ do
|
it "imports using 'from' syntax" $ do
|
||||||
env <- environment . snd . fst <$> evaluate "main2.py"
|
((Right [(_, env)], _), _) <- evaluate "main2.py"
|
||||||
Env.names env `shouldContain` [ "bar", "foo" ]
|
Env.names env `shouldContain` [ "bar", "foo" ]
|
||||||
|
|
||||||
it "imports with relative syntax" $ do
|
it "imports with relative syntax" $ do
|
||||||
((_, state), _) <- evaluate "main3.py"
|
((Right [(_, env)], state), _) <- evaluate "main3.py"
|
||||||
Env.names (environment state) `shouldContain` [ "utils" ]
|
Env.names env `shouldContain` [ "utils" ]
|
||||||
(derefQName (heap state) ("utils" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("utils", ["to_s"])
|
(derefQName (heap state) ("utils" :| []) env >>= deNamespace) `shouldBe` Just ("utils", ["to_s"])
|
||||||
|
|
||||||
it "subclasses" $ do
|
it "subclasses" $ do
|
||||||
((res, _), _) <- evaluate "subclass.py"
|
((res, _), _) <- evaluate "subclass.py"
|
||||||
res `shouldBe` Right [String "\"bar\""]
|
fmap fst <$> res `shouldBe` Right [String "\"bar\""]
|
||||||
|
|
||||||
it "handles multiple inheritance left-to-right" $ do
|
it "handles multiple inheritance left-to-right" $ do
|
||||||
((res, _), _) <- evaluate "multiple_inheritance.py"
|
((res, _), _) <- evaluate "multiple_inheritance.py"
|
||||||
res `shouldBe` Right [String "\"foo!\""]
|
fmap fst <$> res `shouldBe` Right [String "\"foo!\""]
|
||||||
|
|
||||||
where
|
where
|
||||||
ns n = Just . Latest . Last . Just . Namespace n
|
ns n = Just . Latest . Last . Just . Namespace n
|
||||||
|
@ -20,58 +20,57 @@ spec :: Spec
|
|||||||
spec = parallel $ do
|
spec = parallel $ do
|
||||||
describe "Ruby" $ do
|
describe "Ruby" $ do
|
||||||
it "evaluates require_relative" $ do
|
it "evaluates require_relative" $ do
|
||||||
((res, state), _) <- evaluate "main.rb"
|
((Right [(res, env)], state), _) <- evaluate "main.rb"
|
||||||
res `shouldBe` Right [Value.Integer (Number.Integer 1)]
|
res `shouldBe` Value.Integer (Number.Integer 1)
|
||||||
Env.names (environment state) `shouldContain` ["foo"]
|
Env.names env `shouldContain` ["foo"]
|
||||||
|
|
||||||
it "evaluates load" $ do
|
it "evaluates load" $ do
|
||||||
env <- environment . snd . fst <$> evaluate "load.rb"
|
((Right [(_, env)], _), _) <- evaluate "load.rb"
|
||||||
Env.names env `shouldContain` ["foo"]
|
Env.names env `shouldContain` ["foo"]
|
||||||
|
|
||||||
it "evaluates load with wrapper" $ do
|
it "evaluates load with wrapper" $ do
|
||||||
((res, state), _) <- evaluate "load-wrap.rb"
|
((res, state), _) <- evaluate "load-wrap.rb"
|
||||||
res `shouldBe` Left (SomeExc (inject @(EnvironmentError Precise) (FreeVariable "foo")))
|
res `shouldBe` Left (SomeExc (inject @(EnvironmentError Precise) (FreeVariable "foo")))
|
||||||
Env.names (environment state) `shouldContain` [ "Object" ]
|
|
||||||
|
|
||||||
it "evaluates subclass" $ do
|
it "evaluates subclass" $ do
|
||||||
((res, state), _) <- evaluate "subclass.rb"
|
((Right [(res, env)], state), _) <- evaluate "subclass.rb"
|
||||||
res `shouldBe` Right [String "\"<bar>\""]
|
res `shouldBe` String "\"<bar>\""
|
||||||
Env.names (environment state) `shouldContain` [ "Bar", "Foo" ]
|
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
|
it "evaluates modules" $ do
|
||||||
((res, state), _) <- evaluate "modules.rb"
|
((Right [(res, env)], state), _) <- evaluate "modules.rb"
|
||||||
res `shouldBe` Right [String "\"<hello>\""]
|
res `shouldBe` String "\"<hello>\""
|
||||||
Env.names (environment state) `shouldContain` [ "Bar" ]
|
Env.names env `shouldContain` [ "Bar" ]
|
||||||
|
|
||||||
it "handles break correctly" $ do
|
it "handles break correctly" $ do
|
||||||
((res, _), _) <- evaluate "break.rb"
|
((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
|
it "handles break correctly" $ do
|
||||||
((res, _), _) <- evaluate "next.rb"
|
((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
|
it "calls functions with arguments" $ do
|
||||||
((res, _), _) <- evaluate "call.rb"
|
((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
|
it "evaluates early return statements" $ do
|
||||||
((res, _), _) <- evaluate "early-return.rb"
|
((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
|
it "has prelude" $ do
|
||||||
((res, _), _) <- evaluate "preluded.rb"
|
((res, _), _) <- evaluate "preluded.rb"
|
||||||
res `shouldBe` Right [String "\"<foo>\""]
|
fmap fst <$> res `shouldBe` Right [String "\"<foo>\""]
|
||||||
|
|
||||||
it "evaluates __LINE__" $ do
|
it "evaluates __LINE__" $ do
|
||||||
((res, _), _) <- evaluate "line.rb"
|
((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
|
it "resolves builtins used in the prelude" $ do
|
||||||
((res, _), traces) <- evaluate "puts.rb"
|
((res, _), traces) <- evaluate "puts.rb"
|
||||||
res `shouldBe` Right [Unit]
|
fmap fst <$> res `shouldBe` Right [Unit]
|
||||||
traces `shouldContain` [ "\"hello\"" ]
|
traces `shouldContain` [ "\"hello\"" ]
|
||||||
|
|
||||||
where
|
where
|
||||||
|
@ -15,19 +15,19 @@ spec :: Spec
|
|||||||
spec = parallel $ do
|
spec = parallel $ do
|
||||||
describe "evaluates TypeScript" $ do
|
describe "evaluates TypeScript" $ do
|
||||||
it "imports with aliased symbols" $ 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" ]
|
Env.names env `shouldBe` [ "bar", "quz" ]
|
||||||
|
|
||||||
it "imports with qualified names" $ do
|
it "imports with qualified names" $ do
|
||||||
((_, state), _) <- evaluate "main1.ts"
|
((Right [(_, env)], state), _) <- evaluate "main1.ts"
|
||||||
Env.names (environment state) `shouldBe` [ "b", "z" ]
|
Env.names env `shouldBe` [ "b", "z" ]
|
||||||
|
|
||||||
(derefQName (heap state) ("b" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ])
|
(derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ])
|
||||||
(derefQName (heap state) ("z" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ])
|
(derefQName (heap state) ("z" :| []) env >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ])
|
||||||
|
|
||||||
it "side effect only imports" $ do
|
it "side effect only imports" $ do
|
||||||
env <- environment . snd . fst <$> evaluate "main2.ts"
|
((res, _), _) <- evaluate "main2.ts"
|
||||||
env `shouldBe` emptyEnv
|
fmap snd <$> res `shouldBe` Right [emptyEnv]
|
||||||
|
|
||||||
it "fails exporting symbols not defined in the module" $ do
|
it "fails exporting symbols not defined in the module" $ do
|
||||||
((res, _), _) <- evaluate "bad-export.ts"
|
((res, _), _) <- evaluate "bad-export.ts"
|
||||||
@ -35,7 +35,7 @@ spec = parallel $ do
|
|||||||
|
|
||||||
it "evaluates early return statements" $ do
|
it "evaluates early return statements" $ do
|
||||||
((res, _), _) <- evaluate "early-return.ts"
|
((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
|
where
|
||||||
fixtures = "test/fixtures/typescript/analysis/"
|
fixtures = "test/fixtures/typescript/analysis/"
|
||||||
|
@ -20,13 +20,13 @@ spec :: Spec
|
|||||||
spec = parallel $ do
|
spec = parallel $ do
|
||||||
it "constructs integers" $ do
|
it "constructs integers" $ do
|
||||||
(expected, _) <- evaluate (pure (integer 123))
|
(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
|
it "calls functions" $ do
|
||||||
(expected, _) <- evaluate $ do
|
(expected, _) <- evaluate $ do
|
||||||
identity <- closure [name "x"] lowerBound (variable (name "x"))
|
identity <- closure [name "x"] lowerBound (variable (name "x"))
|
||||||
call identity [pure (integer 123)]
|
call identity [pure (integer 123)]
|
||||||
expected `shouldBe` Right (Value.Integer (Number.Integer 123))
|
fst <$> expected `shouldBe` Right (Value.Integer (Number.Integer 123))
|
||||||
|
|
||||||
evaluate
|
evaluate
|
||||||
= runM
|
= runM
|
||||||
@ -38,6 +38,7 @@ evaluate
|
|||||||
. runEnvironmentError
|
. runEnvironmentError
|
||||||
. runAddressError
|
. runAddressError
|
||||||
. runAllocator
|
. runAllocator
|
||||||
|
. runEnv lowerBound
|
||||||
. runReturn
|
. runReturn
|
||||||
. runLoopControl
|
. runLoopControl
|
||||||
|
|
||||||
|
@ -34,7 +34,6 @@ import Data.Project as X
|
|||||||
import Data.Functor.Listable as X
|
import Data.Functor.Listable as X
|
||||||
import Data.Language as X
|
import Data.Language as X
|
||||||
import Data.List.NonEmpty as X (NonEmpty(..))
|
import Data.List.NonEmpty as X (NonEmpty(..))
|
||||||
import Data.Monoid as X (Last(..))
|
|
||||||
import Data.Range as X
|
import Data.Range as X
|
||||||
import Data.Record as X
|
import Data.Record as X
|
||||||
import Data.Source as X
|
import Data.Source as X
|
||||||
|
69
test/fixtures/haskell/corpus/literals.A.hs
vendored
69
test/fixtures/haskell/corpus/literals.A.hs
vendored
@ -35,3 +35,72 @@ aZ' = undefined
|
|||||||
|
|
||||||
a = True
|
a = True
|
||||||
a = False
|
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
69
test/fixtures/haskell/corpus/literals.B.hs
vendored
@ -35,3 +35,72 @@ bZ' = undefined
|
|||||||
|
|
||||||
b = True
|
b = True
|
||||||
b = False
|
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
307
test/fixtures/haskell/corpus/literals.diffA-B.txt
vendored
@ -1,11 +1,10 @@
|
|||||||
(Module
|
(Module
|
||||||
(Identifier)
|
(Identifier)
|
||||||
(
|
(
|
||||||
(Function
|
{+(Function
|
||||||
{ (Identifier)
|
{+(Identifier)+}
|
||||||
->(Identifier) }
|
{+(
|
||||||
(
|
{+(Integer)+})+})+}
|
||||||
(Integer)))
|
|
||||||
{+(Function
|
{+(Function
|
||||||
{+(Identifier)+}
|
{+(Identifier)+}
|
||||||
{+(
|
{+(
|
||||||
@ -118,6 +117,156 @@
|
|||||||
{+(Identifier)+}
|
{+(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)+})+})+})+}
|
||||||
|
{-(Function
|
||||||
|
{-(Identifier)-}
|
||||||
|
{-(
|
||||||
|
{-(Integer)-})-})-}
|
||||||
{-(Function
|
{-(Function
|
||||||
{-(Identifier)-}
|
{-(Identifier)-}
|
||||||
{-(
|
{-(
|
||||||
@ -229,4 +378,150 @@
|
|||||||
{-(Function
|
{-(Function
|
||||||
{-(Identifier)-}
|
{-(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
501
test/fixtures/haskell/corpus/literals.diffB-A.txt
vendored
@ -1,113 +1,92 @@
|
|||||||
(Module
|
(Module
|
||||||
(Identifier)
|
(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
|
(Function
|
||||||
{ (Identifier)
|
{ (Identifier)
|
||||||
->(Identifier) }
|
->(Identifier) }
|
||||||
(
|
(
|
||||||
(Integer)))
|
{+(Float)+}
|
||||||
{+(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)+}
|
|
||||||
{-(Integer)-}))
|
{-(Integer)-}))
|
||||||
|
{+(Function
|
||||||
|
{+(Identifier)+}
|
||||||
|
{+(
|
||||||
|
{+(Float)+})+})+}
|
||||||
|
{+(Function
|
||||||
|
{+(Identifier)+}
|
||||||
|
{+(
|
||||||
|
{+(Float)+})+})+}
|
||||||
|
{+(Function
|
||||||
|
{+(Identifier)+}
|
||||||
|
{+(
|
||||||
|
{+(Float)+})+})+}
|
||||||
|
{+(Function
|
||||||
|
{+(Identifier)+}
|
||||||
|
{+(
|
||||||
|
{+(Float)+})+})+}
|
||||||
|
{+(Function
|
||||||
|
{+(Identifier)+}
|
||||||
|
{+(
|
||||||
|
{+(Float)+})+})+}
|
||||||
|
{+(Function
|
||||||
|
{+(Identifier)+}
|
||||||
|
{+(
|
||||||
|
{+(Float)+})+})+}
|
||||||
|
{+(Function
|
||||||
|
{+(Identifier)+}
|
||||||
|
{+(
|
||||||
|
{+(Identifier)+})+})+}
|
||||||
{+(Function
|
{+(Function
|
||||||
{+(Identifier)+}
|
{+(Identifier)+}
|
||||||
{+(
|
{+(
|
||||||
@ -120,6 +99,176 @@
|
|||||||
{+(Identifier)+}
|
{+(Identifier)+}
|
||||||
{+(
|
{+(
|
||||||
{+(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
|
{-(Function
|
||||||
{-(Identifier)-}
|
{-(Identifier)-}
|
||||||
{-(
|
{-(
|
||||||
@ -227,4 +376,150 @@
|
|||||||
{-(Function
|
{-(Function
|
||||||
{-(Identifier)-}
|
{-(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
148
test/fixtures/haskell/corpus/literals.parseA.txt
vendored
@ -116,4 +116,150 @@
|
|||||||
(Function
|
(Function
|
||||||
(Identifier)
|
(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
148
test/fixtures/haskell/corpus/literals.parseB.txt
vendored
@ -116,4 +116,150 @@
|
|||||||
(Function
|
(Function
|
||||||
(Identifier)
|
(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
8
test/fixtures/haskell/corpus/type-synonyms.A.hs
vendored
Normal 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
8
test/fixtures/haskell/corpus/type-synonyms.B.hs
vendored
Normal 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
81
test/fixtures/haskell/corpus/type-synonyms.diffA-B.txt
vendored
Normal 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
81
test/fixtures/haskell/corpus/type-synonyms.diffB-A.txt
vendored
Normal 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
66
test/fixtures/haskell/corpus/type-synonyms.parseA.txt
vendored
Normal 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
68
test/fixtures/haskell/corpus/type-synonyms.parseB.txt
vendored
Normal 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
45
types.proto
Normal 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
2
vendor/fastsum
vendored
@ -1 +1 @@
|
|||||||
Subproject commit 2310af6de3d3c337d671cdf9fe3e007990fdb1e4
|
Subproject commit dbeff0af57fcea85bca07ff5a8149301dd3b084c
|
1
vendor/proto3-suite
vendored
Submodule
1
vendor/proto3-suite
vendored
Submodule
@ -0,0 +1 @@
|
|||||||
|
Subproject commit c75b250e82481e23d2ff586b3e841834b5d93ff9
|
1
vendor/proto3-wire
vendored
Submodule
1
vendor/proto3-wire
vendored
Submodule
@ -0,0 +1 @@
|
|||||||
|
Subproject commit c8792bc33154e849239b1c91ffe06af2e765d734
|
Loading…
Reference in New Issue
Block a user