github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2025-01-03 04:51:57 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #2236 from github/decompose-evaluate

Browse Source 
Decompose evaluate
This commit is contained in:
Rob Rix 2018-10-30 13:10:11 -04:00 committed by GitHub
commit de4cc625d1
36 changed files with 604 additions and 490 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitmodules vendored
View File

@ -13,6 +13,6 @@
[submodule "vendor/semilattices"]
path = vendor/semilattices
url = https://github.com/robrix/semilattices.git
[submodule "vendor/higher-order-effects"]
path = vendor/higher-order-effects
url = https://github.com/robrix/higher-order-effects.git
[submodule "vendor/fused-effects"]
path = vendor/fused-effects
url = https://github.com/robrix/fused-effects.git

42
.licenses/semantic/cabal/MonadRandom.txt Normal file
View File

@ -0,0 +1,42 @@
---
type: cabal
name: MonadRandom
version: 0.5.1.1
summary: Random-number generation monad.
homepage:
license: bsd-3-clause
---
Copyright (c) 2016, Brent Yorgey
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Brent Yorgey nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Previous versions of this package were distributed under the simple
permissive license used on the Haskell Wiki; see OLD-LICENSE for
details.

8
.licenses/semantic/cabal/higher-order-effects.txt → .licenses/semantic/cabal/fused-effects.txt
View File

@ -1,12 +1,12 @@
---
type: cabal
name: higher-order-effects
name: fused-effects
version: 0.1.0.0
summary: Semilattices
homepage: https://github.com/robrix/higher-order-effects
summary: 'A fast, flexible, fused effect system, à la Effect Handlers in Scope, Monad Transformers and Modular Algebraic Effects: What Binds Them Together, and Fusion for Free—Efficient Algebraic Effect Handlers.'
homepage: https://github.com/robrix/fused-effects
license: bsd-3-clause
---
Copyright (c) 2018, Rob Rix
Copyright (c) 2018, Rob Rix and Patrick Thomson
All rights reserved.

9
semantic.cabal
View File

@ -48,6 +48,8 @@ library
, Control.Abstract.Roots
, Control.Abstract.ScopeGraph
, Control.Abstract.Value
-- Effects
, Control.Effect.Interpose
-- Rewriting
, Control.Rewriting
-- Datatypes for abstract interpretation
@ -186,6 +188,7 @@ library
, Reprinting.Typeset
, Reprinting.Pipeline
-- High-level flow & operational functionality (logging, stats, etc.)
, Semantic.Analysis
, Semantic.AST
, Semantic.CLI
, Semantic.Config
@ -234,12 +237,12 @@ library
, filepath
, free
, freer-cofreer
, fused-effects
, ghc-prim
, gitrev
, Glob
, hashable
, haskeline
, higher-order-effects
, hscolour
, http-client
, http-client-tls
@ -362,10 +365,10 @@ test-suite test
, fastsum
, filepath
, free
, fused-effects
, Glob
, hashable
, haskell-tree-sitter
, higher-order-effects
, hspec >= 2.4.1
, hspec-core
, hspec-expectations-pretty-diff
@ -415,8 +418,8 @@ test-suite parse-examples
, directory
, fastsum
, filepath
, fused-effects
, Glob
, higher-order-effects
, hspec >= 2.4.1
, hspec-core
, hspec-expectations-pretty-diff

12
src/Analysis/Abstract/Caching/FlowInsensitive.hs
View File

@ -91,10 +91,13 @@ convergingModules :: ( AbstractValue term address value m
, Ord address
, Ord term
, Carrier sig m
, Effect sig
)
=> Open (Module term -> Evaluator term address value m address)
convergingModules recur m = do
c <- getConfiguration (moduleBody m)
=> (Module (Either prelude term) -> Evaluator term address value (AltC Maybe (Eff m)) address)
-> (Module (Either prelude term) -> Evaluator term address value m address)
convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty
convergingModules recur m@(Module _ (Right term)) = do
c <- getConfiguration term
heap <- getHeap
-- Convergence here is predicated upon an Eq instance, not α-equivalence
(cache, _) <- converge (lowerBound, heap) (\ (prevCache, _) -> isolateCache $ do
@ -106,8 +109,7 @@ convergingModules recur m = do
-- that it doesn't "leak" to the calling context and diverge (otherwise this
-- would never complete). We don’t need to use the values, so we 'gather' the
-- nondeterministic values into @()@.
-- FIXME: do we actually need to gather here after all??
withOracle prevCache (recur m))
withOracle prevCache (raiseHandler runNonDet (recur m)))
address =<< maybe empty scatter (cacheLookup c cache)
-- | Iterate a monadic action starting from some initial seed until the results converge.

12
src/Analysis/Abstract/Caching/FlowSensitive.hs
View File

@ -89,10 +89,13 @@ convergingModules :: ( AbstractValue term address value m
, Member (Env address) sig
, Member (State (Heap address value)) sig
, Carrier sig m
, Effect sig
)
=> Open (Module term -> Evaluator term address value m address)
convergingModules recur m = do
c <- getConfiguration (moduleBody m)
=> (Module (Either prelude term) -> Evaluator term address value (AltC Maybe (Eff m)) address)
-> (Module (Either prelude term) -> Evaluator term address value m address)
convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty
convergingModules recur m@(Module _ (Right term)) = do
c <- getConfiguration term
-- Convergence here is predicated upon an Eq instance, not α-equivalence
cache <- converge lowerBound (\ prevCache -> isolateCache $ do
putHeap (configurationHeap c)
@ -104,8 +107,7 @@ convergingModules recur m = do
-- that it doesn't "leak" to the calling context and diverge (otherwise this
-- would never complete). We don’t need to use the values, so we 'gather' the
-- nondeterministic values into @()@.
-- FIXME: do we actually need to gather here?
withOracle prevCache (recur m))
withOracle prevCache (raiseHandler runNonDet (recur m)))
address =<< maybe empty scatter (cacheLookup c cache)
-- | Iterate a monadic action starting from some initial seed until the results converge.

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

