github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-19 04:41:47 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #1663 from github/imports,-graphed

Browse Source 
Imports, graphed
This commit is contained in:
Josh Vera 2018-03-26 11:52:31 -04:00 committed by GitHub
commit 0afe70df71
12 changed files with 259 additions and 150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
semantic.cabal
View File

@ -18,6 +18,7 @@ library
Analysis.Abstract.Caching
, Analysis.Abstract.Collecting
, Analysis.Abstract.Dead
, Analysis.Abstract.ImportGraph
, Analysis.Abstract.Evaluating
, Analysis.Abstract.Tracing
, Analysis.CallGraph
@ -50,6 +51,7 @@ library
, Data.Abstract.FreeVariables
, Data.Abstract.Heap
, Data.Abstract.Live
, Data.Abstract.Module
, Data.Abstract.ModuleTable
, Data.Abstract.Number
, Data.Abstract.Path

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

@ -7,6 +7,7 @@ import Control.Abstract.Analysis
import Data.Abstract.Cache
import Data.Abstract.Configuration
import Data.Abstract.Heap
import Data.Abstract.Module
import Data.Abstract.Value
import Prologue
@ -93,8 +94,8 @@ instance ( Corecursive term
pairs <- consultOracle c
caching c pairs (liftAnalyze analyzeTerm e)
evaluateModule e = do
c <- getConfiguration e
analyzeModule m = do
c <- getConfiguration (subterm (moduleBody m))
-- Convergence here is predicated upon an Eq instance, not α-equivalence
cache <- converge (\ prevCache -> isolateCache $ do
putHeap (configurationHeap c)
@ -105,7 +106,7 @@ instance ( Corecursive term
-- that it doesn't "leak" to the calling context and diverge (otherwise this
-- would never complete). We don’t need to use the values, so we 'gather' the
-- nondeterministic values into @()@.
withOracle prevCache (gather (const ()) (Caching (evaluateModule e)))) mempty
withOracle prevCache (gather (const ()) (liftAnalyze analyzeModule m))) mempty
maybe empty scatter (cacheLookup c cache)
-- | Iterate a monadic action starting from some initial seed until the results converge.

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

