github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 08:54:07 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #1794 from github/break-the-loop

Browse Source 
Evaluate closure bodies & imports via effects
This commit is contained in:
Rob Rix 2018-05-01 10:10:02 -04:00 committed by GitHub
commit 7074756071
44 changed files with 592 additions and 436 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
semantic.cabal
View File

@ -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

7
src/Analysis/Abstract/BadAddresses.hs
View File

@ -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

7
src/Analysis/Abstract/BadModuleResolutions.hs
View File

@ -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

9
src/Analysis/Abstract/BadSyntax.hs
View File

@ -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

8
src/Analysis/Abstract/BadValues.hs
View File

@ -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

7
src/Analysis/Abstract/BadVariables.hs
View File

@ -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

25
src/Analysis/Abstract/Caching.hs
View File

@ -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

44
src/Analysis/Abstract/Collecting.hs
View File

@ -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)

7
src/Analysis/Abstract/Dead.hs
View File

@ -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)

7
src/Analysis/Abstract/Erroring.hs
View File

@ -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

62
src/Analysis/Abstract/Evaluating.hs
View File

@ -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'.

17
src/Analysis/Abstract/ImportGraph.hs
View File

@ -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)

9
src/Analysis/Abstract/Tracing.hs
View File

@ -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

9
src/Analysis/Abstract/TypeChecking.hs
View File

@ -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

26
src/Control/Abstract/Analysis.hs
View File

@ -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

149
src/Control/Abstract/Evaluator.hs
View File

@ -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))

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

@ -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

14
src/Control/Effect.hs
View File

@ -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

12
src/Data/Abstract/Environment.hs
View File

@ -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

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

@ -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

3
src/Data/Abstract/Exports.hs
View File

@ -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

3
src/Data/Abstract/Heap.hs
View File

@ -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)

5
src/Data/Abstract/ModuleTable.hs
View File

@ -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)

6
src/Data/Abstract/Origin.hs
View File

@ -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

5
src/Data/Abstract/Type.hs
View File

@ -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

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

@ -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

17
src/Data/Empty.hs
View File

@ -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

3
src/Data/Map/Monoidal.hs
View File

@ -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

6
src/Data/Range.hs
View File

@ -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

10
src/Data/Record.hs
View File

@ -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

40
src/Data/Semilattice/Lower.hs Normal file
View File

@ -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

6
src/Data/Span.hs
View File

@ -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)

6
src/Data/Syntax/Statement.hs
View File

@ -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)

50
src/Semantic/Graph.hs
View File

@ -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)))

6
src/Semantic/Task.hs
View File

@ -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)

66
src/Semantic/Util.hs
View File

@ -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

4
test/Analysis/Go/Spec.hs
View File

@ -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

4
test/Analysis/PHP/Spec.hs
View File

@ -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

8
test/Analysis/Python/Spec.hs
View File

@ -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

20
test/Analysis/Ruby/Spec.hs
View File

@ -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 "\"<bar>\""))))))))))
fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"<bar>\"")))))))))
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 "\"<hello>\""))))))))))
fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"<hello>\"")))))))))
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 "\"<foo>\""))))))))))
res `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/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

6
test/Analysis/TypeScript/Spec.hs
View File

@ -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

28
test/Rendering/TOC/Spec.hs
View File

@ -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

15
test/SpecHelpers.hs
View File

@ -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

5
test/fixtures/ruby/analysis/call.rb vendored Normal file
View File

@ -0,0 +1,5 @@
def foo(x, y)
x + y
end
foo(123, 456)