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

Merge branch 'master' into haskell-assignment

Browse Source
This commit is contained in:
Rick Winfrey 2018-06-12 15:44:01 -07:00 committed by GitHub
commit f5dd067eeb
35 changed files with 409 additions and 193 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
semantic.cabal
View File

@ -150,10 +150,12 @@ library
-- High-level flow & operational functionality (logging, stats, etc.)
, Semantic.AST
, Semantic.CLI
, Semantic.Config
, Semantic.Diff
, Semantic.Distribute
, Semantic.Env
, Semantic.Graph
, Semantic.Haystack
, Semantic.IO
, Semantic.Log
, Semantic.Parse
@ -180,6 +182,7 @@ library
, bytestring
, cmark-gfm
, containers
, cryptohash
, directory
, directory-tree
, effects
@ -192,6 +195,9 @@ library
, Glob
, hashable
, hscolour
, http-client
, http-client-tls
, http-types
, kdt
, mersenne-random-pure64
, mtl

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

@ -36,8 +36,8 @@ lookupCache configuration = cacheLookup configuration <$> get
cachingConfiguration :: (Cacheable term address (Cell address) value, Member (State (Cache term address (Cell address) value)) effects, Member (State (Heap address (Cell address) value)) effects)
=> Configuration term address (Cell address) value
-> Set (Cached address (Cell address) value)
-> TermEvaluator term address value effects (ValueRef value)
-> TermEvaluator term address value effects (ValueRef value)
-> TermEvaluator term address value effects (ValueRef address)
-> TermEvaluator term address value effects (ValueRef address)
cachingConfiguration configuration values action = do
modify' (cacheSet configuration values)
result <- Cached <$> action <*> TermEvaluator getHeap
@ -65,8 +65,8 @@ cachingTerms :: ( Cacheable term address (Cell address) value
, Member (Env address) 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))
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address))
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address))
cachingTerms recur term = do
c <- getConfiguration (embedSubterm term)
cached <- lookupCache c
@ -88,8 +88,8 @@ convergingModules :: ( AbstractValue address value effects
, Member (Env address) 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)
=> SubtermAlgebra Module term (TermEvaluator term address value effects address)
-> SubtermAlgebra Module term (TermEvaluator term address value effects address)
convergingModules recur m = do
c <- getConfiguration (subterm (moduleBody m))
-- Convergence here is predicated upon an Eq instance, not α-equivalence
@ -103,7 +103,7 @@ convergingModules recur m = do
-- would never complete). We don’t need to use the values, so we 'gather' the
-- nondeterministic values into @()@.
withOracle prevCache (gatherM (const ()) (recur m)))
TermEvaluator (value =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache)))
TermEvaluator (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache)))
-- | Iterate a monadic action starting from some initial seed until the results converge.
@ -122,7 +122,7 @@ converge seed f = loop seed
loop x'
-- | Nondeterministically write each of a collection of stores & return their associated results.
scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address (Cell address) value)) effects) => t (Cached address (Cell address) value) -> TermEvaluator term address value effects (ValueRef value)
scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address (Cell address) value)) effects) => t (Cached address (Cell address) value) -> TermEvaluator term address value effects (ValueRef address)
scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (putHeap heap') $> value)

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

@ -10,7 +10,7 @@ import Data.Semilattice.Lower
-- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@.
data EvaluatingState address value = EvaluatingState
{ heap :: Heap address (Cell address) value
, modules :: ModuleTable (Maybe (value, Environment address))
, modules :: ModuleTable (Maybe (address, Environment address))
}
deriving instance (Eq (Cell address value), Eq address, Eq value) => Eq (EvaluatingState address value)
@ -21,11 +21,11 @@ deriving instance (Show (Cell address value), Show address, Show value) => Show
evaluating :: Evaluator address value
( Fresh
': State (Heap address (Cell address) value)
': State (ModuleTable (Maybe (value, Environment address)))
': State (ModuleTable (Maybe (address, Environment address)))
': effects) result
-> Evaluator address value effects (result, EvaluatingState address value)
evaluating
= fmap (\ ((result, heap), modules) -> (result, EvaluatingState heap modules))
. runState lowerBound -- State (ModuleTable (Maybe (value, Environment address)))
. runState lowerBound -- State (ModuleTable (Maybe (address, Environment address)))
. runState lowerBound -- State (Heap address (Cell address) value)
. runFresh 0

48
src/Control/Abstract/Evaluator.hs
View File

@ -34,44 +34,52 @@ newtype Evaluator address value effects a = Evaluator { runEvaluator :: Eff effe
deriving instance Member NonDet effects => Alternative (Evaluator address value effects)
-- Effects
-- | An effect for explicitly returning out of a function/method body.
data Return value resume where
Return :: value -> Return value value
data Return address value resume where
Return :: address -> Return address value address
deriving instance Eq value => Eq (Return value a)
deriving instance Show value => Show (Return value a)
deriving instance (Eq address, Eq value) => Eq (Return address value a)
deriving instance (Show address, Eq value) => Show (Return address value a)
earlyReturn :: Member (Return value) effects => value -> Evaluator address value effects value
earlyReturn = send . Return
earlyReturn :: forall address value effects
. Member (Return address value) effects
=> address
-> Evaluator address value effects address
earlyReturn = send . Return @address @value
catchReturn :: Member (Return value) effects => Evaluator address value effects a -> (forall x . Return value x -> Evaluator address value effects a) -> Evaluator address value effects a
catchReturn :: Member (Return address value) effects => Evaluator address value effects a -> (forall x . Return address value x -> Evaluator address value effects a) -> Evaluator address value effects a
catchReturn action handler = interpose pure (\ ret _ -> handler ret) action
runReturn :: Effectful (m address value) => m address value (Return value ': effects) value -> m address value effects value
runReturn :: Effectful (m address value) => m address value (Return address value ': effects) address -> m address value effects address
runReturn = raiseHandler (relay pure (\ (Return value) _ -> pure value))
-- | Effects for control flow around loops (breaking and continuing).
data LoopControl value resume where
Break :: value -> LoopControl value value
Continue :: value -> LoopControl value value
data LoopControl address value resume where
Break :: address -> LoopControl address value address
Continue :: address -> LoopControl address value address
deriving instance Eq value => Eq (LoopControl value a)
deriving instance Show value => Show (LoopControl value a)
deriving instance (Eq address, Eq value) => Eq (LoopControl address value a)
deriving instance (Show address, Show value) => Show (LoopControl address value a)
throwBreak :: Member (LoopControl value) effects => value -> Evaluator address value effects value
throwBreak = send . Break
throwBreak :: forall address value effects
. Member (LoopControl address value) effects
=> address
-> Evaluator address value effects address
throwBreak = send . Break @address @value
throwContinue :: Member (LoopControl value) effects => value -> Evaluator address value effects value
throwContinue = send . Continue
throwContinue :: forall address value effects
. Member (LoopControl address value) effects
=> address
-> Evaluator address value effects address
throwContinue = send . Continue @address @value
catchLoopControl :: Member (LoopControl value) effects => Evaluator address value effects a -> (forall x . LoopControl value x -> Evaluator address value effects a) -> Evaluator address value effects a
catchLoopControl :: Member (LoopControl address value) effects => Evaluator address value effects a -> (forall x . LoopControl address value x -> Evaluator address value effects a) -> Evaluator address value effects a
catchLoopControl action handler = interpose pure (\ control _ -> handler control) action
runLoopControl :: Effectful (m address value) => m address value (LoopControl value ': effects) value -> m address value effects value
runLoopControl :: Effectful (m address value) => m address value (LoopControl address value ': effects) address -> m address value effects address
runLoopControl = raiseHandler (relay pure (\ eff _ -> case eff of
Break value -> pure value
Continue value -> pure value))

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

@ -6,6 +6,7 @@ module Control.Abstract.Heap
, getConfiguration
, getHeap
, putHeap
, box
, alloc
, deref
, assign
@ -52,6 +53,13 @@ putHeap = put
modifyHeap :: Member (State (Heap address (Cell address) value)) effects => (Heap address (Cell address) value -> Heap address (Cell address) value) -> Evaluator address value effects ()
modifyHeap = modify'
box :: Member (Allocator address value) effects
=> value
-> Evaluator address value effects address
box val = do
addr <- alloc "<box>"
assign addr val
pure addr
alloc :: Member (Allocator address value) effects => Name -> Evaluator address value effects address
alloc = sendAllocator . Alloc
@ -95,8 +103,8 @@ letrec' :: ( Member (Allocator address value) effects
, Member (Env address) effects
)
=> Name
-> (address -> Evaluator address value effects value)
-> Evaluator address value effects value
-> (address -> Evaluator address value effects a)
-> Evaluator address value effects a
letrec' name body = do
addr <- lookupOrAlloc name
v <- locally (body addr)
@ -104,13 +112,12 @@ letrec' name body = do
-- | Look up and dereference the given 'Name', throwing an exception for free variables.
variable :: ( Member (Allocator address value) effects
, Member (Env address) effects
variable :: ( Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
)
=> Name
-> Evaluator address value effects value
variable name = lookupEnv name >>= maybeM (freeVariableError name) >>= deref
-> Evaluator address value effects address
variable name = lookupEnv name >>= maybeM (freeVariableError name)
-- Garbage collection

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

@ -26,33 +26,33 @@ import Data.Language
import Prologue
-- | Retrieve an evaluated module, if any. The outer 'Maybe' indicates whether we’ve begun loading the module or not, while the inner 'Maybe' indicates whether we’ve completed loading it or not. Thus, @Nothing@ means we’ve never tried to load it, @Just Nothing@ means we’ve started but haven’t yet finished loading it, and @Just (Just (env, value))@ indicates the result of a completed load.
lookupModule :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Maybe (value, Environment address)))
lookupModule = send . Lookup
lookupModule :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Maybe (address, Environment address)))
lookupModule = sendModules . Lookup
-- | Resolve a list of module paths to a possible module table entry.
resolve :: Member (Modules address value) effects => [FilePath] -> Evaluator address value effects (Maybe ModulePath)
resolve = sendModules . Resolve
resolve :: forall address value effects . Member (Modules address value) effects => [FilePath] -> Evaluator address value effects (Maybe ModulePath)
resolve = sendModules . Resolve @address @value
listModulesInDir :: Member (Modules address value) effects => FilePath -> Evaluator address value effects [ModulePath]
listModulesInDir = sendModules . List
listModulesInDir :: forall address value effects . Member (Modules address value) effects => FilePath -> Evaluator address value effects [ModulePath]
listModulesInDir = sendModules . List @address @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.
require :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (value, Environment address))
require :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address))
require path = lookupModule path >>= maybeM (load path)
-- | Load another module by name and return its environment and value.
--
-- Always loads/evaluates.
load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (value, Environment address))
load path = send (Load path)
load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address))
load path = sendModules (Load path)
data Modules address value return where
Load :: ModulePath -> Modules address value (Maybe (value, Environment address))
Lookup :: ModulePath -> Modules address value (Maybe (Maybe (value, Environment address)))
Load :: ModulePath -> Modules address value (Maybe (address, Environment address))
Lookup :: ModulePath -> Modules address value (Maybe (Maybe (address, Environment address)))
Resolve :: [FilePath] -> Modules address value (Maybe ModulePath)
List :: FilePath -> Modules address value [ModulePath]
@ -61,10 +61,10 @@ sendModules = send
runModules :: forall term address value effects a
. ( Member (Resumable (LoadError address value)) effects
, Member (State (ModuleTable (Maybe (value, Environment address)))) effects
, Member (State (ModuleTable (Maybe (address, Environment address)))) effects
, Member Trace effects
)
=> (Module term -> Evaluator address value (Modules address value ': effects) (value, Environment address))
=> (Module term -> Evaluator address value (Modules address value ': effects) (address, Environment address))
-> Evaluator address value (Modules address value ': effects) a
-> Evaluator address value (Reader (ModuleTable (NonEmpty (Module term))) ': effects) a
runModules evaluateModule = go
@ -89,17 +89,17 @@ runModules evaluateModule = go
pure (find isMember names)
List dir -> modulePathsInDir dir <$> askModuleTable @term)
getModuleTable :: Member (State (ModuleTable (Maybe (value, Environment address)))) effects => Evaluator address value effects (ModuleTable (Maybe (value, Environment address)))
getModuleTable :: Member (State (ModuleTable (Maybe (address, Environment address)))) effects => Evaluator address value effects (ModuleTable (Maybe (address, Environment address)))
getModuleTable = get
cacheModule :: Member (State (ModuleTable (Maybe (value, Environment address)))) effects => ModulePath -> Maybe (value, Environment address) -> Evaluator address value effects (Maybe (value, Environment address))
cacheModule :: Member (State (ModuleTable (Maybe (address, Environment address)))) effects => ModulePath -> Maybe (address, Environment address) -> Evaluator address value effects (Maybe (address, Environment address))
cacheModule path result = modify' (ModuleTable.insert path result) $> result
askModuleTable :: Member (Reader (ModuleTable (NonEmpty (Module term)))) effects => Evaluator address value effects (ModuleTable (NonEmpty (Module term)))
askModuleTable = ask
newtype Merging m address value = Merging { runMerging :: m (Maybe (value, Environment address)) }
newtype Merging m address value = Merging { runMerging :: m (Maybe (address, Environment address)) }
instance Applicative m => Semigroup (Merging m address value) where
Merging a <> Merging b = Merging (merge <$> a <*> b)
@ -113,7 +113,7 @@ instance Applicative m => Monoid (Merging m address value) where
-- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name.
data LoadError address value resume where
ModuleNotFound :: ModulePath -> LoadError address value (Maybe (value, Environment address))
ModuleNotFound :: ModulePath -> LoadError address value (Maybe (address, Environment address))
deriving instance Eq (LoadError address value resume)
deriving instance Show (LoadError address value resume)
@ -122,8 +122,8 @@ instance Show1 (LoadError address value) where
instance Eq1 (LoadError address value) where
liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b
moduleNotFound :: Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (value, Environment address))
moduleNotFound = throwResumable . ModuleNotFound
moduleNotFound :: forall address value effects . Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address))
moduleNotFound = throwResumable . ModuleNotFound @address @value
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 = catchResumable

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

@ -26,7 +26,7 @@ builtin s def = withCurrentCallStack callStack $ do
def >>= assign addr
lambda :: (AbstractFunction address value effects, Member Fresh effects)
=> (Name -> Evaluator address value effects value)
=> (Name -> Evaluator address value effects address)
-> Evaluator address value effects value
lambda body = do
var <- nameI <$> fresh
@ -44,4 +44,4 @@ defineBuiltins :: ( AbstractValue address value effects
)
=> Evaluator address value effects ()
defineBuiltins =
builtin "print" (lambda (\ v -> variable v >>= asString >>= trace . unpack >> pure unit))
builtin "print" (lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit))

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

@ -10,8 +10,11 @@ module Control.Abstract.Value
, forLoop
, makeNamespace
, evaluateInScopedEnv
, address
, value
, rvalBox
, subtermValue
, subtermAddress
) where
import Control.Abstract.Environment
@ -40,10 +43,10 @@ class Show value => AbstractFunction address value effects where
-- | Build a closure (a binder like a lambda or method definition).
closure :: [Name] -- ^ The parameter names.
-> Set Name -- ^ The set of free variables to close over.
-> Evaluator address value effects value -- ^ The evaluator for the body of the closure.
-> Evaluator address value effects address -- ^ The evaluator for the body of the closure.
-> Evaluator address value effects value
-- | Evaluate an application (like a function call).
call :: value -> [Evaluator address value effects value] -> Evaluator address value effects value
call :: value -> [Evaluator address value effects address] -> Evaluator address value effects address
class Show value => AbstractIntro value where
@ -203,8 +206,8 @@ evaluateInScopedEnv :: ( AbstractValue address value effects
, Member (Env address) effects
)
=> Evaluator address value effects value
-> Evaluator address value effects value
-> Evaluator address value effects value
-> Evaluator address value effects a
-> Evaluator address value effects a
evaluateInScopedEnv scopedEnvTerm term = do
scopedEnv <- scopedEnvTerm >>= scopedEnvironment
maybe term (\ env -> locally (bindAll env *> term)) scopedEnv
@ -216,11 +219,9 @@ value :: ( AbstractValue address value effects
, Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
)
=> ValueRef value
=> ValueRef address
-> Evaluator address value effects value
value (LvalLocal var) = variable var
value (LvalMember obj prop) = evaluateInScopedEnv (pure obj) (variable prop)
value (Rval val) = pure val
value = deref <=< address
-- | Evaluates a 'Subterm' to its rval
subtermValue :: ( AbstractValue address value effects
@ -228,6 +229,34 @@ subtermValue :: ( AbstractValue address value effects
, Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
)
=> Subterm term (Evaluator address value effects (ValueRef value))
=> Subterm term (Evaluator address value effects (ValueRef address))
-> Evaluator address value effects value
subtermValue = value <=< subtermRef
-- | Returns the address of a value referenced by a 'ValueRef'
address :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
)
=> ValueRef address
-> Evaluator address value effects address
address (LvalLocal var) = variable var
address (LvalMember obj prop) = evaluateInScopedEnv (deref obj) (variable prop)
address (Rval addr) = pure addr
-- | Evaluates a 'Subterm' to the address of its rval
subtermAddress :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
)
=> Subterm term (Evaluator address value effects (ValueRef address))
-> Evaluator address value effects address
subtermAddress = address <=< subtermRef
-- | Convenience function for boxing a raw value and wrapping it in an Rval
rvalBox :: Member (Allocator address value) effects
=> value
-> Evaluator address value effects (ValueRef address)
rvalBox val = Rval <$> box val

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

