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

compiles

Browse Source
This commit is contained in:
Patrick Thomson 2019-03-06 10:12:10 -05:00
parent 4cfcda5aaf
commit 79ae590376
15 changed files with 265 additions and 319 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,4 +1,4 @@
{-# LANGUAGE LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.Graph
( Graph(..)
, ControlFlowVertex(..)
@ -106,20 +106,18 @@ graphingPackages :: ( Member (Reader PackageInfo) sig
, Member (State (Graph ControlFlowVertex)) sig
, Member (Reader ControlFlowVertex) sig
, Carrier sig m
, Monad m
)
=> Open (Module term -> m a)
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 :: ( Member (Modules address value) sig
, Member (Reader ModuleInfo) sig
graphingModules :: ( Member (Reader ModuleInfo) sig
, Member (State (Graph ControlFlowVertex)) sig
, Member (Reader ControlFlowVertex) sig
, Carrier sig m
)
=> (Module body -> Evaluator term address value (EavesdropC address value (Eff m)) a)
=> (Module body -> Evaluator term address value (EavesdropC address value m) a)
-> (Module body -> Evaluator term address value m a)
graphingModules recur m = do
let v = moduleVertex (moduleInfo m)
@ -135,12 +133,11 @@ graphingModules recur m = do
in moduleInclusion (moduleVertex (ModuleInfo path'))
-- | Add vertices to the graph for imported modules.
graphingModuleInfo :: ( Member (Modules address value) sig
, Member (Reader ModuleInfo) sig
graphingModuleInfo :: ( Member (Reader ModuleInfo) sig
, Member (State (Graph ModuleInfo)) sig
, Carrier sig m
)
=> (Module body -> Evaluator term address value (EavesdropC address value (Eff m)) a)
=> (Module body -> Evaluator term address value (EavesdropC address value m) a)
-> (Module body -> Evaluator term address value m a)
graphingModuleInfo recur m = do
appendGraph (vertex (moduleInfo m))
@ -149,28 +146,32 @@ graphingModuleInfo recur m = do
Lookup path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
_ -> pure ()
eavesdrop :: (Carrier sig m, Member (Modules address value) sig)
=> Evaluator term address value (EavesdropC address value (Eff m)) a
-> (forall x . Modules address value (Eff m) (Eff m x) -> Evaluator term address value m ())
eavesdrop :: Evaluator term address value (EavesdropC address value m) a
-> (forall x . Modules address value m (m x) -> Evaluator term address value m ())
-> Evaluator term address value m a
eavesdrop m f = raiseHandler (runEavesdropC (runEvaluator . f) . interpret) m
eavesdrop m f = raiseHandler (runHandler (Handler (runEvaluator . f))) m
newtype EavesdropC address value m a = EavesdropC ((forall x . Modules address value m (m x) -> m ()) -> m a)
newtype Handler address value m = Handler (forall x . Modules address value m (m x) -> m ())
runEavesdropC :: (forall x . Modules address value m (m x) -> m ()) -> EavesdropC address value m a -> m a
runEavesdropC f (EavesdropC m) = m f
newtype EavesdropC address value m a = EavesdropC
{ runEavesdropC :: ReaderC (Handler address value m) m a
} deriving (Alternative, Applicative, Functor, Monad)
runHandler :: Handler address value m -> EavesdropC address value m a -> m a
runHandler h = runReader h . runEavesdropC
instance (Carrier sig m, Member (Modules address value) sig, Applicative m) => Carrier sig (EavesdropC address value 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))
-- eff (R other) = _ other
-- eff (L op) = do
-- handler <- EavesdropC ask
-- case prj op of
-- Just e -> runHandler handler e *> send e
-- Nothing -> undefined
-- | Add an edge from the current package to the passed vertex.
packageInclusion :: ( Member (Reader PackageInfo) sig
, Member (State (Graph ControlFlowVertex)) sig
, Carrier sig m
, Monad m
)
=> ControlFlowVertex
-> m ()
@ -182,7 +183,6 @@ packageInclusion v = do
moduleInclusion :: ( Member (Reader ModuleInfo) sig
, Member (State (Graph ControlFlowVertex)) sig
, Carrier sig m
, Monad m
)
=> ControlFlowVertex
-> m ()
@ -194,7 +194,6 @@ moduleInclusion v = do
variableDefinition :: ( Member (State (Graph ControlFlowVertex)) sig
, Member (Reader ControlFlowVertex) sig
, Carrier sig m
, Monad m
)
=> ControlFlowVertex
-> m ()
@ -206,9 +205,9 @@ appendGraph :: (Member (State (Graph v)) sig, Carrier sig m) => Graph v -> m ()
appendGraph = modify . (<>)
graphing :: (Carrier sig m, Effect sig)
=> Evaluator term address value (StateC (Map (Slot address) ControlFlowVertex) (Eff
(StateC (Graph ControlFlowVertex) (Eff
m)))) result
graphing :: Carrier sig m
=> Evaluator term address value (StateC (Map (Slot address) ControlFlowVertex)
(StateC (Graph ControlFlowVertex)
m)) result
-> Evaluator term address value m (Graph ControlFlowVertex, result)
graphing = raiseHandler $ runState mempty . fmap snd . runState lowerBound

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

@ -14,12 +14,7 @@ import Prologue
data Strategy = Unknown | Packages [Text] | FindPackages [Text]
deriving (Show, Eq)
runPythonPackaging :: ( Carrier sig m
, Member (Abstract.String (Value term address)) sig
, Member (Abstract.Array (Value term address)) sig
, Member (State Strategy) sig
, Member (Function term address (Value term address)) sig)
=> Evaluator term address (Value term address) (PythonPackagingC term address m) a
runPythonPackaging :: Evaluator term address (Value term address) (PythonPackagingC term address m) a
-> Evaluator term address (Value term address) m a
runPythonPackaging = raiseHandler runPythonPackagingC

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

@ -144,7 +144,7 @@ runFunction :: (term -> Evaluator term address value (FunctionC term address val
runFunction eval = raiseHandler (runReader (runEvaluator . eval) . runFunctionC)
newtype FunctionC term address value m a = FunctionC { runFunctionC :: ReaderC (term -> FunctionC term address value m value) m a }
deriving newtype (Applicative, Functor, Monad)
deriving newtype (Alternative, Applicative, Functor, Monad)
-- | Construct a boolean value in the abstract domain.
boolean :: (Member (Boolean value) sig, Carrier sig m) => Bool -> m value
@ -252,7 +252,7 @@ runUnit = raiseHandler $ runUnitC
newtype UnitC value m a = UnitC { runUnitC :: m a }
deriving stock Functor
deriving newtype (Applicative, Monad)
deriving newtype (Alternative, Applicative, Monad)
-- | Construct a String value in the abstract domain.
string :: (Member (String value) sig, Carrier sig m) => Text -> m value
@ -277,7 +277,7 @@ instance Effect (String value) where
newtype StringC value m a = StringC { runStringC :: m a }
deriving stock Functor
deriving newtype (Applicative, Monad)
deriving newtype (Alternative, Applicative, Monad)
runString :: Evaluator term address value (StringC value m) a
-> Evaluator term address value m a
@ -331,7 +331,7 @@ instance Effect (Numeric value) where
newtype NumericC value m a = NumericC { runNumericC :: m a }
deriving stock Functor
deriving newtype (Applicative, Monad)
deriving newtype (Alternative, Applicative, Monad)
runNumeric :: Evaluator term address value (NumericC value m) a
-> Evaluator term address value m a
@ -385,7 +385,7 @@ runBitwise = raiseHandler $ runBitwiseC
newtype BitwiseC value m a = BitwiseC { runBitwiseC :: m a }
deriving stock Functor
deriving newtype (Applicative, Monad)
deriving newtype (Alternative, Applicative, Monad)
object :: (Member (Object address value) sig, Carrier sig m) => address -> m value
object address = send (Object address pure)
@ -415,7 +415,7 @@ instance Effect (Object address value) where
newtype ObjectC address value m a = ObjectC { runObjectC :: m a }
deriving stock Functor
deriving newtype (Applicative, Monad)
deriving newtype (Alternative, Applicative, Monad)
runObject :: Evaluator term address value (ObjectC address value m) a
-> Evaluator term address value m a
@ -442,7 +442,7 @@ instance Effect (Array value) where
newtype ArrayC value m a = ArrayC { runArrayC :: m a }
deriving stock Functor
deriving newtype (Applicative, Monad)
deriving newtype (Alternative, Applicative, Monad)
runArray :: Evaluator term address value (ArrayC value m) a
-> Evaluator term address value m a
@ -470,7 +470,7 @@ instance Effect (Hash value) where
newtype HashC value m a = HashC { runHashC :: m a }
deriving stock Functor
deriving newtype (Applicative, Monad)
deriving newtype (Alternative, Applicative, Monad)
runHash :: Evaluator term address value (HashC value m) a
-> Evaluator term address value m a

31
src/Semantic/Analysis.hs
View File

@ -86,35 +86,25 @@ evaluate lang runModule modules = do
. runModule
runDomainEffects :: ( AbstractValue term address value (DomainC term address value m)
, Carrier sig m
, unitC ~ UnitC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m)))
, unitC ~ UnitC value (InterposeC (Resumable (BaseError (UnspecializedError address value))) m)
, unitSig ~ (Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig)
, Carrier unitSig unitC
, hashC ~ HashC value (Eff unitC)
, hashC ~ HashC value unitC
, hashSig ~ (Abstract.Hash value :+: unitSig)
, Carrier hashSig hashC
, arrayC ~ ArrayC value (Eff hashC)
, arrayC ~ ArrayC value hashC
, arraySig ~ (Abstract.Array value :+: hashSig)
, Carrier arraySig arrayC
, objectC ~ ObjectC address value (Eff arrayC)
, objectC ~ ObjectC address value arrayC
, objectSig ~ (Abstract.Object address value :+: arraySig)
, Carrier objectSig objectC
, bitwiseC ~ BitwiseC value (Eff objectC)
, bitwiseC ~ BitwiseC value objectC
, bitwiseSig ~ (Abstract.Bitwise value :+: objectSig)
, Carrier bitwiseSig bitwiseC
, numericC ~ NumericC value (Eff bitwiseC)
, numericC ~ NumericC value bitwiseC
, numericSig ~ (Abstract.Numeric value :+: bitwiseSig)
, Carrier numericSig numericC
, stringC ~ StringC value (Eff numericC)
, stringC ~ StringC value numericC
, stringSig ~ (Abstract.String value :+: numericSig)
, Carrier stringSig stringC
, booleanC ~ BooleanC value (Eff stringC)
, booleanC ~ BooleanC value stringC
, booleanSig ~ (Boolean value :+: stringSig)
, Carrier booleanSig booleanC
, whileC ~ WhileC value (Eff booleanC)
, whileC ~ WhileC value booleanC
, whileSig ~ (While value :+: booleanSig)
, Carrier whileSig whileC
, functionC ~ FunctionC term address value (Eff whileC)
, functionC ~ FunctionC term address value whileC
, functionSig ~ (Function term address value :+: whileSig)
, Carrier functionSig functionC
, HasPrelude lang
@ -128,7 +118,6 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val
, Member (Resumable (BaseError (AddressError address value))) sig
, Member (Resumable (BaseError (HeapError address))) sig
, Member (Resumable (BaseError (ScopeError address))) sig
, Member (Resumable (BaseError (UnspecializedError address value))) sig
, Member (State (Heap address address value)) sig
, Member (State (ScopeGraph address)) sig
, Member Trace sig

14
src/Semantic/Distribute.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE ExistentialQuantification, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
module Semantic.Distribute
( distribute
, distributeFor
@ -18,19 +18,19 @@ import Prologue
-- | Distribute a 'Traversable' container of tasks over the available cores (i.e. execute them concurrently), collecting their results.
--
-- This is a concurrent analogue of 'sequenceA'.
distribute :: (Member Distribute sig, Traversable t, Carrier sig m, Applicative m) => t (m output) -> m (t output)
distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . flip Distribute ret)
distribute :: (Member Distribute sig, Traversable t, Carrier sig m) => t (m output) -> m (t output)
distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . flip Distribute pure)
-- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), collecting the results.
--
-- This is a concurrent analogue of 'for' or 'traverse' (with the arguments flipped).
distributeFor :: (Member Distribute sig, Traversable t, Carrier sig m, Applicative m) => t a -> (a -> m output) -> m (t output)
distributeFor :: (Member Distribute sig, Traversable t, Carrier sig m) => t a -> (a -> m output) -> m (t output)
distributeFor inputs toTask = distribute (fmap toTask inputs)
-- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), combining the results 'Monoid'ally into a final value.
--
-- This is a concurrent analogue of 'foldMap'.
distributeFoldMap :: (Member Distribute sig, Monoid output, Traversable t, Carrier sig m, Applicative m) => (a -> m output) -> t a -> m output
distributeFoldMap :: (Member Distribute sig, Monoid output, Traversable t, Carrier sig m) => (a -> m output) -> t a -> m output
distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs))
@ -52,8 +52,8 @@ runDistribute :: DistributeC (LiftC IO) a -> LiftC IO a
runDistribute = runDistributeC
newtype DistributeC m a = DistributeC { runDistributeC :: m a }
deriving (Functor, Applicative, Monad)
deriving (Functor, Applicative, Monad, MonadIO)
instance Carrier (Distribute :+: Lift IO) (DistributeC (LiftC IO)) where
eff (L (Distribute task k)) = liftIO (Async.runConcurrently (Async.Concurrently (runM task))) >>= k
eff (L (Distribute task k)) = liftIO (Async.runConcurrently (Async.Concurrently (runM . runDistributeC $ task))) >>= k
eff (R other) = DistributeC (eff (handleCoercible other))

