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:
commit
08600b4155
@ -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
|
||||||
|
@ -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 instance’s 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
|
|
||||||
|
@ -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 instance’s 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
|
|
||||||
|
32
src/Analysis/Abstract/BadSyntax.hs
Normal file
32
src/Analysis/Abstract/BadSyntax.hs
Normal file
@ -0,0 +1,32 @@
|
|||||||
|
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-}
|
||||||
|
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s 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' doesn’t know about them, i.e. if they’re 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))
|
@ -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
|
|
||||||
|
@ -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 instance’s 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
|
|
||||||
|
@ -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 instance’s 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 @[])
|
||||||
|
@ -1,4 +1,5 @@
|
|||||||
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-}
|
||||||
|
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s 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)
|
||||||
|
@ -1,4 +1,5 @@
|
|||||||
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-}
|
||||||
|
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s 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)
|
||||||
|
18
src/Analysis/Abstract/Erroring.hs
Normal file
18
src/Analysis/Abstract/Erroring.hs
Normal 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
|
@ -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 term’s origin.
|
, Reader (SomeOrigin term) -- The current term’s 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)
|
||||||
|
@ -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)
|
||||||
|
@ -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' doesn’t know about them, i.e. if they’re 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
|
|
@ -1,4 +1,5 @@
|
|||||||
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
|
||||||
|
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s 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
|
||||||
|
@ -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
|
|
||||||
|
@ -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
|
||||||
|
@ -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
|
|
||||||
|
@ -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
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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' ())
|
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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)))
|
||||||
|
@ -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)
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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"
|
||||||
|
@ -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
2
vendor/effects
vendored
@ -1 +1 @@
|
|||||||
Subproject commit 06b08cd6354b109581388d40181e96de856b698a
|
Subproject commit 635733602419b0a0da86bf06a1de3d5bc67ab3d4
|
Loading…
Reference in New Issue
Block a user