@ -13,7 +13,7 @@ newtype Cache term address cell value = Cache { unCache :: Monoidal.Map (Configu
deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address cell value, Cached address cell value), Semigroup)
data Cached address cell value = Cached
{ cachedValue :: ValueRef value
{ cachedValue :: ValueRef address
, cachedHeap :: Heap address cell value
}
deriving (Eq, Ord, Show)

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

@ -46,7 +46,7 @@ class Show1 constr => Evaluatable constr where
, FreeVariables term
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (LoopControl value) effects
, Member (LoopControl address value) effects
, Member (Modules address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
@ -55,11 +55,11 @@ class Show1 constr => Evaluatable constr where
, Member (Resumable EvalError) effects
, Member (Resumable ResolutionError) effects
, Member (Resumable (Unspecialized value)) effects
, Member (Return value) effects
, Member (Return address value) effects
, Member Trace effects
)
=> SubtermAlgebra constr term (Evaluator address value effects (ValueRef value))
eval expr = throwResumable (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
=> SubtermAlgebra constr term (Evaluator address value effects (ValueRef address))
eval expr = rvalBox =<< throwResumable (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
-- | Evaluate a given package.
@ -79,19 +79,19 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer
, Member (Resumable ResolutionError) outer
, Member (Resumable (Unspecialized value)) outer
, Member (State (Heap address (Cell address) value)) outer
, Member (State (ModuleTable (Maybe (value, Environment address)))) outer
, Member (State (ModuleTable (Maybe (address, Environment address)))) outer
, Member Trace outer
, Recursive term
, Reducer value (Cell address value)
, ValueRoots address value
, inner ~ (LoopControl value ': Return value ': Env address ': Allocator address value ': inner')
, inner ~ (LoopControl address value ': Return address value ': Env address ': Allocator address value ': inner')
, inner' ~ (Reader ModuleInfo ': inner'')
, inner'' ~ (Modules address value ': Reader Span ': Reader PackageInfo ': outer)
)
=> (SubtermAlgebra Module term (TermEvaluator term address value inner value) -> SubtermAlgebra Module term (TermEvaluator term address value inner value))
-> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value)))
=> (SubtermAlgebra Module term (TermEvaluator term address value inner address) -> SubtermAlgebra Module term (TermEvaluator term address value inner address))
-> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address)))
-> Package term
-> TermEvaluator term address value outer [(value, Environment address)]
-> TermEvaluator term address value outer [(address, Environment address)]
evaluatePackageWith analyzeModule analyzeTerm package
= runReader (packageInfo package)
. runReader lowerBound
@ -106,7 +106,7 @@ evaluatePackageWith analyzeModule analyzeTerm package
= runInModule preludeEnv (moduleInfo m)
. analyzeModule (subtermRef . moduleBody)
$ evalTerm <$> m
evalTerm term = Subterm term (TermEvaluator (value =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term)))
evalTerm term = Subterm term (TermEvaluator (address =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term)))
runInModule preludeEnv info
= runReader info
@ -115,14 +115,15 @@ evaluatePackageWith analyzeModule analyzeTerm package
. raiseHandler runReturn
. raiseHandler runLoopControl
evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' (value, Environment address)
evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' (address, Environment address)
evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do
(value, env) <- fromMaybe (unit, emptyEnv) <$> require m
addr <- box unit -- TODO don't *always* allocate - use maybeM instead
(ptr, env) <- fromMaybe (addr, emptyEnv) <$> require m
bindAll env
maybe (pure value) ((`call` []) <=< variable) sym
maybe (pure ptr) ((`call` []) <=< deref <=< variable) sym
evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule emptyEnv)) $ do
(_, builtinsEnv) <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit))
(_, builtinsEnv) <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins *> box unit))
second (mergeEnvs builtinsEnv) <$> evalModule builtinsEnv prelude
withPrelude Nothing f = f emptyEnv
@ -173,7 +174,7 @@ runEvalErrorWith = runResumableWith
data Unspecialized a b where
Unspecialized :: String -> Unspecialized value (ValueRef value)
Unspecialized :: String -> Unspecialized value value
deriving instance Eq (Unspecialized a b)
deriving instance Show (Unspecialized a b)
@ -211,4 +212,4 @@ instance (Evaluatable s, Show a) => Evaluatable (TermF s a) where
-- 3. Only the last statement’s return value is returned.
instance Evaluatable [] where
-- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists.
eval = maybe (pure (Rval unit)) (runApp . foldMap1 (App . subtermRef)) . nonEmpty
eval = maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) . nonEmpty

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