69
src/Semantic/Graph.hs
View File

@ -82,7 +82,7 @@ runGraph :: ( Member Distribute sig
=> GraphType
-> Bool
-> Project
-> Eff m (Graph ControlFlowVertex)
-> m (Graph ControlFlowVertex)
runGraph ImportGraph _ project
| SomeAnalysisParser parser (lang' :: Proxy lang) <- someAnalysisParser (Proxy :: Proxy AnalysisClasses) (projectLanguage project) = do
let parse = if projectLanguage project == Language.Python then parsePythonPackage parser else fmap (fmap snd) . parsePackage parser
@ -112,7 +112,7 @@ runCallGraph :: ( VertexDeclarationWithStrategy (VertexDeclarationStrategy synta
-> Bool
-> [Module term]
-> Package term
-> Eff m (Graph ControlFlowVertex)
-> m (Graph ControlFlowVertex)
runCallGraph lang includePackages modules package
= fmap (simplify . fst)
. runEvaluator
@ -140,8 +140,7 @@ runCallGraph lang includePackages modules package
perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules $ runDomainEffects perTerm
runModuleTable :: Carrier sig m
=> Evaluator term address value (ReaderC (ModuleTable (Module (ModuleResult address value))) (Eff m)) a
runModuleTable :: Evaluator term address value (ReaderC (ModuleTable (Module (ModuleResult address value))) m) a
-> Evaluator term address value m a
runModuleTable = raiseHandler $ runReader lowerBound
@ -159,7 +158,7 @@ runImportGraphToModuleInfos :: ( Declarations term
)
=> Proxy lang
-> Package term
-> Eff m (Graph ControlFlowVertex)
-> m (Graph ControlFlowVertex)
runImportGraphToModuleInfos lang (package :: Package term) = runImportGraph lang package allModuleInfos
where allModuleInfos info = vertex (maybe (unknownModuleVertex info) (moduleVertex . moduleInfo) (ModuleTable.lookup (modulePath info) (packageModules package)))
@ -177,7 +176,7 @@ runImportGraphToModules :: ( Declarations term
)
=> Proxy lang
-> Package term
-> Eff m (Graph (Module term))
-> m (Graph (Module term))
runImportGraphToModules lang (package :: Package term) = runImportGraph lang package resolveOrLowerBound
where resolveOrLowerBound info = maybe lowerBound vertex (ModuleTable.lookup (modulePath info) (packageModules package))
@ -196,7 +195,7 @@ runImportGraph :: ( AccessControls term
=> Proxy lang
-> Package term
-> (ModuleInfo -> Graph vertex)
-> Eff m (Graph vertex)
-> m (Graph vertex)
runImportGraph lang (package :: Package term) f
= fmap (fst >=> f)
. runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise))
@ -220,14 +219,13 @@ runImportGraph lang (package :: Package term) f
. runAllocator
$ evaluate lang (graphingModuleInfo (runDomainEffects (evalTerm id))) (snd <$> ModuleTable.toPairs (packageModules package))
runHeap :: (Carrier sig m, Effect sig)
=> Evaluator term address value (StateC (Heap address address value) (Eff m)) a
runHeap :: Evaluator term address value (StateC (Heap address address value) m) a
-> Evaluator term address value m (Heap address address value, a)
runHeap = raiseHandler (runState lowerBound)
runScopeGraph :: (Carrier sig m, Effect sig, Ord address)
=> Evaluator term address value (StateC (ScopeGraph address) (Eff m)) a
-> Evaluator term address value m (ScopeGraph address, a)
runScopeGraph :: Ord address
=> Evaluator term address value (StateC (ScopeGraph address) m) a
-> Evaluator term address value m (ScopeGraph address, a)
runScopeGraph = raiseHandler (runState lowerBound)
-- | Parse a list of files into a 'Package'.
@ -267,7 +265,7 @@ parsePythonPackage :: forall syntax sig m term.
)
=> Parser term -- ^ A parser.
-> Project -- ^ Project to parse into a package.
-> Eff m (Package term)
-> m (Package term)
parsePythonPackage parser project = do
let runAnalysis = runEvaluator @_ @_ @(Value term (Hole (Maybe Name) Precise))
. raiseHandler (runState PythonPackage.Unknown)
@ -347,19 +345,20 @@ withTermSpans recur term = let
resumingResolutionError :: ( Member Trace sig
, Carrier sig m
)
=> Evaluator term address value (ResumableWithC (BaseError ResolutionError) (Eff
m)) a
=> Evaluator term address value (ResumableWithC (BaseError ResolutionError) m) a
-> Evaluator term address value m a
resumingResolutionError = runResolutionErrorWith (\ baseError -> traceError "ResolutionError" baseError *> case baseErrorException baseError of
NotFoundError nameToResolve _ _ -> pure nameToResolve
GoImportError pathToResolve -> pure [pathToResolve])
resumingResolutionError = runResolutionErrorWith $ \ baseError -> do
traceError "ResolutionError" baseError
case baseErrorException baseError of
NotFoundError nameToResolve _ _ -> pure nameToResolve
GoImportError pathToResolve -> pure [pathToResolve]
resumingLoadError :: ( Carrier sig m
, Member Trace sig
, AbstractHole value
, AbstractHole address
)
=> Evaluator term address value (ResumableWithC (BaseError (LoadError address value)) (Eff m)) a
=> Evaluator term address value (ResumableWithC (BaseError (LoadError address value)) m) a
-> Evaluator term address value m a
resumingLoadError = runLoadErrorWith (\ baseError -> traceError "LoadError" baseError *> case baseErrorException baseError of
ModuleNotFoundError _ -> pure ((hole, hole), hole))
@ -372,8 +371,7 @@ resumingEvalError :: ( Carrier sig m
, AbstractHole address
, AbstractHole value
)
=> Evaluator term address value (ResumableWithC (BaseError (EvalError term address value)) (Eff
m)) a
=> Evaluator term address value (ResumableWithC (BaseError (EvalError term address value)) m) a
-> Evaluator term address value m a
resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" baseError *> case baseErrorException baseError of
AccessControlError{} -> pure hole
@ -393,8 +391,7 @@ resumingUnspecialized :: ( AbstractHole address
, Carrier sig m
, Member Trace sig
)
=> Evaluator term address value (ResumableWithC (BaseError (UnspecializedError address value)) (Eff
m)) a
=> Evaluator term address value (ResumableWithC (BaseError (UnspecializedError address value)) m) a
-> Evaluator term address value m a
resumingUnspecialized = runUnspecializedWith (\ baseError -> traceError "UnspecializedError" baseError *> case baseErrorException baseError of
UnspecializedError _ -> pure hole
@ -405,20 +402,20 @@ resumingAddressError :: ( AbstractHole value
, Member Trace sig
, Show address
)
=> Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) (Eff
m)) a
=> Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) m) a
-> Evaluator term address value m a
resumingAddressError = runAddressErrorWith $ \ baseError -> traceError "AddressError" baseError *> case baseErrorException baseError of
UnallocatedSlot _ -> pure lowerBound
UninitializedSlot _ -> pure hole
resumingAddressError = runAddressErrorWith $ \ baseError -> do
traceError "AddressError" baseError
case baseErrorException baseError of
UnallocatedSlot _ -> pure lowerBound
UninitializedSlot _ -> pure hole
resumingValueError :: ( Carrier sig m
, Member Trace sig
, Show address
, Show term
)
=> Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) (Eff
m)) a
=> Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) m) a
-> Evaluator term address (Value term address) m a
resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" baseError *> case baseErrorException baseError of
CallError{} -> pure hole
@ -440,7 +437,7 @@ resumingHeapError :: ( Carrier sig m
, Member Trace sig
, Show address
)
=> Evaluator term address value (ResumableWithC (BaseError (HeapError address)) (Eff m)) a
=> Evaluator term address value (ResumableWithC (BaseError (HeapError address)) m) a
-> Evaluator term address value m a
resumingHeapError = runHeapErrorWith (\ baseError -> traceError "ScopeError" baseError *> case baseErrorException baseError of
CurrentFrameError -> pure hole
@ -458,7 +455,7 @@ resumingScopeError :: ( Carrier sig m
, AbstractHole (Info address)
, AbstractHole address
)
=> Evaluator term address value (ResumableWithC (BaseError (ScopeError address)) (Eff m)) a
=> Evaluator term address value (ResumableWithC (BaseError (ScopeError address)) m) a
-> Evaluator term address value m a
resumingScopeError = runScopeErrorWith (\ baseError -> traceError "ScopeError" baseError *> case baseErrorException baseError of
ScopeError _ _ -> pure hole
@ -470,13 +467,13 @@ resumingScopeError = runScopeErrorWith (\ baseError -> traceError "ScopeError" b
DeclarationByNameError _ -> pure hole)
resumingTypeError :: ( Carrier sig m
, Member NonDet sig
, Member Trace sig
, Effect sig
, Alternative m
)
=> Evaluator term address Type (ResumableWithC (BaseError TypeError) (Eff
(StateC TypeMap (Eff
m)))) a
=> Evaluator term address Type (ResumableWithC (BaseError TypeError)
(StateC TypeMap
m)) a
-> Evaluator term address Type m a
resumingTypeError = runTypesWith (\ baseError -> traceError "TypeError" baseError *> case baseErrorException baseError of
UnificationError l r -> pure l <|> pure r

27
src/Semantic/REPL.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, LambdaCase, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, LambdaCase, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
module Semantic.REPL
( rubyREPL
@ -100,20 +100,23 @@ repl proxy parser paths =
-- TODO: drive the flow from within the REPL instead of from without
runTelemetryIgnoringStat :: (Carrier sig m, MonadIO m) => LogOptions -> Eff (TelemetryIgnoringStatC m) a -> m a
runTelemetryIgnoringStat logOptions = flip runTelemetryIgnoringStatC logOptions . interpret
runTelemetryIgnoringStat :: (Carrier sig m, MonadIO m) => LogOptions -> TelemetryIgnoringStatC m a -> m a
runTelemetryIgnoringStat logOptions = runReader logOptions . runTelemetryIgnoringStatC
newtype TelemetryIgnoringStatC m a = TelemetryIgnoringStatC { runTelemetryIgnoringStatC :: LogOptions -> m a }
newtype TelemetryIgnoringStatC m a = TelemetryIgnoringStatC { runTelemetryIgnoringStatC :: ReaderC LogOptions m a }
deriving (Applicative, Functor, Monad, MonadIO)
instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryIgnoringStatC m) where
ret = TelemetryIgnoringStatC . const . ret
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)
eff (R other) = TelemetryIgnoringStatC . eff . R . handleCoercible $ other
eff (L op) = do
logOptions <- TelemetryIgnoringStatC ask
case op of
WriteStat _ k -> k
WriteLog level message pairs k -> do
time <- liftIO Time.getCurrentTime
zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time)
writeLogMessage logOptions (Message level message pairs zonedTime)
k
step :: ( Member (Error SomeException) sig
, Member REPL sig

21
src/Semantic/Resolution.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, LambdaCase, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Semantic.Resolution
( Resolution (..)
, nodeJSResolutionMap
@ -41,9 +41,9 @@ nodeJSResolutionMap rootDir prop excludeDirs = do
resolutionMap :: (Member Resolution sig, Carrier sig m) => Project -> m (Map FilePath FilePath)
resolutionMap Project{..} = case projectLanguage of
TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs ret)
JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs ret)
_ -> send (NoResolution ret)
TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs pure)
JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs pure)
_ -> send (NoResolution pure)
data Resolution (m :: * -> *) k
= NodeJSResolution FilePath Text [FilePath] (Map FilePath FilePath -> k)
@ -57,13 +57,14 @@ instance Effect Resolution where
handle state handler (NodeJSResolution path key paths k) = NodeJSResolution path key paths (handler . (<$ state) . k)
handle state handler (NoResolution k) = NoResolution (handler . (<$ state) . k)
runResolution :: (Member Files sig, Carrier sig m) => Eff (ResolutionC m) a -> m a
runResolution = runResolutionC . interpret
runResolution :: ResolutionC m a -> m a
runResolution = runResolutionC
newtype ResolutionC m a = ResolutionC { runResolutionC :: m a }
deriving (Applicative, Functor, Monad, MonadIO)
instance (Member Files sig, Carrier sig m) => Carrier (Resolution :+: sig) (ResolutionC m) where
ret = ResolutionC . ret
eff = ResolutionC . handleSum (eff . handleCoercible) (\case
NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k
NoResolution k -> runResolutionC (k Map.empty))
eff (R other) = ResolutionC . eff . handleCoercible $ other
eff (L op) = case op of
NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= k
NoResolution k -> k Map.empty