@ -18,7 +18,8 @@ module Analysis.Abstract.Graph
import Algebra.Graph.Export.Dot hiding (vertexName)
import Control.Abstract hiding (Function(..))
import Control.Effect.Eavesdrop
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Abstract.Address.Hole
import Data.Abstract.Address.Located
import Data.Abstract.BaseError
@ -117,19 +118,19 @@ graphingPackages recur m =
let v = moduleVertex (moduleInfo m) in packageInclusion v *> local (const v) (recur m)
-- | Add vertices to the graph for imported modules.
graphingModules :: forall term address value m sig a
. ( Member (Eavesdrop (Modules address)) sig
graphingModules :: ( Member (Modules address) sig
, Member (Reader ModuleInfo) sig
, Member (State (Graph ControlFlowVertex)) sig
, Member (Reader ControlFlowVertex) sig
, Carrier sig m
)
=> Open (Module term -> Evaluator term address value m a)
=> (Module body -> Evaluator term address value (EavesdropC address (Eff m)) a)
-> (Module body -> Evaluator term address value m a)
graphingModules recur m = do
let v = moduleVertex (moduleInfo m)
appendGraph (vertex v)
local (const v) $
eavesdrop @(Modules address) (recur m) $ \case
eavesdrop (recur m) $ \case
Load path _ -> includeModule path
Lookup path _ -> includeModule path
_ -> pure ()
@ -141,20 +142,38 @@ graphingModules recur m = do
{-# ANN graphingModules ("HLint: ignore Use ." :: String) #-}
-- | Add vertices to the graph for imported modules.
graphingModuleInfo :: forall term address value m sig a
. ( Member (Eavesdrop (Modules address)) sig
graphingModuleInfo :: ( Member (Modules address) sig
, Member (Reader ModuleInfo) sig
, Member (State (Graph ModuleInfo)) sig
, Carrier sig m
)
=> Open (Module term -> Evaluator term address value m a)
=> (Module body -> Evaluator term address value (EavesdropC address (Eff m)) a)
-> (Module body -> Evaluator term address value m a)
graphingModuleInfo recur m = do
appendGraph (vertex (moduleInfo m))
eavesdrop @(Modules address) (recur m) $ \case
eavesdrop (recur m) $ \case
Load path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
Lookup path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
_ -> pure ()
eavesdrop :: (Carrier sig m, Member (Modules address) sig)
=> Evaluator term address value (EavesdropC address (Eff m)) a
-> (forall x . Modules address (Eff m) (Eff m x) -> Evaluator term address value m ())
-> Evaluator term address value m a
eavesdrop m f = raiseHandler (runEavesdropC (runEvaluator . f) . interpret) m
newtype EavesdropC address m a = EavesdropC ((forall x . Modules address m (m x) -> m ()) -> m a)
runEavesdropC :: (forall x . Modules address m (m x) -> m ()) -> EavesdropC address m a -> m a
runEavesdropC f (EavesdropC m) = m f
instance (Carrier sig m, Member (Modules address) sig, Applicative m) => Carrier sig (EavesdropC address m) where
ret a = EavesdropC (const (ret a))
eff op
| Just eff <- prj op = EavesdropC (\ handler -> let eff' = handlePure (runEavesdropC handler) eff in handler eff' *> send eff')
| otherwise = EavesdropC (\ handler -> eff (handlePure (runEavesdropC handler) op))
-- | Add an edge from the current package to the passed vertex.
packageInclusion :: ( Member (Reader PackageInfo) sig
, Member (State (Graph ControlFlowVertex)) sig

1
src/Control/Abstract.hs
View File

@ -10,4 +10,5 @@ import Control.Abstract.Hole as X
import Control.Abstract.Modules as X
import Control.Abstract.Primitive as X
import Control.Abstract.Roots as X
import Control.Abstract.ScopeGraph as X
import Control.Abstract.Value as X

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

@ -187,19 +187,18 @@ newtype EnvC address m a = EnvC { runEnvC :: Eff (StateC (EvalContext address) (
instance (Carrier sig m, Effect sig) => Carrier (Env address :+: sig) (EnvC address m) where
ret = EnvC . ret
eff = EnvC . (alg \/ eff . R . R . handleCoercible)
where alg = \case
Lookup name k -> gets (Env.lookupEnv' name . ctxEnvironment) >>= runEnvC . k
Bind name addr k -> modify (\EvalContext{..} -> EvalContext ctxSelf (Env.insertEnv name addr ctxEnvironment)) >> runEnvC k
Close names k -> gets (Env.intersect names . ctxEnvironment) >>= runEnvC . k
Locally action k -> do
modify (\EvalContext{..} -> EvalContext ctxSelf (Env.push @address ctxEnvironment))
a <- runEnvC action
modify (\EvalContext{..} -> EvalContext ctxSelf (Env.pop @address ctxEnvironment))
runEnvC (k a)
GetCtx k -> get >>= runEnvC . k
PutCtx e k -> put e >> runEnvC k
Export name alias addr k -> modify (Exports.insert name alias addr) >> runEnvC k
eff = EnvC . handleSum (eff . R . R . handleCoercible) (\case
Lookup name k -> gets (Env.lookupEnv' name . ctxEnvironment) >>= runEnvC . k
Bind name addr k -> modify (\EvalContext{..} -> EvalContext ctxSelf (Env.insertEnv name addr ctxEnvironment)) >> runEnvC k
Close names k -> gets (Env.intersect names . ctxEnvironment) >>= runEnvC . k
Locally action k -> do
modify (\EvalContext{..} -> EvalContext ctxSelf (Env.push @address ctxEnvironment))
a <- runEnvC action
modify (\EvalContext{..} -> EvalContext ctxSelf (Env.pop @address ctxEnvironment))
runEnvC (k a)
GetCtx k -> get >>= runEnvC . k
PutCtx e k -> put e >> runEnvC k
Export name alias addr k -> modify (Exports.insert name alias addr) >> runEnvC k)
freeVariableError :: ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig

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

@ -99,12 +99,11 @@ instance ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))
)
=> Carrier (Modules address :+: sig) (ModulesC address m) where
ret = ModulesC . const . ret
eff op = ModulesC (\ paths -> (alg paths \/ eff . handleReader paths runModulesC) op)
where alg paths = \case
Load name k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name >>= flip runModulesC paths . k
Lookup path k -> askModuleTable >>= flip runModulesC paths . k . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path
Resolve names k -> runModulesC (k (find (`Set.member` paths) names)) paths
List dir k -> runModulesC (k (filter ((dir ==) . takeDirectory) (toList paths))) paths
eff op = ModulesC (\ paths -> handleSum (eff . handleReader paths runModulesC) (\case
Load name k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name >>= flip runModulesC paths . k
Lookup path k -> askModuleTable >>= flip runModulesC paths . k . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path
Resolve names k -> runModulesC (k (find (`Set.member` paths) names)) paths
List dir k -> runModulesC (k (filter ((dir ==) . takeDirectory) (toList paths))) paths) op)
askModuleTable :: (Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig, Carrier sig m) => m (ModuleTable (NonEmpty (Module (ModuleResult address))))
askModuleTable = ask

97
src/Control/Abstract/PythonPackage.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Abstract.PythonPackage
( runPythonPackaging, Strategy(..) ) where
@ -7,7 +7,7 @@ import Control.Abstract.Heap (Allocator, Deref, deref)
import Control.Abstract.Value
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Abstract.Evaluatable hiding (InterposeC)
import Data.Abstract.Evaluatable
import Data.Abstract.Name (name)
import Data.Abstract.Path (stripQuotes)
import Data.Abstract.Value.Concrete (Value (..), ValueError (..))
@ -38,48 +38,61 @@ runPythonPackaging :: ( Carrier sig m
, Member (Reader Span) sig
, Member (Function term address (Value term address)) sig
)
=> Evaluator term address (Value term address) (InterposeC (Function term address (Value term address))
(Evaluator term address (Value term address) m)) a
=> Evaluator term address (Value term address) (PythonPackagingC term address (Eff m)) a
-> Evaluator term address (Value term address) m a
runPythonPackaging = interpose (\case
Call callName super params k -> k =<< do
case callName of
Closure _ _ name' paramNames _ _ -> do
let bindings = foldr (uncurry Map.insert) lowerBound (zip paramNames params)
let asStrings = deref >=> asArray >=> traverse (deref >=> asString)
runPythonPackaging = raiseHandler (runPythonPackagingC . interpret)
case name' of
Just n
| name "find_packages" == n -> do
as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "exclude") bindings)
put (FindPackages as)
| name "setup" == n -> do
packageState <- get
if packageState == Unknown then do
as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "packages") bindings)
put (Packages as)
else
pure ()
_ -> pure ()
_ -> pure ()
call callName super params
Function name params body k -> function name params body >>= k
BuiltIn b k -> builtIn b >>= k)
. runEvaluator
newtype PythonPackagingC term address m a = PythonPackagingC { runPythonPackagingC :: m a }
interpose :: (Member eff sig, HFunctor eff, Carrier sig m)
=> (forall v. eff m (m v) -> m v)
-> Eff (InterposeC eff m) a
-> m a
interpose handler = runInterposeC handler . interpret
wrap :: Evaluator term address (Value term address) m a -> PythonPackagingC term address (Eff m) a
wrap = PythonPackagingC . runEvaluator
newtype InterposeC eff m a = InterposeC ((forall x . eff m (m x) -> m x) -> m a)
runInterposeC :: (forall x . eff m (m x) -> m x) -> InterposeC eff m a -> m a
runInterposeC f (InterposeC m) = m f
instance (Member eff sig, HFunctor eff, Carrier sig m) => Carrier sig (InterposeC eff m) where
ret a = InterposeC (const (ret a))
instance ( Carrier sig m
, Member (Allocator address) sig
, Member (Boolean (Value term address)) sig
, Member (Deref (Value term address)) sig
, Member (Env address) sig
, Member (Error (LoopControl address)) sig
, Member (Error (Return address)) sig
, Member Fresh sig
, Member (Function term address (Value term address)) sig
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address (Value term address)))) sig
, Member (Resumable (BaseError (ValueError term address))) sig
, Member (State (Heap address (Value term address))) sig
, Member (State Strategy) sig
, Member Trace sig
, Ord address
, Show address
, Show term
)
=> Carrier sig (PythonPackagingC term address (Eff m)) where
ret = PythonPackagingC . ret
eff op
| Just e <- prj op = InterposeC (\ handler -> handler (handlePure (runInterposeC handler) e))
| otherwise = InterposeC (\ handler -> eff (handlePure (runInterposeC handler) op))
| Just e <- prj op = wrap $ case handleCoercible e of
Call callName super params k -> Evaluator . k =<< do
case callName of
Closure _ _ name' paramNames _ _ -> do
let bindings = foldr (uncurry Map.insert) lowerBound (zip paramNames params)
let asStrings = deref >=> asArray >=> traverse (deref >=> asString)
case name' of
Just n
| name "find_packages" == n -> do
as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "exclude") bindings)
put (FindPackages as)
| name "setup" == n -> do
packageState <- get
if packageState == Unknown then do
as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "packages") bindings)
put (Packages as)
else
pure ()
_ -> pure ()
_ -> pure ()
call callName super params
Function name params body k -> function name params body >>= Evaluator . k
BuiltIn b k -> builtIn b >>= Evaluator . k
| otherwise = PythonPackagingC (eff (handleCoercible op))

39
src/Control/Abstract/ScopeGraph.hs
View File