@ -4,13 +4,13 @@ module Data.Abstract.Ref where
import Data.Abstract.Name
-- | 'ValueRef' is the type subterms evaluate to and can represent either values directly ('Rval'), or references to values (lvals - such as local variables or object members)
data ValueRef value where
data ValueRef address where
-- | A value.
Rval :: value -> ValueRef value
Rval :: address -> ValueRef address
-- | A local variable. No environment is attached—it’s assumed that 'LvalLocal' will be evaluated in the same scope it was constructed in.
LvalLocal :: Name -> ValueRef value
LvalLocal :: Name -> ValueRef address
-- | An object member.
LvalMember :: value -> Name -> ValueRef value
LvalMember :: address -> Name -> ValueRef address
deriving (Eq, Ord, Show)

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

@ -119,7 +119,7 @@ instance ( Member (Allocator address Type) effects
, Member (Env address) effects
, Member Fresh effects
, Member (Resumable TypeError) effects
, Member (Return Type) effects
, Member (Return address Type) effects
)
=> AbstractFunction address Type effects where
closure names _ body = do
@ -128,16 +128,16 @@ instance ( Member (Allocator address Type) effects
tvar <- Var <$> fresh
assign addr tvar
bimap (Env.insert name addr) (tvar :) <$> rest) (pure (emptyEnv, [])) names
(zeroOrMoreProduct tvars :->) <$> locally (bindAll env *> body `catchReturn` \ (Return value) -> pure value)
(zeroOrMoreProduct tvars :->) <$> (deref =<< locally (bindAll env *> body `catchReturn` \ (Return ptr) -> pure ptr))
call op params = do
tvar <- fresh
paramTypes <- sequenceA params
paramTypes <- traverse (>>= deref) params
let needed = zeroOrMoreProduct paramTypes :-> Var tvar
unified <- op `unify` needed
case unified of
_ :-> ret -> pure ret
gotten -> throwResumable (UnificationError needed gotten)
_ :-> ret -> box ret
gotten -> box =<< throwResumable (UnificationError needed gotten)
-- | Discard the value arguments (if any), constructing a 'Type' instead.
@ -146,7 +146,7 @@ instance ( Member (Allocator address Type) effects
, Member Fresh effects
, Member NonDet effects
, Member (Resumable TypeError) effects
, Member (Return Type) effects
, Member (Return address Type) effects
)
=> AbstractValue address Type effects where
array fields = do

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