81
src/Semantic/Task.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, KindSignatures, LambdaCase, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
module Semantic.Task
( Task
, TaskEff
@ -47,7 +47,6 @@ module Semantic.Task
, ParserCancelled(..)
-- * Re-exports
, Distribute
, Eff
, Error
, Lift
, throwError
@ -95,17 +94,17 @@ import Serializing.Format hiding (Options)
-- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap'
type TaskEff
= Eff (TaskC
( Eff (ResolutionC
( Eff (Files.FilesC
( Eff (ReaderC TaskSession
( Eff (TraceInTelemetryC
( Eff (TelemetryC
( Eff (ErrorC SomeException
( Eff (TimeoutC
( Eff (ResourceC
( Eff (DistributeC
( Eff (LiftC IO)))))))))))))))))))))
= TaskC
( ResolutionC
( Files.FilesC
( ReaderC TaskSession
( TraceInTelemetryC
( TelemetryC
( ErrorC SomeException
( TimeoutC
( ResourceC
( DistributeC
( LiftC IO))))))))))
-- | A function to render terms or diffs.
type Renderer i o = i -> o
@ -115,40 +114,40 @@ parse :: (Member Task sig, Carrier sig m)
=> Parser term
-> Blob
-> m term
parse parser blob = send (Parse parser blob ret)
parse parser blob = send (Parse parser blob pure)
-- | A task running some 'Analysis.Evaluator' to completion.
analyze :: (Member Task sig, Carrier sig m)
=> (Analysis.Evaluator term address value m a -> result)
-> Analysis.Evaluator term address value m a
-> m result
analyze interpret analysis = send (Analyze interpret analysis ret)
analyze interpret analysis = send (Analyze interpret analysis pure)
-- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
decorate :: (Functor f, Member Task sig, Carrier sig m)
=> RAlgebra (TermF f Location) (Term f Location) field
-> Term f Location
-> m (Term f field)
decorate algebra term = send (Decorate algebra term ret)
decorate algebra term = send (Decorate algebra term pure)
-- | A task which diffs a pair of terms using the supplied 'Differ' function.
diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member Task sig, Carrier sig m)
=> These (Term syntax ann) (Term syntax ann)
-> m (Diff syntax ann ann)
diff terms = send (Semantic.Task.Diff terms ret)
diff terms = send (Semantic.Task.Diff terms pure)
-- | A task which renders some input using the supplied 'Renderer' function.
render :: (Member Task sig, Carrier sig m)
=> Renderer input output
-> input
-> m output
render renderer input = send (Render renderer input ret)
render renderer input = send (Render renderer input pure)
serialize :: (Member Task sig, Carrier sig m)
=> Format input
-> input
-> m Builder
serialize format input = send (Serialize format input ret)
serialize format input = send (Serialize format input pure)
data TaskSession
= TaskSession
@ -191,18 +190,16 @@ withOptions options with = do
config <- defaultConfig options
withTelemetry config (\ (TelemetryQueues logger statter _) -> with config logger statter)
runTraceInTelemetry :: (Member Telemetry sig, Carrier sig m)
=> Eff (TraceInTelemetryC m) a
runTraceInTelemetry :: TraceInTelemetryC m a
-> m a
runTraceInTelemetry = runTraceInTelemetryC . interpret
runTraceInTelemetry = runTraceInTelemetryC
newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetryC :: m a }
deriving (Applicative, Functor, Monad, MonadIO)
instance (Member Telemetry sig, Carrier sig m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where
ret = TraceInTelemetryC . ret
eff = TraceInTelemetryC . handleSum
(eff . handleCoercible)
(\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k)
eff (R other) = TraceInTelemetryC . eff . handleCoercible $ other
eff (L (Trace str k)) = writeLog Debug str [] >> k
-- | An effect describing high-level tasks to be performed.
@ -228,33 +225,23 @@ instance Effect Task where
handle state handler (Serialize format input k) = Serialize format input (handler . (<$ state) . k)
-- | Run a 'Task' effect by performing the actions in 'IO'.
runTaskF :: ( Member (Error SomeException) sig
, Member (Lift IO) sig
, Member (Reader TaskSession) sig
, Member Resource sig
, Member Telemetry sig
, Member Timeout sig
, Member Trace sig
, Carrier sig m
, MonadIO m
)
=> Eff (TaskC m) a
-> m a
runTaskF = runTaskC . interpret
runTaskF :: TaskC m a -> m a
runTaskF = runTaskC
newtype TaskC m a = TaskC { runTaskC :: m a }
deriving (Applicative, Functor, Monad, MonadIO)
instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader TaskSession) 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 . 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))
eff (R other) = TaskC . eff . handleCoercible $ other
eff (L op) = case op of
Parse parser blob k -> runParser blob parser >>= k
Analyze interpret analysis k -> k . interpret $ analysis
Decorate algebra term k -> k (decoratorWithAlgebra algebra term)
Semantic.Task.Diff terms k -> k (diffTermPair terms)
Render renderer input k -> k (renderer input)
Serialize format input k -> do
formatStyle <- asks (bool Plain Colourful . configIsTerminal . config)
runTaskC (k (runSerialize formatStyle format input)))
k (runSerialize formatStyle format input)
-- | Log an 'Error.Error' at the specified 'Level'.

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

