1
1
mirror of https://github.com/github/semantic.git synced 2024-12-26 00:12:29 +03:00

Merge remote-tracking branch 'origin/master' into eval-__FILE__

This commit is contained in:
Timothy Clem 2018-04-26 13:23:42 -07:00
commit 08600b4155
30 changed files with 355 additions and 389 deletions

View File

@ -16,15 +16,16 @@ library
exposed-modules: exposed-modules:
-- Analyses & term annotations -- Analyses & term annotations
Analysis.Abstract.BadAddresses Analysis.Abstract.BadAddresses
Analysis.Abstract.BadVariables , Analysis.Abstract.BadSyntax
Analysis.Abstract.BadValues , Analysis.Abstract.BadModuleResolutions
Analysis.Abstract.BadModuleResolutions , Analysis.Abstract.BadVariables
, Analysis.Abstract.BadValues
, Analysis.Abstract.Caching , Analysis.Abstract.Caching
, Analysis.Abstract.Collecting , Analysis.Abstract.Collecting
, Analysis.Abstract.Dead , Analysis.Abstract.Dead
, Analysis.Abstract.Erroring
, Analysis.Abstract.Evaluating , Analysis.Abstract.Evaluating
, Analysis.Abstract.ImportGraph , Analysis.Abstract.ImportGraph
, Analysis.Abstract.Quiet
, Analysis.Abstract.Tracing , Analysis.Abstract.Tracing
, Analysis.Abstract.TypeChecking , Analysis.Abstract.TypeChecking
, Analysis.CallGraph , Analysis.CallGraph
@ -45,17 +46,15 @@ library
, Control.Abstract.Value , Control.Abstract.Value
-- Control flow -- Control flow
, Control.Effect , Control.Effect
-- Effects used for program analysis
, Control.Effect.Fresh
-- Datatypes for abstract interpretation -- Datatypes for abstract interpretation
, Data.Abstract.Address , Data.Abstract.Address
, Data.Abstract.Cache , Data.Abstract.Cache
, Data.Abstract.Configuration , Data.Abstract.Configuration
, Data.Abstract.Declarations
, Data.Abstract.Environment , Data.Abstract.Environment
, Data.Abstract.Evaluatable , Data.Abstract.Evaluatable
, Data.Abstract.Exports , Data.Abstract.Exports
, Data.Abstract.FreeVariables , Data.Abstract.FreeVariables
, Data.Abstract.Declarations
, Data.Abstract.Heap , Data.Abstract.Heap
, Data.Abstract.Live , Data.Abstract.Live
, Data.Abstract.Located , Data.Abstract.Located

View File