@ -98,23 +98,22 @@ newtype ScopeEnvC address m a = ScopeEnvC { runScopeEnvC :: Eff (StateC (ScopeGr
instance (Ord address, Member Fresh sig, Member (Allocator address) sig, Carrier sig m, Effect sig) => Carrier (ScopeEnv address :+: sig) (ScopeEnvC address m) where
ret = ScopeEnvC . ret
eff = ScopeEnvC . (alg \/ eff . R . handleCoercible)
where alg = \case
Lookup ref k -> gets (ScopeGraph.scopeOfRef ref) >>= runScopeEnvC . k
Declare decl span scope k -> modify @(ScopeGraph address) (ScopeGraph.declare decl span scope) *> runScopeEnvC k
PutDeclarationScope decl scope k -> modify @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope) *> runScopeEnvC k
Reference ref decl k -> modify @(ScopeGraph address) (ScopeGraph.reference ref decl) *> runScopeEnvC k
NewScope edges k -> do
-- Take the edges and construct a new scope, update the current scope to the new scope
name <- gensym
address <- runEvaluator (alloc name)
modify @(ScopeGraph address) (ScopeGraph.newScope address edges)
runScopeEnvC (k address)
CurrentScope k -> gets ScopeGraph.currentScope >>= runScopeEnvC . k
AssociatedScope decl k -> gets (ScopeGraph.associatedScope decl) >>= runScopeEnvC . k
Local scope action k -> do
prevScope <- gets ScopeGraph.currentScope
modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = Just scope })
value <- runScopeEnvC action
modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = prevScope })
runScopeEnvC (k value)
eff = ScopeEnvC . handleSum (eff . R . handleCoercible) (\case
Lookup ref k -> gets (ScopeGraph.scopeOfRef ref) >>= runScopeEnvC . k
Declare decl span scope k -> modify @(ScopeGraph address) (ScopeGraph.declare decl span scope) *> runScopeEnvC k
PutDeclarationScope decl scope k -> modify @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope) *> runScopeEnvC k
Reference ref decl k -> modify @(ScopeGraph address) (ScopeGraph.reference ref decl) *> runScopeEnvC k
NewScope edges k -> do
-- Take the edges and construct a new scope, update the current scope to the new scope
name <- gensym
address <- runEvaluator (alloc name)
modify @(ScopeGraph address) (ScopeGraph.newScope address edges)
runScopeEnvC (k address)
CurrentScope k -> gets ScopeGraph.currentScope >>= runScopeEnvC . k
AssociatedScope decl k -> gets (ScopeGraph.associatedScope decl) >>= runScopeEnvC . k
Local scope action k -> do
prevScope <- gets ScopeGraph.currentScope
modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = Just scope })
value <- runScopeEnvC action
modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = prevScope })
runScopeEnvC (k value))

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