@ -1,4 +1,4 @@
{-# LANGUAGE ExistentialQuantification, GADTs, LambdaCase, KindSignatures, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, LambdaCase, KindSignatures, TypeOperators, UndecidableInstances #-}
module Semantic.Task.Files
( Files
@ -59,11 +59,11 @@ instance Effect Files where
handle state handler (Write destination builder k) = Write destination builder (handler (k <$ state))
-- | Run a 'Files' effect in 'IO'.
runFiles :: (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => FilesC m a -> m a
runFiles :: FilesC m a -> m a
runFiles = runFilesC
newtype FilesC m a = FilesC { runFilesC :: m a }
deriving (Functor, Applicative, Monad)
deriving (Functor, Applicative, Monad, MonadIO)
instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier (Files :+: sig) (FilesC m) where
eff (L op) = case op of
@ -73,33 +73,33 @@ instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier
Read (FromPairHandle handle) k -> (readBlobPairsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= k
ReadProject rootDir dir language excludeDirs k -> (readProjectFromPaths rootDir dir language excludeDirs `catchIO` (throwError . toException @SomeException)) >>= k
FindFiles dir exts excludeDirs k -> (findFilesInDir dir exts excludeDirs `catchIO` (throwError . toException @SomeException)) >>= 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)
Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> k
Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> k
eff (R other) = FilesC (eff (handleCoercible other))
readBlob :: (Member Files sig, Carrier sig m) => File -> m Blob
readBlob file = send (Read (FromPath file) ret)
readBlob file = send (Read (FromPath file) pure)
-- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
readBlobs :: (Member Files sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [File] -> m [Blob]
readBlobs (Left handle) = send (Read (FromHandle handle) ret)
readBlobs (Right paths) = traverse (send . flip Read ret . FromPath) paths
readBlobs :: (Member Files sig, Carrier sig m) => Either (Handle 'IO.ReadMode) [File] -> m [Blob]
readBlobs (Left handle) = send (Read (FromHandle handle) pure)
readBlobs (Right paths) = traverse (send . flip Read pure . FromPath) paths
-- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
readBlobPairs :: (Member Files sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair]
readBlobPairs (Left handle) = send (Read (FromPairHandle handle) ret)
readBlobPairs (Right paths) = traverse (send . flip Read ret . FromPathPair) paths
readBlobPairs :: (Member Files sig, Carrier sig m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair]
readBlobPairs (Left handle) = send (Read (FromPairHandle handle) pure)
readBlobPairs (Right paths) = traverse (send . flip Read pure . FromPathPair) paths
readProject :: (Member Files sig, Carrier sig m) => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs ret)
readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs pure)
findFiles :: (Member Files sig, Carrier sig m) => FilePath -> [String] -> [FilePath] -> m [FilePath]
findFiles dir exts paths = send (FindFiles dir exts paths ret)
findFiles dir exts paths = send (FindFiles dir exts paths pure)
-- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'.
write :: (Member Files sig, Carrier sig m) => Destination -> B.Builder -> m ()
write dest builder = send (Write dest builder (ret ()))
write dest builder = send (Write dest builder (pure ()))
-- | Generalize 'Exc.catch' to other 'MonadIO' contexts for the handler and result.

23
src/Semantic/Telemetry.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE DerivingStrategies, GADTs, KindSignatures, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE DerivingStrategies, GADTs, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances #-}
module Semantic.Telemetry
(
-- Async telemetry interface
@ -52,6 +52,7 @@ module Semantic.Telemetry
import Control.Effect
import Control.Effect.Carrier
import Control.Effect.Reader
import Control.Effect.Sum
import Control.Exception
import Control.Monad.IO.Class
@ -121,11 +122,11 @@ queueStat q = liftIO . writeAsyncQueue q
-- | A task which logs a message at a specific log level to stderr.
writeLog :: (Member Telemetry sig, Carrier sig m) => Level -> String -> [(String, String)] -> m ()
writeLog level message pairs = send (WriteLog level message pairs (ret ()))
writeLog level message pairs = send (WriteLog level message pairs (pure ()))
-- | A task which writes a stat.
writeStat :: (Member Telemetry sig, Carrier sig m) => Stat -> m ()
writeStat stat = send (WriteStat stat (ret ()))
writeStat stat = send (WriteStat stat (pure ()))
-- | A task which measures and stats the timing of another task.
time :: (Member Telemetry sig, Carrier sig m, MonadIO m) => String -> [(String, String)] -> m output -> m output
@ -151,8 +152,8 @@ instance Effect Telemetry where
handle state handler (WriteLog level message pairs k) = WriteLog level message pairs (handler (k <$ state))
-- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to.
runTelemetry :: (Carrier sig m, MonadIO m) => LogQueue -> StatQueue -> TelemetryC m a -> m a
runTelemetry logger statter = flip runTelemetryC (logger, statter)
runTelemetry :: LogQueue -> StatQueue -> TelemetryC m a -> m a
runTelemetry logger statter = runReader (logger, statter) . runTelemetryC
newtype TelemetryC m a = TelemetryC { runTelemetryC :: ReaderC (LogQueue, StatQueue) m a }
deriving (Applicative, Functor, Monad, MonadIO)
@ -166,13 +167,13 @@ instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryC m
eff (R other) = TelemetryC (eff (R (handleCoercible other)))
-- | Run a 'Telemetry' effect by ignoring statting/logging.
ignoreTelemetry :: Carrier sig m => Eff (IgnoreTelemetryC m) a -> m a
ignoreTelemetry = runIgnoreTelemetryC . interpret
ignoreTelemetry :: IgnoreTelemetryC m a -> m a
ignoreTelemetry = runIgnoreTelemetryC
newtype IgnoreTelemetryC m a = IgnoreTelemetryC { runIgnoreTelemetryC :: m a }
deriving (Applicative, Functor, Monad)
instance Carrier sig m => Carrier (Telemetry :+: sig) (IgnoreTelemetryC m) where
ret = IgnoreTelemetryC . ret
eff = handleSum (IgnoreTelemetryC . eff . handlePure runIgnoreTelemetryC) (\case
WriteStat _ k -> k
WriteLog _ _ _ k -> k)
eff (R other) = IgnoreTelemetryC . eff . handleCoercible $ other
eff (L (WriteStat _ k)) = k
eff (L (WriteLog _ _ _ k)) = k

3
src/Semantic/Timeout.hs
View File

@ -9,6 +9,7 @@ module Semantic.Timeout
import Control.Effect
import Control.Effect.Carrier
import Control.Effect.Reader
import Control.Effect.Sum
import Control.Monad.IO.Class
import Data.Duration
@ -18,7 +19,7 @@ import qualified System.Timeout as System
-- within the specified duration. Uses 'System.Timeout.timeout' so all caveats
-- about not operating over FFI boundaries apply.
timeout :: (Member Timeout sig, Carrier sig m) => Duration -> m output -> m (Maybe output)
timeout n = send . flip (Timeout n) ret
timeout n = send . flip (Timeout n) pure
-- | 'Timeout' effects run other effects, aborting them if they exceed the
-- specified duration.

137
src/Semantic/Util.hs
View File

@ -58,40 +58,30 @@ justEvaluating :: Evaluator
(Value term Precise)
(ResumableC
(BaseError (ValueError term Precise))
(Eff
(ResumableC
(BaseError (AddressError Precise (Value term Precise)))
(Eff
(ResumableC
(BaseError ResolutionError)
(Eff
(ResumableC
(BaseError
(EvalError term Precise (Value term Precise)))
(Eff
(ResumableC
(BaseError (HeapError Precise))
(Eff
(ResumableC
(BaseError (ScopeError Precise))
(Eff
(ResumableC
(BaseError
(UnspecializedError
Precise (Value term Precise)))
(Eff
(ResumableC
(BaseError
(LoadError
Precise
(Value term Precise)))
(Eff
(FreshC
(Eff
(StateC
(ScopeGraph
Precise)
(Eff
(StateC
(Heap
Precise
@ -99,11 +89,9 @@ justEvaluating :: Evaluator
(Value
term
Precise))
(Eff
(TraceByPrintingC
(Eff
(LiftC
IO)))))))))))))))))))))))))
IO)))))))))))))
result
-> IO
(Heap Precise Precise (Value term Precise),
@ -148,18 +136,18 @@ justEvaluatingCatchingErrors :: ( hole ~ Hole (Maybe Name) Precise
value
(ResumableWithC
(BaseError (ValueError term hole))
(Eff (ResumableWithC (BaseError (AddressError hole value))
(Eff (ResumableWithC (BaseError ResolutionError)
(Eff (ResumableWithC (BaseError (EvalError term hole value))
(Eff (ResumableWithC (BaseError (HeapError hole))
(Eff (ResumableWithC (BaseError (ScopeError hole))
(Eff (ResumableWithC (BaseError (UnspecializedError hole value))
(Eff (ResumableWithC (BaseError (LoadError hole value))
(Eff (FreshC
(Eff (StateC (ScopeGraph hole)
(Eff (StateC (Heap hole hole (Concrete.Value (Quieterm (Sum lang) Location) (Hole (Maybe Name) Precise)))
(Eff (TraceByPrintingC
(Eff (LiftC IO))))))))))))))))))))))))) a
(ResumableWithC (BaseError (AddressError hole value))
(ResumableWithC (BaseError ResolutionError)
(ResumableWithC (BaseError (EvalError term hole value))
(ResumableWithC (BaseError (HeapError hole))
(ResumableWithC (BaseError (ScopeError hole))
(ResumableWithC (BaseError (UnspecializedError hole value))
(ResumableWithC (BaseError (LoadError hole value))
(FreshC
(StateC (ScopeGraph hole)
(StateC (Heap hole hole (Concrete.Value (Quieterm (Sum lang) Location) (Hole (Maybe Name) Precise)))
(TraceByPrintingC
(LiftC IO))))))))))))) a
-> IO (Heap hole hole value, (ScopeGraph hole, a))
justEvaluatingCatchingErrors
= runM
@ -185,84 +173,67 @@ checking
(ResumableC
(BaseError
Type.TypeError)
(Eff
(StateC
Type.TypeMap
(Eff
(ResumableC
(BaseError
(AddressError
Monovariant
Type.Type))
(Eff
(ResumableC
(BaseError
(EvalError
term
Monovariant
Type.Type))
(Eff
(ResumableC
(BaseError
ResolutionError)
(Eff
(ResumableC
(BaseError
(HeapError
Monovariant))
(Eff
(ResumableC
(BaseError
(ScopeError
Monovariant))
(Eff
(ResumableC
(BaseError
(UnspecializedError
Monovariant
Type.Type))
(Eff
(ResumableC
(BaseError
(LoadError
Monovariant
Type.Type))
(Eff
(ReaderC
(Live
Monovariant)
(Eff
(AltC
[]
(Eff
(ReaderC
(Cache
term
Monovariant
Type.Type)
(Eff
(StateC
(Cache
term
Monovariant
Type.Type)
(Eff
(FreshC
(Eff
(StateC
(ScopeGraph
Monovariant)
(Eff
(StateC
(Heap
Monovariant
Monovariant
Type.Type)
(Eff
(TraceByPrintingC
(Eff
(LiftC
IO)))))))))))))))))))))))))))))))))))
IO))))))))))))))))))
result
-> IO
(Heap
@ -564,17 +535,18 @@ callGraphRubyProject :: [FilePath] -> IO (Graph ControlFlowVertex, [Module ()])
callGraphRubyProject = callGraphProject rubyParser (Proxy @'Language.Ruby)
type EvalEffects qterm err = ResumableC (BaseError err)
(Eff (ResumableC (BaseError (AddressError Precise (Value qterm Precise)))
(Eff (ResumableC (BaseError ResolutionError)
(Eff (ResumableC (BaseError (EvalError qterm Precise (Value qterm Precise)))
(Eff (ResumableC (BaseError (HeapError Precise))
(Eff (ResumableC (BaseError (ScopeError Precise))
(Eff (ResumableC (BaseError (UnspecializedError Precise (Value qterm Precise)))
(Eff (ResumableC (BaseError (LoadError Precise (Value qterm Precise)))
(Eff (FreshC (Eff (StateC (ScopeGraph Precise)
(Eff (StateC (Heap Precise Precise (Value qterm Precise))
(Eff (TraceByPrintingC
(Eff (LiftC IO))))))))))))))))))))))))
(ResumableC (BaseError (AddressError Precise (Value qterm Precise)))
(ResumableC (BaseError ResolutionError)
(ResumableC (BaseError (EvalError qterm Precise (Value qterm Precise)))
(ResumableC (BaseError (HeapError Precise))
(ResumableC (BaseError (ScopeError Precise))
(ResumableC (BaseError (UnspecializedError Precise (Value qterm Precise)))
(ResumableC (BaseError (LoadError Precise (Value qterm Precise)))
(FreshC
(StateC (ScopeGraph Precise)
(StateC (Heap Precise Precise (Value qterm Precise))
(TraceByPrintingC
(LiftC IO))))))))))))
type LanguageSyntax lang syntax = ( Language.SLanguage lang
, HasPrelude lang
@ -643,18 +615,18 @@ evaluateProjectForScopeGraph :: ( term ~ Term (Sum syntax) Location
-> IO (Evaluator qterm address
(Value qterm address)
(ResumableWithC (BaseError (ValueError qterm address))
(Eff (ResumableWithC (BaseError (AddressError address (Value qterm address)))
(Eff (ResumableWithC (BaseError ResolutionError)
(Eff (ResumableWithC (BaseError (EvalError qterm address (Value qterm address)))
(Eff (ResumableWithC (BaseError (HeapError address))
(Eff (ResumableWithC (BaseError (ScopeError address))
(Eff (ResumableWithC (BaseError (UnspecializedError address (Value qterm address)))
(Eff (ResumableWithC (BaseError (LoadError address (Value qterm address)))
(Eff (FreshC
(Eff (StateC (ScopeGraph address)
(Eff (StateC (Heap address address (Value qterm address))
(Eff (TraceByPrintingC
(Eff (LiftC IO)))))))))))))))))))))))))
(ResumableWithC (BaseError (AddressError address (Value qterm address)))
(ResumableWithC (BaseError ResolutionError)
(ResumableWithC (BaseError (EvalError qterm address (Value qterm address)))
(ResumableWithC (BaseError (HeapError address))
(ResumableWithC (BaseError (ScopeError address))
(ResumableWithC (BaseError (UnspecializedError address (Value qterm address)))
(ResumableWithC (BaseError (LoadError address (Value qterm address)))
(FreshC
(StateC (ScopeGraph address)
(StateC (Heap address address (Value qterm address))
(TraceByPrintingC
(LiftC IO)))))))))))))
(ModuleTable (Module
(ModuleResult address (Value qterm address)))))
evaluateProjectForScopeGraph proxy parser project = runTask' $ do
@ -678,22 +650,23 @@ evaluateProjectWithCaching :: ( term ~ Term (Sum syntax) Location
-> FilePath
-> IO (Evaluator qterm Monovariant Type
(ResumableC (BaseError Type.TypeError)
(Eff (StateC TypeMap
(Eff (ResumableC (BaseError (AddressError Monovariant Type))
(Eff (ResumableC (BaseError (EvalError qterm Monovariant Type))
(Eff (ResumableC (BaseError ResolutionError)
(Eff (ResumableC (BaseError (HeapError Monovariant))
(Eff (ResumableC (BaseError (ScopeError Monovariant))
(Eff (ResumableC (BaseError (UnspecializedError Monovariant Type))
(Eff (ResumableC (BaseError (LoadError Monovariant Type))
(Eff (ReaderC (Live Monovariant)
(Eff (AltC []
(Eff (ReaderC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type)
(Eff (StateC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type)
(Eff (FreshC
(Eff (StateC (ScopeGraph Monovariant)
(Eff (StateC (Heap Monovariant Monovariant Type)
(Eff (TraceByPrintingC (Eff (LiftC IO)))))))))))))))))))))))))))))))))))
(StateC TypeMap
(ResumableC (BaseError (AddressError Monovariant Type))
(ResumableC (BaseError (EvalError qterm Monovariant Type))
(ResumableC (BaseError ResolutionError)
(ResumableC (BaseError (HeapError Monovariant))
(ResumableC (BaseError (ScopeError Monovariant))
(ResumableC (BaseError (UnspecializedError Monovariant Type))
(ResumableC (BaseError (LoadError Monovariant Type))
(ReaderC (Live Monovariant)
(AltC []
(ReaderC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type)
(StateC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type)
(FreshC
(StateC (ScopeGraph Monovariant)
(StateC (Heap Monovariant Monovariant Type)
(TraceByPrintingC
(LiftC IO))))))))))))))))))
(ModuleTable (Module (ModuleResult Monovariant Type))))
evaluateProjectWithCaching proxy parser path = runTask' $ do
project <- readProject Nothing path (Language.reflect proxy) []

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