@ -32,7 +32,7 @@ data Value address body
| Hole
deriving (Eq, Ord, Show)
data ClosureBody address body = ClosureBody { closureBodyId :: Int, closureBody :: body (Value address body) }
data ClosureBody address body = ClosureBody { closureBodyId :: Int, closureBody :: body address }
instance Eq (ClosureBody address body) where
(==) = (==) `on` closureBodyId
@ -60,7 +60,7 @@ instance ( Coercible body (Eff effects)
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable (ValueError address body)) effects
, Member (Return (Value address body)) effects
, Member (Return address (Value address body)) effects
, Show address
)
=> AbstractFunction address (Value address body) effects where
@ -77,12 +77,10 @@ instance ( Coercible body (Eff effects)
-- charge them to the closure's origin.
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
bindings <- foldr (\ (name, param) rest -> do
value <- param
addr <- alloc name
assign addr value
addr <- param
Env.insert name addr <$> rest) (pure env) (zip names params)
locally (bindAll bindings *> raiseEff (coerce body) `catchReturn` \ (Return value) -> pure value)
_ -> throwValueError (CallError op)
locally (bindAll bindings *> raiseEff (coerce body) `catchReturn` \ (Return ptr) -> pure ptr)
_ -> box =<< throwValueError (CallError op)
instance Show address => AbstractIntro (Value address body) where
@ -107,11 +105,11 @@ instance ( Coercible body (Eff effects)
, Member (Allocator address (Value address body)) effects
, Member (Env address) effects
, Member Fresh effects
, Member (LoopControl (Value address body)) effects
, Member (LoopControl address (Value address body)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable (ValueError address body)) effects
, Member (Return (Value address body)) effects
, Member (Return address (Value address body)) effects
, Show address
)
=> AbstractValue address (Value address body) effects where
@ -218,7 +216,7 @@ instance ( Coercible body (Eff effects)
where pair = (left, right)
loop x = catchLoopControl (fix x) (\ control -> case control of
Break value -> pure value
Break value -> deref value
-- FIXME: Figure out how to deal with this. Ruby treats this as the result of the current block iteration, while PHP specifies a breakout level and TypeScript appears to take a label.
Continue _ -> loop x)

2
src/Data/Syntax.hs
View File

@ -170,7 +170,7 @@ instance Ord1 Empty where liftCompare _ _ _ = EQ
instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
instance Evaluatable Empty where
eval _ = pure (Rval unit)
eval _ = rvalBox unit
-- | Syntax representing a parsing or assignment error.
data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] }

2
src/Data/Syntax/Comment.hs
View File

@ -15,7 +15,7 @@ instance Ord1 Comment where liftCompare = genericLiftCompare
instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Comment where
eval _ = pure (Rval unit)
eval _ = rvalBox unit
-- TODO: nested comment types
-- TODO: documentation comment types

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

@ -24,8 +24,9 @@ instance Show1 Function where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Function where
eval Function{..} = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm functionName)
(v, addr) <- letrec name (closure (paramNames functionParameters) (Set.fromList (freeVariables functionBody)) (subtermValue functionBody))
Rval v <$ bind name addr
(_, addr) <- letrec name (closure (paramNames functionParameters) (Set.fromList (freeVariables functionBody)) (subtermAddress functionBody))
bind name addr
pure (Rval addr)
where paramNames = foldMap (freeVariables . subterm)
instance Declarations a => Declarations (Function a) where
@ -47,8 +48,9 @@ instance Diffable Method where
instance Evaluatable Method where
eval Method{..} = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm methodName)
(v, addr) <- letrec name (closure (paramNames methodParameters) (Set.fromList (freeVariables methodBody)) (subtermValue methodBody))
Rval v <$ bind name addr
(_, addr) <- letrec name (closure (paramNames methodParameters) (Set.fromList (freeVariables methodBody)) (subtermAddress methodBody))
bind name addr
pure (Rval addr)
where paramNames = foldMap (freeVariables . subterm)
@ -98,8 +100,8 @@ instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare
instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable VariableDeclaration where
eval (VariableDeclaration []) = pure (Rval unit)
eval (VariableDeclaration decs) = Rval . multiple <$> traverse subtermValue decs
eval (VariableDeclaration []) = rvalBox unit
eval (VariableDeclaration decs) = rvalBox =<< (multiple <$> traverse subtermValue decs)
instance Declarations a => Declarations (VariableDeclaration a) where
declaredName (VariableDeclaration vars) = case vars of
@ -165,7 +167,7 @@ instance Evaluatable Class where
void $ subtermValue classBody
classEnv <- Env.head <$> getEnv
klass name supers classEnv
Rval v <$ bind name addr
rvalBox =<< (v <$ bind name addr)
-- | A decorator in Python
data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a }
@ -244,7 +246,7 @@ instance Evaluatable TypeAlias where
v <- subtermValue typeAliasKind
addr <- lookupOrAlloc name
assign addr v
Rval v <$ bind name addr
rvalBox =<< (v <$ bind name addr)
instance Declarations a => Declarations (TypeAlias a) where
declaredName TypeAlias{..} = declaredName typeAliasIdentifier

4
src/Data/Syntax/Directive.hs
View File

@ -18,7 +18,7 @@ instance Ord1 File where liftCompare = genericLiftCompare
instance Show1 File where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable File where
eval File = Rval . string . T.pack . modulePath <$> currentModule
eval File = rvalBox =<< (string . T.pack . modulePath <$> currentModule)
-- A line directive like the Ruby constant `__LINE__`.
@ -30,4 +30,4 @@ instance Ord1 Line where liftCompare = genericLiftCompare
instance Show1 Line where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Line where
eval Line = Rval . integer . fromIntegral . posLine . spanStart <$> currentSpan
eval Line = rvalBox =<< (integer . fromIntegral . posLine . spanStart <$> currentSpan)

20
src/Data/Syntax/Expression.hs
View File