@ -26,6 +26,8 @@ instance ( Effectful (m term value)
=> MonadEvaluator term value (Collecting m term value effects) where
getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap
askModuleStack = Collecting askModuleStack
instance ( Effectful (m term value)
, Foldable (Cell (LocationFor value))
@ -46,6 +48,8 @@ instance ( Effectful (m term value)
modifyHeap (gc (roots <> valueRoots v))
pure v
analyzeModule = liftAnalyze analyzeModule
-- | Retrieve the local 'Live' set.
askRoots :: (Effectful m, Member (Reader (Live (LocationFor value) value)) effects) => m effects (Live (LocationFor value) value)

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

@ -4,6 +4,7 @@ module Analysis.Abstract.Dead
) where
import Control.Abstract.Analysis
import Data.Abstract.Module
import Data.Semigroup.Reducer as Reducer
import Data.Set (delete)
import Prologue
@ -51,6 +52,6 @@ instance ( Corecursive term
revive (embedSubterm term)
liftAnalyze analyzeTerm term
evaluateModule term = do
killAll (subterms term)
DeadCode (evaluateModule term)
analyzeModule m = do
killAll (subterms (subterm (moduleBody m)))
liftAnalyze analyzeModule m

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

@ -2,17 +2,13 @@
StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Analysis.Abstract.Evaluating
( type Evaluating
, evaluate
, evaluates
, evaluateWith
, evaluatesWith
, findValue
, findEnv
, findHeap
, require
, load
) where
( type Evaluating
, findValue
, findEnv
, findHeap
, require
, load
) where
import Control.Abstract.Evaluator
import Control.Monad.Effect
@ -23,101 +19,15 @@ import qualified Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Data.Abstract.Exports (Exports)
import qualified Data.Abstract.Exports as Export
import Data.Abstract.Heap (Heap (..))
import Data.Abstract.Heap
import Data.Abstract.Module
import Data.Abstract.ModuleTable
import Data.Abstract.Value
import Data.Blob
import qualified Data.ByteString.Char8 as BC
import qualified Data.IntMap as IntMap
import Data.Language
import Data.List.Split (splitWhen)
import qualified Data.Map as Map
import qualified Data.Map.Monoidal as Monoidal
import Prelude hiding (fail)
import Prologue hiding (throwError)
import System.FilePath.Posix
-- | Evaluate a term to a value.
evaluate :: forall value term effects
. ( effects ~ RequiredEffects term value (Evaluating term value effects)
, Evaluatable (Base term)
, FreeVariables term
, MonadAddressable (LocationFor value) value (Evaluating term value effects)
, MonadValue value (Evaluating term value effects)
, Recursive term
, Show (LocationFor value)
)
=> term
-> Final effects value
evaluate = runAnalysis @(Evaluating term value) . evaluateModule
evaluateWith :: forall value term effects
. ( effects ~ RequiredEffects term value (Evaluating term value effects)
, Evaluatable (Base term)
, FreeVariables term
, MonadAddressable (LocationFor value) value (Evaluating term value effects)
, MonadValue value (Evaluating term value effects)
, Recursive term
, Show (LocationFor value)
)
=> term
-> term
-> Final effects value
evaluateWith prelude t = runAnalysis @(Evaluating term value) $ do
-- evaluateTerm here rather than evaluateModule
-- TODO: we could add evaluatePrelude to MonadAnalysis as an alias for evaluateModule,
-- overridden in Evaluating to not reset the environment. In the future we'll want the
-- result of evaluating the Prelude to be a build artifact, rather than something that's
-- evaluated every single time, but that's contingent upon a whole lot of other future
-- scaffolding.
preludeEnv <- evaluateTerm prelude *> getEnv
withDefaultEnvironment preludeEnv (evaluateModule t)
-- | Evaluate terms and an entry point to a value.
evaluates :: forall value term effects
. ( effects ~ RequiredEffects term value (Evaluating term value effects)
, Evaluatable (Base term)
, FreeVariables term
, MonadAddressable (LocationFor value) value (Evaluating term value effects)
, MonadValue value (Evaluating term value effects)
, Recursive term
, Show (LocationFor value)
)
=> [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated
-> (Blob, term) -- Entrypoint
-> Final effects value
evaluates pairs (b, t) = runAnalysis @(Evaluating term value) (withModules b pairs (evaluateModule t))
-- | 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)
, Evaluatable (Base term)
, FreeVariables term
, MonadAddressable (LocationFor value) value (Evaluating term value effects)
, MonadValue value (Evaluating term value effects)
, Recursive term
, Show (LocationFor value)
)
=> term -- ^ Prelude to evaluate once
-> [(Blob, term)] -- ^ List of (blob, term) pairs that make up the program to be evaluated
-> (Blob, term) -- ^ Entrypoint
-> Final effects value
evaluatesWith prelude pairs (b, t) = runAnalysis @(Evaluating term value) $ do
preludeEnv <- evaluateTerm prelude *> getEnv
withDefaultEnvironment preludeEnv (withModules b pairs (evaluateModule t))
-- | Run an action with the passed ('Blob', @term@) pairs available for imports.
withModules :: MonadAnalysis term value m => Blob -> [(Blob, term)] -> m a -> m a
withModules Blob{..} pairs = localModuleTable (const moduleTable)
where
moduleTable = ModuleTable (Map.fromListWith (<>) (map (bimap moduleName pure) pairs))
rootDir = dropFileName blobPath
moduleName Blob{..} = let path = dropExtensions (makeRelative rootDir blobPath)
in case blobLanguage of
-- TODO: Need a better way to handle module registration and resolution
Just Go -> toName (takeDirectory path) -- Go allows defining modules across multiple files in the same directory.
_ -> toName path
toName str = qualifiedName (fmap BC.pack (splitWhen (== pathSeparator) str))
-- | Require/import another module by name and return it's environment and value.
--
@ -136,7 +46,7 @@ load :: (MonadAnalysis term value m, MonadValue value m)
load name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name
where
notFound = fail ("cannot load module: " <> show name)
evalAndCache :: (MonadAnalysis term value m, MonadValue value m) => [term] -> m (EnvironmentFor value, value)
evalAndCache :: (MonadAnalysis term value m, MonadValue value m) => [Module term] -> m (EnvironmentFor value, value)
evalAndCache [] = (,) <$> pure mempty <*> unit
evalAndCache [x] = evalAndCache' x
evalAndCache (x:xs) = do
@ -144,7 +54,7 @@ load name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup n
(env', v') <- evalAndCache xs
pure (env <> env', v')
evalAndCache' :: (MonadAnalysis term value m) => term -> m (EnvironmentFor value, value)
evalAndCache' :: (MonadAnalysis term value m) => Module term -> m (EnvironmentFor value, value)
evalAndCache' x = do
v <- evaluateModule x
env <- filterEnv <$> getExports <*> getEnv
@ -172,10 +82,11 @@ deriving instance Member NonDet effects => MonadNonDet (Evaluating term value
type EvaluatingEffects term value
= '[ Resumable ValueExc
, Resumable (Unspecialized value)
, Fail -- Failure with an error message
, Fail -- Failure with an error message
, Reader [Module term] -- The stack of currently-evaluating modules.
, State (EnvironmentFor value) -- Environments (both local and global)
, State (HeapFor value) -- The heap
, Reader (ModuleTable [term]) -- Cache of unevaluated modules
, Reader (ModuleTable [Module term]) -- Cache of unevaluated modules
, Reader (EnvironmentFor value) -- Default environment used as a fallback in lookupEnv
, State (ModuleTable (EnvironmentFor value, value)) -- Cache of evaluated modules
, State (ExportsFor value) -- Exports (used to filter environments when they are imported)
@ -238,7 +149,7 @@ instance Member (State (HeapFor value)) effects => MonadHeap value (Evaluating t
getHeap = raise get
putHeap = raise . put
instance Members '[Reader (ModuleTable [term]), State (ModuleTable (EnvironmentFor value, value))] effects => MonadModuleTable term value (Evaluating term value effects) where
instance Members '[Reader (ModuleTable [Module term]), State (ModuleTable (EnvironmentFor value, value))] effects => MonadModuleTable term value (Evaluating term value effects) where
getModuleTable = raise get
putModuleTable = raise . put
@ -248,6 +159,8 @@ instance Members '[Reader (ModuleTable [term]), State (ModuleTable (EnvironmentF
instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value (Evaluating term value effects) where
getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap
askModuleStack = raise ask
instance ( Evaluatable (Base term)
, FreeVariables term
, Members (EvaluatingEffects term value) effects
@ -260,3 +173,8 @@ instance ( Evaluatable (Base term)
type RequiredEffects term value (Evaluating term value effects) = EvaluatingEffects term value
analyzeTerm term = resumeException @(Unspecialized value) (eval term) (\yield (Unspecialized str) -> string (BC.pack str) >>= yield)
analyzeModule m = pushModule (subterm <$> m) (subtermValue (moduleBody m))
pushModule :: Member (Reader [Module term]) effects => Module term -> Evaluating term value effects a -> Evaluating term value effects a
pushModule m = raise . local (m :) . lower

75
src/Analysis/Abstract/ImportGraph.hs Normal file
View File

@ -0,0 +1,75 @@
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.ImportGraph
( ImportGraph(..)
, renderImportGraph
, ImportGraphing
) where
import qualified Algebra.Graph as G
import Algebra.Graph.Class
import Algebra.Graph.Export.Dot
import Control.Abstract.Analysis
import Data.Abstract.FreeVariables
import Data.Abstract.Module
import Prologue hiding (empty)
-- | The graph of function definitions to symbols used in a given program.
newtype ImportGraph = ImportGraph { unImportGraph :: G.Graph Name }
deriving (Eq, Graph, Show)
-- | Render a 'ImportGraph' to a 'ByteString' in DOT notation.
renderImportGraph :: ImportGraph -> ByteString
renderImportGraph = export (defaultStyle friendlyName) . unImportGraph
newtype ImportGraphing m term value (effects :: [* -> *]) a = ImportGraphing (m term value 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)
instance ( Effectful (m term value)
, Member (State ImportGraph) effects
, MonadAnalysis term value (m 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)
analyzeTerm = liftAnalyze analyzeTerm
analyzeModule m = do
ms <- askModuleStack
let parent = maybe empty (vertex . moduleName) (listToMaybe ms)
modifyImportGraph (parent >< vertex (moduleName m) <>)
liftAnalyze analyzeModule m
(><) :: 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 = raise . modify
instance Semigroup ImportGraph where
(<>) = overlay
instance Monoid ImportGraph where
mempty = empty
mappend = (<>)
instance Ord ImportGraph where
compare (ImportGraph G.Empty) (ImportGraph G.Empty) = EQ
compare (ImportGraph G.Empty) _ = LT
compare _ (ImportGraph G.Empty) = GT
compare (ImportGraph (G.Vertex a)) (ImportGraph (G.Vertex b)) = compare a b
compare (ImportGraph (G.Vertex _)) _ = LT
compare _ (ImportGraph (G.Vertex _)) = GT
compare (ImportGraph (G.Overlay a1 a2)) (ImportGraph (G.Overlay b1 b2)) = (compare `on` ImportGraph) a1 b1 <> (compare `on` ImportGraph) a2 b2
compare (ImportGraph (G.Overlay _ _)) _ = LT
compare _ (ImportGraph (G.Overlay _ _)) = GT
compare (ImportGraph (G.Connect a1 a2)) (ImportGraph (G.Connect b1 b2)) = (compare `on` ImportGraph) a1 b1 <> (compare `on` ImportGraph) a2 b2

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

@ -38,6 +38,8 @@ instance ( Corecursive term
trace (Reducer.unit config)
liftAnalyze analyzeTerm term
analyzeModule = liftAnalyze analyzeModule
-- | Log the given trace of configurations.
trace :: ( Effectful (m term value)
, Member (Writer (trace (ConfigurationFor term value))) effects

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

@ -3,6 +3,9 @@
module Control.Abstract.Analysis
( MonadAnalysis(..)
, evaluateTerm
, evaluateModule
, withModules
, evaluateModules
, liftAnalyze
, runAnalysis
, module X
@ -18,8 +21,10 @@ 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 Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import Data.Coerce
import Prelude
import Prelude hiding (fail)
import Prologue
-- | A 'Monad' in which one can evaluate some specific term type to some specific value type.
@ -29,12 +34,11 @@ class (MonadEvaluator term value m, Recursive term) => MonadAnalysis term value
-- | 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 :: [* -> *]
-- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances.
-- | Analyze a term using the semantics of the current analysis. This should generally only be called by 'evaluateTerm' and by definitions of 'analyzeTerm' in instances for composite analyses.
analyzeTerm :: SubtermAlgebra (Base term) term (m value)
-- | Evaluate a (root-level) term to a value using the semantics of the current analysis. This should be used to evaluate single-term programs as well as each module in multi-term programs.
evaluateModule :: term -> m value
evaluateModule = evaluateTerm
-- | 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 :: SubtermAlgebra Module term (m value)
-- | Isolate the given action with an empty global environment and exports.
isolate :: m a -> m a
@ -46,13 +50,28 @@ class (MonadEvaluator term value m, Recursive term) => MonadAnalysis term value
evaluateTerm :: MonadAnalysis term value m => term -> m value
evaluateTerm = foldSubterms analyzeTerm
-- | Evaluate a (root-level) term to a value using the semantics of the current analysis. This should be used to evaluate single-term programs as well as each module in multi-term programs.
evaluateModule :: MonadAnalysis term value m => Module term -> m value
evaluateModule m = analyzeModule (fmap (Subterm <*> evaluateTerm) m)
-- | Run an action with the a list of 'Module's available for imports.
withModules :: MonadAnalysis term value m => [Module term] -> m a -> m a
withModules = localModuleTable . const . ModuleTable.fromList
-- | Evaluate with a list of modules in scope, taking the head module as the entry point.
evaluateModules :: MonadAnalysis term value m => [Module term] -> m value
evaluateModules [] = fail "evaluateModules: empty list"
evaluateModules (m:ms) = withModules ms (evaluateModule m)
-- | 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)
, Coercible (t m term value effects value) ( m term value effects value)
, Functor (Base term)
, Functor base
)
=> SubtermAlgebra (Base term) term ( m term value effects value)
-> SubtermAlgebra (Base term) term (t m term value effects value)
=> SubtermAlgebra base term ( m term value effects value)
-> SubtermAlgebra base term (t m term value effects value)
liftAnalyze analyze term = coerce (analyze (second coerce <$> term))

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

@ -23,10 +23,10 @@ import qualified Data.Abstract.Environment as Env
import qualified Data.Abstract.Exports as Export
import Data.Abstract.FreeVariables
import Data.Abstract.Heap
import Data.Abstract.Module
import Data.Abstract.ModuleTable
import Data.Abstract.Value
import Data.Semigroup.Reducer
import Prelude
import Prologue
-- | A 'Monad' providing the basic essentials for evaluation.
@ -45,6 +45,12 @@ class ( MonadControl term m
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: Ord (LocationFor value) => term -> m (ConfigurationFor term value)
-- | Retrieve the stack of modules currently being evaluated.
--
-- With great power comes great responsibility. If you 'evaluateModule' any of these, you probably deserve what you get.
askModuleStack :: m [Module term]
-- | A 'Monad' abstracting local and global environments.
class Monad m => MonadEnvironment value m | m -> value where
-- | Retrieve the environment.
@ -142,9 +148,9 @@ class Monad m => MonadModuleTable term value m | m -> term, m -> value where
putModuleTable :: ModuleTable (EnvironmentFor value, value) -> m ()
-- | Retrieve the table of unevaluated modules.
askModuleTable :: m (ModuleTable [term])
askModuleTable :: m (ModuleTable [Module term])
-- | Run an action with a locally-modified table of unevaluated modules.
localModuleTable :: (ModuleTable [term] -> ModuleTable [term]) -> m a -> m a
localModuleTable :: (ModuleTable [Module term] -> ModuleTable [Module term]) -> m a -> m a
-- | Update the evaluated module table.
modifyModuleTable :: MonadModuleTable term value m => (ModuleTable (EnvironmentFor value, value) -> ModuleTable (EnvironmentFor value, value)) -> m ()

32
src/Data/Abstract/Module.hs Normal file
View File

@ -0,0 +1,32 @@
module Data.Abstract.Module
( Module(..)
, ModuleName
, moduleForBlob
) where
import Data.Abstract.FreeVariables
import Data.Blob
import qualified Data.ByteString.Char8 as BC
import Data.Language
import Data.List.Split (splitWhen)
import System.FilePath.Posix
type ModuleName = Name
data Module term = Module { moduleName :: ModuleName, modulePath :: FilePath, moduleBody :: term }
deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
-- | Construct a 'Module' for a 'Blob' and @term@, relative to some root 'FilePath'.
moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the module will be resolved, if any.
-> Blob -- ^ The 'Blob' containing the module.
-> term -- ^ The @term@ representing the body of the module.
-> Module term -- ^ A 'Module' named appropriate for the 'Blob', holding the @term@, and constructed relative to the root 'FilePath', if any.
moduleForBlob rootDir blob = Module (moduleNameForPath (modulePathForBlob blob)) (blobPath blob)
where modulePathForBlob Blob{..} | Just Go <- blobLanguage = takeDirectory (modulePath blobPath)
| otherwise = modulePath blobPath
-- TODO: Need a better way to handle module registration and resolution
modulePath = dropExtensions . maybe takeFileName makeRelative rootDir
moduleNameForPath :: FilePath -> ModuleName
moduleNameForPath = qualifiedName . map BC.pack . splitWhen (== pathSeparator)

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

@ -1,18 +1,16 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.Abstract.ModuleTable
( ModuleName
, ModuleTable (..)
, moduleTableLookup
, moduleTableInsert
) where
( ModuleName
, ModuleTable (..)
, moduleTableLookup
, moduleTableInsert
, fromList
) where
import Data.Abstract.FreeVariables
import Data.Semigroup
import GHC.Generics
import Data.Abstract.Module
import qualified Data.Map as Map
type ModuleName = Name
import Data.Semigroup
import GHC.Generics (Generic1)
newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModuleName a }
deriving (Eq, Foldable, Functor, Generic1, Monoid, Ord, Semigroup, Show, Traversable)
@ -22,3 +20,9 @@ moduleTableLookup k = Map.lookup k . unModuleTable
moduleTableInsert :: ModuleName -> a -> ModuleTable a -> ModuleTable a
moduleTableInsert k v ModuleTable{..} = ModuleTable (Map.insert k v unModuleTable)
-- | Construct a 'ModuleTable' from a list of 'Module's.
fromList :: [Module term] -> ModuleTable [Module term]
fromList modules = ModuleTable (Map.fromListWith (<>) (map toEntry modules))
where toEntry m = (moduleName m, [m])

81
src/Semantic/Util.hs
View File

@ -12,6 +12,7 @@ import Control.Abstract.Analysis
import Control.Monad.IO.Class
import Data.Abstract.Evaluatable
import Data.Abstract.Address
import Data.Abstract.Module
import Data.Abstract.Type
import Data.Abstract.Value
import Data.Blob
@ -29,6 +30,7 @@ import Prologue
import Semantic
import Semantic.IO as IO
import Semantic.Task
import System.FilePath.Posix
import qualified Language.Go.Assignment as Go
import qualified Language.Python.Assignment as Python
@ -41,21 +43,21 @@ evaluateRubyFiles = evaluateFilesWithPrelude rubyParser
-- Go
evaluateGoFile = evaluateFile goParser
evaluateGoFiles = evaluateFiles goParser
typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluateModule . snd <$> parseFile goParser path
typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluateModule <$> parseFile goParser Nothing path
-- Python
evaluatePythonFile = evaluateWithPrelude pythonParser
evaluatePythonFiles = evaluateFilesWithPrelude pythonParser
typecheckPythonFile path = runAnalysis @(Caching Evaluating Python.Term Type) . evaluateModule . snd <$> parseFile pythonParser path
tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term Value) . evaluateModule . snd <$> parseFile pythonParser path
evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term Value) . evaluateModule . snd <$> parseFile pythonParser 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
evaluatePHPFile = evaluateFile phpParser
evaluatePHPFiles = evaluateFiles phpParser
-- TypeScript
typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term Type) . evaluateModule . snd <$> parseFile typescriptParser path
typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term Type) . evaluateModule <$> parseFile typescriptParser Nothing path
evaluateTypeScriptFile = evaluateFile typescriptParser
evaluateTypeScriptFiles = evaluateFiles typescriptParser
@ -71,7 +73,28 @@ evaluateFile :: forall term effects
=> Parser term
-> FilePath
-> IO (Final effects Value)
evaluateFile parser path = evaluate . snd <$> parseFile parser path
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)
, Evaluatable (Base term)
, FreeVariables term
, MonadAddressable (LocationFor value) value (Evaluating term value effects)
, MonadValue value (Evaluating term value effects)
, Recursive term
, Show (LocationFor value)
)
=> Module term
-> Module term
-> Final effects value
evaluateWith prelude m = runAnalysis @(Evaluating term value) $ do
-- TODO: we could add evaluatePrelude to MonadAnalysis as an alias for evaluateModule,
-- overridden in Evaluating to not reset the environment. In the future we'll want the
-- result of evaluating the Prelude to be a build artifact, rather than something that's
-- evaluated every single time, but that's contingent upon a whole lot of other future
-- scaffolding.
preludeEnv <- evaluateModule prelude *> getEnv
withDefaultEnvironment preludeEnv (evaluateModule m)
evaluateWithPrelude :: forall term effects
. ( Evaluatable (Base term)
@ -87,9 +110,10 @@ evaluateWithPrelude :: forall term effects
-> IO (Final effects Value)
evaluateWithPrelude parser path = do
let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term))
prelude <- parseFile parser preludePath
blob <- parseFile parser path
pure $ evaluateWith (snd prelude) (snd blob)
prelude <- parseFile parser Nothing preludePath
m <- parseFile parser Nothing path
pure $ evaluateWith prelude m
-- Evaluate a list of files (head of file list is considered the entry point).
evaluateFiles :: forall term effects
@ -103,9 +127,25 @@ evaluateFiles :: forall term effects
=> Parser term
-> [FilePath]
-> IO (Final effects Value)
evaluateFiles parser paths = do
entry:xs <- traverse (parseFile parser) paths
pure $ evaluates @Value xs entry
evaluateFiles parser paths = runAnalysis @(Evaluating term Value) . evaluateModules <$> parseFiles parser paths
-- | 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)
, Evaluatable (Base term)
, FreeVariables term
, MonadAddressable (LocationFor value) value (Evaluating term value effects)
, MonadValue value (Evaluating term value effects)
, Recursive term
, Show (LocationFor value)
)
=> Module term -- ^ Prelude to evaluate once
-> [Module term] -- ^ List of (blob, term) pairs that make up the program to be evaluated
-> Module term -- ^ Entrypoint
-> Final effects value
evaluatesWith prelude modules m = runAnalysis @(Evaluating term value) $ do
preludeEnv <- evaluateModule prelude *> getEnv
withDefaultEnvironment preludeEnv (withModules modules (evaluateModule m))
evaluateFilesWithPrelude :: forall term effects
. ( Evaluatable (Base term)
@ -121,15 +161,20 @@ evaluateFilesWithPrelude :: forall term effects
-> IO (Final effects Value)
evaluateFilesWithPrelude parser paths = do
let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term))
prelude <- parseFile parser preludePath
entry:xs <- traverse (parseFile parser) paths
pure $ evaluatesWith @Value (snd prelude) xs entry
prelude <- parseFile parser Nothing preludePath
entry:xs <- traverse (parseFile parser Nothing) paths
pure $ evaluatesWith @Value prelude xs entry
-- Read and parse a file.
parseFile :: Parser term -> FilePath -> IO (Blob, term)
parseFile parser path = runTask $ do
parseFile :: Parser term -> Maybe FilePath -> FilePath -> IO (Module term)
parseFile parser rootDir path = runTask $ do
blob <- file path
(,) blob <$> parse parser blob
moduleForBlob rootDir blob <$> parse parser blob
parseFiles :: Parser term -> [FilePath] -> IO [Module term]
parseFiles parser paths = traverse (parseFile parser (Just (dropFileName (head paths)))) paths
-- Read a file from the filesystem into a Blob.
file :: MonadIO m => FilePath -> m Blob