@ -69,7 +69,7 @@ evaluate
. runValueError
. runAddressError
. runEvalError
. runDeref @Val
. runDeref @SpecEff
. runAllocator
. runReturn
. runLoopControl
@ -85,29 +85,29 @@ reassociate = mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeError
type Val = Value SpecEff Precise
newtype SpecEff = SpecEff
{ runSpecEff :: Evaluator SpecEff Precise Val (FunctionC SpecEff Precise Val
(Eff (BooleanC Val
(Eff (NumericC Val
(Eff (ErrorC (LoopControl Val)
(Eff (ErrorC (Return Val)
(Eff (AllocatorC Precise
(Eff (DerefC Precise Val
(Eff (ResumableC (BaseError (EvalError SpecEff Precise Val))
(Eff (ResumableC (BaseError (AddressError Precise Val))
(Eff (ResumableC (BaseError (ValueError SpecEff Precise))
(Eff (ResumableC (BaseError (HeapError Precise))
(Eff (ResumableC (BaseError (ScopeError Precise))
(Eff (ReaderC (CurrentFrame Precise)
(Eff (ReaderC (CurrentScope Precise)
(Eff (AllocatorC Precise
(Eff (ReaderC Span
(Eff (StateC Span
(Eff (ReaderC ModuleInfo
(Eff (ReaderC PackageInfo
(Eff (FreshC
(Eff (StateC (Heap Precise Precise Val)
(Eff (StateC (ScopeGraph Precise)
(Eff (TraceByIgnoringC
(Eff (LiftC IO)))))))))))))))))))))))))))))))))))))))))))))))
(BooleanC Val
(NumericC Val
(ErrorC (LoopControl Val)
(ErrorC (Return Val)
(AllocatorC Precise
(DerefC Precise Val
(ResumableC (BaseError (EvalError SpecEff Precise Val))
(ResumableC (BaseError (AddressError Precise Val))
(ResumableC (BaseError (ValueError SpecEff Precise))
(ResumableC (BaseError (HeapError Precise))
(ResumableC (BaseError (ScopeError Precise))
(ReaderC (CurrentFrame Precise)
(ReaderC (CurrentScope Precise)
(AllocatorC Precise
(ReaderC Span
(StateC Span
(ReaderC ModuleInfo
(ReaderC PackageInfo
(FreshC
(StateC (Heap Precise Precise Val)
(StateC (ScopeGraph Precise)
(TraceByIgnoringC
(LiftC IO))))))))))))))))))))))))
Val
}