@ -1,30 +1,27 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instances MonadEvaluator constraint
module Analysis.Abstract.BadAddresses where module Analysis.Abstract.BadAddresses where
import Control.Abstract.Analysis import Control.Abstract.Analysis
import Data.Abstract.Address import Data.Abstract.Address
import Prologue import Prologue
newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses (m effects a) newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses { runBadAddresses :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadAddresses m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadAddresses m)
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadAddresses m)
instance ( Effectful m instance ( Interpreter effects result rest m
, Member (Resumable (AddressError location value)) effects , MonadEvaluator location term value effects m
, MonadAnalysis location term value effects m , AbstractHole value
, MonadValue location value effects (BadAddresses m)
, Monoid (Cell location value) , Monoid (Cell location value)
, Show location , Show location
) )
=> MonadAnalysis location term value effects (BadAddresses m) where => Interpreter (Resumable (AddressError location value) ': effects) result rest (BadAddresses m) where
type Effects location term value (BadAddresses m) = Effects location term value m interpret
= interpret
analyzeTerm eval term = resume @(AddressError location value) (liftAnalyze analyzeTerm eval term) ( . runBadAddresses
\yield error -> do . raiseHandler (relay pure (\ (Resumable err) yield -> traceM ("AddressError:" <> show err) *> case err of
traceM ("AddressError:" <> show error)
case error of
UnallocatedAddress _ -> yield mempty UnallocatedAddress _ -> yield mempty
UninitializedAddress _ -> hole >>= yield) UninitializedAddress _ -> yield hole))
analyzeModule = liftAnalyze analyzeModule

View File

@ -1,29 +1,24 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instances MonadEvaluator constraint
module Analysis.Abstract.BadModuleResolutions where module Analysis.Abstract.BadModuleResolutions where
import Control.Abstract.Analysis import Control.Abstract.Analysis
import Data.Abstract.Evaluatable import Data.Abstract.Evaluatable
import Prologue import Prologue
newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions (m effects a) newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions { runBadModuleResolutions :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadModuleResolutions m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadModuleResolutions m)
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadModuleResolutions m)
instance ( Effectful m instance ( Interpreter effects result rest m
, Member (Resumable (ResolutionError value)) effects , MonadEvaluator location term value effects m
, Member (State [Name]) effects
, MonadAnalysis location term value effects m
, MonadValue location value effects (BadModuleResolutions m)
) )
=> MonadAnalysis location term value effects (BadModuleResolutions m) where => Interpreter (Resumable (ResolutionError value) ': effects) result rest (BadModuleResolutions m) where
type Effects location term value (BadModuleResolutions m) = State [Name] ': Effects location term value m interpret
= interpret
analyzeTerm eval term = resume @(ResolutionError value) (liftAnalyze analyzeTerm eval term) ( . runBadModuleResolutions
\yield error -> do . raiseHandler (relay pure (\ (Resumable err) yield -> traceM ("ResolutionError:" <> show err) *> case err of
traceM ("ResolutionError:" <> show error) NotFoundError nameToResolve _ _ -> yield nameToResolve
case error of GoImportError pathToResolve -> yield [pathToResolve]))
(NotFoundError nameToResolve _ _) -> yield nameToResolve
(GoImportError pathToResolve) -> yield [pathToResolve])
analyzeModule = liftAnalyze analyzeModule

View File

@ -0,0 +1,32 @@
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instances MonadEvaluator constraint
module Analysis.Abstract.BadSyntax
( BadSyntax
) where
import Control.Abstract.Analysis
import Data.Abstract.Evaluatable
import Prologue
-- | An analysis which resumes exceptions instead of failing.
--
-- Use it by composing it onto an analysis:
--
-- > runAnalysis @(BadSyntax (Evaluating term value)) (…)
--
-- Note that exceptions thrown by other analyses may not be caught if 'BadSyntax' doesnt know about them, i.e. if theyre not part of the generic 'MonadValue', 'MonadAddressable', etc. machinery.
newtype BadSyntax m (effects :: [* -> *]) a = BadSyntax { runBadSyntax :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadSyntax m)
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadSyntax m)
instance ( Interpreter effects result rest m
, MonadEvaluator location term value effects m
, AbstractHole value
)
=> Interpreter (Resumable (Unspecialized value) ': effects) result rest (BadSyntax m) where
interpret
= interpret
. runBadSyntax
. raiseHandler (relay pure (\ (Resumable err@(Unspecialized _)) yield -> traceM ("Unspecialized:" <> show err) *> yield hole))

View File

@ -1,44 +1,38 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.BadValues where module Analysis.Abstract.BadValues where
import Control.Abstract.Analysis import Control.Abstract.Analysis
import Data.Abstract.Evaluatable
import Data.Abstract.Environment as Env import Data.Abstract.Environment as Env
import Prologue
import Data.ByteString.Char8 (pack) import Data.ByteString.Char8 (pack)
import Prologue
newtype BadValues m (effects :: [* -> *]) a = BadValues (m effects a) newtype BadValues m (effects :: [* -> *]) a = BadValues { runBadValues :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadValues m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadValues m)
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadValues m)
instance ( Effectful m instance ( Interpreter effects result rest m
, Member (Resumable (ValueError location value)) effects , MonadEvaluator location term value effects m
, Member (State [Name]) effects , AbstractHole value
, MonadAnalysis location term value effects m , Show value
, MonadValue location value effects (BadValues m)
) )
=> MonadAnalysis location term value effects (BadValues m) where => Interpreter (Resumable (ValueError location value) ': effects) result rest (BadValues m) where
type Effects location term value (BadValues m) = State [Name] ': Effects location term value m interpret
= interpret
analyzeTerm eval term = resume @(ValueError location value) (liftAnalyze analyzeTerm eval term) ( . runBadValues
\yield error -> do . raiseHandler (relay pure (\ (Resumable err) yield -> traceM ("ValueError" <> show err) *> case err of
traceM ("ValueError" <> show error)
case error of
ScopedEnvironmentError{} -> do ScopedEnvironmentError{} -> do
env <- getEnv env <- lower @m getEnv
yield (Env.push env) yield (Env.push env)
CallError val -> yield val CallError val -> yield val
StringError val -> yield (pack $ show val) StringError val -> yield (pack (show val))
BoolError{} -> yield True BoolError{} -> yield True
NumericError{} -> hole >>= yield NumericError{} -> yield hole
Numeric2Error{} -> hole >>= yield Numeric2Error{} -> yield hole
ComparisonError{} -> hole >>= yield ComparisonError{} -> yield hole
NamespaceError{} -> getEnv >>= yield NamespaceError{} -> lower @m getEnv >>= yield
BitwiseError{} -> hole >>= yield BitwiseError{} -> yield hole
Bitwise2Error{} -> hole >>= yield Bitwise2Error{} -> yield hole
KeyValueError{} -> hole >>= \x -> yield (x, x) KeyValueError{} -> yield (hole, hole)
ArithmeticError{} -> hole >>= yield ArithmeticError{} -> yield hole))
)
analyzeModule = liftAnalyze analyzeModule

View File

@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instances MonadEvaluator constraint
module Analysis.Abstract.BadVariables module Analysis.Abstract.BadVariables
( BadVariables ( BadVariables
) where ) where
@ -8,30 +9,27 @@ import Data.Abstract.Evaluatable
import Prologue import Prologue
-- An analysis that resumes from evaluation errors and records the list of unresolved free variables. -- An analysis that resumes from evaluation errors and records the list of unresolved free variables.
newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a) newtype BadVariables m (effects :: [* -> *]) a = BadVariables { runBadVariables :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadVariables m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadVariables m)
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadVariables m)
instance ( Effectful m instance ( Interpreter effects (result, [Name]) rest m
, Member (Resumable (EvalError value)) effects , MonadEvaluator location term value effects m
, Member (State [Name]) effects , AbstractHole value
, MonadAnalysis location term value effects m
, MonadValue location value effects (BadVariables m)
) )
=> MonadAnalysis location term value effects (BadVariables m) where => Interpreter (Resumable (EvalError value) ': State [Name] ': effects) result rest (BadVariables m) where
type Effects location term value (BadVariables m) = State [Name] ': Effects location term value m interpret
= interpret
analyzeTerm eval term = resume @(EvalError value) (liftAnalyze analyzeTerm eval term) ( . runBadVariables
\yield err -> do . raiseHandler
traceM ("EvalError" <> show err) ( flip runState []
case err of . relay pure (\ (Resumable err) yield -> traceM ("EvalError" <> show err) *> case err of
DefaultExportError{} -> yield () DefaultExportError{} -> yield ()
ExportError{} -> yield () ExportError{} -> yield ()
IntegerFormatError{} -> yield 0 IntegerFormatError{} -> yield 0
FloatFormatError{} -> yield 0 FloatFormatError{} -> yield 0
RationalFormatError{} -> yield 0 RationalFormatError{} -> yield 0
FreeVariableError name -> raise (modify' (name :)) >> hole >>= yield FreeVariableError name -> modify' (name :) *> yield hole
FreeVariablesError names -> raise (modify' (names <>)) >> yield (fromMaybeLast "unknown" names)) FreeVariablesError names -> modify' (names <>) *> yield (fromMaybeLast "unknown" names)))
analyzeModule = liftAnalyze analyzeModule

View File

@ -1,9 +1,11 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instances MonadEvaluator constraint
module Analysis.Abstract.Caching module Analysis.Abstract.Caching
( Caching ( Caching
) where ) where
import Control.Abstract.Analysis import Control.Abstract.Analysis
import Control.Monad.Effect hiding (interpret)
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Cache import Data.Abstract.Cache
import Data.Abstract.Configuration import Data.Abstract.Configuration
@ -19,7 +21,7 @@ type CachingEffects location term value effects
': effects ': effects
-- | A (coinductively-)cached analysis suitable for guaranteeing termination of (suitably finitized) analyses over recursive programs. -- | A (coinductively-)cached analysis suitable for guaranteeing termination of (suitably finitized) analyses over recursive programs.
newtype Caching m (effects :: [* -> *]) a = Caching (m effects a) newtype Caching m (effects :: [* -> *]) a = Caching { runCaching :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Caching m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Caching m)
@ -73,9 +75,6 @@ instance ( Alternative (m effects)
, Ord value , Ord value
) )
=> MonadAnalysis location term value effects (Caching m) where => MonadAnalysis location term value effects (Caching m) where
-- We require the 'CachingEffects' in addition to the underlying analysis 'Effects'.
type Effects location term value (Caching m) = CachingEffects location term value (Effects location term value m)
-- Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache. -- Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
analyzeTerm recur e = do analyzeTerm recur e = do
c <- getConfiguration (embedSubterm e) c <- getConfiguration (embedSubterm e)
@ -92,7 +91,7 @@ instance ( Alternative (m effects)
cache <- converge (\ prevCache -> isolateCache $ do cache <- converge (\ prevCache -> isolateCache $ do
putHeap (configurationHeap c) putHeap (configurationHeap c)
-- We need to reset fresh generation so that this invocation converges. -- We need to reset fresh generation so that this invocation converges.
reset 0 reset 0 $
-- This is subtle: though the calling context supports nondeterminism, we want -- This is subtle: though the calling context supports nondeterminism, we want
-- to corral all the nondeterminism that happens in this @eval@ invocation, so -- to corral all the nondeterminism that happens in this @eval@ invocation, so
-- that it doesn't "leak" to the calling context and diverge (otherwise this -- that it doesn't "leak" to the calling context and diverge (otherwise this
@ -101,6 +100,9 @@ instance ( Alternative (m effects)
withOracle prevCache (raise (gather (const ()) (lower (liftAnalyze analyzeModule recur m))))) mempty withOracle prevCache (raise (gather (const ()) (lower (liftAnalyze analyzeModule recur m))))) mempty
maybe empty scatter (cacheLookup c cache) maybe empty scatter (cacheLookup c cache)
reset :: (Effectful m, Member Fresh effects) => Int -> m effects a -> m effects a
reset start = raiseHandler (interposeState start (const pure) (\ counter Fresh yield -> (yield $! succ counter) counter))
-- | Iterate a monadic action starting from some initial seed until the results converge. -- | Iterate a monadic action starting from some initial seed until the results converge.
-- --
-- This applies the Kleene fixed-point theorem to finitize a monotone action. cf https://en.wikipedia.org/wiki/Kleene_fixed-point_theorem -- This applies the Kleene fixed-point theorem to finitize a monotone action. cf https://en.wikipedia.org/wiki/Kleene_fixed-point_theorem
@ -119,3 +121,20 @@ converge f = loop
-- | Nondeterministically write each of a collection of stores & return their associated results. -- | Nondeterministically write each of a collection of stores & return their associated results.
scatter :: (Alternative (m effects), Foldable t, MonadEvaluator location term value effects m) => t (a, Heap location value) -> m effects a scatter :: (Alternative (m effects), Foldable t, MonadEvaluator location term value effects m) => t (a, Heap location value) -> m effects a
scatter = foldMapA (\ (value, heap') -> putHeap heap' $> value) scatter = foldMapA (\ (value, heap') -> putHeap heap' $> value)
instance ( Interpreter effects ([result], Cache location term value) rest m
, MonadEvaluator location term value effects m
, Ord (Cell location value)
, Ord location
, Ord term
, Ord value
)
=> Interpreter (NonDet ': Reader (Cache location term value) ': State (Cache location term value) ': effects) result rest (Caching m) where
interpret
= interpret
. runCaching
. raiseHandler
( flip runState mempty
. flip runReader mempty
. makeChoiceA @[])

View File

@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instances MonadEvaluator constraint
module Analysis.Abstract.Collecting module Analysis.Abstract.Collecting
( Collecting ( Collecting
) where ) where
@ -10,7 +11,7 @@ import Data.Abstract.Heap
import Data.Abstract.Live import Data.Abstract.Live
import Prologue import Prologue
newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a) newtype Collecting m (effects :: [* -> *]) a = Collecting { runCollecting :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving (Alternative, Applicative, Functor, Effectful, Monad)
instance ( Effectful m instance ( Effectful m
@ -29,10 +30,6 @@ instance ( Effectful m
, ValueRoots location value , ValueRoots location value
) )
=> MonadAnalysis location term value effects (Collecting m) where => MonadAnalysis location term value effects (Collecting m) where
type Effects location term value (Collecting m)
= Reader (Live location value)
': Effects location term value m
-- Small-step evaluation which garbage-collects any non-rooted addresses after evaluating each term. -- Small-step evaluation which garbage-collects any non-rooted addresses after evaluating each term.
analyzeTerm recur term = do analyzeTerm recur term = do
roots <- askRoots roots <- askRoots
@ -76,3 +73,11 @@ reachable roots heap = go mempty roots
Just (a, as) -> go (liveInsert a seen) (case heapLookupAll a heap of Just (a, as) -> go (liveInsert a seen) (case heapLookupAll a heap of
Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen
_ -> seen) _ -> seen)
instance ( Interpreter effects result rest m
, MonadEvaluator location term value effects m
, Ord location
)
=> Interpreter (Reader (Live location value) ': effects) result rest (Collecting m) where
interpret = interpret . runCollecting . raiseHandler (`runReader` mempty)

View File

@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instances MonadEvaluator constraint
module Analysis.Abstract.Dead module Analysis.Abstract.Dead
( DeadCode ( DeadCode
) where ) where
@ -10,7 +11,7 @@ import Data.Set (delete)
import Prologue import Prologue
-- | An analysis tracking dead (unreachable) code. -- | An analysis tracking dead (unreachable) code.
newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a) newtype DeadCode m (effects :: [* -> *]) a = DeadCode { runDeadCode :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (DeadCode m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (DeadCode m)
@ -43,8 +44,6 @@ instance ( Corecursive term
, Recursive term , Recursive term
) )
=> MonadAnalysis location term value effects (DeadCode m) where => MonadAnalysis location term value effects (DeadCode m) where
type Effects location term value (DeadCode m) = State (Dead term) ': Effects location term value m
analyzeTerm recur term = do analyzeTerm recur term = do
revive (embedSubterm term) revive (embedSubterm term)
liftAnalyze analyzeTerm recur term liftAnalyze analyzeTerm recur term
@ -52,3 +51,10 @@ instance ( Corecursive term
analyzeModule recur m = do analyzeModule recur m = do
killAll (subterms (subterm (moduleBody m))) killAll (subterms (subterm (moduleBody m)))
liftAnalyze analyzeModule recur m liftAnalyze analyzeModule recur m
instance ( Interpreter effects (result, Dead term) rest m
, MonadEvaluator location term value effects m
, Ord term
)
=> Interpreter (State (Dead term) ': effects) result rest (DeadCode m) where
interpret = interpret . runDeadCode . raiseHandler (`runState` mempty)

View File

@ -0,0 +1,18 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.Erroring
( Erroring
) where
import Control.Abstract.Analysis
import Prologue
-- | An analysis that fails on errors.
newtype Erroring (exc :: * -> *) m (effects :: [* -> *]) a = Erroring { runErroring :: m effects a }
deriving (Alternative, Applicative, Effectful, Functor, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Erroring exc m)
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (Erroring exc m)
instance Interpreter effects (Either (SomeExc exc) result) rest m
=> Interpreter (Resumable exc ': effects) result rest (Erroring exc m) where
interpret = interpret . runErroring . raiseHandler runError

View File

@ -1,20 +1,23 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Analysis.Abstract.Evaluating module Analysis.Abstract.Evaluating
( Evaluating ( Evaluating
) where ) where
import Control.Abstract.Analysis import Control.Abstract.Analysis
import Control.Monad.Effect import Control.Monad.Effect.Exception as Exc
import Control.Monad.Effect.Resumable as Res
import Data.Abstract.Address
import Data.Abstract.Configuration import Data.Abstract.Configuration
import Data.Abstract.Environment as Env import Data.Abstract.Environment
import Data.Abstract.Evaluatable import Data.Abstract.Evaluatable
import Data.Abstract.Module import Data.Abstract.Module
import Data.Abstract.ModuleTable import Data.Abstract.ModuleTable
import Data.Abstract.Origin import Data.Abstract.Origin
import Prologue import Data.Empty
import Prologue hiding (empty)
-- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@.
newtype Evaluating location term value effects a = Evaluating (Eff effects a) newtype Evaluating location term value effects a = Evaluating { runEvaluating :: Eff effects a }
deriving (Applicative, Functor, Effectful, Monad) deriving (Applicative, Functor, Effectful, Monad)
deriving instance Member NonDet effects => Alternative (Evaluating location term value effects) deriving instance Member NonDet effects => Alternative (Evaluating location term value effects)
@ -23,12 +26,7 @@ deriving instance Member NonDet effects => Alternative (Evaluating location term
type EvaluatingEffects location term value type EvaluatingEffects location term value
= '[ Exc (ReturnThrow value) = '[ Exc (ReturnThrow value)
, Exc (LoopThrow value) , Exc (LoopThrow value)
, Resumable (EvalError value)
, Resumable (ResolutionError value)
, Resumable (LoadError term value) , Resumable (LoadError term value)
, Resumable (ValueError location value)
, Resumable (Unspecialized value)
, Resumable (AddressError location value)
, Fail -- Failure with an error message , Fail -- Failure with an error message
, Fresh -- For allocating new addresses and/or type variables. , Fresh -- For allocating new addresses and/or type variables.
, Reader (SomeOrigin term) -- The current terms origin. , Reader (SomeOrigin term) -- The current terms origin.
@ -55,8 +53,33 @@ instance ( Corecursive term
, Recursive term , Recursive term
) )
=> MonadAnalysis location term value effects (Evaluating location term value) where => MonadAnalysis location term value effects (Evaluating location term value) where
type Effects location term value (Evaluating location term value) = EvaluatingEffects location term value
analyzeTerm eval term = pushOrigin (termOrigin (embedSubterm term)) (eval term) analyzeTerm eval term = pushOrigin (termOrigin (embedSubterm term)) (eval term)
analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (eval m) analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (eval m)
instance ( Ord location
, Semigroup (Cell location value)
)
=> Interpreter
(EvaluatingEffects location term value) result
( Either String
(Either (SomeExc (LoadError term value))
(Either (LoopThrow value)
(Either (ReturnThrow value)
result)))
, EvaluatorState location term value)
(Evaluating location term value) where
interpret
= interpret
. runEvaluating
. raiseHandler
( flip runState empty -- State (EvaluatorState location term value)
. flip runReader empty -- Reader (Environment location value)
. flip runReader empty -- Reader (ModuleTable [Module term])
. flip runReader empty -- Reader (SomeOrigin term)
. flip runFresh' 0
. runFail
. Res.runError
. Exc.runError
. Exc.runError)

View File

@ -1,5 +1,4 @@
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.ImportGraph module Analysis.Abstract.ImportGraph
( ImportGraph(..) ( ImportGraph(..)
, renderImportGraph , renderImportGraph
@ -54,7 +53,7 @@ style = (defaultStyle vertexName)
edgeAttributes Variable{} Module{} = [ "color" := "blue" ] edgeAttributes Variable{} Module{} = [ "color" := "blue" ]
edgeAttributes _ _ = [] edgeAttributes _ _ = []
newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a) newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing { runImportGraphing :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (ImportGraphing m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (ImportGraphing m)
@ -66,12 +65,10 @@ instance ( Effectful m
, Member (State ImportGraph) effects , Member (State ImportGraph) effects
, Member Syntax.Identifier syntax , Member Syntax.Identifier syntax
, MonadAnalysis (Located location term) term value effects m , MonadAnalysis (Located location term) term value effects m
, term ~ Term (Union syntax) ann
, Show ann , Show ann
, term ~ Term (Union syntax) ann
) )
=> MonadAnalysis (Located location term) term value effects (ImportGraphing m) where => MonadAnalysis (Located location term) term value effects (ImportGraphing m) where
type Effects (Located location term) term value (ImportGraphing m) = State ImportGraph ': Effects (Located location term) term value m
analyzeTerm eval term@(In _ syntax) = do analyzeTerm eval term@(In _ syntax) = do
case prj syntax of case prj syntax of
Just (Syntax.Identifier name) -> do Just (Syntax.Identifier name) -> do
@ -169,3 +166,8 @@ vertexToType :: Vertex -> Text
vertexToType Package{} = "package" vertexToType Package{} = "package"
vertexToType Module{} = "module" vertexToType Module{} = "module"
vertexToType Variable{} = "variable" vertexToType Variable{} = "variable"
instance Interpreter effects (result, ImportGraph) rest m
=> Interpreter (State ImportGraph ': effects) result rest (ImportGraphing m) where
interpret = interpret . runImportGraphing . raiseHandler (`runState` mempty)

View File

@ -1,33 +0,0 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-}
module Analysis.Abstract.Quiet
( Quietly
) where
import Control.Abstract.Analysis
import Data.Abstract.Evaluatable
import Prologue
-- | An analysis which resumes exceptions instead of failing.
--
-- Use it by composing it onto an analysis:
--
-- > runAnalysis @(Quietly (Evaluating term value)) (…)
--
-- Note that exceptions thrown by other analyses may not be caught if 'Quietly' doesnt know about them, i.e. if theyre not part of the generic 'MonadValue', 'MonadAddressable', etc. machinery.
newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Quietly m)
instance ( Effectful m
, Member (Resumable (Unspecialized value)) effects
, MonadAnalysis location term value effects m
, MonadValue location value effects (Quietly m)
)
=> MonadAnalysis location term value effects (Quietly m) where
type Effects location term value (Quietly m) = Effects location term value m
analyzeTerm eval term = resume @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield err@(Unspecialized _) ->
traceM ("Unspecialized:" <> show err) >> hole >>= yield)
analyzeModule = liftAnalyze analyzeModule

View File

@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instances MonadEvaluator constraint
module Analysis.Abstract.Tracing module Analysis.Abstract.Tracing
( Tracing ( Tracing
) where ) where
@ -13,7 +14,7 @@ import Prologue
-- | Trace analysis. -- | Trace analysis.
-- --
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a) newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing { runTracing :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Tracing trace m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Tracing trace m)
@ -26,11 +27,16 @@ instance ( Corecursive term
, Reducer (Configuration location term value) (trace (Configuration location term value)) , Reducer (Configuration location term value) (trace (Configuration location term value))
) )
=> MonadAnalysis location term value effects (Tracing trace m) where => MonadAnalysis location term value effects (Tracing trace m) where
type Effects location term value (Tracing trace m) = Writer (trace (Configuration location term value)) ': Effects location term value m
analyzeTerm recur term = do analyzeTerm recur term = do
config <- getConfiguration (embedSubterm term) config <- getConfiguration (embedSubterm term)
raise (tell @(trace (Configuration location term value)) (Reducer.unit config)) raise (tell @(trace (Configuration location term value)) (Reducer.unit config))
liftAnalyze analyzeTerm recur term liftAnalyze analyzeTerm recur term
analyzeModule = liftAnalyze analyzeModule analyzeModule = liftAnalyze analyzeModule
instance ( Interpreter effects (result, trace (Configuration location term value)) rest m
, MonadEvaluator location term value effects m
, Monoid (trace (Configuration location term value))
)
=> Interpreter (Writer (trace (Configuration location term value)) ': effects) result rest (Tracing trace m) where
interpret = interpret . runTracing . raiseHandler runWriter

View File

@ -1,4 +1,4 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.TypeChecking module Analysis.Abstract.TypeChecking
( TypeChecking ( TypeChecking
@ -8,35 +8,22 @@ import Control.Abstract.Analysis
import Data.Abstract.Type import Data.Abstract.Type
import Prologue hiding (TypeError) import Prologue hiding (TypeError)
newtype TypeChecking m (effects :: [* -> *]) a = TypeChecking (m effects a) newtype TypeChecking m (effects :: [* -> *]) a = TypeChecking { runTypeChecking :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (TypeChecking m) deriving instance MonadEvaluator location term Type effects m => MonadEvaluator location term Type effects (TypeChecking m)
deriving instance MonadAnalysis location term Type effects m => MonadAnalysis location term Type effects (TypeChecking m)
instance ( Effectful m instance ( Interpreter effects (Either (SomeExc TypeError) result) rest m
, Alternative (m effects) , MonadEvaluator location term Type effects m
, MonadAnalysis location term value effects m
, Member (Resumable TypeError) effects
, Member NonDet effects
, MonadValue location value effects (TypeChecking m)
, value ~ Type
) )
=> MonadAnalysis location term value effects (TypeChecking m) where => Interpreter (Resumable TypeError ': effects) result rest (TypeChecking m) where
interpret
type Effects location term value (TypeChecking m) = Resumable TypeError ': Effects location term value m = interpret
. runTypeChecking
analyzeTerm eval term = -- TODO: We should handle TypeError by yielding both sides of the exception,
resume @TypeError (liftAnalyze analyzeTerm eval term) (
\yield err -> case err of
NoValueError _ a -> yield a
-- TODO: These should all yield both sides of the exception,
-- but something is mysteriously busted in the innards of typechecking, -- but something is mysteriously busted in the innards of typechecking,
-- so doing that just yields an empty list in the result type, which isn't -- so doing that just yields an empty list in the result type, which isn't
-- extraordinarily helpful. Better for now to just die with an error and -- extraordinarily helpful. Better for now to just die with an error and
-- tackle this issue in a separate PR. -- tackle this issue in a separate PR.
BitOpError{} -> throwResumable err . raiseHandler runError
NumOpError{} -> throwResumable err
UnificationError{} -> throwResumable err
)
analyzeModule = liftAnalyze analyzeModule

View File

@ -1,10 +1,10 @@
{-# LANGUAGE GADTs, TypeFamilies, UndecidableInstances #-} {-# LANGUAGE GADTs, UndecidableInstances #-}
module Control.Abstract.Addressable where module Control.Abstract.Addressable where
import Control.Abstract.Evaluator import Control.Abstract.Evaluator
import Control.Applicative import Control.Applicative
import Control.Effect import Control.Effect
import Control.Effect.Fresh import Control.Monad.Effect.Fresh
import Control.Monad.Effect.Resumable as Eff import Control.Monad.Effect.Resumable as Eff
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Environment (insert) import Data.Abstract.Environment (insert)
@ -57,7 +57,7 @@ letrec' name body = do
-- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
instance (Effectful m, Member Fresh effects, Monad (m effects)) => MonadAddressable Precise effects m where instance (Effectful m, Member Fresh effects, Monad (m effects)) => MonadAddressable Precise effects m where
derefCell _ = pure . unLatest derefCell _ = pure . unLatest
allocLoc _ = Precise <$> fresh allocLoc _ = Precise <$> raise fresh
-- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
instance (Alternative (m effects), Effectful m, Member Fresh effects, Monad (m effects)) => MonadAddressable Monovariant effects m where instance (Alternative (m effects), Effectful m, Member Fresh effects, Monad (m effects)) => MonadAddressable Monovariant effects m where

View File

@ -1,22 +1,19 @@
{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-} {-# LANGUAGE KindSignatures #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For runAnalysis {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For runAnalysis
module Control.Abstract.Analysis module Control.Abstract.Analysis
( MonadAnalysis(..) ( MonadAnalysis(..)
, liftAnalyze , liftAnalyze
, runAnalysis , runAnalysis
, SomeAnalysis(..)
, runSomeAnalysis
, module X , module X
, Subterm(..)
, SubtermAlgebra
) where ) where
import Control.Abstract.Addressable as X import Control.Abstract.Addressable as X
import Control.Abstract.Evaluator as X import Control.Abstract.Evaluator as X
import Control.Abstract.Value as X import Control.Abstract.Value as X
import Control.Effect as X import Control.Effect as X
import Control.Effect.Fresh as X
import Control.Monad.Effect.Fail as X import Control.Monad.Effect.Fail as X
import Control.Monad.Effect.Fresh as X
import Control.Monad.Effect.Internal as X (Eff, relay)
import Control.Monad.Effect.NonDet as X import Control.Monad.Effect.NonDet as X
import Control.Monad.Effect.Reader as X import Control.Monad.Effect.Reader as X
import Control.Monad.Effect.State as X import Control.Monad.Effect.State as X
@ -30,9 +27,6 @@ import Prologue
-- --
-- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses.
class MonadEvaluator location term value effects m => MonadAnalysis location term value effects m where class MonadEvaluator location term value effects m => MonadAnalysis location term value effects m where
-- | The effects necessary to run the analysis. Analyses which are composed on top of (wrap) other analyses should include the inner analyses 'Effects' in their own list.
type family Effects location term value m :: [* -> *]
-- | Analyze a term using the semantics of the current analysis. -- | Analyze a term using the semantics of the current analysis.
analyzeTerm :: (Base term (Subterm term (outer effects value)) -> m effects value) analyzeTerm :: (Base term (Subterm term (outer effects value)) -> m effects value)
-> (Base term (Subterm term (outer effects value)) -> m effects value) -> (Base term (Subterm term (outer effects value)) -> m effects value)
@ -57,25 +51,8 @@ liftAnalyze analyze recur term = coerce (analyze (coerceWith (sym Coercion) . r
-- --
-- This enables us to refer to the analysis type as e.g. @Analysis1 (Analysis2 Evaluating) Term Value@ without explicitly mentioning its effects (which are inferred to be simply its 'Effects'). -- This enables us to refer to the analysis type as e.g. @Analysis1 (Analysis2 Evaluating) Term Value@ without explicitly mentioning its effects (which are inferred to be simply its 'Effects').
runAnalysis :: ( Effectful m runAnalysis :: ( Effectful m
, Effects location term value m ~ effects , Interpreter effects a function m
, MonadAnalysis location term value effects m
, RunEffects effects a
) )
=> m effects a => m effects a
-> Final effects a -> function
runAnalysis = X.run runAnalysis = interpret
-- | An abstraction over analyses.
data SomeAnalysis m result where
SomeAnalysis :: ( Effectful m
, effects ~ Effects location term value m
, MonadAnalysis location term value effects m
, RunEffects effects a
)
=> m effects a
-> SomeAnalysis m (Final effects a)
-- | Run an abstracted analysis.
runSomeAnalysis :: SomeAnalysis m result -> result
runSomeAnalysis (SomeAnalysis a) = X.run a

View File

@ -1,6 +1,7 @@
{-# LANGUAGE FunctionalDependencies, GADTs, KindSignatures, Rank2Types #-} {-# LANGUAGE FunctionalDependencies, GADTs, KindSignatures, Rank2Types #-}
module Control.Abstract.Value module Control.Abstract.Value
( MonadValue(..) ( MonadValue(..)
, AbstractHole(..)
, Comparator(..) , Comparator(..)
, while , while
, doWhile , doWhile
@ -31,6 +32,9 @@ data Comparator
= Concrete (forall a . Ord a => a -> a -> Bool) = Concrete (forall a . Ord a => a -> a -> Bool)
| Generalized | Generalized
class AbstractHole value where
hole :: value
-- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc).
-- --
-- This allows us to abstract the choice of whether to evaluate under binders for different value types. -- This allows us to abstract the choice of whether to evaluate under binders for different value types.
@ -39,9 +43,6 @@ class (Monad (m effects), Show value) => MonadValue location value (effects :: [
-- TODO: This might be the same as the empty tuple for some value types -- TODO: This might be the same as the empty tuple for some value types
unit :: m effects value unit :: m effects value
-- | Construct an abstract hole.
hole :: m effects value
-- | Construct an abstract integral value. -- | Construct an abstract integral value.
integer :: Prelude.Integer -> m effects value integer :: Prelude.Integer -> m effects value

View File

@ -1,99 +1,22 @@
{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies, RankNTypes, TypeOperators #-}
module Control.Effect module Control.Effect
( Control.Effect.run ( Effectful(..)
, RunEffects(..) , raiseHandler
, RunEffect(..) , Interpreter(..)
, Effectful(..)
, resume , resume
, mergeEither
) where ) where
import Control.Monad.Effect as Effect import Control.Monad.Effect as Effect
import Control.Monad.Effect.Exception as Exception
import Control.Monad.Effect.Fail
import Control.Monad.Effect.NonDet
import Control.Monad.Effect.Reader
import Control.Monad.Effect.Resumable as Resumable import Control.Monad.Effect.Resumable as Resumable
import Control.Monad.Effect.State
import Control.Monad.Effect.Writer
import Data.Empty as E
import Data.Semigroup.Reducer
import Prologue
-- | Run an 'Effectful' computation to completion, interpreting each effect with some sensible defaults, and return the 'Final' result. resume :: (Member (Resumable exc) e, Effectful m) => m e a -> (forall v . (v -> m e a) -> exc v -> m e a) -> m e a
run :: (Effectful m, RunEffects effects a) => m effects a -> Final effects a
run = runEffects . lower
-- | A typeclass to run a computation to completion, interpreting each effect with some sensible defaults.
class RunEffects fs a where
-- | The final result type of the computation, factoring in the results of any effects, e.g. pairing 'State' results with the final state, wrapping 'Fail' results in 'Either', etc.
type Final fs a
runEffects :: Eff fs a -> Final fs a
instance (RunEffect f a, RunEffects fs (Result f a)) => RunEffects (f ': fs) a where
type Final (f ': fs) a = Final fs (Result f a)
runEffects = runEffects . runEffect
instance RunEffects '[] a where
type Final '[] a = a
runEffects = Effect.run
-- | A typeclass to interpret a single effect with some sensible defaults (defined per-effect).
class RunEffect f a where
-- | The incremental result of an effect w.r.t. the parameter value, factoring in the interpretation of the effect.
type Result f a
type instance Result f a = a
-- | Interpret the topmost effect in a computation with some sensible defaults (defined per-effect), and return the incremental 'Result'.
runEffect :: Eff (f ': fs) a -> Eff fs (Result f a)
-- | 'State' effects with 'Monoid'al states are interpreted starting from the 'mempty' state value into a pair of result value and final state.
instance E.Empty b => RunEffect (State b) a where
type Result (State b) a = (a, b)
runEffect = flip runState E.empty
-- | 'Reader' effects with 'Monoid'al environments are interpreted starting from the 'mempty' environment value.
instance Monoid b => RunEffect (Reader b) a where
runEffect = flip runReader mempty
-- | 'Fail' effects are interpreted into 'Either' s.t. failures are in 'Left' and successful results are in 'Right'.
instance RunEffect Fail a where
type Result Fail a = Either String a
runEffect = runFail
-- | 'Writer' effects are interpreted into a pair of result value and final log.
instance Monoid w => RunEffect (Writer w) a where
type Result (Writer w) a = (a, w)
runEffect = runWriter
-- | 'NonDet' effects are interpreted into a nondeterministic set of result values.
instance Ord a => RunEffect NonDet a where
type Result NonDet a = Set a
runEffect = runNonDet unit
-- | 'Resumable' effects are interpreted into 'Either' s.t. failures are in 'Left' and successful results are in 'Right'.
instance RunEffect (Resumable exc) a where
type Result (Resumable exc) a = Either (SomeExc exc) a
runEffect = Resumable.runError
-- | Standard (non-resumable) exceptions, as above, are rendered into 'Left's and 'Right's.
instance RunEffect (Exc exc) a where
type Result (Exc exc) a = Either exc a
runEffect = Exception.runError
resume :: (Resumable exc :< e, Effectful m) => m e a -> (forall v . (v -> m e a) -> exc v -> m e a) -> m e a
resume m handle = raise (resumeError (lower m) (\yield -> lower . handle (raise . yield))) resume m handle = raise (resumeError (lower m) (\yield -> lower . handle (raise . yield)))
-- | Reassociate 'Either's, combining errors into 'Left' values and successes in a single level of 'Right'.
mergeEither :: Either a (Either b c) -> Either (Either a b) c
mergeEither = either (Left . Left) (either (Left . Right) Right)
-- | Types wrapping 'Eff' actions. -- | Types wrapping 'Eff' actions.
-- --
-- Most instances of 'Effectful' will be derived using @-XGeneralizedNewtypeDeriving@, with these ultimately bottoming out on the instance for 'Eff' (for which 'raise' and 'lower' are simply the identity). Because of this, types can be nested arbitrarily deeply and still call 'raise'/'lower' just once to get at the (ultimately) underlying 'Eff'. -- Most instances of 'Effectful' will be derived using @-XGeneralizedNewtypeDeriving@, with these ultimately bottoming out on the instance for 'Eff' (for which 'raise' and 'lower' are simply the identity). Because of this, types can be nested arbitrarily deeply and still call 'raise'/'lower' just once to get at the (ultimately) underlying 'Eff'.
class Effectful (m :: [* -> *] -> * -> *) where class Effectful m where
-- | Raise an action in 'Eff' into an action in @m@. -- | Raise an action in 'Eff' into an action in @m@.
raise :: Eff effects a -> m effects a raise :: Eff effects a -> m effects a
-- | Lower an action in @m@ into an action in 'Eff'. -- | Lower an action in @m@ into an action in 'Eff'.
@ -102,3 +25,16 @@ class Effectful (m :: [* -> *] -> * -> *) where
instance Effectful Eff where instance Effectful Eff where
raise = id raise = id
lower = id lower = id
raiseHandler :: Effectful m => (Eff effectsA a -> Eff effectsB b) -> m effectsA a -> m effectsB b
raiseHandler handler = raise . handler . lower
-- | Interpreters determine and interpret a list of effects, optionally taking extra arguments.
--
-- Instances will generally be defined recursively in terms of underlying interpreters, bottoming out with the instance for 'Eff' which uses 'Effect.run' to produce a final value.
class Effectful m => Interpreter effects result function m | m -> effects, m result -> function where
interpret :: m effects result -> function
instance Interpreter '[] result result Eff where
interpret = Effect.run

View File

@ -1,27 +0,0 @@
{-# LANGUAGE GADTs, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
module Control.Effect.Fresh where
import Control.Effect
import Control.Monad.Effect.Internal
-- | An effect offering a (resettable) sequence of always-incrementing, and therefore “fresh,” type variables.
data Fresh a where
-- | Request a reset of the sequence of variable names.
Reset :: Int -> Fresh ()
-- | Request a fresh variable name.
Fresh :: Fresh Int
-- | Get a fresh variable name, guaranteed unused (since the last 'reset').
fresh :: (Effectful m, Member Fresh effects) => m effects Int
fresh = raise (send Fresh)
-- | Reset the sequence of variable names. Useful to avoid complicated alpha-equivalence comparisons when iteratively recomputing the results of an analysis til convergence.
reset :: (Effectful m, Member Fresh effects) => Int -> m effects ()
reset = raise . send . Reset
-- | 'Fresh' effects are interpreted starting from 0, incrementing the current name with each request for a fresh name, and overwriting the counter on reset.
instance RunEffect Fresh a where
runEffect = relayState (0 :: Int) (const pure) (\ s action k -> case action of
Fresh -> k (succ s) s
Reset s' -> k s' ())

View File

@ -55,7 +55,6 @@ type MonadEvaluatable location term value effects m =
, Member (Exc.Exc (LoopThrow value)) effects , Member (Exc.Exc (LoopThrow value)) effects
, Member Fail effects , Member Fail effects
, Member (Resumable (Unspecialized value)) effects , Member (Resumable (Unspecialized value)) effects
, Member (Resumable (ValueError location value)) effects
, Member (Resumable (LoadError term value)) effects , Member (Resumable (LoadError term value)) effects
, Member (Resumable (EvalError value)) effects , Member (Resumable (EvalError value)) effects
, Member (Resumable (ResolutionError value)) effects , Member (Resumable (ResolutionError value)) effects
@ -119,7 +118,7 @@ data EvalError value resume where
-- | Look up and dereference the given 'Name', throwing an exception for free variables. -- | Look up and dereference the given 'Name', throwing an exception for free variables.
variable :: MonadEvaluatable location term value effects m => Name -> m effects value variable :: (Member (Resumable (AddressError location value)) effects, Member (Resumable (EvalError value)) effects, MonadAddressable location effects m, MonadEvaluator location term value effects m) => Name -> m effects value
variable name = lookupWith deref name >>= maybeM (throwResumable (FreeVariableError name)) variable name = lookupWith deref name >>= maybeM (throwResumable (FreeVariableError name))
deriving instance Eq (EvalError a b) deriving instance Eq (EvalError a b)
@ -137,13 +136,13 @@ instance Eq1 (EvalError term) where
liftEq _ _ _ = False liftEq _ _ _ = False
throwValueError :: MonadEvaluatable location term value effects m => ValueError location value resume -> m effects resume throwValueError :: (Member (Resumable (ValueError location value)) effects, MonadEvaluator location term value effects m) => ValueError location value resume -> m effects resume
throwValueError = throwResumable throwValueError = throwResumable
throwLoadError :: MonadEvaluatable location term value effects m => LoadError term value resume -> m effects resume throwLoadError :: (Member (Resumable (LoadError term value)) effects, MonadEvaluator location term value effects m) => LoadError term value resume -> m effects resume
throwLoadError = throwResumable throwLoadError = throwResumable
throwEvalError :: MonadEvaluatable location term value effects m => EvalError value resume -> m effects resume throwEvalError :: (Member (Resumable (EvalError value)) effects, MonadEvaluator location term value effects m) => EvalError value resume -> m effects resume
throwEvalError = throwResumable throwEvalError = throwResumable
throwLoop :: MonadEvaluatable location term value effects m => LoopThrow value -> m effects a throwLoop :: MonadEvaluatable location term value effects m => LoopThrow value -> m effects a

View File

@ -38,21 +38,18 @@ data Type
-- TODO: À la carte representation of types. -- TODO: À la carte representation of types.
data TypeError resume where data TypeError resume where
NoValueError :: Type -> a -> TypeError a
NumOpError :: Type -> Type -> TypeError Type NumOpError :: Type -> Type -> TypeError Type
BitOpError :: Type -> Type -> TypeError Type BitOpError :: Type -> Type -> TypeError Type
UnificationError :: Type -> Type -> TypeError Type UnificationError :: Type -> Type -> TypeError Type
deriving instance Show resume => Show (TypeError resume) deriving instance Show (TypeError resume)
instance Show1 TypeError where instance Show1 TypeError where
liftShowsPrec _ _ _ (NoValueError v _) = showString "NoValueError " . shows v
liftShowsPrec _ _ _ (NumOpError l r) = showString "NumOpError " . shows [l, r] liftShowsPrec _ _ _ (NumOpError l r) = showString "NumOpError " . shows [l, r]
liftShowsPrec _ _ _ (BitOpError l r) = showString "BitOpError " . shows [l, r] liftShowsPrec _ _ _ (BitOpError l r) = showString "BitOpError " . shows [l, r]
liftShowsPrec _ _ _ (UnificationError l r) = showString "UnificationError " . shows [l, r] liftShowsPrec _ _ _ (UnificationError l r) = showString "UnificationError " . shows [l, r]
instance Eq1 TypeError where instance Eq1 TypeError where
liftEq _ (NoValueError a _) (NoValueError b _) = a == b
liftEq _ (BitOpError a b) (BitOpError c d) = a == c && b == d liftEq _ (BitOpError a b) (BitOpError c d) = a == c && b == d
liftEq _ (NumOpError a b) (NumOpError c d) = a == c && b == d liftEq _ (NumOpError a b) (NumOpError c d) = a == c && b == d
liftEq _ (UnificationError a b) (UnificationError c d) = a == c && b == d liftEq _ (UnificationError a b) (UnificationError c d) = a == c && b == d
@ -74,6 +71,10 @@ unify t1 t2
instance Ord location => ValueRoots location Type where instance Ord location => ValueRoots location Type where
valueRoots _ = mempty valueRoots _ = mempty
instance AbstractHole Type where
hole = Hole
-- | Discard the value arguments (if any), constructing a 'Type' instead. -- | Discard the value arguments (if any), constructing a 'Type' instead.
instance ( Alternative (m effects) instance ( Alternative (m effects)
, Member Fresh effects , Member Fresh effects
@ -86,14 +87,13 @@ instance ( Alternative (m effects)
lambda names (Subterm _ body) = do lambda names (Subterm _ body) = do
(env, tvars) <- foldr (\ name rest -> do (env, tvars) <- foldr (\ name rest -> do
a <- alloc name a <- alloc name
tvar <- Var <$> fresh tvar <- Var <$> raise fresh
assign a tvar assign a tvar
(env, tvars) <- rest (env, tvars) <- rest
pure (Env.insert name a env, tvar : tvars)) (pure mempty) names pure (Env.insert name a env, tvar : tvars)) (pure mempty) names
ret <- localEnv (mappend env) body ret <- localEnv (mappend env) body
pure (Product tvars :-> ret) pure (Product tvars :-> ret)
hole = pure Hole
unit = pure Unit unit = pure Unit
integer _ = pure Int integer _ = pure Int
boolean _ = pure Bool boolean _ = pure Bool
@ -113,9 +113,12 @@ instance ( Alternative (m effects)
scopedEnvironment _ = pure mempty scopedEnvironment _ = pure mempty
asString _ = throwResumable (NoValueError String "") asString t = unify t String $> ""
asPair _ = throwResumable (NoValueError (Product []) (Hole, Hole)) asPair t = do
asBool _ = throwResumable (NoValueError Bool True) t1 <- raise fresh
t2 <- raise fresh
unify t (Product [Var t1, Var t2]) $> (Var t1, Var t2)
asBool t = unify t Bool *> (pure True <|> pure False)
isHole ty = pure (ty == Hole) isHole ty = pure (ty == Hole)
@ -146,7 +149,7 @@ instance ( Alternative (m effects)
_ -> unify left right $> Bool _ -> unify left right $> Bool
call op params = do call op params = do
tvar <- fresh tvar <- raise fresh
paramTypes <- sequenceA params paramTypes <- sequenceA params
let needed = Product paramTypes :-> Var tvar let needed = Product paramTypes :-> Var tvar
unified <- op `unify` needed unified <- op `unify` needed

View File

@ -198,9 +198,15 @@ instance Ord location => ValueRoots location (Value location) where
| otherwise = mempty | otherwise = mempty
instance AbstractHole (Value location) where
hole = injValue Hole
-- | Construct a 'Value' wrapping the value arguments (if any). -- | Construct a 'Value' wrapping the value arguments (if any).
instance (Monad (m effects), MonadEvaluatable location term (Value location) effects m) => MonadValue location (Value location) effects m where instance ( Monad (m effects)
hole = pure . injValue $ Hole , Member (Resumable (ValueError location (Value location))) effects
, MonadEvaluatable location term (Value location) effects m
)
=> MonadValue location (Value location) effects m where
unit = pure . injValue $ Unit unit = pure . injValue $ Unit
integer = pure . injValue . Integer . Number.Integer integer = pure . injValue . Integer . Number.Integer
boolean = pure . injValue . Boolean boolean = pure . injValue . Boolean
@ -247,7 +253,7 @@ instance (Monad (m effects), MonadEvaluatable location term (Value location) eff
ifthenelse cond if' else' = do ifthenelse cond if' else' = do
isHole <- isHole cond isHole <- isHole cond
if isHole then if isHole then
hole pure hole
else do else do
bool <- asBool cond bool <- asBool cond
if bool then if' else else' if bool then if' else else'
@ -280,7 +286,7 @@ instance (Monad (m effects), MonadEvaluatable location term (Value location) eff
tentative x i j = attemptUnsafeArithmetic (x i j) tentative x i j = attemptUnsafeArithmetic (x i j)
-- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor -- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
specialize :: MonadEvaluatable location term value effects m => Either ArithException Number.SomeNumber -> m effects value specialize :: (Member (Resumable (ValueError location value)) effects, MonadEvaluatable location term value effects m) => Either ArithException Number.SomeNumber -> m effects value
specialize (Left exc) = throwValueError (ArithmeticError exc) specialize (Left exc) = throwValueError (ArithmeticError exc)
specialize (Right (Number.SomeNumber (Number.Integer i))) = integer i specialize (Right (Number.SomeNumber (Number.Integer i))) = integer i
specialize (Right (Number.SomeNumber (Number.Ratio r))) = rational r specialize (Right (Number.SomeNumber (Number.Ratio r))) = rational r

View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, ScopedTypeVariables #-} {-# LANGUAGE GADTs #-}
module Semantic.Graph where module Semantic.Graph where
import qualified Analysis.Abstract.ImportGraph as Abstract import qualified Analysis.Abstract.ImportGraph as Abstract
@ -15,10 +15,10 @@ import Data.Abstract.Located
import Data.Abstract.Address import Data.Abstract.Address
import Analysis.Abstract.BadAddresses import Analysis.Abstract.BadAddresses
import Analysis.Abstract.BadModuleResolutions import Analysis.Abstract.BadModuleResolutions
import Analysis.Abstract.BadSyntax
import Analysis.Abstract.BadValues import Analysis.Abstract.BadValues
import Analysis.Abstract.BadVariables import Analysis.Abstract.BadVariables
import Analysis.Abstract.Evaluating import Analysis.Abstract.Evaluating
import Analysis.Abstract.Quiet
import Data.Output import Data.Output
import Parsing.Parser import Parsing.Parser
import Prologue hiding (MonadError (..)) import Prologue hiding (MonadError (..))
@ -63,13 +63,12 @@ parseModule parser rootDir file = do
type ImportGraphAnalysis term effects value = type ImportGraphAnalysis term effects value =
Abstract.ImportGraphing Abstract.ImportGraphing
(BadAddresses (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))))) (BadAddresses (BadModuleResolutions (BadVariables (BadValues (BadSyntax (Evaluating (Located Precise term) term (Value (Located Precise term))))))))
effects effects
value value
-- | Render the import graph for a given 'Package'. -- | Render the import graph for a given 'Package'.
graphImports :: ( graphImports :: ( Show ann
Show ann
, Ord ann , Ord ann
, Apply Analysis.Declarations1 syntax , Apply Analysis.Declarations1 syntax
, Apply Analysis.Evaluatable syntax , Apply Analysis.Evaluatable syntax
@ -80,10 +79,9 @@ graphImports :: (
, Apply Show1 syntax , Apply Show1 syntax
, Member Syntax.Identifier syntax , Member Syntax.Identifier syntax
, Members '[Exc SomeException, Task] effs , Members '[Exc SomeException, Task] effs
, term ~ Term (Union syntax) ann
) )
=> Package term -> Eff effs Abstract.ImportGraph => Package (Term (Union syntax) ann) -> Eff effs Abstract.ImportGraph
graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package)) >>= extractGraph graphImports package = analyze (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package) >>= extractGraph
where where
asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value
-> Package term -> Package term
@ -91,5 +89,5 @@ graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage
asAnalysisForTypeOfPackage = const asAnalysisForTypeOfPackage = const
extractGraph result = case result of extractGraph result = case result of
(Right (Right (Right (Right (Right (Right (Right (Right (Right ((((_, graph), _), _), _))))))))), _) -> pure $! graph (Right (Right (Right (Right ((_, graph), _)))), _) -> pure graph
_ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result)))

View File

@ -88,7 +88,7 @@ parse :: Member Task effs => Parser term -> Blob -> Eff effs term
parse parser = send . Parse parser parse parser = send . Parse parser
-- | A task running some 'Analysis.MonadAnalysis' to completion. -- | A task running some 'Analysis.MonadAnalysis' to completion.
analyze :: Member Task effs => Analysis.SomeAnalysis m result -> Eff effs result analyze :: (Analysis.Interpreter analysisEffects result function m, Member Task effs) => m analysisEffects result -> Eff effs function
analyze = send . Analyze analyze = send . Analyze
-- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function. -- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
@ -131,7 +131,7 @@ runTaskWithOptions options task = do
-- | An effect describing high-level tasks to be performed. -- | An effect describing high-level tasks to be performed.
data Task output where data Task output where
Parse :: Parser term -> Blob -> Task term Parse :: Parser term -> Blob -> Task term
Analyze :: Analysis.SomeAnalysis m result -> Task result Analyze :: Analysis.Interpreter effects result function m => m effects result -> Task function
Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields))) Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields)))
Diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2) Diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2)
Render :: Renderer input output -> input -> Task output Render :: Renderer input output -> input -> Task output
@ -140,7 +140,7 @@ data Task output where
runTaskF :: Members '[Reader Options, Telemetry, Exc SomeException, IO] effs => Eff (Task ': effs) a -> Eff effs a runTaskF :: Members '[Reader Options, Telemetry, Exc SomeException, IO] effs => Eff (Task ': effs) a -> Eff effs a
runTaskF = interpret $ \ task -> case task of runTaskF = interpret $ \ task -> case task of
Parse parser blob -> runParser blob parser Parse parser blob -> runParser blob parser
Analyze analysis -> pure (Analysis.runSomeAnalysis analysis) Analyze analysis -> pure (Analysis.runAnalysis analysis)
Decorate algebra term -> pure (decoratorWithAlgebra algebra term) Decorate algebra term -> pure (decoratorWithAlgebra algebra term)
Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2) Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2)
Render renderer input -> pure (renderer input) Render renderer input -> pure (renderer input)

View File

@ -1,15 +1,17 @@
-- MonoLocalBinds is to silence a warning about a simplifiable constraint. -- MonoLocalBinds is to silence a warning about a simplifiable constraint.
{-# LANGUAGE MonoLocalBinds, ScopedTypeVariables, TypeFamilies, TypeOperators #-} {-# LANGUAGE MonoLocalBinds, TypeOperators #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -Wno-missing-signatures #-}
module Semantic.Util where module Semantic.Util where
import Analysis.Abstract.BadAddresses
import Analysis.Abstract.BadModuleResolutions import Analysis.Abstract.BadModuleResolutions
import Analysis.Abstract.BadSyntax
import Analysis.Abstract.BadValues import Analysis.Abstract.BadValues
import Analysis.Abstract.BadVariables import Analysis.Abstract.BadVariables
import Analysis.Abstract.Caching import Analysis.Abstract.Caching
import Analysis.Abstract.Erroring
import Analysis.Abstract.Evaluating as X import Analysis.Abstract.Evaluating as X
import Analysis.Abstract.ImportGraph import Analysis.Abstract.ImportGraph
import Analysis.Abstract.Quiet
import Analysis.Abstract.TypeChecking import Analysis.Abstract.TypeChecking
import Analysis.Declaration import Analysis.Declaration
import Control.Abstract.Analysis import Control.Abstract.Analysis
@ -43,13 +45,26 @@ import qualified Language.Python.Assignment as Python
import qualified Language.Ruby.Assignment as Ruby import qualified Language.Ruby.Assignment as Ruby
import qualified Language.TypeScript.Assignment as TypeScript import qualified Language.TypeScript.Assignment as TypeScript
-- type TestEvaluating term = Evaluating Precise term (Value Precise)
type JustEvaluating term = Evaluating (Located Precise term) term (Value (Located Precise term)) type JustEvaluating term
type EvaluatingWithHoles term = BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))) = Erroring (AddressError (Located Precise term) (Value (Located Precise term)))
( Erroring (EvalError (Value (Located Precise term)))
( Erroring (ResolutionError (Value (Located Precise term)))
( Erroring (Unspecialized (Value (Located Precise term)))
( Erroring (ValueError (Located Precise term) (Value (Located Precise term)))
( Evaluating (Located Precise term) term (Value (Located Precise term)))))))
type EvaluatingWithHoles term = BadAddresses (BadModuleResolutions (BadVariables (BadValues (BadSyntax (Evaluating (Located Precise term) term (Value (Located Precise term)))))))
type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term)
-- The order is significant here: Caching has to come on the outside, or the RunEffect instance for NonDet -- The order is significant here: Caching has to come on the outside, or the RunEffect instance for NonDet
-- will expect the TypeError exception type to have an Ord instance, which is wrong. -- will expect the TypeError exception type to have an Ord instance, which is wrong.
type Checking term = Caching (TypeChecking (Evaluating Monovariant term Type)) type Checking term
= Caching
( TypeChecking
( Erroring (AddressError Monovariant Type)
( Erroring (EvalError Type)
( Erroring (ResolutionError Type)
( Erroring (Unspecialized Type)
( Evaluating Monovariant term Type))))))
evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path
evalRubyProject path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path evalRubyProject path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path

View File

@ -30,7 +30,7 @@ spec = parallel $ do
it "evaluates load with wrapper" $ do it "evaluates load with wrapper" $ do
res <- evaluate "load-wrap.rb" res <- evaluate "load-wrap.rb"
fst res `shouldBe` Right (Right (Right (Right (Right (Right (Left (SomeExc (FreeVariableError "foo")))))))) fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Left (SomeExc (FreeVariableError "foo")))))))))
environment (snd res) `shouldBe` [ ("Object", addr 0) ] environment (snd res) `shouldBe` [ ("Object", addr 0) ]
it "evaluates subclass" $ do it "evaluates subclass" $ do

View File

@ -34,7 +34,7 @@ spec = parallel $ do
it "fails exporting symbols not defined in the module" $ do it "fails exporting symbols not defined in the module" $ do
v <- fst <$> evaluate "bad-export.ts" v <- fst <$> evaluate "bad-export.ts"
v `shouldBe` Right (Right (Right (Right (Right (Right (Left (SomeExc $ ExportError "foo.ts" (Name "pip")))))))) v `shouldBe` Right (Right (Right (Right (Right (Right (Right (Left (SomeExc (ExportError "foo.ts" (Name "pip"))))))))))
it "evaluates early return statements" $ do it "evaluates early return statements" $ do
res <- evaluate "early-return.ts" res <- evaluate "early-return.ts"

View File

@ -12,8 +12,13 @@ module SpecHelpers (
, TestEvaluating , TestEvaluating
, ) where , ) where
import Analysis.Abstract.Erroring
import Analysis.Abstract.Evaluating
import Control.Abstract.Addressable
import Control.Abstract.Evaluator as X (EvaluatorState(..)) import Control.Abstract.Evaluator as X (EvaluatorState(..))
import Control.Abstract.Value
import Data.Abstract.Address as X import Data.Abstract.Address as X
import Data.Abstract.Evaluatable
import Data.Abstract.FreeVariables as X hiding (dropExtension) import Data.Abstract.FreeVariables as X hiding (dropExtension)
import Data.Abstract.Heap as X import Data.Abstract.Heap as X
import Data.Abstract.ModuleTable as X hiding (lookup) import Data.Abstract.ModuleTable as X hiding (lookup)
@ -50,7 +55,6 @@ import Test.LeanCheck as X
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Semantic.IO as IO import qualified Semantic.IO as IO
import Data.Abstract.Value import Data.Abstract.Value
import Analysis.Abstract.Evaluating
-- | Returns an s-expression formatted diff for the specified FilePath pair. -- | Returns an s-expression formatted diff for the specified FilePath pair.
diffFilePaths :: Both FilePath -> IO ByteString diffFilePaths :: Both FilePath -> IO ByteString
@ -68,7 +72,13 @@ readFilePair paths = let paths' = fmap file paths in
readFileVerbatim :: FilePath -> IO Verbatim readFileVerbatim :: FilePath -> IO Verbatim
readFileVerbatim = fmap verbatim . B.readFile readFileVerbatim = fmap verbatim . B.readFile
type TestEvaluating term = Evaluating Precise term (Value Precise) type TestEvaluating term
= Erroring (AddressError Precise (Value Precise))
( Erroring (EvalError (Value Precise))
( Erroring (ResolutionError (Value Precise))
( Erroring (Unspecialized (Value Precise))
( Erroring (ValueError Precise (Value Precise))
( Evaluating Precise term (Value Precise))))))
ns n = Just . Latest . Just . injValue . Namespace n ns n = Just . Latest . Just . injValue . Namespace n
addr = Address . Precise addr = Address . Precise

2
vendor/effects vendored

@ -1 +1 @@
Subproject commit 06b08cd6354b109581388d40181e96de856b698a Subproject commit 635733602419b0a0da86bf06a1de3d5bc67ab3d4