diff --git a/semantic.cabal b/semantic.cabal index 3d6247711..aed7305bd 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -72,7 +72,6 @@ library , Data.AST , Data.Blob , Data.Diff - , Data.Empty , Data.Error , Data.File , Data.Functor.Both @@ -86,6 +85,7 @@ library , Data.Range , Data.Record , Data.Semigroup.App + , Data.Semilattice.Lower , Data.Scientific.Exts , Data.Source , Data.Span diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index e98acd943..50cc0fee3 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadAddresses where @@ -12,13 +12,14 @@ newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses { runBadAddresses 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 ( Interpreter effects result rest m +instance ( Interpreter m effects , MonadEvaluator location term value effects m , AbstractHole value , Monoid (Cell location value) , Show location ) - => Interpreter (Resumable (AddressError location value) ': effects) result rest (BadAddresses m) where + => Interpreter (BadAddresses m) (Resumable (AddressError location value) ': effects) where + type Result (BadAddresses m) (Resumable (AddressError location value) ': effects) result = Result m effects result interpret = interpret . runBadAddresses diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index 034d6ef99..3c7926089 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadModuleResolutions where @@ -12,10 +12,11 @@ newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions { 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 ( Interpreter effects result rest m +instance ( Interpreter m effects , MonadEvaluator location term value effects m ) - => Interpreter (Resumable (ResolutionError value) ': effects) result rest (BadModuleResolutions m) where + => Interpreter (BadModuleResolutions m) (Resumable (ResolutionError value) ': effects) where + type Result (BadModuleResolutions m) (Resumable (ResolutionError value) ': effects) result = Result m effects result interpret = interpret . runBadModuleResolutions diff --git a/src/Analysis/Abstract/BadSyntax.hs b/src/Analysis/Abstract/BadSyntax.hs index 149703171..9026958cc 100644 --- a/src/Analysis/Abstract/BadSyntax.hs +++ b/src/Analysis/Abstract/BadSyntax.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadSyntax ( BadSyntax @@ -12,7 +12,7 @@ import Prologue -- -- Use it by composing it onto an analysis: -- --- > runAnalysis @(BadSyntax (Evaluating term value)) (…) +-- > interpret @(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 } @@ -21,11 +21,12 @@ newtype BadSyntax m (effects :: [* -> *]) a = BadSyntax { runBadSyntax :: m effe 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 +instance ( Interpreter m effects , MonadEvaluator location term value effects m , AbstractHole value ) - => Interpreter (Resumable (Unspecialized value) ': effects) result rest (BadSyntax m) where + => Interpreter (BadSyntax m) (Resumable (Unspecialized value) ': effects) where + type Result (BadSyntax m) (Resumable (Unspecialized value) ': effects) result = Result m effects result interpret = interpret . runBadSyntax diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index af8a26f66..eca14d530 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.BadValues where import Control.Abstract.Analysis +import Data.Abstract.Value (ValueError(..)) import Data.ByteString.Char8 (pack) import Prologue @@ -11,12 +12,13 @@ newtype BadValues m (effects :: [* -> *]) a = BadValues { runBadValues :: m effe 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 ( Interpreter effects result rest m +instance ( Interpreter m effects , MonadEvaluator location term value effects m , AbstractHole value , Show value ) - => Interpreter (Resumable (ValueError location value) ': effects) result rest (BadValues m) where + => Interpreter (BadValues m) (Resumable (ValueError location value) ': effects) where + type Result (BadValues m) (Resumable (ValueError location value) ': effects) result = Result m effects result interpret = interpret . runBadValues diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 16ff5043f..93d62f20f 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadVariables ( BadVariables @@ -15,12 +15,13 @@ newtype BadVariables m (effects :: [* -> *]) a = BadVariables { runBadVariables 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 ( Interpreter effects (result, [Name]) rest m +instance ( Interpreter m effects , MonadEvaluator location term value effects m , AbstractHole value , Show value ) - => Interpreter (Resumable (EvalError value) ': State [Name] ': effects) result rest (BadVariables m) where + => Interpreter (BadVariables m) (Resumable (EvalError value) ': State [Name] ': effects) where + type Result (BadVariables m) (Resumable (EvalError value) ': State [Name] ': effects) result = Result m effects (result, [Name]) interpret = interpret . runBadVariables diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 325c7c425..461584524 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Caching ( Caching @@ -10,16 +10,10 @@ import Data.Abstract.Address import Data.Abstract.Cache import Data.Abstract.Configuration import Data.Abstract.Heap +import Data.Abstract.Live import Data.Abstract.Module import Prologue --- | The effects necessary for caching analyses. -type CachingEffects location term value effects - = NonDet -- For 'Alternative' and 'gather'. - ': Reader (Cache location term value) -- The in-cache used as an oracle while converging on a result. - ': State (Cache location term value) -- The out-cache used to record results in each iteration of convergence. - ': effects - -- | A (coinductively-)cached analysis suitable for guaranteeing termination of (suitably finitized) analyses over recursive programs. newtype Caching m (effects :: [* -> *]) a = Caching { runCaching :: m effects a } deriving (Alternative, Applicative, Functor, Effectful, Monad) @@ -42,7 +36,8 @@ class MonadEvaluator location term value effects m => MonadCaching location term isolateCache :: m effects a -> m effects (Cache location term value) instance ( Effectful m - , Members (CachingEffects location term value '[]) effects + , Member (Reader (Cache location term value)) effects + , Member (State (Cache location term value)) effects , MonadEvaluator location term value effects m , Ord (Cell location value) , Ord location @@ -51,7 +46,7 @@ instance ( Effectful m ) => MonadCaching location term value effects (Caching m) where consultOracle configuration = raise (fromMaybe mempty . cacheLookup configuration <$> ask) - withOracle cache = raise . local (const cache) . lower + withOracle cache = raiseHandler (local (const cache)) lookupCache configuration = raise (cacheLookup configuration <$> get) caching configuration values action = do @@ -67,7 +62,10 @@ instance ( Alternative (m effects) , Corecursive term , Effectful m , Member Fresh effects - , Members (CachingEffects location term value '[]) effects + , Member NonDet effects + , Member (Reader (Cache location term value)) effects + , Member (Reader (Live location value)) effects + , Member (State (Cache location term value)) effects , MonadAnalysis location term value effects m , Ord (Cell location value) , Ord location @@ -123,14 +121,15 @@ scatter :: (Alternative (m effects), Foldable t, MonadEvaluator location term va scatter = foldMapA (\ (value, heap') -> putHeap heap' $> value) -instance ( Interpreter effects ([result], Cache location term value) rest m +instance ( Interpreter m effects , 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 + => Interpreter (Caching m) (NonDet ': Reader (Cache location term value) ': State (Cache location term value) ': effects) where + type Result (Caching m) (NonDet ': Reader (Cache location term value) ': State (Cache location term value) ': effects) result = Result m effects ([result], Cache location term value) interpret = interpret . runCaching diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index b270e8b43..bc2c34d5a 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -1,25 +1,21 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Collecting ( Collecting +, Retaining ) where import Control.Abstract.Analysis import Data.Abstract.Address -import Data.Abstract.Configuration import Data.Abstract.Heap import Data.Abstract.Live import Prologue +-- | An analysis performing GC after every instruction. newtype Collecting m (effects :: [* -> *]) a = Collecting { runCollecting :: m effects a } - deriving (Alternative, Applicative, Functor, Effectful, Monad) + deriving (Alternative, Applicative, Effectful, Functor, Monad) -instance ( Effectful m - , Member (Reader (Live location value)) effects - , MonadEvaluator location term value effects m - ) - => MonadEvaluator location term value effects (Collecting m) where - getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Collecting m) instance ( Effectful m @@ -40,15 +36,6 @@ instance ( Effectful m analyzeModule = liftAnalyze analyzeModule --- | Retrieve the local 'Live' set. -askRoots :: (Effectful m, Member (Reader (Live location value)) effects) => m effects (Live location value) -askRoots = raise ask - --- | Run a computation with the given 'Live' set added to the local root set. --- extraRoots :: (Effectful m, Member (Reader (Live location value)) effects, Ord location) => Live location value -> m effects a -> m effects a --- extraRoots roots = raise . local (<> roots) . lower - - -- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set. gc :: ( Ord location , Foldable (Cell location) @@ -75,9 +62,26 @@ reachable roots heap = go mempty roots _ -> seen) -instance ( Interpreter effects result rest m +instance ( Interpreter m effects , MonadEvaluator location term value effects m , Ord location ) - => Interpreter (Reader (Live location value) ': effects) result rest (Collecting m) where + => Interpreter (Collecting m) (Reader (Live location value) ': effects) where + type Result (Collecting m) (Reader (Live location value) ': effects) result = Result m effects result interpret = interpret . runCollecting . raiseHandler (`runReader` mempty) + + +-- | An analysis providing a 'Live' set, but never performing GC. +newtype Retaining m (effects :: [* -> *]) a = Retaining { runRetaining :: m effects a } + deriving (Alternative, Applicative, Effectful, Functor, Monad) + +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Retaining m) +deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (Retaining m) + +instance ( Interpreter m effects + , MonadEvaluator location term value effects m + , Ord location + ) + => Interpreter (Retaining m) (Reader (Live location value) ': effects) where + type Result (Retaining m) (Reader (Live location value) ': effects) result = Result m effects result + interpret = interpret . runRetaining . raiseHandler (`runReader` mempty) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index b9f0de2f0..d340f49b5 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Dead ( DeadCode @@ -52,9 +52,10 @@ instance ( Corecursive term killAll (subterms (subterm (moduleBody m))) liftAnalyze analyzeModule recur m -instance ( Interpreter effects (result, Dead term) rest m +instance ( Interpreter m effects , MonadEvaluator location term value effects m , Ord term ) - => Interpreter (State (Dead term) ': effects) result rest (DeadCode m) where + => Interpreter (DeadCode m) (State (Dead term) ': effects) where + type Result (DeadCode m) (State (Dead term) ': effects) result = Result m effects (result, Dead term) interpret = interpret . runDeadCode . raiseHandler (`runState` mempty) diff --git a/src/Analysis/Abstract/Erroring.hs b/src/Analysis/Abstract/Erroring.hs index edca0febb..5625c3d1e 100644 --- a/src/Analysis/Abstract/Erroring.hs +++ b/src/Analysis/Abstract/Erroring.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Erroring ( Erroring ) where @@ -13,6 +13,7 @@ newtype Erroring (exc :: * -> *) m (effects :: [* -> *]) a = Erroring { runError 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 +instance Interpreter m effects + => Interpreter (Erroring exc m) (Resumable exc ': effects) where + type Result (Erroring exc m) (Resumable exc ': effects) result = Result m effects (Either (SomeExc exc) result) interpret = interpret . runErroring . raiseHandler runError diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index e6662ca5c..2c4d821ae 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,20 +1,16 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} module Analysis.Abstract.Evaluating ( Evaluating ) where import Control.Abstract.Analysis -import Control.Monad.Effect.Exception as Exc -import Control.Monad.Effect.Resumable as Res -import Data.Abstract.Address -import Data.Abstract.Configuration +import qualified Control.Monad.Effect as Eff import Data.Abstract.Environment -import Data.Abstract.Evaluatable import Data.Abstract.Module import Data.Abstract.ModuleTable import Data.Abstract.Origin -import Data.Empty -import Prologue hiding (empty) +import Data.Semilattice.Lower +import Prologue -- | 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 { runEvaluating :: Eff effects a } @@ -24,9 +20,10 @@ deriving instance Member NonDet effects => Alternative (Evaluating location term -- | Effects necessary for evaluating (whether concrete or abstract). type EvaluatingEffects location term value - = '[ Exc (ReturnThrow value) - , Exc (LoopThrow value) - , Resumable (LoadError term value) + = '[ EvalClosure term value + , EvalModule term value + , Return value + , LoopControl value , Fail -- Failure with an error message , Fresh -- For allocating new addresses and/or type variables. , Reader (SomeOrigin term) -- The current term’s origin. @@ -35,17 +32,14 @@ type EvaluatingEffects location term value , State (EvaluatorState location term value) -- Environment, heap, modules, exports, and jumps. ] -instance ( Member Fail effects - , Member (Reader (Environment location value)) effects +instance ( Member (Reader (Environment location value)) effects , Member (Reader (ModuleTable [Module term])) effects , Member (Reader (SomeOrigin term)) effects , Member (State (EvaluatorState location term value)) effects ) - => MonadEvaluator location term value effects (Evaluating location term value) where - getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap + => MonadEvaluator location term value effects (Evaluating location term value) instance ( Corecursive term - , Member Fail effects , Member (Reader (Environment location value)) effects , Member (Reader (ModuleTable [Module term])) effects , Member (Reader (SomeOrigin term)) effects @@ -58,28 +52,26 @@ instance ( Corecursive term 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 +instance (AbstractHole value, Show term, Show value) => Interpreter (Evaluating location term value) (EvaluatingEffects location term value) where + type Result (Evaluating location term value) (EvaluatingEffects location term value) result + = ( Either String result + , EvaluatorState location term value) 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 runState lowerBound -- State (EvaluatorState location term value) + . flip runReader lowerBound -- Reader (Environment location value) + . flip runReader lowerBound -- Reader (ModuleTable [Module term]) + . flip runReader lowerBound -- Reader (SomeOrigin term) . flip runFresh' 0 . runFail - . Res.runError - . Exc.runError - . Exc.runError) + -- NB: We should never have a 'Return', 'Break', or 'Continue' at this point in execution; the scope being returned from/broken from/continued should have intercepted the effect. This handler will therefore only be invoked if we issue a 'Return', 'Break', or 'Continue' outside of such a scope, and unfortunately if this happens it will handle it by resuming the scope being returned from. While it would be _slightly_ more correct to instead exit with the value being returned, we aren’t able to do that here since 'Interpreter'’s type is parametric in the value being returned—we don’t know that we’re returning a @value@ (because we very well may not be). On the balance, I felt the strange behaviour in error cases is worth the improved behaviour in the common case—we get to lose a layer of 'Either' in the result for each. + -- In general, it’s expected that none of the following effects will remain by the time 'interpret' is called—they should have been handled by local 'interpose's—but if they do, we’ll at least trace. + . Eff.interpret (\ control -> case control of + Break value -> traceM ("Evaluating.interpret: resuming uncaught break with " <> show value) $> value + Continue -> traceM "Evaluating.interpret: resuming uncaught continue with hole" $> hole) + . Eff.interpret (\ (Return value) -> traceM ("Evaluating.interpret: resuming uncaught return with " <> show value) $> value) + . Eff.interpret (\ (EvalModule m) -> traceM ("Evaluating.interpret: resuming uncaught EvalModule of " <> show m <> " with hole") $> hole) + . Eff.interpret (\ (EvalClosure term) -> traceM ("Evaluating.interpret: resuming uncaught EvalClosure of " <> show term <> " with hole") $> hole)) + -- TODO: Replace 'traceM's with e.g. 'Telemetry'. diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 7d7be3612..5001c1be9 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.ImportGraph ( ImportGraph(..) , renderImportGraph @@ -8,7 +8,7 @@ module Analysis.Abstract.ImportGraph import qualified Algebra.Graph as G import Algebra.Graph.Class hiding (Vertex) import Algebra.Graph.Export.Dot hiding (vertexName) -import Control.Abstract.Analysis hiding (origin) +import Control.Abstract.Analysis import Data.Abstract.Address import Data.Abstract.Evaluatable (LoadError (..)) import Data.Abstract.FreeVariables @@ -16,7 +16,7 @@ import Data.Abstract.Located import Data.Abstract.Module hiding (Module) import Data.Abstract.Origin hiding (Module, Package) import Data.Abstract.Package hiding (Package) -import Data.Aeson +import Data.Aeson hiding (Result) import qualified Data.ByteString.Char8 as BC import Data.ByteString.Lazy (toStrict) import Data.Output @@ -60,12 +60,10 @@ deriving instance MonadEvaluator location term value effects m => MonadEvaluator instance ( Effectful m - , Member (Reader (SomeOrigin term)) effects - , Member (Resumable (LoadError term value)) effects + , Member (Resumable (LoadError term)) effects , Member (State ImportGraph) effects , Member Syntax.Identifier syntax , MonadAnalysis (Located location term) term value effects m - , Show ann , term ~ Term (Union syntax) ann ) => MonadAnalysis (Located location term) term value effects (ImportGraphing m) where @@ -76,7 +74,7 @@ instance ( Effectful m variableDefinition name _ -> pure () resume - @(LoadError term value) + @(LoadError term) (liftAnalyze analyzeTerm eval term) (\yield (LoadError name) -> moduleInclusion (Module (BC.pack name)) >> yield []) @@ -168,6 +166,7 @@ vertexToType Module{} = "module" vertexToType Variable{} = "variable" -instance Interpreter effects (result, ImportGraph) rest m - => Interpreter (State ImportGraph ': effects) result rest (ImportGraphing m) where +instance Interpreter m effects + => Interpreter (ImportGraphing m) (State ImportGraph ': effects) where + type Result (ImportGraphing m) (State ImportGraph ': effects) result = Result m effects (result, ImportGraph) interpret = interpret . runImportGraphing . raiseHandler (`runState` mempty) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 955065fac..ccb676320 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Tracing ( Tracing @@ -7,6 +7,7 @@ module Analysis.Abstract.Tracing import Control.Abstract.Analysis import Control.Monad.Effect.Writer import Data.Abstract.Configuration +import Data.Abstract.Live import Data.Semigroup.Reducer as Reducer import Data.Union import Prologue @@ -21,6 +22,7 @@ deriving instance MonadEvaluator location term value effects m => MonadEvaluator instance ( Corecursive term , Effectful m + , Member (Reader (Live location value)) effects , Member (Writer (trace (Configuration location term value))) effects , MonadAnalysis location term value effects m , Ord location @@ -34,9 +36,10 @@ instance ( Corecursive term analyzeModule = liftAnalyze analyzeModule -instance ( Interpreter effects (result, trace (Configuration location term value)) rest m +instance ( Interpreter m effects , 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 + => Interpreter (Tracing trace m) (Writer (trace (Configuration location term value)) ': effects) where + type Result (Tracing trace m) (Writer (trace (Configuration location term value)) ': effects) result = Result m effects (result, trace (Configuration location term value)) interpret = interpret . runTracing . raiseHandler runWriter diff --git a/src/Analysis/Abstract/TypeChecking.hs b/src/Analysis/Abstract/TypeChecking.hs index b909280e3..28da3f359 100644 --- a/src/Analysis/Abstract/TypeChecking.hs +++ b/src/Analysis/Abstract/TypeChecking.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.TypeChecking ( TypeChecking @@ -14,10 +14,9 @@ newtype TypeChecking m (effects :: [* -> *]) a = TypeChecking { runTypeChecking 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 ( Interpreter effects (Either (SomeExc TypeError) result) rest m - , MonadEvaluator location term Type effects m - ) - => Interpreter (Resumable TypeError ': effects) result rest (TypeChecking m) where +instance Interpreter m effects + => Interpreter (TypeChecking m) (Resumable TypeError ': effects) where + type Result (TypeChecking m) (Resumable TypeError ': effects) result = Result m effects (Either (SomeExc TypeError) result) interpret = interpret . runTypeChecking diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 1f7465038..481284a20 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,9 +1,7 @@ {-# LANGUAGE KindSignatures #-} -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For runAnalysis module Control.Abstract.Analysis ( MonadAnalysis(..) , liftAnalyze -, runAnalysis , module X ) where @@ -20,7 +18,6 @@ import Control.Monad.Effect.State as X import Control.Monad.Effect.Resumable as X import Data.Abstract.Module import Data.Coerce -import Data.Empty as Empty import Data.Type.Coercion import Prologue @@ -29,16 +26,12 @@ import Prologue -- 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 -- | Analyze a term using the semantics of the current analysis. - analyzeTerm :: (Base term (Subterm term (outer effects value)) -> m effects value) - -> (Base term (Subterm term (outer effects value)) -> m effects value) + analyzeTerm :: (Base term (Subterm term (outer value)) -> m effects value) + -> (Base term (Subterm term (outer value)) -> m effects value) -- | Analyze a module using the semantics of the current analysis. This should generally only be called by 'evaluateModule' and by definitions of 'analyzeModule' in instances for composite analyses. - analyzeModule :: (Module (Subterm term (outer effects value)) -> m effects value) - -> (Module (Subterm term (outer effects value)) -> m effects value) - - -- | Isolate the given action with an empty global environment and exports. - isolate :: m effects a -> m effects a - isolate = withEnv Empty.empty . withExports Empty.empty + analyzeModule :: (Module (Subterm term (outer value)) -> m effects value) + -> (Module (Subterm term (outer value)) -> m effects value) -- | Lift a 'SubtermAlgebra' for an underlying analysis into a containing analysis. Use this when defining an analysis which can be composed onto other analyses to ensure that a call to 'analyzeTerm' occurs in the inner analysis and not the outer one. @@ -46,14 +39,3 @@ liftAnalyze :: Coercible ( m effects value) (t m (effects :: [* -> *]) value) => ((base (Subterm term (outer value)) -> m effects value) -> (base (Subterm term (outer value)) -> m effects value)) -> ((base (Subterm term (outer value)) -> t m effects value) -> (base (Subterm term (outer value)) -> t m effects value)) liftAnalyze analyze recur term = coerce (analyze (coerceWith (sym Coercion) . recur) term) - - --- | Run an analysis, performing its effects and returning the result alongside any state. --- --- 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 - , Interpreter effects a function m - ) - => m effects a - -> function -runAnalysis = interpret diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index a1916e5f3..5bec937d6 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE ConstrainedClassMethods, FunctionalDependencies, RankNTypes, ScopedTypeVariables, TypeFamilies #-} +{-# LANGUAGE ConstrainedClassMethods, FunctionalDependencies, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-} module Control.Abstract.Evaluator - ( MonadEvaluator(..) - -- State + ( MonadEvaluator + -- * State , EvaluatorState(..) - -- Environment + -- * Environment , getEnv , putEnv , modifyEnv @@ -15,19 +15,25 @@ module Control.Abstract.Evaluator , localize , lookupEnv , lookupWith - -- Exports + -- * Exports , getExports , putExports , modifyExports , addExport , withExports - -- Heap + , isolate + -- * Heap , getHeap , putHeap , modifyHeap , lookupHeap , assign - -- Module tables + -- * Roots + , askRoots + , extraRoots + -- * Configuration + , getConfiguration + -- * Module tables , getModuleTable , putModuleTable , modifyModuleTable @@ -38,22 +44,29 @@ module Control.Abstract.Evaluator , modifyLoadStack , currentModule , currentPackage - -- Control + -- * Control , label , goto - -- Exceptions - , throwResumable - , throwException - , catchException - -- | Origin + -- * Effects + , EvalClosure(..) + , evaluateClosureBody + , EvalModule(..) + , evaluateModule + , Return(..) + , earlyReturn + , catchReturn + , LoopControl(..) + , throwBreak + , throwContinue + , catchLoopControl + -- * Origin , pushOrigin ) where import Control.Effect -import Control.Monad.Effect.Exception as Exception +import qualified Control.Monad.Effect as Eff import Control.Monad.Effect.Fail import Control.Monad.Effect.Reader -import Control.Monad.Effect.Resumable as Resumable import Control.Monad.Effect.State import Data.Abstract.Address import Data.Abstract.Configuration @@ -61,13 +74,14 @@ import Data.Abstract.Environment as Env import Data.Abstract.Exports as Export import Data.Abstract.FreeVariables import Data.Abstract.Heap +import Data.Abstract.Live import Data.Abstract.Module import Data.Abstract.ModuleTable import Data.Abstract.Package import Data.Abstract.Origin -import Data.Empty as Empty import qualified Data.IntMap as IntMap import Data.Semigroup.Reducer +import Data.Semilattice.Lower import Lens.Micro import Prelude hiding (fail) import Prologue @@ -79,16 +93,13 @@ import Prologue -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import class ( Effectful m - , Member Fail effects , Member (Reader (Environment location value)) effects , Member (Reader (ModuleTable [Module term])) effects , Member (Reader (SomeOrigin term)) effects , Member (State (EvaluatorState location term value)) effects , Monad (m effects) ) - => MonadEvaluator location term value effects m | m effects -> location term value where - -- | Get the current 'Configuration' with a passed-in term. - getConfiguration :: Ord location => term -> m effects (Configuration location term value) + => MonadEvaluator location term value effects m | m effects -> location term value -- State @@ -100,18 +111,14 @@ data EvaluatorState location term value = EvaluatorState , loadStack :: LoadStack , exports :: Exports location value , jumps :: IntMap.IntMap (SomeOrigin term, term) - , origin :: SomeOrigin term } deriving instance (Eq (Cell location value), Eq location, Eq term, Eq value, Eq (Base term ())) => Eq (EvaluatorState location term value) deriving instance (Ord (Cell location value), Ord location, Ord term, Ord value, Ord (Base term ())) => Ord (EvaluatorState location term value) deriving instance (Show (Cell location value), Show location, Show term, Show value, Show (Base term ())) => Show (EvaluatorState location term value) -instance (Ord location, Semigroup (Cell location value)) => Semigroup (EvaluatorState location term value) where - EvaluatorState e1 h1 m1 l1 x1 j1 o1 <> EvaluatorState e2 h2 m2 l2 x2 j2 o2 = EvaluatorState (mergeEnvs e1 e2) (h1 <> h2) (m1 <> m2) (l1 <> l2) (x1 <> x2) (j1 <> j2) (o1 <> o2) - -instance (Ord location, Semigroup (Cell location value)) => Empty (EvaluatorState location term value) where - empty = EvaluatorState Empty.empty mempty mempty mempty mempty mempty mempty +instance Lower (EvaluatorState location term value) where + lowerBound = EvaluatorState lowerBound lowerBound lowerBound lowerBound lowerBound lowerBound -- Lenses @@ -134,9 +141,6 @@ _exports = lens exports (\ s e -> s {exports = e}) _jumps :: Lens' (EvaluatorState location term value) (IntMap.IntMap (SomeOrigin term, term)) _jumps = lens jumps (\ s j -> s {jumps = j}) -_origin :: Lens' (EvaluatorState location term value) (SomeOrigin term) -_origin = lens origin (\ s o -> s {origin = o}) - (.=) :: MonadEvaluator location term value effects m => ASetter (EvaluatorState location term value) (EvaluatorState location term value) a b -> b -> m effects () lens .= val = raise (modify' (lens .~ val)) @@ -180,7 +184,7 @@ defaultEnvironment = raise ask -- | Set the default environment for the lifetime of an action. -- Usually only invoked in a top-level evaluation function. withDefaultEnvironment :: MonadEvaluator location term value effects m => Environment location value -> m effects a -> m effects a -withDefaultEnvironment e = raise . local (const e) . lower +withDefaultEnvironment e = raiseHandler (local (const e)) -- | Obtain an environment that is the composition of the current and default environments. -- Useful for debugging. @@ -233,6 +237,10 @@ addExport name alias = modifyExports . Export.insert name alias withExports :: MonadEvaluator location term value effects m => Exports location value -> m effects a -> m effects a withExports s = localEvaluatorState _exports (const s) +-- | Isolate the given action with an empty global environment and exports. +isolate :: MonadEvaluator location term value effects m => m effects a -> m effects a +isolate = withEnv lowerBound . withExports lowerBound + -- Heap @@ -265,6 +273,24 @@ assign :: ( Ord location assign address = modifyHeap . heapInsert address +-- Roots + +-- | Retrieve the local 'Live' set. +askRoots :: (Effectful m, Member (Reader (Live location value)) effects) => m effects (Live location value) +askRoots = raise ask + +-- | Run a computation with the given 'Live' set added to the local root set. +extraRoots :: (Effectful m, Member (Reader (Live location value)) effects, Ord location) => Live location value -> m effects a -> m effects a +extraRoots roots = raiseHandler (local (<> roots)) + + +-- Configuration + +-- | Get the current 'Configuration' with a passed-in term. +getConfiguration :: (Member (Reader (Live location value)) effects, MonadEvaluator location term value effects m) => term -> m effects (Configuration location term value) +getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap + + -- Module table -- | Retrieve the table of evaluated modules. @@ -288,7 +314,7 @@ askModuleTable = raise ask -- | Run an action with a locally-modified table of unevaluated modules. localModuleTable :: MonadEvaluator location term value effects m => (ModuleTable [Module term] -> ModuleTable [Module term]) -> m effects a -> m effects a -localModuleTable f a = raise (local f (lower a)) +localModuleTable f = raiseHandler (local f) -- | Retrieve the module load stack @@ -307,13 +333,13 @@ modifyLoadStack f = do -- | Get the currently evaluating 'ModuleInfo'. -currentModule :: forall location term value effects m . MonadEvaluator location term value effects m => m effects ModuleInfo +currentModule :: forall location term value effects m . (Member Fail effects, MonadEvaluator location term value effects m) => m effects ModuleInfo currentModule = do o <- raise ask maybeM (raise (fail "unable to get currentModule")) $ withSomeOrigin (originModule @term) o -- | Get the currently evaluating 'PackageInfo'. -currentPackage :: forall location term value effects m . MonadEvaluator location term value effects m => m effects PackageInfo +currentPackage :: forall location term value effects m . (Member Fail effects, MonadEvaluator location term value effects m) => m effects PackageInfo currentPackage = do o <- raise ask maybeM (raise (fail "unable to get currentPackage")) $ withSomeOrigin (originPackage @term) o @@ -333,7 +359,7 @@ label term = do pure i -- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated in e.g. a 'MonadAnalysis' instance). -goto :: (Recursive term, MonadEvaluator location term value effects m) => Label -> (term -> m effects a) -> m effects a +goto :: (Recursive term, Member Fail effects, MonadEvaluator location term value effects m) => Label -> (term -> m effects a) -> m effects a goto label comp = do maybeTerm <- IntMap.lookup label <$> view _jumps case maybeTerm of @@ -341,16 +367,55 @@ goto label comp = do Nothing -> raise (fail ("unknown label: " <> show label)) --- Exceptions +-- Effects -throwResumable :: (Member (Resumable exc) effects, Effectful m) => exc v -> m effects v -throwResumable = raise . Resumable.throwError +-- | An effect to evaluate a closure’s body. +data EvalClosure term value resume where + EvalClosure :: term -> EvalClosure term value value -throwException :: (Member (Exc exc) effects, Effectful m) => exc -> m effects a -throwException = raise . Exception.throwError +evaluateClosureBody :: (Effectful m, Member (EvalClosure term value) effects) => term -> m effects value +evaluateClosureBody = raise . Eff.send . EvalClosure + + +-- | An effect to evaluate a module. +data EvalModule term value resume where + EvalModule :: Module term -> EvalModule term value value + +evaluateModule :: (Effectful m, Member (EvalModule term value) effects) => Module term -> m effects value +evaluateModule = raise . Eff.send . EvalModule + + +-- | An effect for explicitly returning out of a function/method body. +data Return value resume where + Return :: value -> Return value value + +deriving instance Eq value => Eq (Return value a) +deriving instance Show value => Show (Return value a) + +earlyReturn :: (Effectful m, Member (Return value) effects) => value -> m effects value +earlyReturn = raise . Eff.send . Return + +catchReturn :: (Effectful m, Member (Return value) effects) => m effects a -> (forall x . Return value x -> m effects a) -> m effects a +catchReturn action handler = raiseHandler (Eff.interpose pure (\ ret _ -> lower (handler ret))) action + + +-- | Effects for control flow around loops (breaking and continuing). +data LoopControl value resume where + Break :: value -> LoopControl value value + Continue :: LoopControl value value + +deriving instance Eq value => Eq (LoopControl value a) +deriving instance Show value => Show (LoopControl value a) + +throwBreak :: (Effectful m, Member (LoopControl value) effects) => value -> m effects value +throwBreak = raise . Eff.send . Break + +throwContinue :: (Effectful m, Member (LoopControl value) effects) => m effects value +throwContinue = raise (Eff.send Continue) + +catchLoopControl :: (Effectful m, Member (LoopControl value) effects) => m effects a -> (forall x . LoopControl value x -> m effects a) -> m effects a +catchLoopControl action handler = raiseHandler (Eff.interpose pure (\ control _ -> lower (handler control))) action -catchException :: (Member (Exc exc) effects, Effectful m) => m effects v -> (exc -> m effects v) -> m effects v -catchException action handler = raise (lower action `Exception.catchError` (lower . handler)) -- | Push a 'SomeOrigin' onto the stack. This should be used to contextualize execution with information about the originating term, module, or package. pushOrigin :: ( Effectful m @@ -359,4 +424,4 @@ pushOrigin :: ( Effectful m => SomeOrigin term -> m effects a -> m effects a -pushOrigin o = raise . local (<> o) . lower +pushOrigin o = raiseHandler (local (<> o)) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index f94ae4ae2..ffc239487 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -8,7 +8,6 @@ module Control.Abstract.Value , forLoop , makeNamespace , ValueRoots(..) -, ValueError(..) ) where import Control.Abstract.Evaluator @@ -17,9 +16,9 @@ import Data.Abstract.Environment as Env import Data.Abstract.FreeVariables import Data.Abstract.Live (Live) import Data.Abstract.Number as Number -import Data.Empty as Empty import Data.Scientific (Scientific) import Data.Semigroup.Reducer hiding (unit) +import Data.Semilattice.Lower import Prelude import Prologue hiding (TypeError) @@ -185,8 +184,8 @@ makeNamespace :: ( MonadValue location value effects m -> Maybe value -> m effects value makeNamespace name addr super = do - superEnv <- maybe (pure (Just Empty.empty)) scopedEnvironment super - let env' = fromMaybe Empty.empty superEnv + superEnv <- maybe (pure (Just lowerBound)) scopedEnvironment super + let env' = fromMaybe lowerBound superEnv namespaceEnv <- Env.head <$> getEnv v <- namespace name (Env.mergeNewer env' namespaceEnv) v <$ assign addr v @@ -196,42 +195,3 @@ makeNamespace name addr super = do class ValueRoots location value where -- | Compute the set of addresses rooted by a given value. valueRoots :: value -> Live location value - - --- The type of exceptions that can be thrown when constructing values in `MonadValue`. -data ValueError location value resume where - StringError :: value -> ValueError location value ByteString - BoolError :: value -> ValueError location value Bool - IndexError :: value -> value -> ValueError location value value - NamespaceError :: Prelude.String -> ValueError location value (Environment location value) - CallError :: value -> ValueError location value value - NumericError :: value -> ValueError location value value - Numeric2Error :: value -> value -> ValueError location value value - ComparisonError :: value -> value -> ValueError location value value - BitwiseError :: value -> ValueError location value value - Bitwise2Error :: value -> value -> ValueError location value value - KeyValueError :: value -> ValueError location value (value, value) - -- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching. - ArithmeticError :: ArithException -> ValueError location value value - -- Out-of-bounds error - BoundsError :: [value] -> Integer -> ValueError location value value - - - -instance Eq value => Eq1 (ValueError location value) where - liftEq _ (StringError a) (StringError b) = a == b - liftEq _ (NamespaceError a) (NamespaceError b) = a == b - liftEq _ (CallError a) (CallError b) = a == b - liftEq _ (BoolError a) (BoolError c) = a == c - liftEq _ (IndexError a b) (IndexError c d) = (a == c) && (b == d) - liftEq _ (Numeric2Error a b) (Numeric2Error c d) = (a == c) && (b == d) - liftEq _ (ComparisonError a b) (ComparisonError c d) = (a == c) && (b == d) - liftEq _ (Bitwise2Error a b) (Bitwise2Error c d) = (a == c) && (b == d) - liftEq _ (BitwiseError a) (BitwiseError b) = a == b - liftEq _ (KeyValueError a) (KeyValueError b) = a == b - liftEq _ (BoundsError a b) (BoundsError c d) = (a == c) && (b == d) - liftEq _ _ _ = False - -deriving instance (Show value) => Show (ValueError location value resume) -instance (Show value) => Show1 (ValueError location value) where - liftShowsPrec _ _ = showsPrec diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index f827c2c1a..e0769d27e 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -1,14 +1,18 @@ -{-# LANGUAGE FunctionalDependencies, RankNTypes, TypeOperators #-} +{-# LANGUAGE FunctionalDependencies, RankNTypes, TypeFamilies, TypeOperators #-} module Control.Effect ( Effectful(..) , raiseHandler , Interpreter(..) +, throwResumable , resume ) where import Control.Monad.Effect as Effect import Control.Monad.Effect.Resumable as Resumable +throwResumable :: (Member (Resumable exc) effects, Effectful m) => exc v -> m effects v +throwResumable = raise . throwError + resume :: (Member (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))) @@ -33,8 +37,10 @@ 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 +class Effectful m => Interpreter m effects | m -> effects where + type Result m effects result + type instance Result m effects result = result + interpret :: m effects result -> Result m effects result -instance Interpreter '[] result result Eff where +instance Interpreter Eff '[] where interpret = Effect.run diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 10d718f16..e86431b1d 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -24,8 +24,8 @@ import Data.Abstract.Address import Data.Abstract.FreeVariables import Data.Abstract.Live import Data.Align -import Data.Empty as Empty import qualified Data.Map as Map +import Data.Semilattice.Lower import GHC.Exts (IsList (..)) import Prologue import qualified Data.List.NonEmpty as NonEmpty @@ -52,15 +52,12 @@ instance IsList (Environment l a) where fromList xs = Environment (Map.fromList xs :| []) toList (Environment (x :| _)) = Map.toList x -instance Empty (Environment l a) where - empty = emptyEnv - mergeEnvs :: Environment l a -> Environment l a -> Environment l a mergeEnvs (Environment (a :| as)) (Environment (b :| bs)) = Environment ((<>) a b :| alignWith (mergeThese (<>)) as bs) emptyEnv :: Environment l a -emptyEnv = Environment (Empty.empty :| []) +emptyEnv = Environment (lowerBound :| []) -- | Make and enter a new empty scope in the given environment. push :: Environment l a -> Environment l a @@ -68,7 +65,7 @@ push (Environment (a :| as)) = Environment (mempty :| a : as) -- | Remove the frontmost scope. pop :: Environment l a -> Environment l a -pop (Environment (_ :| [])) = Empty.empty +pop (Environment (_ :| [])) = emptyEnv pop (Environment (_ :| a : as)) = Environment (a :| as) -- | Drop all scopes save for the frontmost one. @@ -140,3 +137,6 @@ roots env = foldMap (maybe mempty liveSingleton . flip lookup env) addresses :: Ord l => Environment l a -> Live l a addresses = Live . fromList . fmap snd . pairs + + +instance Lower (Environment location value) where lowerBound = emptyEnv diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index c384323cf..cc222647d 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -1,24 +1,17 @@ -{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Data.Abstract.Evaluatable ( module X , MonadEvaluatable , Evaluatable(..) , Unspecialized(..) -, ReturnThrow(..) , EvalError(..) , LoadError(..) -, LoopThrow(..) , ResolutionError(..) , variable , evaluateInScopedEnv -, evaluateTerm -, evaluateModule , evaluatePackage , evaluatePackageBody -, throwLoadError -, throwLoop , throwEvalError -, throwValueError , resolve , traceResolve , listModulesInDir @@ -27,8 +20,9 @@ module Data.Abstract.Evaluatable ) where import Control.Abstract.Addressable as X -import Control.Abstract.Analysis as X -import qualified Control.Monad.Effect.Exception as Exc +import Control.Abstract.Analysis as X hiding (LoopControl(..), Return(..)) +import Control.Abstract.Analysis (LoopControl, Return(..)) +import Control.Monad.Effect as Eff import Data.Abstract.Address import Data.Abstract.Declarations as X import Data.Abstract.Environment as X @@ -39,7 +33,6 @@ import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Origin (packageOrigin) import Data.Abstract.Package as Package import Data.Language -import Data.Empty as Empty import Data.Scientific (Scientific) import Data.Semigroup.App import Data.Semigroup.Foldable @@ -49,34 +42,25 @@ import Prologue type MonadEvaluatable location term value effects m = ( Declarations term - , Effectful m , Evaluatable (Base term) , FreeVariables term - , Member (Exc.Exc (ReturnThrow value)) effects - , Member (Exc.Exc (LoopThrow value)) effects + , Member (EvalClosure term value) effects + , Member (EvalModule term value) effects , Member Fail effects + , Member (LoopControl value) effects , Member (Resumable (Unspecialized value)) effects - , Member (Resumable (LoadError term value)) effects + , Member (Resumable (LoadError term)) effects , Member (Resumable (EvalError value)) effects , Member (Resumable (ResolutionError value)) effects , Member (Resumable (AddressError location value)) effects + , Member (Return value) effects , MonadAddressable location effects m - , MonadAnalysis location term value effects m + , MonadEvaluator location term value effects m , MonadValue location value effects m , Recursive term , Reducer value (Cell location value) - , Show location ) -newtype ReturnThrow value - = Ret value - deriving (Eq, Show) - -data LoopThrow value - = Brk value - | Con - deriving (Eq, Show) - -- | An error thrown when we can't resolve a module from a qualified name. data ResolutionError value resume where NotFoundError :: String -- ^ The path that was not found. @@ -95,14 +79,14 @@ instance Eq1 (ResolutionError value) where liftEq _ _ _ = False -- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name. -data LoadError term value resume where - LoadError :: ModulePath -> LoadError term value [Module term] +data LoadError term resume where + LoadError :: ModulePath -> LoadError term [Module term] -deriving instance Eq (LoadError term a b) -deriving instance Show (LoadError term a b) -instance Show1 (LoadError term value) where +deriving instance Eq (LoadError term resume) +deriving instance Show (LoadError term resume) +instance Show1 (LoadError term) where liftShowsPrec _ _ = showsPrec -instance Eq1 (LoadError term a) where +instance Eq1 (LoadError term) where liftEq _ (LoadError a) (LoadError b) = a == b -- | The type of error thrown when failing to evaluate a term. @@ -119,18 +103,24 @@ data EvalError value resume where EnvironmentLookupError :: value -> EvalError value value -- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'. --- Throws an 'EnvironmentLookupError' if 'scopedEnvTerm' does not have an environment. -evaluateInScopedEnv :: (MonadEvaluatable location term value effects m) +-- Throws an 'EnvironmentLookupError' if @scopedEnvTerm@ does not have an environment. +evaluateInScopedEnv :: MonadEvaluatable location term value effects m => m effects value -> m effects value -> m effects value evaluateInScopedEnv scopedEnvTerm term = do value <- scopedEnvTerm scopedEnv <- scopedEnvironment value - maybe (throwEvalError $ EnvironmentLookupError value) (flip localEnv term . mergeEnvs) scopedEnv + maybe (throwEvalError (EnvironmentLookupError value)) (flip localEnv term . mergeEnvs) scopedEnv -- | Look up and dereference the given 'Name', throwing an exception for free variables. -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 :: ( 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)) deriving instance Eq a => Eq (EvalError a b) @@ -149,17 +139,9 @@ instance Eq term => Eq1 (EvalError term) where liftEq _ _ _ = False -throwValueError :: (Member (Resumable (ValueError location value)) effects, MonadEvaluator location term value effects m) => ValueError location value resume -> m effects resume -throwValueError = throwResumable - -throwLoadError :: (Member (Resumable (LoadError term value)) effects, MonadEvaluator location term value effects m) => LoadError term value resume -> m effects resume -throwLoadError = throwResumable - throwEvalError :: (Member (Resumable (EvalError value)) effects, MonadEvaluator location term value effects m) => EvalError value resume -> m effects resume throwEvalError = throwResumable -throwLoop :: MonadEvaluatable location term value effects m => LoopThrow value -> m effects a -throwLoop = throwException data Unspecialized a b where Unspecialized :: { getUnspecialized :: Prelude.String } -> Unspecialized value value @@ -218,22 +200,48 @@ listModulesInDir dir = ModuleTable.modulePathsInDir dir <$> askModuleTable -- | Require/import another module by name and return it's environment and value. -- -- Looks up the term's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module. -require :: MonadEvaluatable location term value effects m +require :: ( Member (EvalModule term value) effects + , Member (Resumable (LoadError term)) effects + , MonadEvaluator location term value effects m + , MonadValue location value effects m + ) => ModulePath -> m effects (Environment location value, value) -require name = getModuleTable >>= maybeM (load name) . ModuleTable.lookup name +require = requireWith evaluateModule + +requireWith :: ( Member (Resumable (LoadError term)) effects + , MonadEvaluator location term value effects m + , MonadValue location value effects m + ) + => (Module term -> m effects value) + -> ModulePath + -> m effects (Environment location value, value) +requireWith with name = getModuleTable >>= maybeM (loadWith with name) . ModuleTable.lookup name -- | Load another module by name and return it's environment and value. -- -- Always loads/evaluates. -load :: MonadEvaluatable location term value effects m +load :: ( Member (EvalModule term value) effects + , Member (Resumable (LoadError term)) effects + , MonadEvaluator location term value effects m + , MonadValue location value effects m + ) => ModulePath -> m effects (Environment location value, value) -load name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= evalAndCache - where - notFound = throwLoadError (LoadError name) +load = loadWith evaluateModule - evalAndCache [] = (,) Empty.empty <$> unit +loadWith :: ( Member (Resumable (LoadError term)) effects + , MonadEvaluator location term value effects m + , MonadValue location value effects m + ) + => (Module term -> m effects value) + -> ModulePath + -> m effects (Environment location value, value) +loadWith with name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= evalAndCache + where + notFound = throwResumable (LoadError name) + + evalAndCache [] = (,) emptyEnv <$> unit evalAndCache [x] = evalAndCache' x evalAndCache (x:xs) = do (env, _) <- evalAndCache' x @@ -246,10 +254,10 @@ load name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= eva if mPath `elem` unLoadStack then do -- Circular load, don't keep evaluating. v <- trace ("load (skip evaluating, circular load): " <> show mPath) unit - pure (Empty.empty, v) + pure (emptyEnv, v) else do modifyLoadStack (loadStackPush mPath) - v <- trace ("load (evaluating): " <> show mPath) $ evaluateModule x + v <- trace ("load (evaluating): " <> show mPath) $ with x modifyLoadStack loadStackPop traceM ("load done:" <> show mPath) env <- filterEnv <$> getExports <*> getEnv @@ -265,37 +273,43 @@ load name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= eva | otherwise = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env --- | Evaluate a term to a value using the semantics of the current analysis. --- --- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'. -evaluateTerm :: MonadEvaluatable location term value effects m - => term - -> m effects value -evaluateTerm = foldSubterms (analyzeTerm eval) - --- | Evaluate a (root-level) term to a value using the semantics of the current analysis. This should be used to evaluate single-term programs, or (via 'evaluateModules') the entry point of multi-term programs. -evaluateModule :: MonadEvaluatable location term value effects m - => Module term - -> m effects value -evaluateModule m = analyzeModule (subtermValue . moduleBody) (fmap (Subterm <*> evaluateTerm) m) +-- | Evaluate a (root-level) term to a value using the semantics of the current analysis. +evalModule :: forall location term value effects m + . ( MonadAnalysis location term value effects m + , MonadEvaluatable location term value effects m + ) + => Module term + -> m effects value +evalModule m = raiseHandler + (interpose @(EvalModule term value) pure (\ (EvalModule m) yield -> lower @m (evalModule m) >>= yield)) + (analyzeModule (subtermValue . moduleBody) (fmap (Subterm <*> evalTerm) m)) + where evalTerm term = catchReturn @m @value + (raiseHandler + (interpose @(EvalClosure term value) pure (\ (EvalClosure term) yield -> lower (evalTerm term) >>= yield)) + (foldSubterms (analyzeTerm eval) term)) + (\ (Return value) -> pure value) -- | Evaluate a given package. -evaluatePackage :: MonadEvaluatable location term value effects m +evaluatePackage :: ( MonadAnalysis location term value effects m + , MonadEvaluatable location term value effects m + ) => Package term -> m effects [value] evaluatePackage p = pushOrigin (packageOrigin p) (evaluatePackageBody (packageBody p)) -- | Evaluate a given package body (module table and entry points). -evaluatePackageBody :: MonadEvaluatable location term value effects m +evaluatePackageBody :: ( MonadAnalysis location term value effects m + , MonadEvaluatable location term value effects m + ) => PackageBody term -> m effects [value] evaluatePackageBody body = withPrelude (packagePrelude body) $ localModuleTable (<> packageModules body) (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints body))) where evaluateEntryPoint (m, sym) = do - (_, v) <- require m + (_, v) <- requireWith evalModule m maybe (pure v) ((`call` []) <=< variable) sym withPrelude Nothing a = a withPrelude (Just prelude) a = do - preludeEnv <- evaluateModule prelude *> getEnv + preludeEnv <- evalModule prelude *> getEnv withDefaultEnvironment preludeEnv a diff --git a/src/Data/Abstract/Exports.hs b/src/Data/Abstract/Exports.hs index 853053d3b..915f9da32 100644 --- a/src/Data/Abstract/Exports.hs +++ b/src/Data/Abstract/Exports.hs @@ -13,10 +13,11 @@ import Data.Abstract.Address import Data.Abstract.Environment (Environment, unpairs) import Data.Abstract.FreeVariables import qualified Data.Map as Map +import Data.Semilattice.Lower -- | A map of export names to an alias & address tuple. newtype Exports l a = Exports { unExports :: Map.Map Name (Name, Maybe (Address l a)) } - deriving (Eq, Foldable, Functor, Generic1, Monoid, Ord, Semigroup, Show, Traversable) + deriving (Eq, Foldable, Functor, Generic1, Lower, Monoid, Ord, Semigroup, Show, Traversable) null :: Exports l a -> Bool null = Map.null . unExports diff --git a/src/Data/Abstract/Heap.hs b/src/Data/Abstract/Heap.hs index 5035d716b..6510fec02 100644 --- a/src/Data/Abstract/Heap.hs +++ b/src/Data/Abstract/Heap.hs @@ -5,11 +5,12 @@ import Data.Abstract.Address import Data.Abstract.Live import qualified Data.Map.Monoidal as Monoidal import Data.Semigroup.Reducer +import Data.Semilattice.Lower import Prologue -- | A map of addresses onto cells holding their values. newtype Heap l a = Heap { unHeap :: Monoidal.Map l (Cell l a) } - deriving (Generic1) + deriving (Generic1, Lower) deriving instance (Eq l, Eq (Cell l a)) => Eq (Heap l a) deriving instance (Ord l, Ord (Cell l a)) => Ord (Heap l a) diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index eab956215..a3efb257f 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -18,13 +18,14 @@ module Data.Abstract.ModuleTable import Data.Abstract.Module import qualified Data.Map as Map import Data.Semigroup +import Data.Semilattice.Lower import Prologue import System.FilePath.Posix import GHC.Generics (Generic1) import Prelude hiding (lookup) newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModulePath a } - deriving (Eq, Foldable, Functor, Generic1, Monoid, Ord, Semigroup, Show, Traversable) + deriving (Eq, Foldable, Functor, Generic1, Lower, Monoid, Ord, Semigroup, Show, Traversable) singleton :: ModulePath -> a -> ModuleTable a singleton name = ModuleTable . Map.singleton name @@ -55,7 +56,7 @@ toPairs = Map.toList . unModuleTable -- | Stack of module paths used to help break circular loads/imports. newtype LoadStack = LoadStack { unLoadStack :: [ModulePath] } - deriving (Eq, Ord, Show, Monoid, Semigroup) + deriving (Eq, Lower, Monoid, Ord, Semigroup, Show) loadStackPush :: ModulePath -> LoadStack -> LoadStack loadStackPush x LoadStack{..} = LoadStack (x : unLoadStack) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 53d832668..764bee1e0 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -3,6 +3,7 @@ module Data.Abstract.Origin where import qualified Data.Abstract.Module as M import qualified Data.Abstract.Package as P +import Data.Semilattice.Lower import Prologue -- | An 'Origin' encapsulates the location at which a name is bound or allocated. @@ -52,6 +53,9 @@ liftCompareOrigins c (Term m1 t1) (Term m2 t2) = liftCompareOrigins c m1 m2 instance Ord (Base term ()) => Ord (Origin term ty) where compare = liftCompareOrigins compare +instance Lower (Origin term ty) where lowerBound = Unknown + + -- | An existential abstraction over 'Origin's of different types. data SomeOrigin term where SomeOrigin :: Origin term ty -> SomeOrigin term @@ -98,3 +102,5 @@ instance Semigroup (SomeOrigin term) where instance Monoid (SomeOrigin term) where mempty = SomeOrigin Unknown mappend = (<>) + +instance Lower (SomeOrigin term) where lowerBound = SomeOrigin lowerBound diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 901dcaf76..c5fb4e78c 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -10,7 +10,6 @@ import Control.Abstract.Analysis import Data.Abstract.Address import Data.Abstract.Environment as Env import Data.Align (alignWith) -import qualified Data.Empty as Empty import Data.Semigroup.Reducer (Reducer) import Prelude import Prologue hiding (TypeError) @@ -93,7 +92,7 @@ instance ( Alternative (m effects) tvar <- Var <$> raise fresh assign a tvar (env, tvars) <- rest - pure (Env.insert name a env, tvar : tvars)) (pure (Empty.empty, Empty.empty)) names + pure (Env.insert name a env, tvar : tvars)) (pure (emptyEnv, [])) names ret <- localEnv (mergeEnvs env) body pure (Product tvars :-> ret) @@ -114,7 +113,7 @@ instance ( Alternative (m effects) klass _ _ _ = pure Object namespace _ _ = pure Unit - scopedEnvironment _ = pure (Just Empty.empty) + scopedEnvironment _ = pure (Just emptyEnv) asString t = unify t String $> "" asPair t = do diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 6e1a72182..cc4becb2c 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -1,14 +1,21 @@ -{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Data.Abstract.Value where -import Control.Abstract.Analysis -import Data.Abstract.Environment (Environment) +import Control.Abstract.Addressable +import Control.Abstract.Evaluator +import Control.Abstract.Value +import Control.Effect +import Control.Monad.Effect.Fail +import Control.Monad.Effect.Resumable +import Data.Abstract.Address +import Data.Abstract.Environment (Environment, emptyEnv, mergeEnvs) import qualified Data.Abstract.Environment as Env -import Data.Abstract.Evaluatable +import Data.Abstract.FreeVariables import qualified Data.Abstract.Number as Number import Data.List (genericIndex, genericLength) import Data.Scientific (Scientific) import Data.Scientific.Exts +import Data.Semigroup.Reducer import qualified Data.Set as Set import Prologue hiding (TypeError) import Prelude hiding (Float, Integer, String, Rational) @@ -203,9 +210,18 @@ instance AbstractHole (Value location) where hole = injValue Hole -- | Construct a 'Value' wrapping the value arguments (if any). -instance ( Monad (m effects) +instance ( Member (EvalClosure term (Value location)) effects + , Member Fail effects + , Member (LoopControl (Value location)) effects + , Member (Resumable (AddressError location (Value location))) effects , Member (Resumable (ValueError location (Value location))) effects - , MonadEvaluatable location term (Value location) effects m + , Member (Return (Value location)) effects + , Monad (m effects) + , MonadAddressable location effects m + , MonadEvaluator location term (Value location) effects m + , Recursive term + , Reducer (Value location) (Cell location (Value location)) + , Show location ) => MonadValue location (Value location) effects m where unit = pure . injValue $ Unit @@ -295,7 +311,7 @@ instance ( Monad (m effects) tentative x i j = attemptUnsafeArithmetic (x i j) -- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor - specialize :: (Member (Resumable (ValueError location value)) effects, MonadEvaluatable location term value effects m) => Either ArithException Number.SomeNumber -> m effects value + specialize :: Either ArithException Number.SomeNumber -> m effects (Value location) specialize (Left exc) = throwValueError (ArithmeticError exc) specialize (Right (Number.SomeNumber (Number.Integer i))) = integer i specialize (Right (Number.SomeNumber (Number.Ratio r))) = rational r @@ -314,7 +330,7 @@ instance ( Monad (m effects) where -- Explicit type signature is necessary here because we're passing all sorts of things -- to these comparison functions. - go :: (Ord a, MonadValue location value effects m) => a -> a -> m effects value + go :: Ord a => a -> a -> m effects (Value location) go l r = case comparator of Concrete f -> boolean (f l r) Generalized -> integer (orderingToInt (compare l r)) @@ -353,13 +369,50 @@ instance ( Monad (m effects) localEnv (mergeEnvs bindings) (evalClosure body) Nothing -> throwValueError (CallError op) where - evalClosure :: term -> m effects (Value location) - evalClosure term = catchException (evaluateTerm term) handleReturn + evalClosure term = catchReturn @m @(Value location) (evaluateClosureBody term) (\ (Return value) -> pure value) - handleReturn :: ReturnThrow (Value location) -> m effects (Value location) - handleReturn (Ret v) = pure v + loop x = catchLoopControl @m @(Value location) (fix x) (\ control -> case control of + Break value -> pure value + Continue -> loop x) - loop x = catchException (fix x) handleLoop where - handleLoop :: LoopThrow (Value location) -> m effects (Value location) - handleLoop (Brk v) = pure v - handleLoop Con = loop x + +-- | The type of exceptions that can be thrown when constructing values in 'Value'’s 'MonadValue' instance. +data ValueError location value resume where + StringError :: value -> ValueError location value ByteString + BoolError :: value -> ValueError location value Bool + IndexError :: value -> value -> ValueError location value value + NamespaceError :: Prelude.String -> ValueError location value (Environment location value) + CallError :: value -> ValueError location value value + NumericError :: value -> ValueError location value value + Numeric2Error :: value -> value -> ValueError location value value + ComparisonError :: value -> value -> ValueError location value value + BitwiseError :: value -> ValueError location value value + Bitwise2Error :: value -> value -> ValueError location value value + KeyValueError :: value -> ValueError location value (value, value) + -- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching. + ArithmeticError :: ArithException -> ValueError location value value + -- Out-of-bounds error + BoundsError :: [value] -> Prelude.Integer -> ValueError location value value + + + +instance Eq value => Eq1 (ValueError location value) where + liftEq _ (StringError a) (StringError b) = a == b + liftEq _ (NamespaceError a) (NamespaceError b) = a == b + liftEq _ (CallError a) (CallError b) = a == b + liftEq _ (BoolError a) (BoolError c) = a == c + liftEq _ (IndexError a b) (IndexError c d) = (a == c) && (b == d) + liftEq _ (Numeric2Error a b) (Numeric2Error c d) = (a == c) && (b == d) + liftEq _ (ComparisonError a b) (ComparisonError c d) = (a == c) && (b == d) + liftEq _ (Bitwise2Error a b) (Bitwise2Error c d) = (a == c) && (b == d) + liftEq _ (BitwiseError a) (BitwiseError b) = a == b + liftEq _ (KeyValueError a) (KeyValueError b) = a == b + liftEq _ (BoundsError a b) (BoundsError c d) = (a == c) && (b == d) + liftEq _ _ _ = False + +deriving instance (Show value) => Show (ValueError location value resume) +instance (Show value) => Show1 (ValueError location value) where + liftShowsPrec _ _ = showsPrec + +throwValueError :: (Member (Resumable (ValueError location value)) effects, MonadEvaluator location term value effects m) => ValueError location value resume -> m effects resume +throwValueError = throwResumable diff --git a/src/Data/Empty.hs b/src/Data/Empty.hs deleted file mode 100644 index e0c02a5dd..000000000 --- a/src/Data/Empty.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -module Data.Empty ( Empty (..) ) where - --- | A typeclass for values that have a sensible notion of an empty value. --- This is used in Control.Effect to provide a useful default for running --- a State computation without providing it an explicit starting value. --- This is very useful if a type has no coherent Monoid instance but --- needs a value analogous to 'mempty'. It is not recommended to use this --- for other purposes, as there are no laws by which 'empty' is required --- to abide. -class Empty a where - empty :: a - --- | Every Monoid has an Empty instance. -instance {-# OVERLAPS #-} Monoid a => Empty a where - empty = mempty diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index d3de1f021..cf359a94d 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -11,6 +11,7 @@ module Data.Map.Monoidal import qualified Data.Map as Map import Data.Semigroup.Reducer as Reducer +import Data.Semilattice.Lower import Prelude hiding (lookup) import Prologue hiding (Map) @@ -42,3 +43,5 @@ instance (Ord key, Reducer a value) => Reducer (key, a) (Map key value) where unit (key, a) = Map (Map.singleton key (unit a)) cons (key, a) (Map m) = Map (Map.insertWith (<>) key (unit a) m) snoc (Map m) (key, a) = Map (Map.insertWith (flip (<>)) key (unit a) m) + +instance Lower (Map key value) where lowerBound = Map lowerBound diff --git a/src/Data/Range.hs b/src/Data/Range.hs index 280303b77..51f9048f4 100644 --- a/src/Data/Range.hs +++ b/src/Data/Range.hs @@ -7,9 +7,10 @@ module Data.Range , subtractRange ) where -import Prologue import Data.Aeson import Data.JSON.Fields +import Data.Semilattice.Lower +import Prologue -- | A half-open interval of integers, defined by start & end indices. data Range = Range { start :: {-# UNPACK #-} !Int, end :: {-# UNPACK #-} !Int } @@ -51,3 +52,6 @@ instance Ord Range where instance ToJSONFields Range where toJSONFields Range{..} = ["sourceRange" .= [ start, end ]] + +instance Lower Range where + lowerBound = Range 0 0 diff --git a/src/Data/Record.hs b/src/Data/Record.hs index f979ac6b2..9a5d72b62 100644 --- a/src/Data/Record.hs +++ b/src/Data/Record.hs @@ -1,10 +1,11 @@ {-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-} module Data.Record where -import Prologue import Data.Aeson import Data.JSON.Fields import Data.Kind +import Data.Semilattice.Lower +import Prologue -- | A type-safe, extensible record structure. -- | @@ -87,3 +88,10 @@ instance ToJSONFields (Record '[]) where instance ToJSONFields (Record fs) => ToJSON (Record fs) where toJSON = object . toJSONFields toEncoding = pairs . mconcat . toJSONFields + + +instance (Lower h, Lower (Record t)) => Lower (Record (h ': t)) where + lowerBound = lowerBound :. lowerBound + +instance Lower (Record '[]) where + lowerBound = Nil diff --git a/src/Data/Semilattice/Lower.hs b/src/Data/Semilattice/Lower.hs new file mode 100644 index 000000000..096f65541 --- /dev/null +++ b/src/Data/Semilattice/Lower.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DefaultSignatures #-} +module Data.Semilattice.Lower +( Lower (..) +) where + +import Data.IntMap as IntMap +import Data.IntSet as IntSet +import Data.Map as Map +import Data.Set as Set + +class Lower s where + -- | The greatest lower bound of @s@. + -- + -- Laws: + -- + -- If @s@ is 'Bounded', we require 'lowerBound' and 'minBound' to agree: + -- + -- > lowerBound = minBound + -- + -- If @s@ is a 'Join' semilattice, 'lowerBound' must be the identity of '(\/)': + -- + -- > lowerBound \/ a = a + -- + -- If @s@ is 'Ord'ered, 'lowerBound' must be at least as small as every terminating value: + -- + -- > compare lowerBound a /= GT + lowerBound :: s + default lowerBound :: Bounded s => s + lowerBound = minBound + +instance Lower b => Lower (a -> b) where lowerBound = const lowerBound + +instance Lower (Maybe a) where lowerBound = Nothing +instance Lower [a] where lowerBound = [] + +-- containers +instance Lower (IntMap a) where lowerBound = IntMap.empty +instance Lower IntSet where lowerBound = IntSet.empty +instance Lower (Map k a) where lowerBound = Map.empty +instance Lower (Set a) where lowerBound = Set.empty diff --git a/src/Data/Span.hs b/src/Data/Span.hs index aaef4c9ad..cd1a7a928 100644 --- a/src/Data/Span.hs +++ b/src/Data/Span.hs @@ -9,10 +9,11 @@ module Data.Span , emptySpan ) where -import Prologue import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A import Data.JSON.Fields +import Data.Semilattice.Lower +import Prologue -- | Source position information data Pos = Pos @@ -56,3 +57,6 @@ instance A.FromJSON Span where instance ToJSONFields Span where toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ] + +instance Lower Span where + lowerBound = Span (Pos 1 1) (Pos 1 1) diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 292b952b8..d63bb47c8 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -138,7 +138,7 @@ instance Ord1 Return where liftCompare = genericLiftCompare instance Show1 Return where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Return where - eval (Return x) = throwException =<< Ret <$> subtermValue x + eval (Return x) = subtermValue x >>= earlyReturn newtype Yield a = Yield a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) @@ -159,7 +159,7 @@ instance Ord1 Break where liftCompare = genericLiftCompare instance Show1 Break where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Break where - eval (Break x) = throwLoop =<< Brk <$> subtermValue x + eval (Break x) = subtermValue x >>= throwBreak newtype Continue a = Continue a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) @@ -170,7 +170,7 @@ instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Continue where -- TODO: figure out what to do with the datum inside Continue. what can it represent? - eval (Continue _) = throwLoop Con + eval (Continue _) = throwContinue newtype Retry a = Retry a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index fd005d001..f157748a4 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -1,32 +1,33 @@ {-# LANGUAGE GADTs #-} module Semantic.Graph where -import qualified Analysis.Abstract.ImportGraph as Abstract -import qualified Data.Abstract.Evaluatable as Analysis -import Data.Abstract.FreeVariables -import Data.Abstract.Package as Package -import qualified Control.Exception as Exc -import Data.Abstract.Module -import Data.File -import Data.Term -import qualified Data.Syntax as Syntax -import Data.Abstract.Value (Value) -import Data.Abstract.Located -import Data.Abstract.Address import Analysis.Abstract.BadAddresses import Analysis.Abstract.BadModuleResolutions import Analysis.Abstract.BadSyntax import Analysis.Abstract.BadValues import Analysis.Abstract.BadVariables +import Analysis.Abstract.Erroring import Analysis.Abstract.Evaluating +import Analysis.Abstract.ImportGraph +import qualified Control.Exception as Exc +import Data.Abstract.Address +import qualified Data.Abstract.Evaluatable as Analysis +import Data.Abstract.FreeVariables +import Data.Abstract.Located +import Data.Abstract.Module +import Data.Abstract.Package as Package +import Data.Abstract.Value (Value) +import Data.File import Data.Output +import qualified Data.Syntax as Syntax +import Data.Term import Parsing.Parser import Prologue hiding (MonadError (..)) import Rendering.Renderer import Semantic.IO (Files) import Semantic.Task -graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs) +graph :: Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs => GraphRenderer output -> Project -> Eff effs ByteString @@ -35,7 +36,7 @@ graph renderer project (Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do parsePackage parser prelude project >>= graphImports >>= case renderer of JSONGraphRenderer -> pure . toOutput - DOTGraphRenderer -> pure . Abstract.renderImportGraph + DOTGraphRenderer -> pure . renderImportGraph -- | Parse a list of files into a 'Package'. parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs @@ -61,11 +62,18 @@ parseModule parser rootDir file = do moduleForBlob rootDir blob <$> parse parser blob -type ImportGraphAnalysis term effects value = - Abstract.ImportGraphing - (BadAddresses (BadModuleResolutions (BadVariables (BadValues (BadSyntax (Evaluating (Located Precise term) term (Value (Located Precise term)))))))) - effects - value +type ImportGraphAnalysis term + = ImportGraphing + ( BadAddresses + ( BadModuleResolutions + ( BadVariables + ( BadValues + ( BadSyntax + ( Erroring (Analysis.LoadError term) + ( Evaluating + (Located Precise term) + term + (Value (Located Precise term))))))))) -- | Render the import graph for a given 'Package'. graphImports :: ( Show ann @@ -80,7 +88,7 @@ graphImports :: ( Show ann , Member Syntax.Identifier syntax , Members '[Exc SomeException, Task] effs ) - => Package (Term (Union syntax) ann) -> Eff effs Abstract.ImportGraph + => Package (Term (Union syntax) ann) -> Eff effs ImportGraph graphImports package = analyze (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package) >>= extractGraph where asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value @@ -89,5 +97,5 @@ graphImports package = analyze (Analysis.evaluatePackage package `asAnalysisForT asAnalysisForTypeOfPackage = const extractGraph result = case result of - (Right (Right (Right (Right ((_, graph), _)))), _) -> pure graph + (Right (Right ((_, graph), _)), _) -> pure graph _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index ef26ab710..7f42bb972 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -88,7 +88,7 @@ parse :: Member Task effs => Parser term -> Blob -> Eff effs term parse parser = send . Parse parser -- | A task running some 'Analysis.MonadAnalysis' to completion. -analyze :: (Analysis.Interpreter analysisEffects result function m, Member Task effs) => m analysisEffects result -> Eff effs function +analyze :: (Analysis.Interpreter m analysisEffects, Member Task effs) => m analysisEffects result -> Eff effs (Analysis.Result m analysisEffects result) analyze = send . Analyze -- | 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. data Task output where Parse :: Parser term -> Blob -> Task term - Analyze :: Analysis.Interpreter effects result function m => m effects result -> Task function + Analyze :: Analysis.Interpreter m effects => m effects result -> Task (Analysis.Result m effects result) 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) 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 = interpret $ \ task -> case task of Parse parser blob -> runParser blob parser - Analyze analysis -> pure (Analysis.runAnalysis analysis) + Analyze analysis -> pure (Analysis.interpret analysis) Decorate algebra term -> pure (decoratorWithAlgebra algebra term) Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2) Render renderer input -> pure (renderer input) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 6c5784234..7dfcf87c5 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -1,5 +1,3 @@ --- MonoLocalBinds is to silence a warning about a simplifiable constraint. -{-# LANGUAGE MonoLocalBinds, TypeOperators #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} module Semantic.Util where @@ -9,11 +7,10 @@ import Analysis.Abstract.BadSyntax import Analysis.Abstract.BadValues import Analysis.Abstract.BadVariables import Analysis.Abstract.Caching +import Analysis.Abstract.Collecting import Analysis.Abstract.Erroring import Analysis.Abstract.Evaluating as X -import Analysis.Abstract.ImportGraph import Analysis.Abstract.TypeChecking -import Analysis.Declaration import Control.Abstract.Analysis import Data.Abstract.Address import Data.Abstract.Evaluatable @@ -21,20 +18,12 @@ import Data.Abstract.Located import Data.Abstract.Type import Data.Abstract.Value import Data.Blob -import Data.Diff import Data.File import qualified Data.Language as Language -import Data.Range -import Data.Record -import Data.Span -import Data.Term -import Diffing.Algorithm -import Diffing.Interpreter import qualified GHC.TypeLits as TypeLevel import Language.Preluded import Parsing.Parser import Prologue -import Semantic.Diff (diffTermPair) import Semantic.Graph import Semantic.IO as IO import Semantic.Task @@ -51,10 +40,19 @@ type JustEvaluating 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) --- The order is significant here: Caching has to come on the outside, or the RunEffect instance for NonDet + ( Erroring (LoadError term) + ( Evaluating (Located Precise term) term (Value (Located Precise term)))))))) + +type EvaluatingWithHoles term + = BadAddresses + ( BadModuleResolutions + ( BadVariables + ( BadValues + ( BadSyntax + ( Erroring (LoadError term) + ( Evaluating (Located Precise term) term (Value (Located Precise term)))))))) + +-- The order is significant here: Caching has to come on the outside, or its Interpreter instance -- will expect the TypeError exception type to have an Ord instance, which is wrong. type Checking term = Caching @@ -63,16 +61,18 @@ type Checking term ( Erroring (EvalError Type) ( Erroring (ResolutionError Type) ( Erroring (Unspecialized Type) - ( Evaluating Monovariant term Type)))))) + ( Erroring (LoadError term) + ( Retaining + ( Evaluating Monovariant term Type)))))))) -evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path -evalRubyProject path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path -evalPHPProject path = runAnalysis @(JustEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path -evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path -evalTypeScriptProjectQuietly path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path -evalTypeScriptProject path = runAnalysis @(JustEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path +evalGoProject path = interpret @(JustEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path +evalRubyProject path = interpret @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path +evalPHPProject path = interpret @(JustEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path +evalPythonProject path = interpret @(JustEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path +evalTypeScriptProjectQuietly path = interpret @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path +evalTypeScriptProject path = interpret @(JustEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path -typecheckGoFile path = runAnalysis @(Checking Go.Term) <$> evaluateProject goParser Language.Go Nothing path +typecheckGoFile path = interpret @(Checking Go.Term) <$> evaluateProject goParser Language.Go Nothing path rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Language.Ruby) pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Language.Python) @@ -80,7 +80,7 @@ pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Py -- Evaluate a project, starting at a single entrypoint. evaluateProject parser lang prelude path = evaluatePackage <$> runTask (readProject Nothing path lang [] >>= parsePackage parser prelude) -evalRubyFile path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateFile rubyParser path +evalRubyFile path = interpret @(JustEvaluating Ruby.Term) <$> evaluateFile rubyParser path evaluateFile parser path = evaluateModule <$> runTask (parseModule parser Nothing (file path)) @@ -89,19 +89,3 @@ parseFile parser = runTask . (parse parser <=< readBlob . file) blob :: FilePath -> IO Blob blob = runTask . readBlob . file - --- Diff helpers -diffWithParser :: ( HasField fields Data.Span.Span - , HasField fields Range - , Eq1 syntax - , Show1 syntax - , Traversable syntax - , Diffable syntax - , GAlign syntax - , HasDeclaration syntax - , Members '[Distribute WrappedTask, Task] effs - ) - => Parser (Term syntax (Record fields)) - -> BlobPair - -> Eff effs (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields))) -diffWithParser parser blobs = distributeFor blobs (\ blob -> WrapTask $ parse parser blob >>= decorate (declarationAlgebra blob)) >>= diffTermPair diffTerms . runJoin diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index 97f9672ba..0ab365cc8 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedLists #-} module Analysis.Go.Spec (spec) where -import Data.Abstract.Evaluatable (EvalError(..), runAnalysis) +import Data.Abstract.Evaluatable (EvalError(..), interpret) import qualified Language.Go.Assignment as Go import qualified Data.Language as Language @@ -32,4 +32,4 @@ spec = parallel $ do where fixtures = "test/fixtures/go/analysis/" evaluate entry = evalGoProject (fixtures <> entry) - evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path + evalGoProject path = interpret @(TestEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index e8a22cb9c..a79755974 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedLists #-} module Analysis.PHP.Spec (spec) where -import Data.Abstract.Evaluatable (EvalError(..), runAnalysis) +import Data.Abstract.Evaluatable (EvalError(..), interpret) import qualified Language.PHP.Assignment as PHP import qualified Data.Language as Language @@ -36,4 +36,4 @@ spec = parallel $ do where fixtures = "test/fixtures/php/analysis/" evaluate entry = evalPHPProject (fixtures <> entry) - evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path + evalPHPProject path = interpret @(TestEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index c3b3e9fab..7f79356ab 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedLists, OverloadedStrings #-} module Analysis.Python.Spec (spec) where -import Data.Abstract.Evaluatable (EvalError(..), runAnalysis) +import Data.Abstract.Evaluatable (EvalError(..), interpret) import Data.Abstract.Value import Data.Map import qualified Language.Python.Assignment as Python @@ -40,15 +40,15 @@ spec = parallel $ do it "subclasses" $ do v <- fst <$> evaluate "subclass.py" - v `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"bar\""))))))))))) + v `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"bar\""))))))))) it "handles multiple inheritance left-to-right" $ do v <- fst <$> evaluate "multiple_inheritance.py" - v `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"foo!\""))))))))))) + v `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"foo!\""))))))))) where ns n = Just . Latest . Just . injValue . Namespace n addr = Address . Precise fixtures = "test/fixtures/python/analysis/" evaluate entry = evalPythonProject (fixtures <> entry) - evalPythonProject path = runAnalysis @(TestEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path + evalPythonProject path = interpret @(TestEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 5514f546c..b351d44a3 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -30,12 +30,12 @@ spec = parallel $ do it "evaluates load with wrapper" $ do res <- evaluate "load-wrap.rb" - fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Left (SomeExc (FreeVariableError "foo"))))))))) + fst res `shouldBe` Right (Right (Right (Right (Right (Left (SomeExc (FreeVariableError "foo"))))))) environment (snd res) `shouldBe` [ ("Object", addr 0) ] it "evaluates subclass" $ do res <- evaluate "subclass.rb" - fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"\"")))))))))) + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"\""))))))))) environment (snd res) `shouldBe` [ ("Bar", addr 6) , ("Foo", addr 3) , ("Object", addr 0) ] @@ -47,29 +47,33 @@ spec = parallel $ do it "evaluates modules" $ do res <- evaluate "modules.rb" - fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"\"")))))))))) + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"\""))))))))) environment (snd res) `shouldBe` [ ("Object", addr 0) , ("Bar", addr 3) ] it "handles break correctly" $ do res <- evaluate "break.rb" - fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (Value.Integer (Number.Integer 3))))))))))) + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Integer (Number.Integer 3)))))))))) it "handles break correctly" $ do res <- evaluate "next.rb" - fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (Value.Integer (Number.Integer 8))))))))))) + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Integer (Number.Integer 8)))))))))) + + it "calls functions with arguments" $ do + res <- evaluate "call.rb" + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Integer (Number.Integer 579)))))))))) it "evaluates early return statements" $ do res <- evaluate "early-return.rb" - fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (Value.Integer (Number.Integer 123))))))))))) + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Integer (Number.Integer 123)))))))))) it "has prelude" $ do res <- fst <$> evaluate "preluded.rb" - res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"\"")))))))))) + res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"\""))))))))) where ns n = Just . Latest . Just . injValue . Namespace n addr = Address . Precise fixtures = "test/fixtures/ruby/analysis/" evaluate entry = evalRubyProject (fixtures <> entry) - evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path + evalRubyProject path = interpret @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index b100b583b..6a2c72180 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -34,13 +34,13 @@ spec = parallel $ do it "fails exporting symbols not defined in the module" $ do v <- fst <$> evaluate "bad-export.ts" - v `shouldBe` Right (Right (Right (Right (Right (Right (Right (Left (SomeExc (ExportError "foo.ts" (Name "pip")))))))))) + v `shouldBe` Right (Right (Right (Right (Right (Left (SomeExc (ExportError "foo.ts" (Name "pip")))))))) it "evaluates early return statements" $ do res <- evaluate "early-return.ts" - fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (Value.Float (Number.Decimal 123.0))))))))))) + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Float (Number.Decimal 123.0)))))))))) where fixtures = "test/fixtures/typescript/analysis/" evaluate entry = evalTypeScriptProject (fixtures <> entry) - evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path + evalTypeScriptProject path = interpret @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index 99ee6d422..23e634b74 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -1,14 +1,22 @@ -{-# LANGUAGE DataKinds, TypeOperators #-} - module Rendering.TOC.Spec (spec) where +{-# LANGUAGE DataKinds, MonoLocalBinds, TypeOperators #-} +module Rendering.TOC.Spec (spec) where import Analysis.Declaration import Data.Aeson +import Data.Align.Generic import Data.Bifunctor +import Data.Bifunctor.Join import Data.Diff +import Data.Functor.Classes import Data.Patch +import Data.Range +import Data.Record +import Data.Span +import Data.Term import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Data.Union +import Diffing.Algorithm import Diffing.Interpreter import Prelude import qualified Data.Syntax as Syntax @@ -222,3 +230,19 @@ blankDiff = merge (arrayInfo, arrayInfo) (inj [ inserting (termIn literalInfo (i where arrayInfo = Nothing :. Range 0 3 :. Span (Pos 1 1) (Pos 1 5) :. Nil literalInfo = Nothing :. Range 1 2 :. Span (Pos 1 2) (Pos 1 4) :. Nil + +-- Diff helpers +diffWithParser :: ( HasField fields Data.Span.Span + , HasField fields Range + , Eq1 syntax + , Show1 syntax + , Traversable syntax + , Diffable syntax + , GAlign syntax + , HasDeclaration syntax + , Members '[Distribute WrappedTask, Task] effs + ) + => Parser (Term syntax (Record fields)) + -> BlobPair + -> Eff effs (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields))) +diffWithParser parser blobs = distributeFor blobs (\ blob -> WrapTask $ parse parser blob >>= decorate (declarationAlgebra blob)) >>= diffTermPair diffTerms . runJoin diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 904d20361..1299dbd21 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -1,16 +1,15 @@ {-# LANGUAGE GADTs, ScopedTypeVariables, TypeFamilies, TypeOperators #-} -module SpecHelpers ( - module X +module SpecHelpers +( module X , diffFilePaths , parseFilePath , readFilePair -, readFileVerbatim , addr , ns , verbatim , Verbatim(..) , TestEvaluating -, ) where +) where import Analysis.Abstract.Erroring import Analysis.Abstract.Evaluating @@ -22,6 +21,7 @@ import Data.Abstract.Evaluatable import Data.Abstract.FreeVariables as X hiding (dropExtension) import Data.Abstract.Heap as X import Data.Abstract.ModuleTable as X hiding (lookup) +import Data.Abstract.Value (Namespace(..), Value, ValueError, injValue) import Data.Blob as X import Data.File as X import Data.Functor.Listable as X @@ -54,7 +54,6 @@ import Test.LeanCheck as X import qualified Data.ByteString as B import qualified Semantic.IO as IO -import Data.Abstract.Value -- | Returns an s-expression formatted diff for the specified FilePath pair. diffFilePaths :: Both FilePath -> IO ByteString @@ -69,16 +68,14 @@ readFilePair :: Both FilePath -> IO BlobPair readFilePair paths = let paths' = fmap file paths in runBothWith IO.readFilePair paths' -readFileVerbatim :: FilePath -> IO Verbatim -readFileVerbatim = fmap verbatim . B.readFile - 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)))))) + ( Erroring (LoadError term) + ( Evaluating Precise term (Value Precise))))))) ns n = Just . Latest . Just . injValue . Namespace n addr = Address . Precise diff --git a/test/fixtures/ruby/analysis/call.rb b/test/fixtures/ruby/analysis/call.rb new file mode 100644 index 000000000..a94a2ee2f --- /dev/null +++ b/test/fixtures/ruby/analysis/call.rb @@ -0,0 +1,5 @@ +def foo(x, y) + x + y +end + +foo(123, 456)