26
test/SpecHelpers.hs
View File

@ -117,19 +117,19 @@ runTaskOrDie :: TaskEff a -> IO a
runTaskOrDie task = runTaskWithOptions defaultOptions { optionsLogLevel = Nothing } task >>= either (die . displayException) pure
type TestEvaluatingC term
= ResumableC (BaseError (AddressError Precise (Val term))) (Eff
( ResumableC (BaseError (ValueError term Precise)) (Eff
( ResumableC (BaseError ResolutionError) (Eff
( ResumableC (BaseError (EvalError term Precise (Val term))) (Eff
( ResumableC (BaseError (HeapError Precise)) (Eff
( ResumableC (BaseError (ScopeError Precise)) (Eff
( ResumableC (BaseError (UnspecializedError Precise (Val term))) (Eff
( ResumableC (BaseError (LoadError Precise (Val term))) (Eff
( StateC (Heap Precise Precise (Val term)) (Eff
( StateC (ScopeGraph Precise) (Eff
( FreshC (Eff
( TraceByIgnoringC (Eff
( LiftC IO))))))))))))))))))))))))
= ResumableC (BaseError (AddressError Precise (Val term)))
( ResumableC (BaseError (ValueError term Precise))
( ResumableC (BaseError ResolutionError)
( ResumableC (BaseError (EvalError term Precise (Val term)))
( ResumableC (BaseError (HeapError Precise))
( ResumableC (BaseError (ScopeError Precise))
( ResumableC (BaseError (UnspecializedError Precise (Val term)))
( ResumableC (BaseError (LoadError Precise (Val term)))
( StateC (Heap Precise Precise (Val term))
( StateC (ScopeGraph Precise)
( FreshC
( TraceByIgnoringC
( LiftC IO))))))))))))
type TestEvaluatingErrors term
= '[ BaseError (AddressError Precise (Val term))
, BaseError (ValueError term Precise)