mirror of
https://github.com/github/semantic.git
synced 2024-12-20 21:31:48 +03:00
Merge remote-tracking branch 'origin/master' into module-resolution
This commit is contained in:
Timothy Clem
commit
b680076d30
@ -15,7 +15,8 @@ library
|
||||
hs-source-dirs: src
|
||||
exposed-modules:
|
||||
-- Analyses & term annotations
|
||||
Analysis.Abstract.Caching
|
||||
Analysis.Abstract.BadVariables
|
||||
, Analysis.Abstract.Caching
|
||||
, Analysis.Abstract.Collecting
|
||||
, Analysis.Abstract.Dead
|
||||
, Analysis.Abstract.Evaluating
|
||||
|
||||
33
src/Analysis/Abstract/BadVariables.hs
Normal file
33
src/Analysis/Abstract/BadVariables.hs
Normal file
@ -0,0 +1,33 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Analysis.Abstract.BadVariables
|
||||
( BadVariables
|
||||
) where
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
import Data.Abstract.Evaluatable
|
||||
import Prologue
|
||||
|
||||
-- An analysis that resumes from evaluation errors and records the list of unresolved free variables.
|
||||
newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a)
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
|
||||
|
||||
deriving instance MonadControl term (m effects) => MonadControl term (BadVariables m effects)
|
||||
deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (BadVariables m effects)
|
||||
deriving instance MonadHeap value (m effects) => MonadHeap value (BadVariables m effects)
|
||||
deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (BadVariables m effects)
|
||||
deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (BadVariables m effects)
|
||||
|
||||
instance ( Effectful m
|
||||
, Member (Resumable (EvalError value)) effects
|
||||
, Member (State [Name]) effects
|
||||
, MonadAnalysis term value (m effects)
|
||||
, MonadValue value (BadVariables m effects)
|
||||
)
|
||||
=> MonadAnalysis term value (BadVariables m effects) where
|
||||
type Effects term value (BadVariables m effects) = State [Name] ': Effects term value (m effects)
|
||||
|
||||
analyzeTerm eval term = resumeException @(EvalError value) (liftAnalyze analyzeTerm eval term) (
|
||||
\yield (FreeVariableError name) ->
|
||||
raise (modify' (name :)) >> unit >>= yield)
|
||||
|
||||
analyzeModule = liftAnalyze analyzeModule
|
||||
@ -1,6 +1,6 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Analysis.Abstract.Caching
|
||||
( type Caching
|
||||
( Caching
|
||||
) where
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
@ -22,14 +22,14 @@ type CachingEffects term value effects
|
||||
type CacheFor term value = Cache (LocationFor value) term value
|
||||
|
||||
-- | A (coinductively-)cached analysis suitable for guaranteeing termination of (suitably finitized) analyses over recursive programs.
|
||||
newtype Caching m term value (effects :: [* -> *]) a = Caching (m term value effects a)
|
||||
newtype Caching m (effects :: [* -> *]) a = Caching (m effects a)
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
|
||||
|
||||
deriving instance MonadControl term (m term value effects) => MonadControl term (Caching m term value effects)
|
||||
deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Caching m term value effects)
|
||||
deriving instance MonadHeap value (m term value effects) => MonadHeap value (Caching m term value effects)
|
||||
deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Caching m term value effects)
|
||||
deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Caching m term value effects)
|
||||
deriving instance MonadControl term (m effects) => MonadControl term (Caching m effects)
|
||||
deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Caching m effects)
|
||||
deriving instance MonadHeap value (m effects) => MonadHeap value (Caching m effects)
|
||||
deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Caching m effects)
|
||||
deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Caching m effects)
|
||||
|
||||
-- | Functionality used to perform caching analysis. This is not exported, and exists primarily for organizational reasons.
|
||||
class MonadEvaluator term value m => MonadCaching term value m where
|
||||
@ -46,15 +46,15 @@ class MonadEvaluator term value m => MonadCaching term value m where
|
||||
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
|
||||
isolateCache :: m a -> m (CacheFor term value)
|
||||
|
||||
instance ( Effectful (m term value)
|
||||
instance ( Effectful m
|
||||
, Members (CachingEffects term value '[]) effects
|
||||
, MonadEvaluator term value (m term value effects)
|
||||
, MonadEvaluator term value (m effects)
|
||||
, Ord (CellFor value)
|
||||
, Ord (LocationFor value)
|
||||
, Ord term
|
||||
, Ord value
|
||||
)
|
||||
=> MonadCaching term value (Caching m term value effects) where
|
||||
=> MonadCaching term value (Caching m effects) where
|
||||
consultOracle configuration = raise (fromMaybe mempty . cacheLookup configuration <$> ask)
|
||||
withOracle cache = raise . local (const cache) . lower
|
||||
|
||||
@ -69,19 +69,19 @@ instance ( Effectful (m term value)
|
||||
|
||||
-- | This instance coinductively iterates the analysis of a term until the results converge.
|
||||
instance ( Corecursive term
|
||||
, Effectful (m term value)
|
||||
, MonadAnalysis term value (m term value effects)
|
||||
, MonadFresh (m term value effects)
|
||||
, MonadNonDet (m term value effects)
|
||||
, Effectful m
|
||||
, Members (CachingEffects term value '[]) effects
|
||||
, MonadAnalysis term value (m effects)
|
||||
, MonadFresh (m effects)
|
||||
, MonadNonDet (m effects)
|
||||
, Ord (CellFor value)
|
||||
, Ord (LocationFor value)
|
||||
, Ord term
|
||||
, Ord value
|
||||
)
|
||||
=> MonadAnalysis term value (Caching m term value effects) where
|
||||
-- We require the 'CachingEffects' in addition to the underlying analysis’ 'RequiredEffects'.
|
||||
type RequiredEffects term value (Caching m term value effects) = CachingEffects term value (RequiredEffects term value (m term value effects))
|
||||
=> MonadAnalysis term value (Caching m effects) where
|
||||
-- We require the 'CachingEffects' in addition to the underlying analysis’ 'Effects'.
|
||||
type Effects term value (Caching m effects) = CachingEffects term value (Effects term value (m effects))
|
||||
|
||||
-- Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
|
||||
analyzeTerm recur e = do
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Analysis.Abstract.Collecting
|
||||
( type Collecting
|
||||
( Collecting
|
||||
) where
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
@ -10,35 +10,35 @@ import Data.Abstract.Heap
|
||||
import Data.Abstract.Live
|
||||
import Prologue
|
||||
|
||||
newtype Collecting m term value (effects :: [* -> *]) a = Collecting (m term value effects a)
|
||||
newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a)
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
|
||||
|
||||
deriving instance MonadControl term (m term value effects) => MonadControl term (Collecting m term value effects)
|
||||
deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Collecting m term value effects)
|
||||
deriving instance MonadHeap value (m term value effects) => MonadHeap value (Collecting m term value effects)
|
||||
deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Collecting m term value effects)
|
||||
deriving instance MonadControl term (m effects) => MonadControl term (Collecting m effects)
|
||||
deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Collecting m effects)
|
||||
deriving instance MonadHeap value (m effects) => MonadHeap value (Collecting m effects)
|
||||
deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Collecting m effects)
|
||||
|
||||
instance ( Effectful (m term value)
|
||||
instance ( Effectful m
|
||||
, Member (Reader (Live (LocationFor value) value)) effects
|
||||
, MonadEvaluator term value (m term value effects)
|
||||
, MonadEvaluator term value (m effects)
|
||||
)
|
||||
=> MonadEvaluator term value (Collecting m term value effects) where
|
||||
=> MonadEvaluator term value (Collecting m effects) where
|
||||
getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap
|
||||
|
||||
askModuleStack = Collecting askModuleStack
|
||||
|
||||
|
||||
instance ( Effectful (m term value)
|
||||
instance ( Effectful m
|
||||
, Foldable (Cell (LocationFor value))
|
||||
, Member (Reader (Live (LocationFor value) value)) effects
|
||||
, MonadAnalysis term value (m term value effects)
|
||||
, MonadAnalysis term value (m effects)
|
||||
, Ord (LocationFor value)
|
||||
, ValueRoots value
|
||||
)
|
||||
=> MonadAnalysis term value (Collecting m term value effects) where
|
||||
type RequiredEffects term value (Collecting m term value effects)
|
||||
=> MonadAnalysis term value (Collecting m effects) where
|
||||
type Effects term value (Collecting m effects)
|
||||
= Reader (Live (LocationFor value) value)
|
||||
': RequiredEffects term value (m term value effects)
|
||||
': Effects term value (m effects)
|
||||
|
||||
-- Small-step evaluation which garbage-collects any non-rooted addresses after evaluating each term.
|
||||
analyzeTerm recur term = do
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Analysis.Abstract.Dead
|
||||
( type DeadCode
|
||||
( DeadCode
|
||||
) where
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
@ -10,14 +10,14 @@ import Data.Set (delete)
|
||||
import Prologue
|
||||
|
||||
-- | An analysis tracking dead (unreachable) code.
|
||||
newtype DeadCode m term value (effects :: [* -> *]) a = DeadCode (m term value effects a)
|
||||
newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a)
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
|
||||
|
||||
deriving instance MonadControl term (m term value effects) => MonadControl term (DeadCode m term value effects)
|
||||
deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (DeadCode m term value effects)
|
||||
deriving instance MonadHeap value (m term value effects) => MonadHeap value (DeadCode m term value effects)
|
||||
deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (DeadCode m term value effects)
|
||||
deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (DeadCode m term value effects)
|
||||
deriving instance MonadControl term (m effects) => MonadControl term (DeadCode m effects)
|
||||
deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (DeadCode m effects)
|
||||
deriving instance MonadHeap value (m effects) => MonadHeap value (DeadCode m effects)
|
||||
deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (DeadCode m effects)
|
||||
deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (DeadCode m effects)
|
||||
|
||||
-- | A set of “dead” (unreachable) terms.
|
||||
newtype Dead term = Dead { unDead :: Set term }
|
||||
@ -26,11 +26,11 @@ newtype Dead term = Dead { unDead :: Set term }
|
||||
deriving instance Ord term => Reducer term (Dead term)
|
||||
|
||||
-- | Update the current 'Dead' set.
|
||||
killAll :: (Effectful (m term value), Member (State (Dead term)) effects) => Dead term -> DeadCode m term value effects ()
|
||||
killAll :: (Effectful m, Member (State (Dead term)) effects) => Dead term -> DeadCode m effects ()
|
||||
killAll = raise . put
|
||||
|
||||
-- | Revive a single term, removing it from the current 'Dead' set.
|
||||
revive :: (Effectful (m term value), Member (State (Dead term)) effects) => Ord term => term -> DeadCode m term value effects ()
|
||||
revive :: (Effectful m, Member (State (Dead term)) effects) => Ord term => term -> DeadCode m effects ()
|
||||
revive t = raise (modify (Dead . delete t . unDead))
|
||||
|
||||
-- | Compute the set of all subterms recursively.
|
||||
@ -39,15 +39,15 @@ subterms term = term `cons` para (foldMap (uncurry cons)) term
|
||||
|
||||
|
||||
instance ( Corecursive term
|
||||
, Effectful (m term value)
|
||||
, Effectful m
|
||||
, Foldable (Base term)
|
||||
, Member (State (Dead term)) effects
|
||||
, MonadAnalysis term value (m term value effects)
|
||||
, MonadAnalysis term value (m effects)
|
||||
, Ord term
|
||||
, Recursive term
|
||||
)
|
||||
=> MonadAnalysis term value (DeadCode m term value effects) where
|
||||
type RequiredEffects term value (DeadCode m term value effects) = State (Dead term) ': RequiredEffects term value (m term value effects)
|
||||
=> MonadAnalysis term value (DeadCode m effects) where
|
||||
type Effects term value (DeadCode m effects) = State (Dead term) ': Effects term value (m effects)
|
||||
|
||||
analyzeTerm recur term = do
|
||||
revive (embedSubterm term)
|
||||
|
||||
@ -20,14 +20,16 @@ import Prologue
|
||||
newtype Evaluating term value effects a = Evaluating (Eff effects a)
|
||||
deriving (Applicative, Functor, Effectful, Monad)
|
||||
|
||||
deriving instance Member Fail effects => MonadFail (Evaluating term value effects)
|
||||
deriving instance Member Fresh effects => MonadFresh (Evaluating term value effects)
|
||||
deriving instance Member NonDet effects => Alternative (Evaluating term value effects)
|
||||
deriving instance Member NonDet effects => MonadNonDet (Evaluating term value effects)
|
||||
deriving instance Member Fail effects => MonadFail (Evaluating term value effects)
|
||||
deriving instance Member Fresh effects => MonadFresh (Evaluating term value effects)
|
||||
deriving instance Member NonDet effects => Alternative (Evaluating term value effects)
|
||||
deriving instance Member NonDet effects => MonadNonDet (Evaluating term value effects)
|
||||
|
||||
-- | Effects necessary for evaluating (whether concrete or abstract).
|
||||
type EvaluatingEffects term value
|
||||
= '[ Resumable (ValueExc value)
|
||||
= '[ Resumable (EvalError value)
|
||||
, Resumable (LoadError term value)
|
||||
, Resumable (ValueExc value)
|
||||
, Resumable (Unspecialized value)
|
||||
, Fail -- Failure with an error message
|
||||
, Reader [Module term] -- The stack of currently-evaluating modules.
|
||||
@ -134,7 +136,7 @@ instance ( Members (EvaluatingEffects term value) effects
|
||||
, MonadValue value (Evaluating term value effects)
|
||||
)
|
||||
=> MonadAnalysis term value (Evaluating term value effects) where
|
||||
type RequiredEffects term value (Evaluating term value effects) = EvaluatingEffects term value
|
||||
type Effects term value (Evaluating term value effects) = EvaluatingEffects term value
|
||||
|
||||
analyzeTerm = id
|
||||
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving,
|
||||
TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Analysis.Abstract.ImportGraph
|
||||
( ImportGraph(..)
|
||||
, renderImportGraph
|
||||
@ -6,12 +7,13 @@ module Analysis.Abstract.ImportGraph
|
||||
) where
|
||||
|
||||
import qualified Algebra.Graph as G
|
||||
import Algebra.Graph.Class
|
||||
import Algebra.Graph.Export.Dot
|
||||
import Control.Abstract.Analysis
|
||||
import Data.Abstract.Module
|
||||
import Algebra.Graph.Class
|
||||
import Algebra.Graph.Export.Dot
|
||||
import Control.Abstract.Analysis
|
||||
import Data.Abstract.Evaluatable (LoadError (..))
|
||||
import Data.Abstract.Module
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import Prologue hiding (empty)
|
||||
import Prologue hiding (empty)
|
||||
|
||||
-- | The graph of function definitions to symbols used in a given program.
|
||||
newtype ImportGraph = ImportGraph { unImportGraph :: G.Graph FilePath }
|
||||
@ -21,37 +23,49 @@ newtype ImportGraph = ImportGraph { unImportGraph :: G.Graph FilePath }
|
||||
renderImportGraph :: ImportGraph -> ByteString
|
||||
renderImportGraph = export (defaultStyle BC.pack) . unImportGraph
|
||||
|
||||
newtype ImportGraphing m term value (effects :: [* -> *]) a = ImportGraphing (m term value effects a)
|
||||
newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a)
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
|
||||
|
||||
deriving instance MonadControl term (m term value effects) => MonadControl term (ImportGraphing m term value effects)
|
||||
deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (ImportGraphing m term value effects)
|
||||
deriving instance MonadHeap value (m term value effects) => MonadHeap value (ImportGraphing m term value effects)
|
||||
deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (ImportGraphing m term value effects)
|
||||
deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (ImportGraphing m term value effects)
|
||||
deriving instance MonadControl term (m effects) => MonadControl term (ImportGraphing m effects)
|
||||
deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (ImportGraphing m effects)
|
||||
deriving instance MonadHeap value (m effects) => MonadHeap value (ImportGraphing m effects)
|
||||
deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (ImportGraphing m effects)
|
||||
deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (ImportGraphing m effects)
|
||||
|
||||
|
||||
instance ( Effectful (m term value)
|
||||
instance ( Effectful m
|
||||
, Member (State ImportGraph) effects
|
||||
, MonadAnalysis term value (m term value effects)
|
||||
, MonadAnalysis term value (m effects)
|
||||
, Member (Resumable (LoadError term value)) effects
|
||||
)
|
||||
=> MonadAnalysis term value (ImportGraphing m term value effects) where
|
||||
type RequiredEffects term value (ImportGraphing m term value effects) = State ImportGraph ': RequiredEffects term value (m term value effects)
|
||||
=> MonadAnalysis term value (ImportGraphing m effects) where
|
||||
type Effects term value (ImportGraphing m effects) = State ImportGraph ': Effects term value (m effects)
|
||||
|
||||
analyzeTerm = liftAnalyze analyzeTerm
|
||||
analyzeTerm eval term = resumeException
|
||||
@(LoadError term value)
|
||||
(liftAnalyze analyzeTerm eval term)
|
||||
(\yield (LoadError name) -> insertVertexName name >> yield [])
|
||||
|
||||
analyzeModule recur m = do
|
||||
insertVertexName (modulePath m)
|
||||
liftAnalyze analyzeModule recur m
|
||||
|
||||
insertVertexName :: (Effectful m
|
||||
, Member (State ImportGraph) effects
|
||||
, MonadEvaluator term value (m effects))
|
||||
=> FilePath
|
||||
-> ImportGraphing m effects ()
|
||||
insertVertexName name = do
|
||||
ms <- askModuleStack
|
||||
let parent = maybe empty (vertex . modulePath) (listToMaybe ms)
|
||||
modifyImportGraph (parent >< vertex (modulePath m) <>)
|
||||
liftAnalyze analyzeModule recur m
|
||||
modifyImportGraph (parent >< vertex name <>)
|
||||
|
||||
(><) :: Graph a => a -> a -> a
|
||||
(><) = connect
|
||||
|
||||
infixr 7 ><
|
||||
|
||||
modifyImportGraph :: (Effectful (m term value), Member (State ImportGraph) effects) => (ImportGraph -> ImportGraph) -> ImportGraphing m term value effects ()
|
||||
modifyImportGraph :: (Effectful m, Member (State ImportGraph) effects) => (ImportGraph -> ImportGraph) -> ImportGraphing m effects ()
|
||||
modifyImportGraph = raise . modify
|
||||
|
||||
|
||||
|
||||
@ -1,8 +1,9 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies #-}
|
||||
module Analysis.Abstract.Quiet where
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-}
|
||||
module Analysis.Abstract.Quiet
|
||||
( Quietly
|
||||
) where
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
import Control.Monad.Effect.Resumable
|
||||
import Data.Abstract.Evaluatable
|
||||
import Prologue
|
||||
|
||||
@ -10,25 +11,25 @@ import Prologue
|
||||
--
|
||||
-- Use it by composing it onto an analysis:
|
||||
--
|
||||
-- > runAnalysis @(Quietly Evaluating term value) (…)
|
||||
-- > runAnalysis @(Quietly (Evaluating term value)) (…)
|
||||
--
|
||||
-- Note that exceptions thrown by other analyses may not be caught if 'Quietly' doesn’t know about them, i.e. if they’re not part of the generic 'MonadValue', 'MonadAddressable', etc. machinery.
|
||||
newtype Quietly m term value (effects :: [* -> *]) a = Quietly (m term value effects a)
|
||||
newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a)
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
|
||||
|
||||
deriving instance MonadControl term (m term value effects) => MonadControl term (Quietly m term value effects)
|
||||
deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Quietly m term value effects)
|
||||
deriving instance MonadHeap value (m term value effects) => MonadHeap value (Quietly m term value effects)
|
||||
deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Quietly m term value effects)
|
||||
deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Quietly m term value effects)
|
||||
deriving instance MonadControl term (m effects) => MonadControl term (Quietly m effects)
|
||||
deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Quietly m effects)
|
||||
deriving instance MonadHeap value (m effects) => MonadHeap value (Quietly m effects)
|
||||
deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Quietly m effects)
|
||||
deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Quietly m effects)
|
||||
|
||||
instance ( Effectful (m term value)
|
||||
instance ( Effectful m
|
||||
, Member (Resumable (Unspecialized value)) effects
|
||||
, MonadAnalysis term value (m term value effects)
|
||||
, MonadValue value (Quietly m term value effects)
|
||||
, MonadAnalysis term value (m effects)
|
||||
, MonadValue value (Quietly m effects)
|
||||
)
|
||||
=> MonadAnalysis term value (Quietly m term value effects) where
|
||||
type RequiredEffects term value (Quietly m term value effects) = RequiredEffects term value (m term value effects)
|
||||
=> MonadAnalysis term value (Quietly m effects) where
|
||||
type Effects term value (Quietly m effects) = Effects term value (m effects)
|
||||
|
||||
analyzeTerm eval term = resumeException @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield (Unspecialized _) -> unit >>= yield)
|
||||
|
||||
|
||||
@ -1,47 +1,39 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Analysis.Abstract.Tracing
|
||||
( type Tracing
|
||||
( Tracing
|
||||
) where
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
import Control.Monad.Effect.Writer
|
||||
import Data.Semigroup.Reducer as Reducer
|
||||
import Data.Union
|
||||
import Prologue hiding (trace)
|
||||
import Prologue
|
||||
|
||||
-- | Trace analysis.
|
||||
--
|
||||
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
|
||||
newtype Tracing (trace :: * -> *) m term value (effects :: [* -> *]) a = Tracing (m term value effects a)
|
||||
newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a)
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
|
||||
|
||||
deriving instance MonadControl term (m term value effects) => MonadControl term (Tracing trace m term value effects)
|
||||
deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Tracing trace m term value effects)
|
||||
deriving instance MonadHeap value (m term value effects) => MonadHeap value (Tracing trace m term value effects)
|
||||
deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Tracing trace m term value effects)
|
||||
deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Tracing trace m term value effects)
|
||||
deriving instance MonadControl term (m effects) => MonadControl term (Tracing trace m effects)
|
||||
deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Tracing trace m effects)
|
||||
deriving instance MonadHeap value (m effects) => MonadHeap value (Tracing trace m effects)
|
||||
deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Tracing trace m effects)
|
||||
deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Tracing trace m effects)
|
||||
|
||||
instance ( Corecursive term
|
||||
, Effectful (m term value)
|
||||
, Effectful m
|
||||
, Member (Writer (trace (ConfigurationFor term value))) effects
|
||||
, MonadAnalysis term value (m term value effects)
|
||||
, MonadAnalysis term value (m effects)
|
||||
, Ord (LocationFor value)
|
||||
, Reducer (ConfigurationFor term value) (trace (ConfigurationFor term value))
|
||||
)
|
||||
=> MonadAnalysis term value (Tracing trace m term value effects) where
|
||||
type RequiredEffects term value (Tracing trace m term value effects) = Writer (trace (ConfigurationFor term value)) ': RequiredEffects term value (m term value effects)
|
||||
=> MonadAnalysis term value (Tracing trace m effects) where
|
||||
type Effects term value (Tracing trace m effects) = Writer (trace (ConfigurationFor term value)) ': Effects term value (m effects)
|
||||
|
||||
analyzeTerm recur term = do
|
||||
config <- getConfiguration (embedSubterm term)
|
||||
trace (Reducer.unit config)
|
||||
raise (tell @(trace (ConfigurationFor term value)) (Reducer.unit config))
|
||||
liftAnalyze analyzeTerm recur term
|
||||
|
||||
analyzeModule = liftAnalyze analyzeModule
|
||||
|
||||
-- | Log the given trace of configurations.
|
||||
trace :: ( Effectful (m term value)
|
||||
, Member (Writer (trace (ConfigurationFor term value))) effects
|
||||
)
|
||||
=> trace (ConfigurationFor term value)
|
||||
-> Tracing trace m term value effects ()
|
||||
trace = raise . tell
|
||||
|
||||
@ -19,6 +19,7 @@ import qualified Control.Monad.Effect as Effect
|
||||
import Control.Monad.Effect.Fail as X
|
||||
import Control.Monad.Effect.Reader as X
|
||||
import Control.Monad.Effect.State as X
|
||||
import Control.Monad.Effect.Resumable as X
|
||||
import Data.Abstract.Module
|
||||
import Data.Coerce
|
||||
import Data.Type.Coercion
|
||||
@ -28,8 +29,8 @@ import Prologue
|
||||
--
|
||||
-- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses.
|
||||
class MonadEvaluator term value m => MonadAnalysis term value m where
|
||||
-- | The effects necessary to run the analysis. Analyses which are composed on top of (wrap) other analyses should include the inner analyses 'RequiredEffects' in their own list.
|
||||
type family RequiredEffects term value m :: [* -> *]
|
||||
-- | The effects necessary to run the analysis. Analyses which are composed on top of (wrap) other analyses should include the inner analyses 'Effects' in their own list.
|
||||
type family Effects term value m :: [* -> *]
|
||||
|
||||
-- | Analyze a term using the semantics of the current analysis.
|
||||
analyzeTerm :: (Base term (Subterm term (outer value)) -> m value)
|
||||
@ -45,19 +46,19 @@ class MonadEvaluator term value m => MonadAnalysis term value m where
|
||||
|
||||
|
||||
-- | 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.
|
||||
liftAnalyze :: Coercible ( m term value effects value) (t m term value (effects :: [* -> *]) value)
|
||||
=> ((base (Subterm term (outer value)) -> m term value effects value) -> (base (Subterm term (outer value)) -> m term value effects value))
|
||||
-> ((base (Subterm term (outer value)) -> t m term value effects value) -> (base (Subterm term (outer value)) -> t m term value effects value))
|
||||
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 'RequiredEffects').
|
||||
-- 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
|
||||
, RunEffects effects a
|
||||
, RequiredEffects term value (m effects) ~ effects
|
||||
, Effects term value (m effects) ~ effects
|
||||
, MonadAnalysis term value (m effects)
|
||||
, RunEffects effects a
|
||||
)
|
||||
=> m effects a
|
||||
-> Final effects a
|
||||
|
||||
@ -26,7 +26,7 @@ import Data.Abstract.Number as Number
|
||||
import Data.Scientific (Scientific)
|
||||
import Data.Semigroup.Reducer hiding (unit)
|
||||
import Prelude
|
||||
import Prologue
|
||||
import Prologue hiding (TypeError)
|
||||
|
||||
-- | This datum is passed into liftComparison to handle the fact that Ruby and PHP
|
||||
-- have built-in generalized-comparison ("spaceship") operators. If you want to
|
||||
@ -196,13 +196,17 @@ class ValueRoots value where
|
||||
|
||||
-- The type of exceptions that can be thrown when constructing values in `MonadValue`.
|
||||
data ValueExc value resume where
|
||||
ValueExc :: Prelude.String -> ValueExc value value
|
||||
StringExc :: Prelude.String -> ValueExc value ByteString
|
||||
TypeError :: Prelude.String -> ValueExc value value
|
||||
StringError :: Prelude.String -> ValueExc value ByteString
|
||||
NamespaceError :: Prelude.String -> ValueExc value (EnvironmentFor value)
|
||||
ScopedEnvironmentError :: Prelude.String -> ValueExc value (EnvironmentFor value)
|
||||
|
||||
instance Eq1 (ValueExc value) where
|
||||
liftEq _ (ValueExc a) (ValueExc b) = a == b
|
||||
liftEq _ (StringExc a) (StringExc b) = a == b
|
||||
liftEq _ _ _ = False
|
||||
liftEq _ (TypeError a) (TypeError b) = a == b
|
||||
liftEq _ (StringError a) (StringError b) = a == b
|
||||
liftEq _ (NamespaceError a) (NamespaceError b) = a == b
|
||||
liftEq _ (ScopedEnvironmentError a) (ScopedEnvironmentError b) = a == b
|
||||
liftEq _ _ _ = False
|
||||
|
||||
deriving instance Show (ValueExc value resume)
|
||||
instance Show1 (ValueExc value) where
|
||||
|
||||
@ -1,5 +1,12 @@
|
||||
{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Control.Effect where
|
||||
module Control.Effect
|
||||
( Control.Effect.run
|
||||
, RunEffects(..)
|
||||
, RunEffect(..)
|
||||
, Effectful(..)
|
||||
, resumeException
|
||||
, mergeEither
|
||||
) where
|
||||
|
||||
import Control.Monad.Effect as Effect
|
||||
import Control.Monad.Effect.Fail
|
||||
|
||||
@ -4,27 +4,30 @@ module Data.Abstract.Evaluatable
|
||||
, MonadEvaluatable
|
||||
, Evaluatable(..)
|
||||
, Unspecialized(..)
|
||||
, LoadError(..)
|
||||
, EvalError(..)
|
||||
, evaluateTerm
|
||||
, evaluateModule
|
||||
, withModules
|
||||
, evaluateModules
|
||||
, throwLoadError
|
||||
, resolve
|
||||
, require
|
||||
, load
|
||||
) where
|
||||
|
||||
import Control.Abstract.Addressable as X
|
||||
import Control.Abstract.Analysis as X
|
||||
import Control.Abstract.Addressable as X
|
||||
import Control.Abstract.Analysis as X
|
||||
import qualified Data.Abstract.Environment as Env
|
||||
import qualified Data.Abstract.Exports as Exports
|
||||
import Data.Abstract.FreeVariables as X
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.ModuleTable as ModuleTable
|
||||
import Data.Semigroup.App
|
||||
import Data.Semigroup.Foldable
|
||||
import Data.Term
|
||||
import Prelude hiding (fail)
|
||||
import Prologue
|
||||
import Data.Abstract.FreeVariables as X
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.ModuleTable as ModuleTable
|
||||
import Data.Semigroup.App
|
||||
import Data.Semigroup.Foldable
|
||||
import Data.Term
|
||||
import Prelude hiding (fail)
|
||||
import Prologue
|
||||
|
||||
type MonadEvaluatable term value m =
|
||||
( Evaluatable (Base term)
|
||||
@ -32,11 +35,41 @@ type MonadEvaluatable term value m =
|
||||
, MonadAddressable (LocationFor value) value m
|
||||
, MonadAnalysis term value m
|
||||
, MonadThrow (Unspecialized value) m
|
||||
, MonadThrow (ValueExc value) m
|
||||
, MonadThrow (LoadError term value) m
|
||||
, MonadThrow (EvalError value) m
|
||||
, MonadValue value m
|
||||
, Recursive term
|
||||
, Show (LocationFor value)
|
||||
)
|
||||
|
||||
|
||||
-- | 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 :: ModuleName -> LoadError term value [Module term]
|
||||
|
||||
deriving instance Eq (LoadError term a b)
|
||||
deriving instance Show (LoadError term a b)
|
||||
instance Show1 (LoadError term value) where
|
||||
liftShowsPrec _ _ = showsPrec
|
||||
instance Eq1 (LoadError term a) where
|
||||
liftEq _ (LoadError a) (LoadError b) = a == b
|
||||
|
||||
-- | The type of error thrown when failing to evaluate a term.
|
||||
data EvalError value resume where
|
||||
-- Indicates we weren't able to dereference a name from the evaluated environment.
|
||||
FreeVariableError :: Name -> EvalError value value
|
||||
|
||||
deriving instance Eq (EvalError a b)
|
||||
deriving instance Show (EvalError a b)
|
||||
instance Show1 (EvalError value) where
|
||||
liftShowsPrec _ _ = showsPrec
|
||||
instance Eq1 (EvalError term) where
|
||||
liftEq _ (FreeVariableError a) (FreeVariableError b) = a == b
|
||||
|
||||
throwLoadError :: MonadEvaluatable term value m => LoadError term value resume -> m resume
|
||||
throwLoadError = throwException
|
||||
|
||||
data Unspecialized a b where
|
||||
Unspecialized :: { getUnspecialized :: Prelude.String } -> Unspecialized value value
|
||||
|
||||
@ -96,9 +129,9 @@ require name = getModuleTable >>= maybe (load name) pure . moduleTableLookup nam
|
||||
load :: MonadEvaluatable term value m
|
||||
=> ModuleName
|
||||
-> m (EnvironmentFor value, value)
|
||||
load name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name
|
||||
load name = askModuleTable >>= maybe notFound pure . moduleTableLookup name >>= evalAndCache
|
||||
where
|
||||
notFound = fail ("cannot load module: " <> show name)
|
||||
notFound = throwLoadError (LoadError name)
|
||||
|
||||
evalAndCache [] = (,) <$> pure mempty <*> unit
|
||||
evalAndCache [x] = evalAndCache' x
|
||||
@ -148,5 +181,5 @@ withModules = localModuleTable . const . ModuleTable.fromList
|
||||
evaluateModules :: MonadEvaluatable term value m
|
||||
=> [Module term]
|
||||
-> m value
|
||||
evaluateModules [] = fail "evaluateModules: empty list"
|
||||
evaluateModules [] = fail "evaluateModules: empty list"
|
||||
evaluateModules (m:ms) = withModules ms (evaluateModule m)
|
||||
|
||||
@ -9,7 +9,7 @@ import Data.Abstract.Evaluatable
|
||||
import qualified Data.Abstract.Number as Number
|
||||
import Data.Scientific (Scientific)
|
||||
import qualified Data.Set as Set
|
||||
import Prologue
|
||||
import Prologue hiding (TypeError)
|
||||
import Prelude hiding (Float, Integer, String, Rational, fail)
|
||||
import qualified Prelude
|
||||
|
||||
@ -225,12 +225,12 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where
|
||||
pure (injValue (Namespace n (Env.mergeNewer env' env)))
|
||||
where asNamespaceEnv v
|
||||
| Just (Namespace _ env') <- prjValue v = pure env'
|
||||
| otherwise = fail ("expected " <> show v <> " to be a namespace")
|
||||
| otherwise = throwException $ NamespaceError ("expected " <> show v <> " to be a namespace")
|
||||
|
||||
scopedEnvironment o
|
||||
| Just (Class _ env) <- prjValue o = pure env
|
||||
| Just (Namespace _ env) <- prjValue o = pure env
|
||||
| otherwise = fail ("object type passed to scopedEnvironment doesn't have an environment: " <> show o)
|
||||
| otherwise = throwException $ ScopedEnvironmentError ("object type passed to scopedEnvironment doesn't have an environment: " <> show o)
|
||||
|
||||
asString v
|
||||
| Just (String n) <- prjValue v = pure n
|
||||
|
||||
@ -2,15 +2,14 @@
|
||||
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack
|
||||
module Data.Syntax where
|
||||
|
||||
import Control.Monad.Fail
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Abstract.Evaluatable hiding (catchError)
|
||||
import Data.AST
|
||||
import Data.Range
|
||||
import Data.Record
|
||||
import Data.Span
|
||||
import Data.Term
|
||||
import Diffing.Algorithm hiding (Empty)
|
||||
import Prelude hiding (fail)
|
||||
import Prelude
|
||||
import Prologue
|
||||
import qualified Assigning.Assignment as Assignment
|
||||
import qualified Data.Error as Error
|
||||
@ -107,7 +106,7 @@ instance Ord1 Identifier where liftCompare = genericLiftCompare
|
||||
instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Identifier where
|
||||
eval (Identifier name) = lookupWith deref name >>= maybe (fail ("free variable: " <> show (friendlyName name))) pure
|
||||
eval (Identifier name) = lookupWith deref name >>= maybe (throwException $ FreeVariableError name) pure
|
||||
|
||||
instance FreeVariables1 Identifier where
|
||||
liftFreeVariables _ (Identifier x) = pure x
|
||||
|
||||
@ -77,8 +77,11 @@ instance Eq1 Let where liftEq = genericLiftEq
|
||||
instance Ord1 Let where liftCompare = genericLiftCompare
|
||||
instance Show1 Let where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Let
|
||||
instance Evaluatable Let
|
||||
instance Evaluatable Let where
|
||||
eval Let{..} = do
|
||||
addr <- snd <$> letrec name (subtermValue letValue)
|
||||
localEnv (Env.insert name addr) (subtermValue letBody)
|
||||
where name = freeVariable (subterm letVariable)
|
||||
|
||||
|
||||
-- Assignment
|
||||
|
||||
@ -3,9 +3,11 @@
|
||||
{-# OPTIONS_GHC -Wno-missing-signatures #-}
|
||||
module Semantic.Util where
|
||||
|
||||
import Analysis.Abstract.BadVariables
|
||||
import Analysis.Abstract.Caching
|
||||
import Analysis.Abstract.Dead
|
||||
import Analysis.Abstract.Evaluating as X
|
||||
import Analysis.Abstract.ImportGraph
|
||||
import Analysis.Abstract.Tracing
|
||||
import Analysis.Declaration
|
||||
import Control.Abstract.Analysis
|
||||
@ -35,26 +37,29 @@ import System.FilePath.Posix
|
||||
|
||||
import qualified Language.Go.Assignment as Go
|
||||
import qualified Language.Python.Assignment as Python
|
||||
import qualified Language.Ruby.Assignment as Ruby
|
||||
import qualified Language.TypeScript.Assignment as TypeScript
|
||||
|
||||
-- Ruby
|
||||
evalRubyProject = evaluateProject rubyParser ["rb"]
|
||||
evalRubyFile = evaluateWithPrelude rubyParser
|
||||
evalRubyFiles = evaluateFilesWithPrelude rubyParser
|
||||
evaluateRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating Ruby.Term Value)) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths
|
||||
evaluateRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Ruby.Term Value)) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths
|
||||
|
||||
-- Go
|
||||
evalGoProject = evaluateProject goParser ["go"]
|
||||
evalGoFile = evaluateFile goParser
|
||||
evalGoFiles = evaluateFiles goParser
|
||||
typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluateModule <$> parseFile goParser Nothing path
|
||||
typecheckGoFile path = runAnalysis @(Caching (Evaluating Go.Term Type)) . evaluateModule <$> parseFile goParser Nothing path
|
||||
|
||||
-- Python
|
||||
evalPythonProject = evaluateProject pythonParser ["py"]
|
||||
evalPythonFile = evaluateWithPrelude pythonParser
|
||||
evalPythonFiles = evaluateFilesWithPrelude pythonParser
|
||||
typecheckPythonFile path = runAnalysis @(Caching Evaluating Python.Term Type) . evaluateModule <$> parseFile pythonParser Nothing path
|
||||
tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term Value) . evaluateModule <$> parseFile pythonParser Nothing path
|
||||
evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term Value) . evaluateModule <$> parseFile pythonParser Nothing path
|
||||
typecheckPythonFile path = runAnalysis @(Caching (Evaluating Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path
|
||||
tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Python.Term Value)) . evaluateModule <$> parseFile pythonParser Nothing path
|
||||
evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Python.Term Value))) . evaluateModule <$> parseFile pythonParser Nothing path
|
||||
|
||||
-- PHP
|
||||
evalPHP = evaluateProject phpParser ["php"]
|
||||
@ -65,12 +70,12 @@ evalPHPFiles = evaluateFiles phpParser
|
||||
evalTypeScriptProject = evaluateProject typescriptParser ["ts", "tsx"]
|
||||
evalTypeScriptFile = evaluateFile typescriptParser
|
||||
evalTypeScriptFiles = evaluateFiles typescriptParser
|
||||
typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term Type) . evaluateModule <$> parseFile typescriptParser Nothing path
|
||||
typecheckTypeScriptFile path = runAnalysis @(Caching (Evaluating TypeScript.Term Type)) . evaluateModule <$> parseFile typescriptParser Nothing path
|
||||
|
||||
evaluateProject :: forall term effects
|
||||
. ( Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, effects ~ RequiredEffects term Value (Evaluating term Value effects)
|
||||
, effects ~ Effects term Value (Evaluating term Value effects)
|
||||
, MonadAddressable Precise Value (Evaluating term Value effects)
|
||||
, MonadValue Value (Evaluating term Value effects)
|
||||
, Recursive term
|
||||
@ -90,7 +95,7 @@ getPaths exts = fmap fold . globDir (compile . mappend "**/*." <$> exts)
|
||||
evaluateFile :: forall term effects
|
||||
. ( Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, effects ~ RequiredEffects term Value (Evaluating term Value effects)
|
||||
, effects ~ Effects term Value (Evaluating term Value effects)
|
||||
, MonadAddressable Precise Value (Evaluating term Value effects)
|
||||
, MonadValue Value (Evaluating term Value effects)
|
||||
, Recursive term
|
||||
@ -101,7 +106,7 @@ evaluateFile :: forall term effects
|
||||
evaluateFile parser path = runAnalysis @(Evaluating term Value) . evaluateModule <$> parseFile parser Nothing path
|
||||
|
||||
evaluateWith :: forall value term effects
|
||||
. ( effects ~ RequiredEffects term value (Evaluating term value effects)
|
||||
. ( effects ~ Effects term value (Evaluating term value effects)
|
||||
, Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, MonadAddressable (LocationFor value) value (Evaluating term value effects)
|
||||
@ -124,7 +129,7 @@ evaluateWith prelude m = runAnalysis @(Evaluating term value) $ do
|
||||
evaluateWithPrelude :: forall term effects
|
||||
. ( Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, effects ~ RequiredEffects term Value (Evaluating term Value effects)
|
||||
, effects ~ Effects term Value (Evaluating term Value effects)
|
||||
, MonadAddressable Precise Value (Evaluating term Value effects)
|
||||
, MonadValue Value (Evaluating term Value effects)
|
||||
, Recursive term
|
||||
@ -144,7 +149,7 @@ evaluateWithPrelude parser path = do
|
||||
evaluateFiles :: forall term effects
|
||||
. ( Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, effects ~ RequiredEffects term Value (Evaluating term Value effects)
|
||||
, effects ~ Effects term Value (Evaluating term Value effects)
|
||||
, MonadAddressable Precise Value (Evaluating term Value effects)
|
||||
, MonadValue Value (Evaluating term Value effects)
|
||||
, Recursive term
|
||||
@ -157,7 +162,7 @@ evaluateFiles parser rootDir paths = runAnalysis @(Evaluating term Value) . eval
|
||||
|
||||
-- | Evaluate terms and an entry point to a value with a given prelude.
|
||||
evaluatesWith :: forall value term effects
|
||||
. ( effects ~ RequiredEffects term value (Evaluating term value effects)
|
||||
. ( effects ~ Effects term value (Evaluating term value effects)
|
||||
, Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, MonadAddressable (LocationFor value) value (Evaluating term value effects)
|
||||
@ -176,7 +181,7 @@ evaluatesWith prelude modules m = runAnalysis @(Evaluating term value) $ do
|
||||
evaluateFilesWithPrelude :: forall term effects
|
||||
. ( Evaluatable (Base term)
|
||||
, FreeVariables term
|
||||
, effects ~ RequiredEffects term Value (Evaluating term Value effects)
|
||||
, effects ~ Effects term Value (Evaluating term Value effects)
|
||||
, MonadAddressable Precise Value (Evaluating term Value effects)
|
||||
, MonadValue Value (Evaluating term Value effects)
|
||||
, Recursive term
|
||||
|
||||
@ -30,11 +30,11 @@ spec = parallel $ do
|
||||
|
||||
it "subclasses" $ do
|
||||
v <- fst <$> evaluate "subclass.py"
|
||||
v `shouldBe` Right (Right (Right (injValue (String "\"bar\""))))
|
||||
v `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"bar\""))))))
|
||||
|
||||
it "handles multiple inheritance left-to-right" $ do
|
||||
v <- fst <$> evaluate "multiple_inheritance.py"
|
||||
v `shouldBe` Right (Right (Right (injValue (String "\"foo!\""))))
|
||||
v `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"foo!\""))))))
|
||||
|
||||
where
|
||||
addr = Address . Precise
|
||||
|
||||
@ -2,7 +2,10 @@
|
||||
|
||||
module Analysis.Ruby.Spec (spec) where
|
||||
|
||||
import Data.Abstract.Evaluatable (EvalError(..))
|
||||
import Data.Abstract.Value
|
||||
import Control.Monad.Effect (SomeExc(..))
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Map
|
||||
import Data.Map.Monoidal as Map
|
||||
|
||||
@ -24,12 +27,12 @@ spec = parallel $ do
|
||||
|
||||
it "evaluates load with wrapper" $ do
|
||||
res <- evaluate "load-wrap.rb"
|
||||
fst res `shouldBe` Left "free variable: \"foo\""
|
||||
fst res `shouldBe` Right (Right (Right (Right (Left (SomeExc (FreeVariableError ("foo" :| [])))))))
|
||||
environment (snd res) `shouldBe` [ (name "Object", addr 0) ]
|
||||
|
||||
it "evaluates subclass" $ do
|
||||
res <- evaluate "subclass.rb"
|
||||
fst res `shouldBe` Right (Right (Right (injValue (String "\"<bar>\""))))
|
||||
fst res `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"<bar>\""))))))
|
||||
environment (snd res) `shouldBe` [ (name "Bar", addr 6)
|
||||
, (name "Foo", addr 3)
|
||||
, (name "Object", addr 0) ]
|
||||
@ -41,13 +44,13 @@ spec = parallel $ do
|
||||
|
||||
it "evaluates modules" $ do
|
||||
res <- evaluate "modules.rb"
|
||||
fst res `shouldBe` Right (Right (Right (injValue (String "\"<hello>\""))))
|
||||
fst res `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"<hello>\""))))))
|
||||
environment (snd res) `shouldBe` [ (name "Object", addr 0)
|
||||
, (name "Bar", addr 3) ]
|
||||
|
||||
it "has prelude" $ do
|
||||
res <- fst <$> evaluate "preluded.rb"
|
||||
res `shouldBe` Right (Right (Right (injValue (String "\"<foo>\""))))
|
||||
res `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"<foo>\""))))))
|
||||
|
||||
where
|
||||
ns n = Just . Latest . Just . injValue . Namespace (name n)
|
||||
|
||||
3
test/fixtures/ruby/analysis/src/foo.rb
vendored
Normal file
3
test/fixtures/ruby/analysis/src/foo.rb
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
def foo()
|
||||
return "in foo"
|
||||
end
|
||||
Loading…
Reference in New Issue
Block a user