@ -1,4 +1,4 @@
{-# LANGUAGE DeriveAnyClass, GADTs, KindSignatures, Rank2Types, TypeOperators #-}
{-# LANGUAGE DeriveAnyClass, GADTs, KindSignatures, LambdaCase, Rank2Types, TypeOperators #-}
module Control.Abstract.Value
( AbstractValue(..)
, AbstractIntro(..)
@ -15,7 +15,6 @@ module Control.Abstract.Value
, boolean
, asBool
, ifthenelse
, disjunction
, Boolean(..)
, runBoolean
, BooleanC(..)
@ -124,20 +123,19 @@ asBool = send . flip AsBool ret
ifthenelse :: (Member (Boolean value) sig, Carrier sig m, Monad m) => value -> m a -> m a -> m a
ifthenelse v t e = asBool v >>= \ c -> if c then t else e
-- | Compute the disjunction (boolean or) of two computed values. This should have short-circuiting semantics where applicable.
disjunction :: (Member (Boolean value) sig, Carrier sig m) => m value -> m value -> m value
disjunction a b = send (Disjunction a b ret)
data Boolean value m k
data Boolean value (m :: * -> *) k
= Boolean Bool (value -> k)
| AsBool value (Bool -> k)
| Disjunction (m value) (m value) (value -> k)
deriving (Functor)
instance HFunctor (Boolean value) where
hmap _ (Boolean b k) = Boolean b k
hmap _ (AsBool v k) = AsBool v k
hmap f (Disjunction a b k) = Disjunction (f a) (f b) k
hmap _ = coerce
{-# INLINE hmap #-}
instance Effect (Boolean value) where
handle state handler = \case
Boolean b k -> Boolean b (handler . (<$ state) . k)
AsBool v k -> AsBool v (handler . (<$ state) . k)
runBoolean :: Carrier (Boolean value :+: sig) (BooleanC value (Eff m))
=> Evaluator term address value (BooleanC value (Eff m)) a

49
src/Control/Effect/Interpose.hs Normal file
View File

@ -0,0 +1,49 @@
{-# LANGUAGE ExistentialQuantification, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
module Control.Effect.Interpose
( Interpose(..)
, interpose
, runInterpose
, InterposeC(..)
, Listener(..)
) where
import Control.Effect.Carrier
import Control.Effect.Internal
import Control.Effect.Sum
data Interpose eff m k
= forall a . Interpose (m a) (forall n x . eff n (n x) -> m x) (a -> k)
deriving instance Functor (Interpose eff m)
instance HFunctor (Interpose eff) where
hmap f (Interpose m h k) = Interpose (f m) (f . h) k
-- | Respond to requests for some specific effect with a handler.
--
-- The intercepted effects are not re-sent in the surrounding context; thus, the innermost nested 'interpose' listening for an effect will win, and the effect’s own handler will not get the chance to service the request.
--
-- Note that since 'Interpose' lacks an 'Effect' instance, only “pure” effects, i.e. effects which can be handled inside other effects using 'hmap' alone, can be run within the 'runInterpose' scope. This includes @Reader@, but not e.g. @State@ or @Error@.
interpose :: (Member (Interpose eff) sig, Carrier sig m)
=> m a
-> (forall n x . eff n (n x) -> m x)
-> m a
interpose m f = send (Interpose m f ret)
-- | Run an 'Interpose' effect.
runInterpose :: (Member eff sig, Carrier sig m, Monad m) => Eff (InterposeC eff m) a -> m a
runInterpose = flip runInterposeC Nothing . interpret
newtype InterposeC eff m a = InterposeC { runInterposeC :: Maybe (Listener eff m) -> m a }
newtype Listener eff m = Listener { runListener :: forall n x . eff n (n x) -> m x }
instance (Carrier sig m, Member eff sig, Monad m) => Carrier (Interpose eff :+: sig) (InterposeC eff m) where
ret a = InterposeC (const (ret a))
eff op = InterposeC (\ listener -> handleSum (algOther listener) (alg listener) op)
where alg listener (Interpose m h k) = runInterposeC m (Just (Listener (flip runInterposeC listener . h))) >>= flip runInterposeC listener . k
algOther listener op
| Just listener <- listener
, Just eff <- prj op = runListener listener eff
| otherwise = eff (handleReader listener runInterposeC op)

13
src/Data/Abstract/Address/Hole.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE TypeOperators, UndecidableInstances #-}
{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Address.Hole
( Hole(..)
, toMaybe
@ -29,8 +29,9 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC address m)
)
=> Carrier (Allocator (Hole context address) :+: sig) (AllocatorC (Hole context address) m) where
ret = promoteA . ret
eff = alg \/ AllocatorC . eff . handleCoercible
where alg (Alloc name k) = Total <$> promoteA (eff (L (Alloc name ret))) >>= k
eff = handleSum
(AllocatorC . eff . handleCoercible)
(\ (Alloc name k) -> Total <$> promoteA (eff (L (Alloc name ret))) >>= k)
promoteD :: DerefC address value m a -> DerefC (Hole context address) value m a
@ -39,6 +40,6 @@ promoteD = DerefC . runDerefC
instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m)
=> Carrier (Deref value :+: sig) (DerefC (Hole context address) value m) where
ret = promoteD . ret
eff = alg \/ DerefC . eff . handleCoercible
where alg (DerefCell cell k) = promoteD (eff (L (DerefCell cell ret))) >>= k
alg (AssignCell value cell k) = promoteD (eff (L (AssignCell value cell ret))) >>= k
eff = handleSum (DerefC . eff . handleCoercible) (\case
DerefCell cell k -> promoteD (eff (L (DerefCell cell ret))) >>= k
AssignCell value cell k -> promoteD (eff (L (AssignCell value cell ret))) >>= k)

13
src/Data/Abstract/Address/Located.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE TypeOperators, UndecidableInstances #-}
{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Address.Located
( Located(..)
) where
@ -32,8 +32,9 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC address m)
)
=> Carrier (Allocator (Located address) :+: sig) (AllocatorC (Located address) m) where
ret = promoteA . ret
eff = alg \/ AllocatorC . eff . handleCoercible
where alg (Alloc name k) = Located <$> promoteA (eff (L (Alloc name ret))) <*> currentPackage <*> currentModule <*> pure name <*> ask >>= k
eff = handleSum
(AllocatorC . eff . handleCoercible)
(\ (Alloc name k) -> Located <$> promoteA (eff (L (Alloc name ret))) <*> currentPackage <*> currentModule <*> pure name <*> ask >>= k)
promoteD :: DerefC address value m a -> DerefC (Located address) value m a
@ -42,6 +43,6 @@ promoteD = DerefC . runDerefC
instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m)
=> Carrier (Deref value :+: sig) (DerefC (Located address) value m) where
ret = promoteD . ret
eff = alg \/ DerefC . eff . handleCoercible
where alg (DerefCell cell k) = promoteD (eff (L (DerefCell cell ret))) >>= k
alg (AssignCell value cell k) = promoteD (eff (L (AssignCell value cell ret))) >>= k
eff = handleSum (DerefC . eff . handleCoercible) (\case
DerefCell cell k -> promoteD (eff (L (DerefCell cell ret))) >>= k
AssignCell value cell k -> promoteD (eff (L (AssignCell value cell ret))) >>= k)

13
src/Data/Abstract/Address/Monovariant.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Address.Monovariant
( Monovariant(..)
) where
@ -20,12 +20,13 @@ instance Show Monovariant where
instance Carrier sig m => Carrier (Allocator Monovariant :+: sig) (AllocatorC Monovariant m) where
ret = AllocatorC . ret
eff = AllocatorC . (alg \/ eff . handleCoercible)
where alg (Alloc name k) = runAllocatorC (k (Monovariant name))
eff = AllocatorC . handleSum
(eff . handleCoercible)
(\ (Alloc name k) -> runAllocatorC (k (Monovariant name)))
instance (Ord value, Carrier sig m, Alternative m, Monad m) => Carrier (Deref value :+: sig) (DerefC Monovariant value m) where
ret = DerefC . ret
eff = DerefC . (alg \/ eff . handleCoercible)
where alg (DerefCell cell k) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k
alg (AssignCell value cell k) = runDerefC (k (Set.insert value cell))
eff = DerefC . handleSum (eff . handleCoercible) (\case
DerefCell cell k -> traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k
AssignCell value cell k -> runDerefC (k (Set.insert value cell)))

13
src/Data/Abstract/Address/Precise.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Address.Precise
( Precise(..)
) where
@ -19,12 +19,13 @@ instance Show Precise where
instance (Member Fresh sig, Carrier sig m, Monad m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where
ret = AllocatorC . ret
eff = AllocatorC . (alg \/ eff . handleCoercible)
where alg (Alloc _ k) = Precise <$> fresh >>= runAllocatorC . k
eff = AllocatorC . handleSum
(eff . handleCoercible)
(\ (Alloc _ k) -> Precise <$> fresh >>= runAllocatorC . k)
instance Carrier sig m => Carrier (Deref value :+: sig) (DerefC Precise value m) where
ret = DerefC . ret
eff = DerefC . (alg \/ eff . handleCoercible)
where alg (DerefCell cell k) = runDerefC (k (fst <$> Set.minView cell))
alg (AssignCell value _ k) = runDerefC (k (Set.singleton value))
eff = DerefC . handleSum (eff . handleCoercible) (\case
DerefCell cell k -> runDerefC (k (fst <$> Set.minView cell))
AssignCell value _ k -> runDerefC (k (Set.singleton value)))

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

@ -2,14 +2,9 @@
module Data.Abstract.Evaluatable
( module X
, Evaluatable(..)
, ModuleC
, ValueC
, evaluate
, traceResolve
-- * Preludes
, HasPrelude(..)
-- * Postludes
, HasPostlude(..)
-- * Effects
, EvalError(..)
, throwEvalError
@ -28,19 +23,14 @@ import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catc
import Control.Abstract.Heap as X hiding (runAddressError, runAddressErrorWith)
import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError)
import Control.Abstract.Value as X hiding (Boolean(..), Function(..), While(..))
import Control.Abstract.ScopeGraph
import Control.Effect.Eavesdrop
import Control.Effect.Interpose
import Data.Abstract.Declarations as X
import Data.Abstract.Environment as X
import Data.Abstract.BaseError as X
import Data.Abstract.FreeVariables as X
import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Name as X
import Data.Abstract.Ref as X
import Data.Language
import Data.Function
import Data.Scientific (Scientific)
import Data.Semigroup.App
import Data.Semigroup.Foldable
@ -86,96 +76,6 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
rvalBox v
type ModuleC address value m
= EavesdropC (Modules address) (Eff
( InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff
( ErrorC (LoopControl address) (Eff
( ErrorC (Return address) (Eff
( EnvC address (Eff
( ScopeEnvC address (Eff
( DerefC address value (Eff
( AllocatorC address (Eff
( ReaderC ModuleInfo (Eff
m)))))))))))))))))
type ValueC term address value m
= FunctionC term address value (Eff
( WhileC value (Eff
( BooleanC value (Eff
m)))))
evaluate :: ( AbstractValue term address value valueC
, Carrier sig c
, allocatorC ~ AllocatorC address (Eff (ReaderC ModuleInfo (Eff c)))
, Carrier (Allocator address :+: Reader ModuleInfo :+: sig) allocatorC
, Carrier (Deref value :+: Allocator address :+: Reader ModuleInfo :+: sig) (DerefC address value (Eff allocatorC))
, booleanC ~ BooleanC value (Eff moduleC)
, Carrier (Boolean value :+: moduleSig) booleanC
, whileC ~ WhileC value (Eff booleanC)
, moduleSig ~ (Eavesdrop (Modules address) :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: Error (LoopControl address) :+: Error (Return address) :+: Env address :+: ScopeEnv address :+: Deref value :+: Allocator address :+: Reader ModuleInfo :+: sig)
, Carrier (While value :+: Boolean value :+: moduleSig) whileC
, Carrier (Function term address value :+: While value :+: Boolean value :+: moduleSig) valueC
, Declarations term
, Effect sig
, Evaluatable (Base term)
, FreeVariables term
, HasPostlude lang
, HasPrelude lang
, Member Fresh sig
, Member (Modules address) sig
, Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (State Span) sig
, Member (Resumable (BaseError (AddressError address value))) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
, Member (Resumable (BaseError EvalError)) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Member (Resumable (BaseError (UnspecializedError value))) sig
, Member (State (Heap address value)) sig
, Member Trace sig
, Ord address
, Recursive term
, moduleC ~ ModuleC address value c
, valueC ~ ValueC term address value moduleC
)
=> proxy lang
-> Open (Module term -> Evaluator term address value moduleC address)
-> Open (Open (term -> Evaluator term address value valueC (ValueRef address)))
-> [Module term]
-> Evaluator term address value c (ModuleTable (NonEmpty (Module (ModuleResult address))))
evaluate lang analyzeModule analyzeTerm modules = do
(_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runValue $ do
definePrelude lang
box unit
foldr (run preludeBinds) ask modules
where run preludeBinds m rest = do
evaluated <- runInModule preludeBinds (moduleInfo m)
(analyzeModule (evalModuleBody . moduleBody)
m)
-- FIXME: this should be some sort of Monoidal insert à la the Heap to accommodate multiple Go files being part of the same module.
local (ModuleTable.insert (modulePath (moduleInfo m)) ((evaluated <$ m) :| [])) rest
evalModuleBody term = runValue (do
result <- evalTerm term
result <$ postlude lang)
evalTerm = fix (analyzeTerm ((. project) . eval)) >=> address
runValue = runBoolean . runWhile . runFunction evalTerm
runInModule preludeBinds info
= raiseHandler (runReader info)
. runAllocator
. runDeref
. runScopeEnv
. runEnv (EvalContext Nothing (X.push (newEnv preludeBinds)))
. runReturn
. runLoopControl
. raiseHandler runInterpose
. raiseHandler runEavesdrop
traceResolve :: (Show a, Show b, Member Trace sig, Carrier sig m) => a -> b -> Evaluator term address value m ()
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
@ -229,36 +129,6 @@ instance HasPrelude 'JavaScript where
defineNamespace (name "console") $ do
define (name "log") (builtIn Print)
-- Postludes
class HasPostlude (language :: Language) where
postlude :: ( AbstractValue term address value m
, Carrier sig m
, HasCallStack
, Member (Allocator address) sig
, Member (Deref value) sig
, Member (Env address) sig
, Member Fresh sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
, Member Trace sig
)
=> proxy language
-> Evaluator term address value m ()
postlude _ = pure ()
instance HasPostlude 'Go
instance HasPostlude 'Haskell
instance HasPostlude 'Java
instance HasPostlude 'PHP
instance HasPostlude 'Python
instance HasPostlude 'Ruby
instance HasPostlude 'TypeScript
instance HasPostlude 'JavaScript where
postlude _ = trace "JS postlude"
-- Effects

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

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, LambdaCase, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Value.Abstract
( Abstract (..)
, runFunction
@ -31,27 +31,25 @@ instance ( Member (Allocator address) sig
)
=> Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract (Eff m)) where
ret = FunctionC . const . ret
eff op = FunctionC (\ eval -> (alg eval \/ eff . handleReader eval runFunctionC) op)
where alg eval = \case
Function _ params body k -> runEvaluator $ do
env <- foldr (\ name rest -> do
addr <- alloc name
assign addr Abstract
Env.insert name addr <$> rest) (pure lowerBound) params
addr <- locally (bindAll env *> catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body))))
deref addr >>= Evaluator . flip runFunctionC eval . k
BuiltIn _ k -> runFunctionC (k Abstract) eval
Call _ _ params k -> runEvaluator $ do
traverse_ deref params
box Abstract >>= Evaluator . flip runFunctionC eval . k
eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
Function _ params body k -> runEvaluator $ do
env <- foldr (\ name rest -> do
addr <- alloc name
assign addr Abstract
Env.insert name addr <$> rest) (pure lowerBound) params
addr <- locally (bindAll env *> catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body))))
deref addr >>= Evaluator . flip runFunctionC eval . k
BuiltIn _ k -> runFunctionC (k Abstract) eval
Call _ _ params k -> runEvaluator $ do
traverse_ deref params
box Abstract >>= Evaluator . flip runFunctionC eval . k) op)
instance (Carrier sig m, Alternative m, Monad m) => Carrier (Boolean Abstract :+: sig) (BooleanC Abstract m) where
instance (Carrier sig m, Alternative m) => Carrier (Boolean Abstract :+: sig) (BooleanC Abstract m) where
ret = BooleanC . ret
eff = BooleanC . (alg \/ eff . handleCoercible)
where alg (Boolean _ k) = runBooleanC (k Abstract)
alg (AsBool _ k) = runBooleanC (k True) <|> runBooleanC (k False)
alg (Disjunction a b k) = (runBooleanC a <|> runBooleanC b) >>= runBooleanC . k
eff = BooleanC . handleSum (eff . handleCoercible) (\case
Boolean _ k -> runBooleanC (k Abstract)
AsBool _ k -> runBooleanC (k True) <|> runBooleanC (k False))
instance ( Member (Abstract.Boolean Abstract) sig
@ -61,10 +59,11 @@ instance ( Member (Abstract.Boolean Abstract) sig
)
=> Carrier (While Abstract :+: sig) (WhileC Abstract m) where
ret = WhileC . ret
eff = WhileC . (alg \/ eff . handleCoercible)
where alg (Abstract.While cond body k) = do
cond' <- runWhileC cond
ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit))
eff = WhileC . handleSum
(eff . handleCoercible)
(\ (Abstract.While cond body k) -> do
cond' <- runWhileC cond
ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit)))
instance Ord address => ValueRoots address Abstract where