@ -19,7 +19,7 @@ instance Show1 Call where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Call where
eval Call{..} = do
op <- subtermValue callFunction
Rval <$> call op (map subtermValue callParams)
Rval <$> call op (map subtermAddress callParams)
data Comparison a
= LessThan !a !a
@ -36,7 +36,7 @@ instance Ord1 Comparison where liftCompare = genericLiftCompare
instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Comparison where
eval t = Rval <$> (traverse subtermValue t >>= go) where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
go x = case x of
(LessThan a b) -> liftComparison (Concrete (<)) a b
(LessThanEqual a b) -> liftComparison (Concrete (<=)) a b
@ -65,7 +65,7 @@ instance Ord1 Arithmetic where liftCompare = genericLiftCompare
instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Arithmetic where
eval t = Rval <$> (traverse subtermValue t >>= go) where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
go (Plus a b) = liftNumeric2 add a b where add = liftReal (+)
go (Minus a b) = liftNumeric2 sub a b where sub = liftReal (-)
go (Times a b) = liftNumeric2 mul a b where mul = liftReal (*)
@ -102,7 +102,7 @@ instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Boolean where
-- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands
eval t = Rval <$> go (fmap subtermValue t) where
eval t = rvalBox =<< go (fmap subtermValue t) where
go (And a b) = do
cond <- a
ifthenelse cond b (pure cond)
@ -176,7 +176,7 @@ instance Ord1 Bitwise where liftCompare = genericLiftCompare
instance Show1 Bitwise where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Bitwise where
eval t = Rval <$> (traverse subtermValue t >>= go) where
eval t = rvalBox =<< (traverse subtermValue t >>= go) where
genLShift x y = shiftL x (fromIntegral y)
genRShift x y = shiftR x (fromIntegral y)
go x = case x of
@ -199,8 +199,8 @@ instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable MemberAccess where
eval (MemberAccess obj propName) = do
obj' <- subtermValue obj
pure $! LvalMember obj' propName
ptr <- subtermAddress obj
pure $! LvalMember ptr propName
-- | Subscript (e.g a[1])
data Subscript a
@ -215,9 +215,9 @@ instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
-- TODO: Finish Eval instance for Subscript
-- TODO return a special LvalSubscript instance here
instance Evaluatable Subscript where
eval (Subscript l [r]) = Rval <$> join (index <$> subtermValue l <*> subtermValue r)
eval (Subscript _ _) = throwResumable (Unspecialized "Eval unspecialized for subscript with slices")
eval (Member _ _) = throwResumable (Unspecialized "Eval unspecialized for member access")
eval (Subscript l [r]) = rvalBox =<< join (index <$> subtermValue l <*> subtermValue r)
eval (Subscript _ _) = rvalBox =<< throwResumable (Unspecialized "Eval unspecialized for subscript with slices")
eval (Member _ _) = rvalBox =<< throwResumable (Unspecialized "Eval unspecialized for member access")
-- | Enumeration (e.g. a[1:10:1] in Python (start at index 1, stop at index 10, step 1 element from start to stop))

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

@ -27,7 +27,7 @@ instance Ord1 Boolean where liftCompare = genericLiftCompare
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Boolean where
eval (Boolean x) = pure (Rval (boolean x))
eval (Boolean x) = rvalBox (boolean x)
-- Numeric
@ -42,7 +42,7 @@ instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShow
instance Evaluatable Data.Syntax.Literal.Integer where
-- TODO: We should use something more robust than shelling out to readMaybe.
eval (Data.Syntax.Literal.Integer x) =
Rval . integer <$> maybeM (throwEvalError (IntegerFormatError x)) (readMaybe (T.unpack x))
rvalBox =<< integer <$> maybeM (throwEvalError (IntegerFormatError x)) (readMaybe (T.unpack x))
-- | A literal float of unspecified width.
@ -55,7 +55,7 @@ instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsP
instance Evaluatable Data.Syntax.Literal.Float where
eval (Float s) =
Rval . float <$> either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s)
rvalBox =<< (float <$> either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s))
-- Rational literals e.g. `2/3r`
newtype Rational a = Rational Text
@ -70,7 +70,7 @@ instance Evaluatable Data.Syntax.Literal.Rational where
let
trimmed = T.takeWhile (/= 'r') r
parsed = readMaybe @Prelude.Integer (T.unpack trimmed)
in Rval . rational <$> maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed
in rvalBox =<< (rational <$> maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed)
-- Complex literals e.g. `3 + 2i`
newtype Complex a = Complex Text
@ -126,7 +126,7 @@ instance Ord1 TextElement where liftCompare = genericLiftCompare
instance Show1 TextElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TextElement where
eval (TextElement x) = pure (Rval (string x))
eval (TextElement x) = rvalBox (string x)
data Null a = Null
deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1)
@ -135,7 +135,7 @@ instance Eq1 Null where liftEq = genericLiftEq
instance Ord1 Null where liftCompare = genericLiftCompare
instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Null where eval _ = pure (Rval null)
instance Evaluatable Null where eval _ = rvalBox null
newtype Symbol a = Symbol { symbolContent :: Text }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
@ -145,7 +145,7 @@ instance Ord1 Symbol where liftCompare = genericLiftCompare
instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Symbol where
eval (Symbol s) = pure (Rval (symbol s))
eval (Symbol s) = rvalBox (symbol s)
newtype Regex a = Regex { regexContent :: Text }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1)
@ -169,7 +169,7 @@ instance Ord1 Array where liftCompare = genericLiftCompare
instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Array where
eval (Array a) = Rval <$> (array =<< traverse subtermValue a)
eval (Array a) = rvalBox =<< (array =<< traverse subtermValue a)
newtype Hash a = Hash { hashElements :: [a] }
deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1)
@ -179,7 +179,7 @@ instance Ord1 Hash where liftCompare = genericLiftCompare
instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Hash where
eval t = Rval . hash <$> traverse (subtermValue >=> asPair) (hashElements t)
eval t = rvalBox =<< (hash <$> traverse (subtermValue >=> asPair) (hashElements t))
data KeyValue a = KeyValue { key :: !a, value :: !a }
deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1)
@ -190,7 +190,7 @@ instance Show1 KeyValue where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable KeyValue where
eval (fmap subtermValue -> KeyValue{..}) =
Rval <$> (kvPair <$> key <*> value)
rvalBox =<< (kvPair <$> key <*> value)
newtype Tuple a = Tuple { tupleContents :: [a] }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
@ -200,7 +200,7 @@ instance Ord1 Tuple where liftCompare = genericLiftCompare
instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Tuple where
eval (Tuple cs) = Rval . multiple <$> traverse subtermValue cs
eval (Tuple cs) = rvalBox =<< (multiple <$> traverse subtermValue cs)
newtype Set a = Set { setElements :: [a] }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)

22
src/Data/Syntax/Statement.hs
View File

@ -24,7 +24,7 @@ instance Show1 Statements where liftShowsPrec = genericLiftShowsPrec
instance ToJSON1 Statements
instance Evaluatable Statements where
eval (Statements xs) = maybe (pure (Rval unit)) (runApp . foldMap1 (App . subtermRef)) (nonEmpty xs)
eval (Statements xs) = maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) (nonEmpty xs)
-- | Conditional. This must have an else block, which can be filled with some default value when omitted in the source, e.g. 'pure ()' for C-style if-without-else or 'pure Nothing' for Ruby-style, in both cases assuming some appropriate Applicative context into which the If will be lifted.
data If a = If { ifCondition :: !a, ifThenBody :: !a, ifElseBody :: !a }
@ -37,7 +37,7 @@ instance Show1 If where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable If where
eval (If cond if' else') = do
bool <- subtermValue cond
Rval <$> ifthenelse bool (subtermValue if') (subtermValue else')
rvalBox =<< ifthenelse bool (subtermValue if') (subtermValue else')
-- | Else statement. The else condition is any term, that upon successful completion, continues evaluation to the elseBody, e.g. `for ... else` in Python.
data Else a = Else { elseCondition :: !a, elseBody :: !a }
@ -100,7 +100,7 @@ instance Evaluatable Let where
eval Let{..} = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm letVariable)
addr <- snd <$> letrec name (subtermValue letValue)
Rval <$> locally (bind name addr *> subtermValue letBody)
rvalBox =<< locally (bind name addr *> subtermValue letBody)
-- Assignment
@ -130,7 +130,7 @@ instance Evaluatable Assignment where
-- the left hand side of the assignment expression is invalid:
pure ()
pure (Rval rhs)
rvalBox rhs
-- | Post increment operator (e.g. 1++ in Go, or i++ in C).
newtype PostIncrement a = PostIncrement a
@ -189,7 +189,7 @@ instance Ord1 Return where liftCompare = genericLiftCompare
instance Show1 Return where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Return where
eval (Return x) = Rval <$> (subtermValue x >>= earlyReturn)
eval (Return x) = Rval <$> (subtermAddress x >>= earlyReturn)
newtype Yield a = Yield a
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
@ -210,7 +210,7 @@ instance Ord1 Break where liftCompare = genericLiftCompare
instance Show1 Break where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Break where
eval (Break x) = Rval <$> (subtermValue x >>= throwBreak)
eval (Break x) = Rval <$> (subtermAddress x >>= throwBreak)
newtype Continue a = Continue a
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
@ -220,7 +220,7 @@ instance Ord1 Continue where liftCompare = genericLiftCompare
instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Continue where
eval (Continue a) = Rval <$> (subtermValue a >>= throwContinue)
eval (Continue x) = Rval <$> (subtermAddress x >>= throwContinue)
newtype Retry a = Retry a
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
@ -241,7 +241,7 @@ instance Ord1 NoOp where liftCompare = genericLiftCompare
instance Show1 NoOp where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NoOp where
eval _ = pure (Rval unit)
eval _ = rvalBox unit
-- Loops
@ -253,7 +253,7 @@ instance Ord1 For where liftCompare = genericLiftCompare
instance Show1 For where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable For where
eval (fmap subtermValue -> For before cond step body) = Rval <$> forLoop before cond step body
eval (fmap subtermValue -> For before cond step body) = rvalBox =<< forLoop before cond step body
data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a }
@ -275,7 +275,7 @@ instance Ord1 While where liftCompare = genericLiftCompare
instance Show1 While where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable While where
eval While{..} = Rval <$> while (subtermValue whileCondition) (subtermValue whileBody)
eval While{..} = rvalBox =<< while (subtermValue whileCondition) (subtermValue whileBody)
data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
@ -285,7 +285,7 @@ instance Ord1 DoWhile where liftCompare = genericLiftCompare
instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable DoWhile where
eval DoWhile{..} = Rval <$> doWhile (subtermValue doWhileBody) (subtermValue doWhileCondition)
eval DoWhile{..} = rvalBox =<< doWhile (subtermValue doWhileBody) (subtermValue doWhileCondition)
-- Exception handling

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