99
src/Data/Abstract/Value/Concrete.hs
View File

@ -75,29 +75,28 @@ instance ( FreeVariables term
)
=> Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) (Eff m)) where
ret = FunctionC . const . ret
eff op = FunctionC (\ eval -> (alg eval \/ eff . handleReader eval runFunctionC) op)
where alg eval = \case
Abstract.Function name params body k -> runEvaluator $ do
packageInfo <- currentPackage
moduleInfo <- currentModule
Closure packageInfo moduleInfo name params (Right body) <$> close (foldr Set.delete (freeVariables body) params) >>= Evaluator . flip runFunctionC eval . k
Abstract.BuiltIn builtIn k -> do
packageInfo <- currentPackage
moduleInfo <- currentModule
runFunctionC (k (Closure packageInfo moduleInfo Nothing [] (Left builtIn) lowerBound)) eval
Abstract.Call op self params k -> runEvaluator $ do
boxed <- case op of
Closure _ _ _ _ (Left Print) _ -> traverse (deref >=> trace . show) params *> box Unit
Closure _ _ _ _ (Left Show) _ -> deref self >>= box . String . pack . show
Closure packageInfo moduleInfo _ names (Right body) env -> do
-- Evaluate the bindings and body with the closure’s package/module info in scope in order to
-- charge them to the closure's origin.
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
bindings <- foldr (\ (name, addr) rest -> Env.insert name addr <$> rest) (pure lowerBound) (zip names params)
let fnCtx = EvalContext (Just self) (Env.push env)
withEvalContext fnCtx (catchReturn (bindAll bindings *> runFunction (Evaluator . eval) (Evaluator (eval body))))
_ -> throwValueError (CallError op) >>= box
Evaluator $ runFunctionC (k boxed) eval
eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
Abstract.Function name params body k -> runEvaluator $ do
packageInfo <- currentPackage
moduleInfo <- currentModule
Closure packageInfo moduleInfo name params (Right body) <$> close (foldr Set.delete (freeVariables body) params) >>= Evaluator . flip runFunctionC eval . k
Abstract.BuiltIn builtIn k -> do
packageInfo <- currentPackage
moduleInfo <- currentModule
runFunctionC (k (Closure packageInfo moduleInfo Nothing [] (Left builtIn) lowerBound)) eval
Abstract.Call op self params k -> runEvaluator $ do
boxed <- case op of
Closure _ _ _ _ (Left Print) _ -> traverse (deref >=> trace . show) params *> box Unit
Closure _ _ _ _ (Left Show) _ -> deref self >>= box . String . pack . show
Closure packageInfo moduleInfo _ names (Right body) env -> do
-- Evaluate the bindings and body with the closure’s package/module info in scope in order to
-- charge them to the closure's origin.
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
bindings <- foldr (\ (name, addr) rest -> Env.insert name addr <$> rest) (pure lowerBound) (zip names params)
let fnCtx = EvalContext (Just self) (Env.push env)
withEvalContext fnCtx (catchReturn (bindAll bindings *> runFunction (Evaluator . eval) (Evaluator (eval body))))
_ -> throwValueError (CallError op) >>= box
Evaluator $ runFunctionC (k boxed) eval) op)
instance ( Member (Reader ModuleInfo) sig
@ -108,21 +107,10 @@ instance ( Member (Reader ModuleInfo) sig
)
=> Carrier (Abstract.Boolean (Value term address) :+: sig) (BooleanC (Value term address) m) where
ret = BooleanC . ret
eff = BooleanC . (alg \/ eff . handleCoercible)
where alg :: Abstract.Boolean (Value term address) (BooleanC (Value term address) m) (BooleanC (Value term address) m a) -> m a
alg = \case
Abstract.Boolean b k -> runBooleanC . k $! Boolean b
Abstract.AsBool (Boolean b) k -> runBooleanC (k b)
Abstract.AsBool other k -> throwBaseError (BoolError other) >>= runBooleanC . k
Abstract.Disjunction a b k -> do
a' <- runBooleanC a
a'' <- case a' of
Boolean b -> pure b
other -> throwBaseError (BoolError other)
if a'' then
runBooleanC (k a')
else
runBooleanC b >>= runBooleanC . k
eff = BooleanC . handleSum (eff . handleCoercible) (\case
Abstract.Boolean b k -> runBooleanC . k $! Boolean b
Abstract.AsBool (Boolean b) k -> runBooleanC (k b)
Abstract.AsBool other k -> throwBaseError (BoolError other) >>= runBooleanC . k)
instance ( Carrier sig m
@ -140,26 +128,25 @@ instance ( Carrier sig m
)
=> Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) (Eff m)) where
ret = WhileC . ret
eff = WhileC . (alg \/ eff . handleCoercible)
where alg = \case
Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError (Value term address)))) (runEvaluator (loop (\continue -> do
cond' <- Evaluator (runWhileC cond)
eff = WhileC . handleSum (eff . handleCoercible) (\case
Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError (Value term address)))) (runEvaluator (loop (\continue -> do
cond' <- Evaluator (runWhileC cond)
-- `interpose` is used to handle 'UnspecializedError's and abort out of the
-- loop, otherwise under concrete semantics we run the risk of the
-- conditional always being true and getting stuck in an infinite loop.
-- `interpose` is used to handle 'UnspecializedError's and abort out of the
-- loop, otherwise under concrete semantics we run the risk of the
-- conditional always being true and getting stuck in an infinite loop.
ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit))))
(\(Resumable (BaseError _ _ (UnspecializedError _)) _) -> throwError (Abort @address))
>>= runWhileC . k
where
loop x = catchLoopControl @address (fix x) $ \case
Break value -> deref value
Abort -> pure unit
-- 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
ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit))))
(\(Resumable (BaseError _ _ (UnspecializedError _)) _) -> throwError (Abort @address))
>>= runWhileC . k)
where
loop x = catchLoopControl @address (fix x) $ \case
Break value -> deref value
Abort -> pure unit
-- 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
instance AbstractHole (Value term address) where

57
src/Data/Abstract/Value/Type.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances, LambdaCase #-}
{-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Value.Type
( Type (..)
, TypeError (..)
@ -253,26 +253,25 @@ instance ( Member (Allocator address) sig
)
=> Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type (Eff m)) where
ret = FunctionC . const . ret
eff op = FunctionC (\ eval -> (alg eval \/ eff . handleReader eval runFunctionC) op)
where alg eval = \case
Abstract.Function _ params body k -> runEvaluator $ do
(env, tvars) <- foldr (\ name rest -> do
addr <- alloc name
tvar <- Var <$> fresh
assign addr tvar
bimap (Env.insert name addr) (tvar :) <$> rest) (pure (lowerBound, [])) params
locally (catchReturn (bindAll env *> runFunction (Evaluator . eval) (Evaluator (eval body)))) >>= deref >>= Evaluator . flip runFunctionC eval . k . (zeroOrMoreProduct tvars :->)
Abstract.BuiltIn Print k -> runFunctionC (k (String :-> Unit)) eval
Abstract.BuiltIn Show k -> runFunctionC (k (Object :-> String)) eval
Abstract.Call op _ params k -> runEvaluator $ do
tvar <- fresh
paramTypes <- traverse deref params
let needed = zeroOrMoreProduct paramTypes :-> Var tvar
unified <- op `unify` needed
boxed <- case unified of
_ :-> ret -> box ret
actual -> throwTypeError (UnificationError needed actual) >>= box
Evaluator $ runFunctionC (k boxed) eval
eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
Abstract.Function _ params body k -> runEvaluator $ do
(env, tvars) <- foldr (\ name rest -> do
addr <- alloc name
tvar <- Var <$> fresh
assign addr tvar
bimap (Env.insert name addr) (tvar :) <$> rest) (pure (lowerBound, [])) params
locally (catchReturn (bindAll env *> runFunction (Evaluator . eval) (Evaluator (eval body)))) >>= deref >>= Evaluator . flip runFunctionC eval . k . (zeroOrMoreProduct tvars :->)
Abstract.BuiltIn Print k -> runFunctionC (k (String :-> Unit)) eval
Abstract.BuiltIn Show k -> runFunctionC (k (Object :-> String)) eval
Abstract.Call op _ params k -> runEvaluator $ do
tvar <- fresh
paramTypes <- traverse deref params
let needed = zeroOrMoreProduct paramTypes :-> Var tvar
unified <- op `unify` needed
boxed <- case unified of
_ :-> ret -> box ret
actual -> throwTypeError (UnificationError needed actual) >>= box
Evaluator $ runFunctionC (k boxed) eval) op)
instance ( Member (Reader ModuleInfo) sig
@ -285,10 +284,9 @@ instance ( Member (Reader ModuleInfo) sig
)
=> Carrier (Abstract.Boolean Type :+: sig) (BooleanC Type m) where
ret = BooleanC . ret
eff = BooleanC . (alg \/ eff . handleCoercible)
where alg (Abstract.Boolean _ k) = runBooleanC (k Bool)
alg (Abstract.AsBool t k) = unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False))
alg (Abstract.Disjunction t1 t2 k) = (runBooleanC t1 >>= unify Bool) <|> (runBooleanC t2 >>= unify Bool) >>= runBooleanC . k
eff = BooleanC . handleSum (eff . handleCoercible) (\case
Abstract.Boolean _ k -> runBooleanC (k Bool)
Abstract.AsBool t k -> unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False)))
instance ( Member (Abstract.Boolean Type) sig
@ -298,10 +296,11 @@ instance ( Member (Abstract.Boolean Type) sig
)
=> Carrier (Abstract.While Type :+: sig) (WhileC Type m) where
ret = WhileC . ret
eff = WhileC . (alg \/ eff . handleCoercible)
where alg (Abstract.While cond body k) = do
cond' <- runWhileC cond
ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit))
eff = WhileC . handleSum
(eff . handleCoercible)
(\ (Abstract.While cond body k) -> do
cond' <- runWhileC cond
ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit)))
instance AbstractHole Type where

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

@ -249,7 +249,9 @@ instance Ord1 Or where liftCompare = genericLiftCompare
instance Show1 Or where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Or where
eval eval (Or a b) = disjunction (eval a >>= Abstract.value) (eval b >>= Abstract.value) >>= rvalBox
eval eval (Or a b) = do
a' <- eval a >>= Abstract.value
ifthenelse a' (rvalBox a') (eval b)
data And a = And { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)

3
src/Parsing/Parser.hs
View File

@ -31,7 +31,7 @@ module Parsing.Parser
import Assigning.Assignment
import qualified Assigning.Assignment.Deterministic as Deterministic
import qualified CMarkGFM
import Data.Abstract.Evaluatable (HasPostlude, HasPrelude)
import Data.Abstract.Evaluatable (HasPrelude)
import Data.AST
import Data.Graph.ControlFlowVertex (VertexDeclaration')
import Data.Kind
@ -73,7 +73,6 @@ data SomeAnalysisParser typeclasses ann where
, Apply (VertexDeclaration' (Sum fs)) fs
, Element Syntax.Identifier fs
, HasPrelude lang
, HasPostlude lang
)
=> Parser (Term (Sum fs) ann)
-> Proxy lang

131
src/Semantic/Analysis.hs Normal file
View File

@ -0,0 +1,131 @@
{-# LANGUAGE TypeFamilies, TypeOperators #-}
module Semantic.Analysis
( evaluate
, evalTerm
) where
import Control.Abstract
import Control.Effect.Interpose
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import Data.Function
import Prologue
type ModuleC address value m
= ErrorC (LoopControl address) (Eff
( ErrorC (Return address) (Eff
( EnvC address (Eff
( ScopeEnvC address (Eff
( DerefC address value (Eff
( AllocatorC address (Eff
( ReaderC ModuleInfo (Eff
m)))))))))))))
type ValueC term address value m
= FunctionC term address value (Eff
( WhileC value (Eff
( BooleanC value (Eff
( InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff
m)))))))
-- | Evaluate a list of modules with the prelude for the passed language available, and applying the passed function to every module.
evaluate :: ( AbstractValue term address value (ValueC term address value inner)
, Carrier innerSig inner
, Carrier outerSig outer
, derefSig ~ (Deref value :+: allocatorSig)
, derefC ~ (DerefC address value (Eff allocatorC))
, Carrier derefSig derefC
, allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: outerSig)
, allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff outer))))
, Carrier allocatorSig allocatorC
, booleanC ~ BooleanC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff inner)))
, booleanSig ~ (Boolean value :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: innerSig)
, Carrier booleanSig booleanC
, whileC ~ WhileC value (Eff booleanC)
, whileSig ~ (While value :+: booleanSig)
, Carrier whileSig whileC
, functionC ~ FunctionC term address value (Eff whileC)
, functionSig ~ (Function term address value :+: whileSig)
, Carrier functionSig functionC
, Effect outerSig
, HasPrelude lang
, Member Fresh outerSig
, Member (Allocator address) innerSig
, Member (Deref value) innerSig
, Member (Env address) innerSig
, Member Fresh innerSig
, Member (Reader ModuleInfo) innerSig
, Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) outerSig
, Member (Reader Span) innerSig
, Member (Resumable (BaseError (AddressError address value))) innerSig
, Member (Resumable (BaseError (EnvironmentError address))) innerSig
, Member (Resumable (BaseError (UnspecializedError value))) innerSig
, Member (State (Heap address value)) innerSig
, Member Trace innerSig
, Ord address
)
=> proxy lang
-> ( (Module (Either (proxy lang) term) -> Evaluator term address value inner address)
-> (Module (Either (proxy lang) term) -> Evaluator term address value (ModuleC address value outer) address))
-> (term -> Evaluator term address value (ValueC term address value inner) address)
-> [Module term]
-> Evaluator term address value outer (ModuleTable (NonEmpty (Module (ModuleResult address))))
evaluate lang perModule runTerm modules = do
let prelude = Module moduleInfoFromCallStack (Left lang)
(_, (preludeBinds, _)) <- evalModule lowerBound prelude
foldr (run preludeBinds . fmap Right) ask modules
where run prelude m rest = do
evaluated <- evalModule prelude m
-- FIXME: this should be some sort of Monoidal insert à la the Heap to accommodate multiple Go files being part of the same module.
local (ModuleTable.insert (modulePath (moduleInfo m)) ((evaluated <$ m) :| [])) rest
evalModule prelude m = runInModule (perModule (runValueEffects . moduleBody) m)
where runInModule
= raiseHandler (runReader (moduleInfo m))
. runAllocator
. runDeref
. runScopeEnv
. runEnv (EvalContext Nothing (Env.push (newEnv prelude)))
. runReturn
. runLoopControl
runValueEffects = raiseHandler runInterpose . runBoolean . runWhile . runFunction runTerm . either ((*> box unit) . definePrelude) runTerm
-- | Evaluate a term recursively, applying the passed function at every recursive position.
--
-- This calls out to the 'Evaluatable' instances, will be passed to 'runValueEffects', and can have other functions composed after it to e.g. intercept effects arising in the evaluation of the term.
evalTerm :: ( Carrier sig m
, Declarations term
, Evaluatable (Base term)
, FreeVariables term
, AbstractValue term address value m
, Member (Allocator address) sig
, Member (Boolean value) sig
, Member (Deref value) sig
, Member (Env address) sig
, Member (Error (LoopControl address)) sig
, Member (Error (Return address)) sig
, Member Fresh sig
, Member (Function term address value) sig
, Member (Modules address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address value))) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
, Member (Resumable (BaseError EvalError)) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Member (Resumable (BaseError (UnspecializedError value))) sig
, Member (ScopeEnv address) sig
, Member (State (Heap address value)) sig
, Member (State Span) sig
, Member Trace sig
, Member (While value) sig
, Ord address
, Recursive term
)
=> Open (Open (term -> Evaluator term address value m (ValueRef address)))
-> term -> Evaluator term address value m address
evalTerm perTerm = fix (perTerm (\ ev -> eval ev . project)) >=> address