@ -68,7 +68,7 @@ instance Evaluatable Import where
traceResolve (unPath importPath) path
importedEnv <- maybe emptyEnv snd <$> require path
bindAll importedEnv
pure (Rval unit)
rvalBox unit
-- | Qualified Import declarations (symbols are qualified in calling environment).
@ -91,7 +91,7 @@ instance Evaluatable QualifiedImport where
importedEnv <- maybe emptyEnv snd <$> require p
bindAll importedEnv
makeNamespace alias addr Nothing
pure (Rval unit)
rvalBox unit
-- | Side effect only imports (no symbols made available to the calling environment).
data SideEffectImport a = SideEffectImport { sideEffectImportFrom :: !ImportPath, sideEffectImportToken :: !a }
@ -106,7 +106,7 @@ instance Evaluatable SideEffectImport where
paths <- resolveGoImport importPath
traceResolve (unPath importPath) paths
for_ paths require
pure (Rval unit)
rvalBox unit
-- A composite literal in Go
data Composite a = Composite { compositeType :: !a, compositeElement :: !a }

2
src/Language/Java/Assignment.hs
View File

@ -270,6 +270,7 @@ method = makeTerm <$> symbol MethodDeclaration <*> children (makeMethod <$> many
methodDeclarator = symbol MethodDeclarator *> children ( (,) <$> identifier <*> formalParameters)
methodHeader = symbol MethodHeader *> children ((,,,,) <$> (typeParameters <|> pure []) <*> manyTerm annotation <*> type' <*> methodDeclarator <*> (throws <|> pure []))
makeMethod modifiers receiver (typeParams, annotations, returnType, (name, params), throws) = Declaration.Method (returnType : modifiers ++ typeParams ++ annotations ++ throws) receiver name params
-- methodHeader needs to include typeParameters (it does)
generic :: Assignment
generic = makeTerm <$> symbol Grammar.GenericType <*> children(Java.Syntax.GenericType <$> term type' <*> manyTerm type')
@ -331,6 +332,7 @@ type' = choice [
, wildcard
, identifier
, generic
, typeArgument
]
where array = foldl (\into each -> makeTerm1 (Type.Array (Just each) into))

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

@ -1,4 +1,4 @@
{-# LANGUAGE DeriveAnyClass, ViewPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
module Language.PHP.Syntax where
import Data.Abstract.Evaluatable
@ -54,14 +54,15 @@ include :: ( AbstractValue address value effects
, Member (Resumable (EnvironmentError address)) effects
, Member Trace effects
)
=> Subterm term (Evaluator address value effects (ValueRef value))
-> (ModulePath -> Evaluator address value effects (Maybe (value, Environment address)))
-> Evaluator address value effects (ValueRef value)
=> Subterm term (Evaluator address value effects (ValueRef address))
-> (ModulePath -> Evaluator address value effects (Maybe (address, Environment address)))
-> Evaluator address value effects (ValueRef address)
include pathTerm f = do
name <- subtermValue pathTerm >>= asString
path <- resolvePHPName name
traceResolve name path
(v, importedEnv) <- fromMaybe (unit, emptyEnv) <$> f path
unitPtr <- box unit -- TODO don't always allocate, use maybeM
(v, importedEnv) <- fromMaybe (unitPtr, emptyEnv) <$> f path
bindAll importedEnv
pure (Rval v)
@ -200,7 +201,7 @@ instance Ord1 QualifiedName where liftCompare = genericLiftCompare
instance Show1 QualifiedName where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable QualifiedName where
eval (fmap subtermValue -> QualifiedName name iden) = Rval <$> evaluateInScopedEnv name iden
eval (QualifiedName name iden) = Rval <$> evaluateInScopedEnv (subtermValue name) (subtermAddress iden)
newtype NamespaceName a = NamespaceName (NonEmpty a)
deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1)
@ -211,7 +212,8 @@ instance Ord1 NamespaceName where liftCompare = genericLiftCompare
instance Show1 NamespaceName where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NamespaceName where
eval (NamespaceName xs) = Rval <$> foldl1 evaluateInScopedEnv (fmap subtermValue xs)
eval (NamespaceName xs) = Rval <$> foldl1 f (fmap subtermAddress xs)
where f ns = evaluateInScopedEnv (ns >>= deref)
newtype ConstDeclaration a = ConstDeclaration [a]
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
@ -366,7 +368,7 @@ instance Ord1 Namespace where liftCompare = genericLiftCompare
instance Show1 Namespace where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Namespace where
eval Namespace{..} = Rval <$> go (freeVariables (subterm namespaceName))
eval Namespace{..} = rvalBox =<< go (freeVariables (subterm namespaceName))
where
-- Each namespace name creates a closure over the subsequent namespace closures
go (name:x:xs) = letrec' name $ \addr ->

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

@ -99,7 +99,7 @@ instance Evaluatable Import where
-- This is a bit of a special case in the syntax as this actually behaves like a qualified relative import.
eval (Import (RelativeQualifiedName n Nothing) [(name, _)]) = do
path <- NonEmpty.last <$> resolvePythonModules (RelativeQualifiedName n (Just (qualifiedName (formatName name :| []))))
Rval <$> evalQualifiedImport name path
rvalBox =<< evalQualifiedImport name path
-- from a import b
-- from a import b as c
@ -115,7 +115,7 @@ instance Evaluatable Import where
let path = NonEmpty.last modulePaths
importedEnv <- maybe emptyEnv snd <$> require path
bindAll (select importedEnv)
pure (Rval unit)
rvalBox unit
where
select importedEnv
| Prologue.null xs = importedEnv
@ -145,7 +145,7 @@ instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable QualifiedImport where
eval (QualifiedImport qualifiedName) = do
modulePaths <- resolvePythonModules (QualifiedName qualifiedName)
Rval <$> go (NonEmpty.zip (name . T.pack <$> qualifiedName) modulePaths)
rvalBox =<< go (NonEmpty.zip (name . T.pack <$> qualifiedName) modulePaths)
where
-- Evaluate and import the last module, updating the environment
go ((name, path) :| []) = evalQualifiedImport name path
@ -172,7 +172,7 @@ instance Evaluatable QualifiedAliasedImport where
-- Evaluate and import the last module, aliasing and updating the environment
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
Rval <$> letrec' alias (\addr -> do
rvalBox =<< letrec' alias (\addr -> do
let path = NonEmpty.last modulePaths
importedEnv <- maybe emptyEnv snd <$> require path
bindAll importedEnv

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

@ -51,10 +51,10 @@ instance Show1 Send where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Send where
eval Send{..} = do
let sel = case sendSelector of
Just sel -> subtermValue sel
Just sel -> subtermAddress sel
Nothing -> variable (name "call")
func <- maybe sel (flip evaluateInScopedEnv sel . subtermValue) sendReceiver
Rval <$> call func (map subtermValue sendArgs) -- TODO pass through sendBlock
func <- deref =<< maybe sel (flip evaluateInScopedEnv sel . subtermValue) sendReceiver
Rval <$> call func (map subtermAddress sendArgs) -- TODO pass through sendBlock
data Require a = Require { requireRelative :: Bool, requirePath :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
@ -70,7 +70,7 @@ instance Evaluatable Require where
traceResolve name path
(v, importedEnv) <- doRequire path
bindAll importedEnv
pure (Rval v) -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
rvalBox v -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
doRequire :: ( AbstractValue address value effects
, Member (Modules address value) effects
@ -94,11 +94,11 @@ instance Show1 Load where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Load where
eval (Load x Nothing) = do
path <- subtermValue x >>= asString
Rval <$> doLoad path False
rvalBox =<< doLoad path False
eval (Load x (Just wrap)) = do
path <- subtermValue x >>= asString
shouldWrap <- subtermValue wrap >>= asBool
Rval <$> doLoad path shouldWrap
rvalBox =<< doLoad path shouldWrap
doLoad :: ( AbstractValue address value effects
, Member (Env address) effects
@ -132,7 +132,7 @@ instance Evaluatable Class where
eval Class{..} = do
super <- traverse subtermValue classSuperClass
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm classIdentifier)
Rval <$> letrec' name (\addr ->
rvalBox =<< letrec' name (\addr ->
subtermValue classBody <* makeNamespace name addr super)
data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
@ -145,7 +145,7 @@ instance Show1 Module where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Module where
eval (Module iden xs) = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
Rval <$> letrec' name (\addr ->
rvalBox =<< letrec' name (\addr ->
value =<< (eval xs <* makeNamespace name addr Nothing))
data LowPrecedenceBoolean a
@ -155,7 +155,7 @@ data LowPrecedenceBoolean a
instance Evaluatable LowPrecedenceBoolean where
-- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands
eval t = Rval <$> go (fmap subtermValue t) where
eval t = rvalBox =<< go (fmap subtermValue t) where
go (LowAnd a b) = do
cond <- a
ifthenelse cond b (pure cond)

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

@ -155,7 +155,8 @@ instance Evaluatable Import where
eval (Import symbols importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
importedEnv <- maybe emptyEnv snd <$> require modulePath
bindAll (renamed importedEnv) $> Rval unit
bindAll (renamed importedEnv)
rvalBox unit
where
renamed importedEnv
| Prologue.null symbols = importedEnv
@ -172,7 +173,7 @@ instance Evaluatable JavaScriptRequire where
eval (JavaScriptRequire aliasTerm importPath) = do
modulePath <- resolveWithNodejsStrategy importPath javascriptExtensions
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
Rval <$> evalRequire modulePath alias
rvalBox =<< evalRequire modulePath alias
data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportAlias :: !a, qualifiedAliasedImportFrom :: ImportPath }
@ -186,7 +187,7 @@ instance Evaluatable QualifiedAliasedImport where
eval (QualifiedAliasedImport aliasTerm importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
Rval <$> evalRequire modulePath alias
rvalBox =<< evalRequire modulePath alias
newtype SideEffectImport a = SideEffectImport { sideEffectImportFrom :: ImportPath }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
@ -199,7 +200,7 @@ instance Evaluatable SideEffectImport where
eval (SideEffectImport importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
void $ require modulePath
pure (Rval unit)
rvalBox unit
-- | Qualified Export declarations
@ -215,7 +216,7 @@ instance Evaluatable QualifiedExport where
-- Insert the aliases with no addresses.
for_ exportSymbols $ \(name, alias) ->
export name alias Nothing
pure (Rval unit)
rvalBox unit
-- | Qualified Export declarations that export from another module.
@ -234,7 +235,7 @@ instance Evaluatable QualifiedExportFrom where
for_ exportSymbols $ \(name, alias) -> do
let address = Env.lookup name importedEnv
maybe (throwEvalError $ ExportError modulePath name) (export name alias . Just) address
pure (Rval unit)
rvalBox unit
newtype DefaultExport a = DefaultExport { defaultExport :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
@ -253,7 +254,7 @@ instance Evaluatable DefaultExport where
export name name Nothing
bind name addr
Nothing -> throwEvalError DefaultExportError
pure (Rval unit)
rvalBox unit
-- | Lookup type for a type-level key in a typescript map.
@ -652,7 +653,7 @@ instance Show1 Module where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Module where
eval (Module iden xs) = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
Rval <$> letrec' name (\addr ->
rvalBox =<< letrec' name (\addr ->
value =<< (eval xs <* makeNamespace name addr Nothing))
@ -667,7 +668,7 @@ instance Show1 InternalModule where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable InternalModule where
eval (InternalModule iden xs) = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
Rval <$> letrec' name (\addr ->
rvalBox =<< letrec' name (\addr ->
value =<< (eval xs <* makeNamespace name addr Nothing))
instance Declarations a => Declarations (InternalModule a) where
@ -723,7 +724,7 @@ instance Evaluatable AbstractClass where
void $ subtermValue classBody
classEnv <- Env.head <$> getEnv
klass name supers classEnv
Rval v <$ bind name addr
rvalBox =<< (v <$ bind name addr)
data JsxElement a = JsxElement { _jsxOpeningElement :: !a, _jsxElements :: ![a], _jsxClosingElement :: !a }

73
src/Semantic/Config.hs Normal file
View File

@ -0,0 +1,73 @@
module Semantic.Config where
import Network.BSD
import Network.HTTP.Client.TLS
import Network.URI
import Prologue
import Semantic.Haystack
import Semantic.Log
import Semantic.Stat
import System.Environment
import System.IO (stderr)
import System.Posix.Process
import System.Posix.Types
data Config
= Config
{ configAppName :: String -- ^ Application name (semantic)
, configHostName :: String -- ^ HostName from getHostName
, configProcessID :: ProcessID -- ^ ProcessID from getProcessID
, configHaystackURL :: Maybe String -- ^ URL of Haystack, with creds from environment
, configStatsAddr :: StatsAddr -- ^ Address of statsd/datadog
, configLogOptions :: Options -- ^ Options pertaining to logging
}
data StatsAddr = StatsAddr { addrHost :: String, addrPort :: String }
defaultConfig :: IO Config
defaultConfig = do
pid <- getProcessID
hostName <- getHostName
haystackURL <- lookupEnv "HAYSTACK_URL"
statsAddr <- lookupStatsAddr
logOptions <- configureOptionsForHandle stderr defaultOptions
pure Config
{ configAppName = "semantic"
, configHostName = hostName
, configProcessID = pid
, configHaystackURL = haystackURL
, configStatsAddr = statsAddr
, configLogOptions = logOptions
}
defaultHaystackClient :: IO HaystackClient
defaultHaystackClient = defaultConfig >>= haystackClientFromConfig
haystackClientFromConfig :: Config -> IO HaystackClient
haystackClientFromConfig Config{..} = haystackClient configHaystackURL tlsManagerSettings configHostName configAppName
defaultStatsClient :: IO StatsClient
defaultStatsClient = defaultConfig >>= statsClientFromConfig
statsClientFromConfig :: Config -> IO StatsClient
statsClientFromConfig Config{..} = statsClient (addrHost configStatsAddr) (addrPort configStatsAddr) configAppName
lookupStatsAddr :: IO StatsAddr
lookupStatsAddr = do
addr <- lookupEnv "STATS_ADDR"
let (host', port) = parseAddr (fmap ("statsd://" <>) addr)
-- When running in Kubes, DOGSTATSD_HOST is set with the dogstatsd host.
kubesHost <- lookupEnv "DOGSTATSD_HOST"
let host = fromMaybe host' kubesHost
pure (StatsAddr host port)
where
defaultHost = "127.0.0.1"
defaultPort = "28125"
parseAddr a | Just s <- a
, Just (Just (URIAuth _ host port)) <- uriAuthority <$> parseURI s
= (parseHost host, parsePort port)
| otherwise = (defaultHost, defaultPort)
parseHost s = if null s then defaultHost else s
parsePort s = if null s then defaultPort else dropWhile (':' ==) s

2
src/Semantic/Graph.hs
View File

@ -119,7 +119,7 @@ resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *
FreeVariablesError names -> pure (fromMaybeLast "unknown" names))
resumingUnspecialized :: (Member Trace effects, AbstractHole value) => Evaluator address value (Resumable (Unspecialized value) ': effects) a -> Evaluator address value effects a
resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized:" <> show err) $> Rval hole)
resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized:" <> show err) $> hole)
resumingAddressError :: (AbstractHole value, Lower (Cell address value), Member Trace effects, Show address) => Evaluator address value (Resumable (AddressError address value) ': effects) a -> Evaluator address value effects a
resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> show err) *> case err of

80
src/Semantic/Haystack.hs Normal file
View File

@ -0,0 +1,80 @@
module Semantic.Haystack where
import Control.Exception
import Control.Monad.IO.Class
import Crypto.Hash
import Data.Aeson hiding (Error)
import qualified Data.ByteString.Char8 as BC
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Network.HTTP.Client
import Network.HTTP.Types.Status (statusCode)
import Prologue hiding (hash)
import Semantic.Log
import Semantic.Queue
import System.IO.Error
data ErrorReport
= ErrorReport
{ errorReportException :: SomeException
, errorReportContext :: [(String, String)]
} deriving (Show)
data HaystackClient
= HaystackClient
{ haystackClientRequest :: Request
, haystackClientManager :: Manager
, haystackClientHostName :: String
, haystackClientAppName :: String
}
| NullHaystackClient -- ^ Doesn't report needles, good for testing or when the 'HAYSTACK_URL' env var isn't set.
-- Queue an error to be reported to haystack.
queueErrorReport :: MonadIO io => AsyncQueue ErrorReport HaystackClient -> SomeException -> [(String, String)] -> io ()
queueErrorReport q@AsyncQueue{..} message = liftIO . queue q . ErrorReport message
-- Create a Haystack HTTP client.
haystackClient :: Maybe String -> ManagerSettings -> String -> String -> IO HaystackClient
haystackClient maybeURL managerSettings hostName appName
| Just url <- maybeURL = do
manager <- newManager managerSettings
request' <- parseRequest url
let request = request'
{ method = "POST"
, requestHeaders = ("Content-Type", "application/json; charset=utf-8") : requestHeaders request'
}
pure $ HaystackClient request manager hostName appName
| otherwise = pure NullHaystackClient
-- Report an error to Haystack over HTTP (blocking).
reportError :: MonadIO io => String -> LogQueue -> HaystackClient -> ErrorReport -> io ()
reportError _ logger NullHaystackClient ErrorReport{..} = let msg = takeWhile (/= '\n') (displayException errorReportException) in queueLogMessage logger Error msg errorReportContext
reportError sha logger HaystackClient{..} ErrorReport{..} = do
let fullMsg = displayException errorReportException
let summary = takeWhile (/= '\n') fullMsg
queueLogMessage logger Error summary errorReportContext
let payload = object $
[ "app" .= haystackClientAppName
, "host" .= haystackClientHostName
, "sha" .= sha
, "message" .= summary
, "class" .= summary
, "backtrace" .= fullMsg
, "rollup" .= rollup fullMsg
] <> foldr (\(k, v) acc -> Text.pack k .= v : acc) [] errorReportContext
let request = haystackClientRequest { requestBody = RequestBodyLBS (encode payload) }
response <- liftIO . tryIOError $ httpLbs request haystackClientManager
case response of
Left e -> queueLogMessage logger Error ("Failed to report error to haystack: " <> displayException e) []
Right response -> do
let status = statusCode (responseStatus response)
if status /= 201
then queueLogMessage logger Error ("Failed to report error to haystack, status=" <> show status <> ".") []
else pure ()
where
rollup :: String -> Text
rollup = Text.decodeUtf8 . digestToHexByteString . md5 . BC.pack
md5 :: ByteString -> Digest MD5
md5 = hash

4
src/Semantic/Log.hs
View File

@ -14,7 +14,6 @@ import System.Posix.Process
import System.Posix.Types
import Text.Printf
-- | A log message at a specific level.
data Message = Message Level String [(String, String)] LocalTime.ZonedTime
deriving (Show)
@ -26,9 +25,10 @@ data Level
| Debug
deriving (Eq, Ord, Show)
type LogQueue = AsyncQueue Message Options
-- | Queue a message to be logged.
queueLogMessage :: MonadIO io => AsyncQueue Message Options -> Level -> String -> [(String, String)] -> io ()
queueLogMessage :: MonadIO io => LogQueue -> Level -> String -> [(String, String)] -> io ()
queueLogMessage q@AsyncQueue{..} level message pairs
| Just logLevel <- optionsLevel asyncQueueExtra, level <= logLevel = liftIO Time.getCurrentTime >>= liftIO . LocalTime.utcToLocalZonedTime >>= liftIO . queue q . Message level message pairs
| otherwise = pure ()

1
src/Semantic/Stat.hs
View File

@ -13,6 +13,7 @@ module Semantic.Stat
-- Client
, defaultStatsClient
, statsClient
, StatsClient(..)
, closeStatClient

2
src/Semantic/Task.hs
View File

@ -143,7 +143,7 @@ runTaskWithOptions options task = do
closeQueue logger
either (die . displayException) pure result
runTaskWithOptions' :: Options -> AsyncQueue Message Options -> AsyncQueue Stat StatsClient -> TaskEff a -> IO (Either SomeException a)
runTaskWithOptions' :: Options -> LogQueue -> AsyncQueue Stat StatsClient -> TaskEff a -> IO (Either SomeException a)
runTaskWithOptions' options logger statter task = do
(result, stat) <- withTiming "run" [] $ do
let run :: TaskEff a -> IO (Either SomeException a)

2
src/Semantic/Telemetry.hs
View File

@ -35,7 +35,7 @@ data Telemetry output where
WriteLog :: Level -> String -> [(String, String)] -> Telemetry ()
-- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to.
runTelemetry :: Member IO effects => AsyncQueue Message Options -> AsyncQueue Stat StatsClient -> Eff (Telemetry ': effects) a -> Eff effects a
runTelemetry :: Member IO effects => LogQueue -> AsyncQueue Stat StatsClient -> Eff (Telemetry ': effects) a -> Eff effects a
runTelemetry logger statter = interpret (\ t -> case t of
WriteStat stat -> liftIO (queue statter stat)
WriteLog level message pairs -> queueLogMessage logger level message pairs)

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

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

9
test/SpecHelpers.hs
View File

@ -88,10 +88,10 @@ testEvaluating :: TermEvaluator term Precise
, Resumable (LoadError Precise (Value Precise (Eff effects)))
, Fresh
, State (Heap Precise Latest (Value Precise (Eff effects)))
, State (ModuleTable (Maybe (Value Precise (Eff effects), Environment Precise)))
, State (ModuleTable (Maybe (Precise, Environment Precise)))
, Trace
]
[(Value Precise (Eff effects), Environment Precise)]
[(Precise, Environment Precise)]
-> ((Either
(SomeExc
(Data.Sum.Sum
@ -118,8 +118,13 @@ testEvaluating
. runEvalError
. runAddressError
. runValueError
. (>>= (traverse deref1))
. runTermEvaluator @_ @_ @(Value Precise (Eff _))
deref1 (ptr, env) = runAllocator $ do
val <- deref ptr
pure (val, env)
deNamespace :: Value Precise term -> Maybe (Name, [Name])
deNamespace (Namespace name scope) = Just (name, Env.names scope)
deNamespace _ = Nothing