4
src/Semantic/Distribute.hs
View File

@ -55,4 +55,6 @@ newtype DistributeC m a = DistributeC { runDistributeC :: m a }
instance Carrier (Distribute :+: Lift IO) (DistributeC (Eff (LiftC IO))) where
ret = DistributeC . ret
eff = DistributeC . ((\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k) \/ eff . handleCoercible)
eff = DistributeC . handleSum
(eff . handleCoercible)
(\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k)

97
src/Semantic/Graph.hs
View File

@ -59,6 +59,7 @@ import Language.Haskell.HsColour
import Language.Haskell.HsColour.Colourise
import Parsing.Parser
import Prologue hiding (TypeError (..))
import Semantic.Analysis
import Semantic.Task as Task
import System.FilePath.Posix (takeDirectory, (</>))
import Text.Show.Pretty (ppShow)
@ -90,10 +91,8 @@ runCallGraph :: ( VertexDeclarationWithStrategy (VertexDeclarationStrategy synta
, Functor syntax
, Evaluatable syntax
, term ~ Term syntax Location
, FreeVariables term
, Recursive term
, FreeVariables1 syntax
, HasPrelude lang
, HasPostlude lang
, Member Trace sig
, Carrier sig m
, Effect sig
@ -103,29 +102,30 @@ runCallGraph :: ( VertexDeclarationWithStrategy (VertexDeclarationStrategy synta
-> [Module term]
-> Package term
-> Eff m (Graph ControlFlowVertex)
runCallGraph lang includePackages modules package = do
let analyzeTerm = withTermSpans . graphingTerms . cachingTerms
analyzeModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules
extractGraph (graph, _) = simplify graph
runGraphAnalysis
= graphing @_ @_ @_ @(Hole (Maybe Name) (Located Monovariant)) @Abstract
. runHeap
. caching
. raiseHandler runFresh
. resumingLoadError
. resumingUnspecialized
. resumingEnvironmentError
. resumingEvalError
. resumingResolutionError
. resumingAddressError
. raiseHandler (runReader (packageInfo package))
. raiseHandler (runReader (lowerBound @Span))
. raiseHandler (runState (lowerBound @Span))
. raiseHandler (runReader (lowerBound @ControlFlowVertex))
. providingLiveSet
. runModuleTable
. runModules (ModuleTable.modulePaths (packageModules package))
extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm modules))
runCallGraph lang includePackages modules package
= fmap (simplify . fst)
. runEvaluator
. graphing @_ @_ @_ @(Hole (Maybe Name) (Located Monovariant)) @Abstract
. runHeap
. caching
. raiseHandler runFresh
. resumingLoadError
. resumingUnspecialized
. resumingEnvironmentError
. resumingEvalError
. resumingResolutionError
. resumingAddressError
. raiseHandler (runReader (packageInfo package))
. raiseHandler (runReader (lowerBound @Span))
. raiseHandler (runState (lowerBound @Span))
. raiseHandler (runReader (lowerBound @ControlFlowVertex))
. providingLiveSet
. runModuleTable
. runModules (ModuleTable.modulePaths (packageModules package))
$ evaluate lang perModule perTerm modules
where perTerm = evalTerm (withTermSpans . graphingTerms . cachingTerms)
perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules
runModuleTable :: Carrier sig m
=> Evaluator term address value (ReaderC (ModuleTable (NonEmpty (Module (ModuleResult address)))) (Eff m)) a
@ -136,7 +136,6 @@ runImportGraphToModuleInfos :: ( Declarations term
, Evaluatable (Base term)
, FreeVariables term
, HasPrelude lang
, HasPostlude lang
, Member Trace sig
, Recursive term
, Carrier sig m
@ -153,7 +152,6 @@ runImportGraphToModules :: ( Declarations term
, Evaluatable (Base term)
, FreeVariables term
, HasPrelude lang
, HasPostlude lang
, Member Trace sig
, Recursive term
, Carrier sig m
@ -170,7 +168,6 @@ runImportGraph :: ( Declarations term
, Evaluatable (Base term)
, FreeVariables term
, HasPrelude lang
, HasPostlude lang
, Member Trace sig
, Recursive term
, Carrier sig m
@ -181,26 +178,25 @@ runImportGraph :: ( Declarations term
-> Package term
-> (ModuleInfo -> Graph vertex)
-> Eff m (Graph vertex)
runImportGraph lang (package :: Package term) f =
let analyzeModule = graphingModuleInfo
extractGraph (graph, _) = graph >>= f
runImportGraphAnalysis
= raiseHandler (runState lowerBound)
. runHeap
. raiseHandler runFresh
. resumingLoadError
. resumingUnspecialized
. resumingEnvironmentError
. resumingEvalError
. resumingResolutionError
. resumingAddressError
. resumingValueError
. runModuleTable
. runModules (ModuleTable.modulePaths (packageModules package))
. raiseHandler (runReader (packageInfo package))
. raiseHandler (runState (lowerBound @Span))
. raiseHandler (runReader (lowerBound @Span))
in extractGraph <$> runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise)) (runImportGraphAnalysis (evaluate lang analyzeModule id (ModuleTable.toPairs (packageModules package) >>= toList . snd)))
runImportGraph lang (package :: Package term) f
= fmap (fst >=> f)
. runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise))
. raiseHandler (runState lowerBound)
. runHeap
. raiseHandler runFresh
. resumingLoadError
. resumingUnspecialized
. resumingEnvironmentError
. resumingEvalError
. resumingResolutionError
. resumingAddressError
. resumingValueError
. runModuleTable
. runModules (ModuleTable.modulePaths (packageModules package))
. raiseHandler (runReader (packageInfo package))
. raiseHandler (runState (lowerBound @Span))
. raiseHandler (runReader (lowerBound @Span))
$ evaluate lang graphingModuleInfo (evalTerm id) (ModuleTable.toPairs (packageModules package) >>= toList . snd)
runHeap :: (Carrier sig m, Effect sig) => Evaluator term address value (StateC (Heap address value) (Eff m)) a -> Evaluator term address value m (Heap address value, a)
@ -264,8 +260,7 @@ parsePythonPackage parser project = do
strat <- case find ((== (projectRootDir project </> "setup.py")) . filePath) (projectFiles project) of
Just setupFile -> do
setupModule <- fmap snd <$> parseModule project parser setupFile
fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id id [ setupModule ])
-- FIXME: what are we gonna do about runPythonPackaging
fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id (runPythonPackaging . evalTerm id) [ setupModule ])
Nothing -> pure PythonPackage.Unknown
case strat of
PythonPackage.Unknown -> do

24
src/Semantic/REPL.hs
View File

@ -30,6 +30,7 @@ import qualified Data.Time.LocalTime as LocalTime
import Numeric (readDec)
import Parsing.Parser (rubyParser)
import Prologue
import Semantic.Analysis
import Semantic.Config (logOptionsFromConfig)
import Semantic.Distribute
import Semantic.Graph
@ -77,10 +78,9 @@ newtype REPLC m a = REPLC { runREPLC :: (Prefs, Settings IO) -> m a }
instance (Carrier sig m, MonadIO m) => Carrier (REPL :+: sig) (REPLC m) where
ret = REPLC . const . ret
eff op = REPLC (\ args -> (alg args \/ eff . handleReader args runREPLC) op)
where alg args = \case
Prompt k -> liftIO (uncurry runInputTWithPrefs args (getInputLine (cyan <> "repl: " <> plain))) >>= flip runREPLC args . k
Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn s)) *> runREPLC k args
eff op = REPLC (\ args -> handleSum (eff . handleReader args runREPLC) (\case
Prompt k -> liftIO (uncurry runInputTWithPrefs args (getInputLine (cyan <> "repl: " <> plain))) >>= flip runREPLC args . k
Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn s)) *> runREPLC k args) op)
rubyREPL = repl (Proxy @'Language.Ruby) rubyParser
@ -120,7 +120,7 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD
. raiseHandler (runReader (packageInfo package))
. raiseHandler (runState (lowerBound @Span))
. raiseHandler (runReader (lowerBound @Span))
$ evaluate proxy id (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))) modules
$ evaluate proxy id (evalTerm (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package))))) modules
-- TODO: REPL for typechecking/abstract semantics
-- TODO: drive the flow from within the REPL instead of from without
@ -132,13 +132,13 @@ newtype TelemetryIgnoringStatC m a = TelemetryIgnoringStatC { runTelemetryIgnori
instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryIgnoringStatC m) where
ret = TelemetryIgnoringStatC . const . ret
eff op = TelemetryIgnoringStatC (\ logOptions -> (algT logOptions \/ eff . handleReader logOptions runTelemetryIgnoringStatC) op)
where algT logOptions (WriteStat _ k) = runTelemetryIgnoringStatC k logOptions
algT logOptions (WriteLog level message pairs k) = do
time <- liftIO Time.getCurrentTime
zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time)
writeLogMessage logOptions (Message level message pairs zonedTime)
runTelemetryIgnoringStatC k logOptions
eff op = TelemetryIgnoringStatC (\ logOptions -> handleSum (eff . handleReader logOptions runTelemetryIgnoringStatC) (\case
WriteStat _ k -> runTelemetryIgnoringStatC k logOptions
WriteLog level message pairs k -> do
time <- liftIO Time.getCurrentTime
zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time)
writeLogMessage logOptions (Message level message pairs zonedTime)
runTelemetryIgnoringStatC k logOptions) op)
step :: ( Member (Env address) sig
, Member (Error SomeException) sig

8
src/Semantic/Resolution.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, LambdaCase, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Semantic.Resolution
( Resolution (..)
, nodeJSResolutionMap
@ -64,6 +64,6 @@ newtype ResolutionC m a = ResolutionC { runResolutionC :: m a }
instance (Member Files sig, Carrier sig m, Monad m) => Carrier (Resolution :+: sig) (ResolutionC m) where
ret = ResolutionC . ret
eff = ResolutionC . (alg \/ eff . handleCoercible)
where alg (NodeJSResolution dir prop excludeDirs k) = nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k
alg (NoResolution k) = runResolutionC (k Map.empty)
eff = ResolutionC . handleSum (eff . handleCoercible) (\case
NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k
NoResolution k -> runResolutionC (k Map.empty))

23
src/Semantic/Task.hs
View File

@ -206,7 +206,9 @@ newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetryC :: m a
instance (Member Telemetry sig, Carrier sig m, Monad m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where
ret = TraceInTelemetryC . ret
eff = TraceInTelemetryC . ((\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k) \/ eff . handleCoercible)
eff = TraceInTelemetryC . handleSum
(eff . handleCoercible)
(\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k)
-- | An effect describing high-level tasks to be performed.
@ -250,16 +252,15 @@ newtype TaskC m a = TaskC { runTaskC :: m a }
instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader Config) sig, Member Resource sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m) => Carrier (Task :+: sig) (TaskC m) where
ret = TaskC . ret
eff = TaskC . (alg \/ eff . handleCoercible)
where alg = \case
Parse parser blob k -> runParser blob parser >>= runTaskC . k
Analyze interpret analysis k -> runTaskC (k (interpret analysis))
Decorate algebra term k -> runTaskC (k (decoratorWithAlgebra algebra term))
Semantic.Task.Diff terms k -> runTaskC (k (diffTermPair terms))
Render renderer input k -> runTaskC (k (renderer input))
Serialize format input k -> do
formatStyle <- asks (bool Plain Colourful . configIsTerminal)
runTaskC (k (runSerialize formatStyle format input))
eff = TaskC . handleSum (eff . handleCoercible) (\case
Parse parser blob k -> runParser blob parser >>= runTaskC . k
Analyze interpret analysis k -> runTaskC (k (interpret analysis))
Decorate algebra term k -> runTaskC (k (decoratorWithAlgebra algebra term))
Semantic.Task.Diff terms k -> runTaskC (k (diffTermPair terms))
Render renderer input k -> runTaskC (k (renderer input))
Serialize format input k -> do
formatStyle <- asks (bool Plain Colourful . configIsTerminal)
runTaskC (k (runSerialize formatStyle format input)))
-- | Log an 'Error.Error' at the specified 'Level'.

19
src/Semantic/Task/Files.hs
View File

@ -66,16 +66,15 @@ newtype FilesC m a = FilesC { runFilesC :: m a }
instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier (Files :+: sig) (FilesC m) where
ret = FilesC . ret
eff = FilesC . (alg \/ eff . handleCoercible)
where alg = \case
Read (FromPath path) k -> (readBlobFromFile' path `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
Read (FromHandle handle) k -> (readBlobsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
Read (FromPathPair paths) k -> (runBothWith readFilePair paths `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
Read (FromPairHandle handle) k -> (readBlobPairsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
ReadProject rootDir dir language excludeDirs k -> (readProjectFromPaths rootDir dir language excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
FindFiles dir exts excludeDirs k -> (findFilesInDir dir exts excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> runFilesC k
Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> runFilesC k
eff = FilesC . handleSum (eff . handleCoercible) (\case
Read (FromPath path) k -> (readBlobFromFile' path `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
Read (FromHandle handle) k -> (readBlobsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
Read (FromPathPair paths) k -> (runBothWith readFilePair paths `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
Read (FromPairHandle handle) k -> (readBlobPairsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
ReadProject rootDir dir language excludeDirs k -> (readProjectFromPaths rootDir dir language excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
FindFiles dir exts excludeDirs k -> (findFilesInDir dir exts excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> runFilesC k
Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> runFilesC k)
readBlob :: (Member Files sig, Carrier sig m) => File -> m Blob

14
src/Semantic/Telemetry.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances #-}
module Semantic.Telemetry
(
-- Async telemetry interface
@ -158,9 +158,9 @@ newtype TelemetryC m a = TelemetryC { runTelemetryC :: (LogQueue, StatQueue) ->
instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryC m) where
ret = TelemetryC . const . ret
eff op = TelemetryC (\ queues -> (alg queues \/ eff . handleReader queues runTelemetryC) op)
where alg queues (WriteStat stat k) = queueStat (snd queues) stat *> runTelemetryC k queues
alg queues (WriteLog level message pairs k) = queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues
eff op = TelemetryC (\ queues -> handleSum (eff . handleReader queues runTelemetryC) (\case
WriteStat stat k -> queueStat (snd queues) stat *> runTelemetryC k queues
WriteLog level message pairs k -> queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues) op)
-- | Run a 'Telemetry' effect by ignoring statting/logging.
@ -171,6 +171,6 @@ newtype IgnoreTelemetryC m a = IgnoreTelemetryC { runIgnoreTelemetryC :: m a }
instance Carrier sig m => Carrier (Telemetry :+: sig) (IgnoreTelemetryC m) where
ret = IgnoreTelemetryC . ret
eff = alg \/ (IgnoreTelemetryC . eff . handlePure runIgnoreTelemetryC)
where alg (WriteStat _ k) = k
alg (WriteLog _ _ _ k) = k
eff = handleSum (IgnoreTelemetryC . eff . handlePure runIgnoreTelemetryC) (\case
WriteStat _ k -> k
WriteLog _ _ _ k -> k)

7
src/Semantic/Timeout.hs
View File

@ -47,7 +47,6 @@ runTimeoutC f (TimeoutC m) = m f
instance (Carrier sig m, MonadIO m) => Carrier (Timeout :+: sig) (TimeoutC m) where
ret a = TimeoutC (const (ret a))
eff op = TimeoutC (\ handler ->
((\ (Timeout n task k) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeoutC handler task))) >>= runTimeoutC handler . k)
\/ (eff . handlePure (runTimeoutC handler)))
op)
eff op = TimeoutC (\ handler -> handleSum
(eff . handlePure (runTimeoutC handler))
(\ (Timeout n task k) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeoutC handler task))) >>= runTimeoutC handler . k) op)

7
src/Semantic/Util.hs
View File

@ -27,6 +27,7 @@ import Data.Quieterm (quieterm)
import Data.Sum (weaken)
import Parsing.Parser
import Prologue
import Semantic.Analysis
import Semantic.Config
import Semantic.Graph
import Semantic.Task
@ -104,7 +105,7 @@ evaluateProject' (TaskConfig config logger statter) proxy parser paths = either
(raiseHandler (runReader (packageInfo package))
(raiseHandler (runState (lowerBound @Span))
(raiseHandler (runReader (lowerBound @Span))
(evaluate proxy id withTermSpans modules)))))))
(evaluate proxy id (evalTerm withTermSpans) modules)))))))
evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions $ do
project <- readProject Nothing path lang []
@ -117,7 +118,7 @@ evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions
(raiseHandler (runReader (packageInfo package))
(raiseHandler (runState (lowerBound @Span))
(raiseHandler (runReader (lowerBound @Span))
(evaluate proxy id withTermSpans modules)))))))
(evaluate proxy id (evalTerm withTermSpans) modules)))))))
evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ do
@ -130,7 +131,7 @@ evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $
(raiseHandler (runReader (lowerBound @Span))
(runModuleTable
(runModules (ModuleTable.modulePaths (packageModules package))
(evaluate proxy id withTermSpans modules)))))))
(evaluate proxy id (evalTerm withTermSpans) modules)))))))
parseFile :: Parser term -> FilePath -> IO term

1
vendor/fused-effects vendored Submodule

@ -0,0 +1 @@
Subproject commit 5f11d009d486b4e7e1741d0d031f8818818856ea

1
vendor/higher-order-effects vendored

@ -1 +0,0 @@
Subproject commit 9678e1d5325392a23b57a47ddc7a52a5250fb304