From 56dbd8b6a131a0caea890b2de2c1cf9915d0130f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 17:54:49 -0400 Subject: [PATCH 01/68] Copy the CallGraph stuff into a new module. --- semantic.cabal | 1 + src/Analysis/Abstract/ImportGraph.hs | 111 +++++++++++++++++++++++++++ 2 files changed, 112 insertions(+) create mode 100644 src/Analysis/Abstract/ImportGraph.hs diff --git a/semantic.cabal b/semantic.cabal index 132722e06..0463bcc8d 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -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 diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs new file mode 100644 index 000000000..eb39c919d --- /dev/null +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} +module Analysis.Abstract.ImportGraph +( ImportGraph(..) +, renderImportGraph +, buildImportGraph +, ImportGraphAlgebra(..) +) where + +import qualified Algebra.Graph as G +import Algebra.Graph.Class +import Algebra.Graph.Export.Dot +import Data.Abstract.FreeVariables +import Data.Set (member) +import qualified Data.Syntax as Syntax +import qualified Data.Syntax.Declaration as Declaration +import Data.Term +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) + +-- | Build the 'ImportGraph' for a 'Term' recursively. +buildImportGraph :: (ImportGraphAlgebra syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> ImportGraph +buildImportGraph = foldSubterms importGraphAlgebra + + +-- | Render a 'ImportGraph' to a 'ByteString' in DOT notation. +renderImportGraph :: ImportGraph -> ByteString +renderImportGraph = export (defaultStyle friendlyName) . unImportGraph + + +-- | Types which contribute to a 'ImportGraph'. There is exactly one instance of this typeclass; customizing the 'ImportGraph's for a new type is done by defining an instance of 'CustomImportGraphAlgebra' instead. +-- +-- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap. +class ImportGraphAlgebra syntax where + -- | A 'SubtermAlgebra' computing the 'ImportGraph' for a piece of @syntax@. + importGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> ImportGraph)) -> Set Name -> ImportGraph + +instance (ImportGraphAlgebraStrategy syntax ~ strategy, ImportGraphAlgebraWithStrategy strategy syntax) => ImportGraphAlgebra syntax where + importGraphAlgebra = importGraphAlgebraWithStrategy (Proxy :: Proxy strategy) + + +-- | Types whose contribution to a 'ImportGraph' is customized. If an instance’s definition is not being used, ensure that the type is mapped to 'Custom' in the 'ImportGraphAlgebraStrategy'. +class CustomImportGraphAlgebra syntax where + customImportGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> ImportGraph)) -> Set Name -> ImportGraph + +-- | 'Declaration.Function's produce a vertex for their name, with edges to any free variables in their body. +instance CustomImportGraphAlgebra Declaration.Function where + customImportGraphAlgebra Declaration.Function{..} bound = foldMap vertex (freeVariables (subterm functionName)) `connect` subtermValue functionBody (foldMap (freeVariables . subterm) functionParameters <> bound) + +-- | 'Declaration.Method's produce a vertex for their name, with edges to any free variables in their body. +instance CustomImportGraphAlgebra Declaration.Method where + customImportGraphAlgebra Declaration.Method{..} bound = foldMap vertex (freeVariables (subterm methodName)) `connect` subtermValue methodBody (foldMap (freeVariables . subterm) methodParameters <> bound) + +-- | 'Syntax.Identifier's produce a vertex iff it’s unbound in the 'Set'. +instance CustomImportGraphAlgebra Syntax.Identifier where + customImportGraphAlgebra (Syntax.Identifier name) bound + | name `member` bound = empty + | otherwise = vertex name + +instance Apply ImportGraphAlgebra syntaxes => CustomImportGraphAlgebra (Union syntaxes) where + customImportGraphAlgebra = Prologue.apply (Proxy :: Proxy ImportGraphAlgebra) importGraphAlgebra + +instance ImportGraphAlgebra syntax => CustomImportGraphAlgebra (TermF syntax a) where + customImportGraphAlgebra = importGraphAlgebra . termFOut + + +-- | The mechanism selecting 'Default'/'Custom' implementations for 'importGraphAlgebra' depending on the @syntax@ type. +class ImportGraphAlgebraWithStrategy (strategy :: Strategy) syntax where + importGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term (Set Name -> ImportGraph)) -> Set Name -> ImportGraph + +-- | The 'Default' definition of 'importGraphAlgebra' combines all of the 'ImportGraph's within the @syntax@ 'Monoid'ally. +instance Foldable syntax => ImportGraphAlgebraWithStrategy 'Default syntax where + importGraphAlgebraWithStrategy _ = foldMap subtermValue + +-- | The 'Custom' strategy calls out to the 'customImportGraphAlgebra' method. +instance CustomImportGraphAlgebra syntax => ImportGraphAlgebraWithStrategy 'Custom syntax where + importGraphAlgebraWithStrategy _ = customImportGraphAlgebra + + +-- | Which instance of 'CustomImportGraphAlgebra' to use for a given @syntax@ type. +data Strategy = Default | Custom + +-- | A mapping of @syntax@ types onto 'Strategy's. +type family ImportGraphAlgebraStrategy syntax where + ImportGraphAlgebraStrategy Declaration.Function = 'Custom + ImportGraphAlgebraStrategy Declaration.Method = 'Custom + ImportGraphAlgebraStrategy Syntax.Identifier = 'Custom + ImportGraphAlgebraStrategy (Union fs) = 'Custom + ImportGraphAlgebraStrategy (TermF f a) = 'Custom + ImportGraphAlgebraStrategy a = 'Default + +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 From f476eb22bd4c257506603af191608b6c671df96b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 17:59:16 -0400 Subject: [PATCH 02/68] Stub in a Data.Abstract.Module module. --- semantic.cabal | 1 + src/Data/Abstract/Module.hs | 1 + 2 files changed, 2 insertions(+) create mode 100644 src/Data/Abstract/Module.hs diff --git a/semantic.cabal b/semantic.cabal index 0463bcc8d..241f3dcb6 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -51,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 diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs new file mode 100644 index 000000000..bcd0af682 --- /dev/null +++ b/src/Data/Abstract/Module.hs @@ -0,0 +1 @@ +module Data.Abstract.Module where From f032aec337df423a163d343356c873316bf6c1cd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 19:09:06 -0400 Subject: [PATCH 03/68] Define a Module type. --- src/Data/Abstract/Module.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index bcd0af682..b32f98397 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -1 +1,10 @@ -module Data.Abstract.Module where +module Data.Abstract.Module +( Module(..) +, ModuleName +) where + +import Data.Abstract.FreeVariables + +type ModuleName = Name + +data Module term = Module { moduleName :: ModuleName, modulePath :: FilePath, moduleTerm :: term } From 84843b8a601b9d1555b6bad1afe1784cbe10ac66 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 19:09:16 -0400 Subject: [PATCH 04/68] Move ModuleName to Module. --- src/Data/Abstract/ModuleTable.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index a913dd81d..85969b7fb 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -6,14 +6,11 @@ module Data.Abstract.ModuleTable , moduleTableInsert ) where -import Data.Abstract.FreeVariables +import Data.Abstract.Module import Data.Semigroup import GHC.Generics import qualified Data.Map as Map - -type ModuleName = Name - newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModuleName a } deriving (Eq, Foldable, Functor, Generic1, Monoid, Ord, Semigroup, Show, Traversable) From 5af7154996c0b9bcbc756a1d2229acca408b92cf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 19:09:37 -0400 Subject: [PATCH 05/68] Derive a bunch of instances for Module. --- src/Data/Abstract/Module.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index b32f98397..7b7fa997b 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -8,3 +8,4 @@ import Data.Abstract.FreeVariables type ModuleName = Name data Module term = Module { moduleName :: ModuleName, modulePath :: FilePath, moduleTerm :: term } + deriving (Eq, Foldable, Functor, Ord, Show, Traversable) From 9d1cf41d6372f30446b1f5a3a0a1af1772a3c7ff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 19:20:08 -0400 Subject: [PATCH 06/68] Rename moduleTerm to moduleBody. --- src/Data/Abstract/Module.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index 7b7fa997b..0954eef62 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -7,5 +7,5 @@ import Data.Abstract.FreeVariables type ModuleName = Name -data Module term = Module { moduleName :: ModuleName, modulePath :: FilePath, moduleTerm :: term } +data Module term = Module { moduleName :: ModuleName, modulePath :: FilePath, moduleBody :: term } deriving (Eq, Foldable, Functor, Ord, Show, Traversable) From 1002395074a0c555404aff66f4c8f66fb8ece88c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 19:30:51 -0400 Subject: [PATCH 07/68] The Reader module table holds Modules. --- src/Analysis/Abstract/Evaluating.hs | 12 +++++++----- src/Control/Abstract/Analysis.hs | 3 ++- src/Control/Abstract/Evaluator.hs | 5 +++-- 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index cb89fea6a..1e25301b4 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -13,6 +13,7 @@ import Control.Monad.Effect.State import Data.Abstract.Configuration import qualified Data.Abstract.Environment as Env import Data.Abstract.Evaluatable +import Data.Abstract.Module import Data.Abstract.ModuleTable import Data.Abstract.Value import Data.Blob @@ -56,10 +57,11 @@ evaluates pairs (b, t) = runAnalysis @(Evaluating term value) (withModules b pai -- | 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) +withModules blob pairs = localModuleTable (const moduleTable) where - moduleTable = ModuleTable (Map.fromListWith (<>) (map (bimap moduleName pure) pairs)) - rootDir = dropFileName blobPath + moduleTable = ModuleTable (Map.fromListWith (<>) (map toModulePair pairs)) + rootDir = dropFileName (blobPath blob) + toModulePair (blob, term) = let name = moduleName blob in (name, [Module name (blobPath blob) term]) moduleName Blob{..} = let path = dropExtensions (makeRelative rootDir blobPath) in case blobLanguage of -- TODO: Need a better way to handle module registration and resolution @@ -81,7 +83,7 @@ type EvaluatingEffects term value = '[ Fail -- Failure with an error message , 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 , State (ModuleTable (EnvironmentFor value)) -- Cache of evaluated modules , State (ExportsFor value) -- Exports (used to filter environments when they are imported) , State (IntMap.IntMap term) -- For jumps @@ -114,7 +116,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))] effects => MonadModuleTable term value (Evaluating term value effects) where +instance Members '[Reader (ModuleTable [Module term]), State (ModuleTable (EnvironmentFor value))] effects => MonadModuleTable term value (Evaluating term value effects) where getModuleTable = raise get putModuleTable = raise . put diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 8b215ee07..943e759ba 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -24,6 +24,7 @@ import Data.Abstract.Environment (Environment) import qualified Data.Abstract.Environment as Env import Data.Abstract.Exports (Exports) import qualified Data.Abstract.Exports as Export +import Data.Abstract.Module import Data.Abstract.ModuleTable import Data.Abstract.Value import Data.Coerce @@ -73,7 +74,7 @@ load :: ( MonadAnalysis term value m ) => ModuleName -> m (EnvironmentFor value) -load name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name +load name = askModuleTable >>= maybe notFound (evalAndCache . map moduleBody) . moduleTableLookup name where notFound = fail ("cannot load module: " <> show name) evalAndCache :: (MonadAnalysis term value m, Ord (LocationFor value)) => [term] -> m (EnvironmentFor value) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index f7456094b..1b7159ee1 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -21,6 +21,7 @@ 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 @@ -128,9 +129,9 @@ class Monad m => MonadModuleTable term value m | m -> term, m -> value where putModuleTable :: ModuleTable (EnvironmentFor 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) -> ModuleTable (EnvironmentFor value)) -> m () From 0f16b4e9737fb86e6f694a35e6fc0bef532f8a21 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 19:35:15 -0400 Subject: [PATCH 08/68] Move withModules into Control.Abstract.Analysis. --- src/Analysis/Abstract/Evaluating.hs | 19 ------------------- src/Control/Abstract/Analysis.hs | 23 +++++++++++++++++++++++ 2 files changed, 23 insertions(+), 19 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 1e25301b4..2c4255366 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -18,13 +18,8 @@ import Data.Abstract.ModuleTable import Data.Abstract.Value import Data.Blob import qualified Data.IntMap as IntMap -import Data.Language -import Data.List.Split (splitWhen) import Prelude hiding (fail) import Prologue -import qualified Data.ByteString.Char8 as BC -import qualified Data.Map as Map -import System.FilePath.Posix -- | Evaluate a term to a value. evaluate :: forall value term effects @@ -55,20 +50,6 @@ evaluates :: forall value term effects -> Final effects value evaluates pairs (b, t) = runAnalysis @(Evaluating term value) (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 toModulePair pairs)) - rootDir = dropFileName (blobPath blob) - toModulePair (blob, term) = let name = moduleName blob in (name, [Module name (blobPath blob) term]) - 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)) - -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. newtype Evaluating term value effects a = Evaluating (Eff effects a) deriving (Applicative, Functor, Effectful, Monad) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 943e759ba..63e3b36ea 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -3,6 +3,7 @@ module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm +, withModules , require , load , liftAnalyze @@ -24,12 +25,19 @@ import Data.Abstract.Environment (Environment) import qualified Data.Abstract.Environment as Env import Data.Abstract.Exports (Exports) import qualified Data.Abstract.Exports as Export +import Data.Abstract.FreeVariables import Data.Abstract.Module import Data.Abstract.ModuleTable import Data.Abstract.Value +import Data.Blob +import qualified Data.ByteString.Char8 as BC import Data.Coerce +import Data.Language +import Data.List.Split (splitWhen) +import qualified Data.Map as Map import Prelude hiding (fail) import Prologue +import System.FilePath.Posix -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- @@ -56,6 +64,21 @@ evaluateTerm :: MonadAnalysis term value m => term -> m value evaluateTerm = foldSubterms analyzeTerm +-- | 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 toModulePair pairs)) + rootDir = dropFileName (blobPath blob) + toModulePair (blob, term) = let name = moduleName blob in (name, [Module name (blobPath blob) term]) + 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 term/file and return an Effect. -- -- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module. From 864606af8a81b6ea15abe6dcc96dc4e997e48148 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 19:44:48 -0400 Subject: [PATCH 09/68] Call withModules directly in Semantic.Util. --- src/Semantic/Util.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index a04782715..4d1be57cc 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -81,7 +81,7 @@ evaluateFiles :: forall term effects -> IO (Final effects Value) evaluateFiles parser paths = do entry:xs <- traverse (parseFile parser) paths - pure $ evaluates @Value xs entry + pure . runAnalysis @(Evaluating term Value) . withModules (fst entry) xs $ evaluateModule (snd entry) -- Read and parse a file. parseFile :: Parser term -> FilePath -> IO (Blob, term) From ba73ae1eaa7ed91603719ef70d95c89ee1078e3d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 19:44:53 -0400 Subject: [PATCH 10/68] :fire: evaluates. --- src/Analysis/Abstract/Evaluating.hs | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 2c4255366..066d8b91e 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -2,7 +2,6 @@ module Analysis.Abstract.Evaluating ( type Evaluating , evaluate -, evaluates ) where import Control.Abstract.Evaluator @@ -16,7 +15,6 @@ import Data.Abstract.Evaluatable import Data.Abstract.Module import Data.Abstract.ModuleTable import Data.Abstract.Value -import Data.Blob import qualified Data.IntMap as IntMap import Prelude hiding (fail) import Prologue @@ -35,20 +33,6 @@ evaluate :: forall value term effects -> Final effects value evaluate = runAnalysis @(Evaluating term value) . evaluateModule --- | 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)) -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. newtype Evaluating term value effects a = Evaluating (Eff effects a) From 21ee6565388d5f54ab7a1c15557975ac3fff8e96 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 19:45:47 -0400 Subject: [PATCH 11/68] Run the analysis directly in Util. --- src/Semantic/Util.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 4d1be57cc..cba43a397 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -65,7 +65,7 @@ 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 . snd <$> parseFile parser path -- Evaluate a list of files (head of file list is considered the entry point). evaluateFiles :: forall term effects From 1cc91b78dcc7982eb52e9f5b3c0f8fd6f289211e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 19:46:03 -0400 Subject: [PATCH 12/68] :fire: evaluate. --- src/Analysis/Abstract/Evaluating.hs | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 066d8b91e..b5f596842 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Evaluating ( type Evaluating -, evaluate ) where import Control.Abstract.Evaluator @@ -19,21 +18,6 @@ import qualified Data.IntMap as IntMap import Prelude hiding (fail) import Prologue --- | 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 - - -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. newtype Evaluating term value effects a = Evaluating (Eff effects a) deriving (Applicative, Functor, Effectful, Monad) From 7e2b8b93e4826a79d8ee1a68822f4ba47e1fe304 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 19:52:20 -0400 Subject: [PATCH 13/68] Define a helper constructing a Module for a Blob relative to some root directory. --- src/Data/Abstract/Module.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index 0954eef62..67fd5b3f1 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -1,11 +1,27 @@ 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) + + +moduleForBlob :: FilePath -> Blob -> term -> Module term +moduleForBlob rootDir blob term = Module (moduleName blob) (blobPath blob) term + where 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)) From 842ab3403dcfe5cb17782e2b590edf2e4f9c5234 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 19:52:52 -0400 Subject: [PATCH 14/68] :memo: moduleForBlob. --- src/Data/Abstract/Module.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index 67fd5b3f1..5f266c1ed 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -17,6 +17,7 @@ data Module term = Module { moduleName :: ModuleName, modulePath :: FilePath, mo deriving (Eq, Foldable, Functor, Ord, Show, Traversable) +-- | Construct a 'Module' for a 'Blob' and @term@, relative to some root 'FilePath'. moduleForBlob :: FilePath -> Blob -> term -> Module term moduleForBlob rootDir blob term = Module (moduleName blob) (blobPath blob) term where moduleName Blob{..} = let path = dropExtensions (makeRelative rootDir blobPath) From da02fc870d7a807882c97175293e208563e29b7f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 19:55:01 -0400 Subject: [PATCH 15/68] :memo: the arguments to moduleForBlob. --- src/Data/Abstract/Module.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index 5f266c1ed..dda8f35db 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -18,7 +18,10 @@ data Module term = Module { moduleName :: ModuleName, modulePath :: FilePath, mo -- | Construct a 'Module' for a 'Blob' and @term@, relative to some root 'FilePath'. -moduleForBlob :: FilePath -> Blob -> term -> Module term +moduleForBlob :: FilePath -- ^ The root directory relative to which the module will be resolved. + -> 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'. moduleForBlob rootDir blob term = Module (moduleName blob) (blobPath blob) term where moduleName Blob{..} = let path = dropExtensions (makeRelative rootDir blobPath) in case blobLanguage of From 99ab0a46cb2f318a92f93eb2089a02cb486d88b9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 19:57:44 -0400 Subject: [PATCH 16/68] Define withModules using moduleForBlob. --- src/Control/Abstract/Analysis.hs | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 63e3b36ea..f8c37d081 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -25,15 +25,11 @@ import Data.Abstract.Environment (Environment) import qualified Data.Abstract.Environment as Env import Data.Abstract.Exports (Exports) import qualified Data.Abstract.Exports as Export -import Data.Abstract.FreeVariables import Data.Abstract.Module import Data.Abstract.ModuleTable import Data.Abstract.Value import Data.Blob -import qualified Data.ByteString.Char8 as BC import Data.Coerce -import Data.Language -import Data.List.Split (splitWhen) import qualified Data.Map as Map import Prelude hiding (fail) import Prologue @@ -70,13 +66,7 @@ withModules blob pairs = localModuleTable (const moduleTable) where moduleTable = ModuleTable (Map.fromListWith (<>) (map toModulePair pairs)) rootDir = dropFileName (blobPath blob) - toModulePair (blob, term) = let name = moduleName blob in (name, [Module name (blobPath blob) term]) - 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)) + toModulePair (blob, term) = let m = moduleForBlob rootDir blob term in (moduleName m, [m]) -- | Require/import another term/file and return an Effect. From 9819f2c29b1d7f97200a1efe2ce0447aed65886c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 19:59:14 -0400 Subject: [PATCH 17/68] Rename withModules to withModulesForBlobs. --- src/Control/Abstract/Analysis.hs | 6 +++--- src/Semantic/Util.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index f8c37d081..2550c09e1 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -3,7 +3,7 @@ module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm -, withModules +, withModulesForBlobs , require , load , liftAnalyze @@ -61,8 +61,8 @@ evaluateTerm = foldSubterms analyzeTerm -- | 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) +withModulesForBlobs :: MonadAnalysis term value m => Blob -> [(Blob, term)] -> m a -> m a +withModulesForBlobs blob pairs = localModuleTable (const moduleTable) where moduleTable = ModuleTable (Map.fromListWith (<>) (map toModulePair pairs)) rootDir = dropFileName (blobPath blob) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index cba43a397..c5056af64 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -81,7 +81,7 @@ evaluateFiles :: forall term effects -> IO (Final effects Value) evaluateFiles parser paths = do entry:xs <- traverse (parseFile parser) paths - pure . runAnalysis @(Evaluating term Value) . withModules (fst entry) xs $ evaluateModule (snd entry) + pure . runAnalysis @(Evaluating term Value) . withModulesForBlobs (fst entry) xs $ evaluateModule (snd entry) -- Read and parse a file. parseFile :: Parser term -> FilePath -> IO (Blob, term) From b08969b44c5897b1606099b90cf81a9296b6128a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:01:13 -0400 Subject: [PATCH 18/68] Define a withModules function running an action with a module table constructed from a list of modules. --- src/Control/Abstract/Analysis.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 2550c09e1..c5f2cc422 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -3,6 +3,7 @@ module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm +, withModules , withModulesForBlobs , require , load @@ -60,6 +61,10 @@ evaluateTerm :: MonadAnalysis term value m => term -> m value evaluateTerm = foldSubterms analyzeTerm +withModules :: MonadAnalysis term value m => [Module term] -> m a -> m a +withModules modules = localModuleTable (const moduleTable) + where moduleTable = ModuleTable (Map.fromListWith (<>) (map ((,) . moduleName <*> pure) modules)) + -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModulesForBlobs :: MonadAnalysis term value m => Blob -> [(Blob, term)] -> m a -> m a withModulesForBlobs blob pairs = localModuleTable (const moduleTable) From bce72b1f0d02fa8f3d7ca939f057fd0aeb2229fb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:03:32 -0400 Subject: [PATCH 19/68] Define a fromList constructor for ModuleTables. --- src/Control/Abstract/Analysis.hs | 5 ++--- src/Data/Abstract/ModuleTable.hs | 7 ++++++- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index c5f2cc422..989795a87 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -27,7 +27,7 @@ import qualified Data.Abstract.Environment as Env import Data.Abstract.Exports (Exports) import qualified Data.Abstract.Exports as Export import Data.Abstract.Module -import Data.Abstract.ModuleTable +import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Value import Data.Blob import Data.Coerce @@ -62,8 +62,7 @@ evaluateTerm = foldSubterms analyzeTerm withModules :: MonadAnalysis term value m => [Module term] -> m a -> m a -withModules modules = localModuleTable (const moduleTable) - where moduleTable = ModuleTable (Map.fromListWith (<>) (map ((,) . moduleName <*> pure) modules)) +withModules = localModuleTable . const . ModuleTable.fromList -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModulesForBlobs :: MonadAnalysis term value m => Blob -> [(Blob, term)] -> m a -> m a diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index 85969b7fb..aea7a2dc3 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -4,11 +4,12 @@ module Data.Abstract.ModuleTable , ModuleTable (..) , moduleTableLookup , moduleTableInsert + , fromList ) where import Data.Abstract.Module import Data.Semigroup -import GHC.Generics +import GHC.Generics (Generic1) import qualified Data.Map as Map newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModuleName a } @@ -19,3 +20,7 @@ moduleTableLookup k = Map.lookup k . unModuleTable moduleTableInsert :: ModuleName -> a -> ModuleTable a -> ModuleTable a moduleTableInsert k v ModuleTable{..} = ModuleTable (Map.insert k v unModuleTable) + + +fromList :: [Module term] -> ModuleTable [Module term] +fromList modules = ModuleTable (Map.fromListWith (<>) (map ((,) . moduleName <*> pure) modules)) From da8d7315ed129fabf1c5cbdebb908ab9099bda61 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:05:01 -0400 Subject: [PATCH 20/68] Use a helper method to construct the pairs. --- src/Data/Abstract/ModuleTable.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index aea7a2dc3..fc8a4cc22 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -23,4 +23,5 @@ moduleTableInsert k v ModuleTable{..} = ModuleTable (Map.insert k v unModuleTabl fromList :: [Module term] -> ModuleTable [Module term] -fromList modules = ModuleTable (Map.fromListWith (<>) (map ((,) . moduleName <*> pure) modules)) +fromList modules = ModuleTable (Map.fromListWith (<>) (map toEntry modules)) + where toEntry m = (moduleName m, [m]) From 7436f9605fa1f04a1ae50b4f652570165e8f2536 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:06:27 -0400 Subject: [PATCH 21/68] Define withModulesForBlobs in terms of withModules. --- src/Control/Abstract/Analysis.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 989795a87..33affe7c1 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -31,7 +31,6 @@ import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Value import Data.Blob import Data.Coerce -import qualified Data.Map as Map import Prelude hiding (fail) import Prologue import System.FilePath.Posix @@ -66,11 +65,8 @@ withModules = localModuleTable . const . ModuleTable.fromList -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModulesForBlobs :: MonadAnalysis term value m => Blob -> [(Blob, term)] -> m a -> m a -withModulesForBlobs blob pairs = localModuleTable (const moduleTable) - where - moduleTable = ModuleTable (Map.fromListWith (<>) (map toModulePair pairs)) - rootDir = dropFileName (blobPath blob) - toModulePair (blob, term) = let m = moduleForBlob rootDir blob term in (moduleName m, [m]) +withModulesForBlobs blob = withModules . map (uncurry (moduleForBlob rootDir)) + where rootDir = dropFileName (blobPath blob) -- | Require/import another term/file and return an Effect. From 2902b9c2a3365de7a6fd1f886678fcec8e7c01b7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:11:44 -0400 Subject: [PATCH 22/68] Make the root directory relative. --- src/Control/Abstract/Analysis.hs | 2 +- src/Data/Abstract/Module.hs | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 33affe7c1..05033991f 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -65,7 +65,7 @@ withModules = localModuleTable . const . ModuleTable.fromList -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModulesForBlobs :: MonadAnalysis term value m => Blob -> [(Blob, term)] -> m a -> m a -withModulesForBlobs blob = withModules . map (uncurry (moduleForBlob rootDir)) +withModulesForBlobs blob = withModules . map (uncurry (moduleForBlob (Just rootDir))) where rootDir = dropFileName (blobPath blob) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index dda8f35db..077eadf87 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -18,12 +18,12 @@ data Module term = Module { moduleName :: ModuleName, modulePath :: FilePath, mo -- | Construct a 'Module' for a 'Blob' and @term@, relative to some root 'FilePath'. -moduleForBlob :: FilePath -- ^ The root directory relative to which the module will be resolved. - -> 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'. +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 term = Module (moduleName blob) (blobPath blob) term - where moduleName Blob{..} = let path = dropExtensions (makeRelative rootDir blobPath) + where moduleName Blob{..} = let path = dropExtensions (maybe takeFileName 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. From a640fa0de30f5c93068eed07192810a8f5c268ff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:13:20 -0400 Subject: [PATCH 23/68] Define a helper constructing modules from a list of blobs. --- src/Control/Abstract/Analysis.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 05033991f..6d8b80a34 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -63,10 +63,13 @@ evaluateTerm = foldSubterms analyzeTerm withModules :: MonadAnalysis term value m => [Module term] -> m a -> m a withModules = localModuleTable . const . ModuleTable.fromList +modulesForBlobs :: Blob -> [(Blob, term)] -> [Module term] +modulesForBlobs blob = map (uncurry (moduleForBlob (Just rootDir))) + where rootDir = dropFileName (blobPath blob) + -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModulesForBlobs :: MonadAnalysis term value m => Blob -> [(Blob, term)] -> m a -> m a -withModulesForBlobs blob = withModules . map (uncurry (moduleForBlob (Just rootDir))) - where rootDir = dropFileName (blobPath blob) +withModulesForBlobs blob = withModules . modulesForBlobs blob -- | Require/import another term/file and return an Effect. From 02dbaf964fddaba75d1386576029d7733c19323d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:14:16 -0400 Subject: [PATCH 24/68] :memo: withModules. --- src/Control/Abstract/Analysis.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 6d8b80a34..a8846cba8 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -60,6 +60,7 @@ evaluateTerm :: MonadAnalysis term value m => term -> m value evaluateTerm = foldSubterms analyzeTerm +-- | 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 From 6591e0fdc4c0a538706a1f1a442ae2ac4054d603 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:17:16 -0400 Subject: [PATCH 25/68] Compute the list of modules in Semantic.Util. --- src/Control/Abstract/Analysis.hs | 11 ----------- src/Semantic/Util.hs | 9 ++++++++- 2 files changed, 8 insertions(+), 12 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index a8846cba8..b381b602f 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -4,7 +4,6 @@ module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm , withModules -, withModulesForBlobs , require , load , liftAnalyze @@ -29,11 +28,9 @@ import qualified Data.Abstract.Exports as Export import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Value -import Data.Blob import Data.Coerce import Prelude hiding (fail) import Prologue -import System.FilePath.Posix -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- @@ -64,14 +61,6 @@ evaluateTerm = foldSubterms analyzeTerm withModules :: MonadAnalysis term value m => [Module term] -> m a -> m a withModules = localModuleTable . const . ModuleTable.fromList -modulesForBlobs :: Blob -> [(Blob, term)] -> [Module term] -modulesForBlobs blob = map (uncurry (moduleForBlob (Just rootDir))) - where rootDir = dropFileName (blobPath blob) - --- | Run an action with the passed ('Blob', @term@) pairs available for imports. -withModulesForBlobs :: MonadAnalysis term value m => Blob -> [(Blob, term)] -> m a -> m a -withModulesForBlobs blob = withModules . modulesForBlobs blob - -- | Require/import another term/file and return an Effect. -- diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index c5056af64..7cead35a1 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -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 @@ -27,6 +28,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 @@ -81,7 +83,12 @@ evaluateFiles :: forall term effects -> IO (Final effects Value) evaluateFiles parser paths = do entry:xs <- traverse (parseFile parser) paths - pure . runAnalysis @(Evaluating term Value) . withModulesForBlobs (fst entry) xs $ evaluateModule (snd entry) + let rootDir = dropFileName (blobPath (fst entry)) + pure . runAnalysis @(Evaluating term Value) . withModules (modulesForBlobs (Just rootDir) xs) $ evaluateModule (snd entry) + +modulesForBlobs :: Maybe FilePath -> [(Blob, term)] -> [Module term] +modulesForBlobs = map . uncurry . moduleForBlob + -- Read and parse a file. parseFile :: Parser term -> FilePath -> IO (Blob, term) From 865bf650ce3facf1950816156c079ed94368c069 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:19:08 -0400 Subject: [PATCH 26/68] Simplify the selection of the root. --- src/Semantic/Util.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 7cead35a1..2110f8e76 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -83,7 +83,7 @@ evaluateFiles :: forall term effects -> IO (Final effects Value) evaluateFiles parser paths = do entry:xs <- traverse (parseFile parser) paths - let rootDir = dropFileName (blobPath (fst entry)) + let rootDir = dropFileName (head paths) pure . runAnalysis @(Evaluating term Value) . withModules (modulesForBlobs (Just rootDir) xs) $ evaluateModule (snd entry) modulesForBlobs :: Maybe FilePath -> [(Blob, term)] -> [Module term] From aaeb85961a5db6b17683c48c2297020c693f03d9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:21:56 -0400 Subject: [PATCH 27/68] Parse directly to modules. --- src/Semantic/Util.hs | 25 +++++++++++-------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 2110f8e76..1cef44d44 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -41,17 +41,17 @@ evaluateRubyFiles = evaluateFiles 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 . moduleBody <$> parseFile goParser Nothing path -- Python evaluatePythonFile = evaluateFile pythonParser evaluatePythonFiles = evaluateFiles 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 . moduleBody <$> parseFile pythonParser Nothing path +tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term Value) . evaluateModule . moduleBody <$> parseFile pythonParser Nothing path +evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term Value) . evaluateModule . moduleBody <$> parseFile pythonParser Nothing path -- TypeScript -typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term Type) . evaluateModule . snd <$> parseFile typescriptParser path +typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term Type) . evaluateModule . moduleBody <$> parseFile typescriptParser Nothing path evaluateTypeScriptFile = evaluateFile typescriptParser evaluateTypeScriptFiles = evaluateFiles typescriptParser @@ -67,7 +67,7 @@ evaluateFile :: forall term effects => Parser term -> FilePath -> IO (Final effects Value) -evaluateFile parser path = runAnalysis @(Evaluating term Value) . evaluateModule . snd <$> parseFile parser path +evaluateFile parser path = runAnalysis @(Evaluating term Value) . evaluateModule . moduleBody <$> parseFile parser Nothing path -- Evaluate a list of files (head of file list is considered the entry point). evaluateFiles :: forall term effects @@ -82,19 +82,16 @@ evaluateFiles :: forall term effects -> [FilePath] -> IO (Final effects Value) evaluateFiles parser paths = do - entry:xs <- traverse (parseFile parser) paths let rootDir = dropFileName (head paths) - pure . runAnalysis @(Evaluating term Value) . withModules (modulesForBlobs (Just rootDir) xs) $ evaluateModule (snd entry) - -modulesForBlobs :: Maybe FilePath -> [(Blob, term)] -> [Module term] -modulesForBlobs = map . uncurry . moduleForBlob + entry:xs <- traverse (parseFile parser (Just rootDir)) paths + pure . runAnalysis @(Evaluating term Value) . withModules xs $ evaluateModule (moduleBody 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 -- Read a file from the filesystem into a Blob. file :: MonadIO m => FilePath -> m Blob From 159f87a15f09795ecc664a2e29e8aea4abdc0e57 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:23:45 -0400 Subject: [PATCH 28/68] evalAndCache takes a list of modules. --- src/Control/Abstract/Analysis.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index b381b602f..de03d8643 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -80,13 +80,13 @@ load :: ( MonadAnalysis term value m ) => ModuleName -> m (EnvironmentFor value) -load name = askModuleTable >>= maybe notFound (evalAndCache . map moduleBody) . moduleTableLookup name +load name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name where notFound = fail ("cannot load module: " <> show name) - evalAndCache :: (MonadAnalysis term value m, Ord (LocationFor value)) => [term] -> m (EnvironmentFor value) + evalAndCache :: (MonadAnalysis term value m, Ord (LocationFor value)) => [Module term] -> m (EnvironmentFor value) evalAndCache [] = pure mempty evalAndCache (x:xs) = do - void $ evaluateModule x + void $ evaluateModule (moduleBody x) env <- filterEnv <$> getExports <*> getEnv modifyModuleTable (moduleTableInsert name env) (env <>) <$> evalAndCache xs From a751f60251204f8a53f9600ae817ef3c7027ca76 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:25:20 -0400 Subject: [PATCH 29/68] evaluateModule takes a Module. --- src/Analysis/Abstract/Caching.hs | 7 ++++--- src/Analysis/Abstract/Dead.hs | 7 ++++--- src/Control/Abstract/Analysis.hs | 6 +++--- src/Semantic/Util.hs | 14 +++++++------- 4 files changed, 18 insertions(+), 16 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 0d0d3f3e4..cec22e4fe 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -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 + evaluateModule m = do + c <- getConfiguration (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 ()) (Caching (evaluateModule m)))) mempty maybe empty scatter (cacheLookup c cache) -- | Iterate a monadic action starting from some initial seed until the results converge. diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index cf004925d..7ea2a7f4a 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -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) + evaluateModule m = do + killAll (subterms (moduleBody m)) + DeadCode (evaluateModule m) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index de03d8643..f6fa6b3c6 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -43,8 +43,8 @@ class (MonadEvaluator term value m, Recursive term) => MonadAnalysis term value 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 + evaluateModule :: Module term -> m value + evaluateModule = evaluateTerm . moduleBody -- | Isolate the given action with an empty global environment and exports. isolate :: m a -> m a @@ -86,7 +86,7 @@ load name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup n evalAndCache :: (MonadAnalysis term value m, Ord (LocationFor value)) => [Module term] -> m (EnvironmentFor value) evalAndCache [] = pure mempty evalAndCache (x:xs) = do - void $ evaluateModule (moduleBody x) + void $ evaluateModule x env <- filterEnv <$> getExports <*> getEnv modifyModuleTable (moduleTableInsert name env) (env <>) <$> evalAndCache xs diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 1cef44d44..96131dade 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -41,17 +41,17 @@ evaluateRubyFiles = evaluateFiles rubyParser -- Go evaluateGoFile = evaluateFile goParser evaluateGoFiles = evaluateFiles goParser -typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluateModule . moduleBody <$> parseFile goParser Nothing path +typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluateModule <$> parseFile goParser Nothing path -- Python evaluatePythonFile = evaluateFile pythonParser evaluatePythonFiles = evaluateFiles pythonParser -typecheckPythonFile path = runAnalysis @(Caching Evaluating Python.Term Type) . evaluateModule . moduleBody <$> parseFile pythonParser Nothing path -tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term Value) . evaluateModule . moduleBody <$> parseFile pythonParser Nothing path -evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term Value) . evaluateModule . moduleBody <$> 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 -- TypeScript -typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term Type) . evaluateModule . moduleBody <$> parseFile typescriptParser Nothing path +typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term Type) . evaluateModule <$> parseFile typescriptParser Nothing path evaluateTypeScriptFile = evaluateFile typescriptParser evaluateTypeScriptFiles = evaluateFiles typescriptParser @@ -67,7 +67,7 @@ evaluateFile :: forall term effects => Parser term -> FilePath -> IO (Final effects Value) -evaluateFile parser path = runAnalysis @(Evaluating term Value) . evaluateModule . moduleBody <$> parseFile parser Nothing path +evaluateFile parser path = runAnalysis @(Evaluating term Value) . evaluateModule <$> parseFile parser Nothing path -- Evaluate a list of files (head of file list is considered the entry point). evaluateFiles :: forall term effects @@ -84,7 +84,7 @@ evaluateFiles :: forall term effects evaluateFiles parser paths = do let rootDir = dropFileName (head paths) entry:xs <- traverse (parseFile parser (Just rootDir)) paths - pure . runAnalysis @(Evaluating term Value) . withModules xs $ evaluateModule (moduleBody entry) + pure . runAnalysis @(Evaluating term Value) . withModules xs $ evaluateModule entry -- Read and parse a file. From 16a0236c196570e78e0760b5c5f1a8c0f461e808 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:27:00 -0400 Subject: [PATCH 30/68] Infix. --- src/Data/Abstract/Module.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index 077eadf87..75427729c 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -28,4 +28,4 @@ moduleForBlob rootDir blob term = Module (moduleName blob) (blobPath blob) term -- 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)) + toName str = qualifiedName (BC.pack <$> splitWhen (== pathSeparator) str) From 45dcfaad4188546141b0eca94f6265ddc606a498 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:27:42 -0400 Subject: [PATCH 31/68] Refactor/align the language switch. --- src/Data/Abstract/Module.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index 75427729c..47aefbdff 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -24,8 +24,8 @@ moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the mo -> Module term -- ^ A 'Module' named appropriate for the 'Blob', holding the @term@, and constructed relative to the root 'FilePath', if any. moduleForBlob rootDir blob term = Module (moduleName blob) (blobPath blob) term where moduleName Blob{..} = let path = dropExtensions (maybe takeFileName makeRelative rootDir blobPath) - in case blobLanguage of + in toName $ 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 + Just Go -> takeDirectory path -- Go allows defining modules across multiple files in the same directory. + _ -> path toName str = qualifiedName (BC.pack <$> splitWhen (== pathSeparator) str) From 36aa4e445c23a201e044c9dc2183cb9fca73c5e8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:30:39 -0400 Subject: [PATCH 32/68] Guard clauses. --- src/Data/Abstract/Module.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index 47aefbdff..85d039996 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -23,9 +23,8 @@ moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the mo -> 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 term = Module (moduleName blob) (blobPath blob) term - where moduleName Blob{..} = let path = dropExtensions (maybe takeFileName makeRelative rootDir blobPath) - in toName $ case blobLanguage of - -- TODO: Need a better way to handle module registration and resolution - Just Go -> takeDirectory path -- Go allows defining modules across multiple files in the same directory. - _ -> path + where moduleName Blob{..} | Just Go <- blobLanguage = toName (takeDirectory (modulePath blobPath)) + | otherwise = toName (modulePath blobPath) + -- TODO: Need a better way to handle module registration and resolution toName str = qualifiedName (BC.pack <$> splitWhen (== pathSeparator) str) + modulePath = dropExtensions . maybe takeFileName makeRelative rootDir From 6273a22c71775d9645a62add77eaab69ec071803 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:31:18 -0400 Subject: [PATCH 33/68] Tacit. --- src/Data/Abstract/Module.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index 85d039996..583160940 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -26,5 +26,5 @@ moduleForBlob rootDir blob term = Module (moduleName blob) (blobPath blob) term where moduleName Blob{..} | Just Go <- blobLanguage = toName (takeDirectory (modulePath blobPath)) | otherwise = toName (modulePath blobPath) -- TODO: Need a better way to handle module registration and resolution - toName str = qualifiedName (BC.pack <$> splitWhen (== pathSeparator) str) + toName = qualifiedName . map BC.pack . splitWhen (== pathSeparator) modulePath = dropExtensions . maybe takeFileName makeRelative rootDir From a8e07107e98c79b3d843cabc87f2d0e496245713 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:32:41 -0400 Subject: [PATCH 34/68] Extract the helper to construct a module name from a FilePath. --- src/Data/Abstract/Module.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index 583160940..3daaa0ae2 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -23,8 +23,10 @@ moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the mo -> 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 term = Module (moduleName blob) (blobPath blob) term - where moduleName Blob{..} | Just Go <- blobLanguage = toName (takeDirectory (modulePath blobPath)) - | otherwise = toName (modulePath blobPath) + where moduleName Blob{..} | Just Go <- blobLanguage = moduleNameForPath (takeDirectory (modulePath blobPath)) + | otherwise = moduleNameForPath (modulePath blobPath) -- TODO: Need a better way to handle module registration and resolution - toName = qualifiedName . map BC.pack . splitWhen (== pathSeparator) modulePath = dropExtensions . maybe takeFileName makeRelative rootDir + +moduleNameForPath :: FilePath -> ModuleName +moduleNameForPath = qualifiedName . map BC.pack . splitWhen (== pathSeparator) From 592fd3051eb51d0f93a0a3049dc4525ea486e829 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 20:34:08 -0400 Subject: [PATCH 35/68] Factor out the moduleNameForPath call. --- src/Data/Abstract/Module.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index 3daaa0ae2..6d32e9511 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -22,10 +22,10 @@ moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the mo -> 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 term = Module (moduleName blob) (blobPath blob) term - where moduleName Blob{..} | Just Go <- blobLanguage = moduleNameForPath (takeDirectory (modulePath blobPath)) - | otherwise = moduleNameForPath (modulePath blobPath) - -- TODO: Need a better way to handle module registration and resolution +moduleForBlob rootDir blob term = Module (moduleNameForPath (modulePathForBlob blob)) (blobPath blob) term + 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 From e7313c152c9a4f6bd81d468933c456063692a8f9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 09:15:39 -0400 Subject: [PATCH 36/68] :fire: a redundant extension. --- src/Analysis/Abstract/Evaluating.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index b5f596842..41ec70099 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Evaluating ( type Evaluating ) where From 3ee6f8ac14abba736f6e49c32262feb14b477a29 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 09:15:44 -0400 Subject: [PATCH 37/68] Eta-reduce moduleForBlob. --- src/Data/Abstract/Module.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index 6d32e9511..b07cad360 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -22,7 +22,7 @@ moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the mo -> 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 term = Module (moduleNameForPath (modulePathForBlob blob)) (blobPath blob) term +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 From 065d97b73fed1ad8d0f2a46eac89785051f9f445 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 11:55:52 -0400 Subject: [PATCH 38/68] :memo: fromList. --- src/Data/Abstract/ModuleTable.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index fc8a4cc22..0418d880e 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -22,6 +22,7 @@ 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]) From 25e96309766f4e36ab431404bf1e407dc1037432 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:01:49 -0400 Subject: [PATCH 39/68] Dedent the exports. --- src/Data/Abstract/ModuleTable.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index 0418d880e..32ed259c3 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -1,11 +1,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Abstract.ModuleTable - ( ModuleName - , ModuleTable (..) - , moduleTableLookup - , moduleTableInsert - , fromList - ) where +( ModuleName +, ModuleTable (..) +, moduleTableLookup +, moduleTableInsert +, fromList +) where import Data.Abstract.Module import Data.Semigroup From 8cf5902a5ed2696f5a2a74a47d792e9c9c5fdb39 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:02:17 -0400 Subject: [PATCH 40/68] Sort imports. --- src/Data/Abstract/ModuleTable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index 32ed259c3..53f697b36 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -8,9 +8,9 @@ module Data.Abstract.ModuleTable ) where import Data.Abstract.Module +import qualified Data.Map as Map import Data.Semigroup import GHC.Generics (Generic1) -import qualified Data.Map as Map newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModuleName a } deriving (Eq, Foldable, Functor, Generic1, Monoid, Ord, Semigroup, Show, Traversable) From 109c95d5099fd98a7a89aa8ce584c2486739c3e0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:06:46 -0400 Subject: [PATCH 41/68] Define an ImportGraphing analysis. --- src/Analysis/Abstract/ImportGraph.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index eb39c919d..1f2879857 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} module Analysis.Abstract.ImportGraph ( ImportGraph(..) +, ImportGraphing , renderImportGraph , buildImportGraph , ImportGraphAlgebra(..) @@ -9,6 +10,7 @@ module Analysis.Abstract.ImportGraph 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.Set (member) import qualified Data.Syntax as Syntax @@ -29,6 +31,15 @@ buildImportGraph = foldSubterms importGraphAlgebra 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) + -- | Types which contribute to a 'ImportGraph'. There is exactly one instance of this typeclass; customizing the 'ImportGraph's for a new type is done by defining an instance of 'CustomImportGraphAlgebra' instead. -- From ae4e17911c314184f463c232959b539d320e4686 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:08:27 -0400 Subject: [PATCH 42/68] Stub in a MonadAnalysis instance for ImportGraphing. --- src/Analysis/Abstract/ImportGraph.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 1f2879857..d381b2aec 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -41,6 +41,12 @@ deriving instance MonadModuleTable term value (m term value effects) => MonadMod deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (ImportGraphing m term value effects) +instance 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) = RequiredEffects term value (m term value effects) + + analyzeTerm = liftAnalyze analyzeTerm + + -- | Types which contribute to a 'ImportGraph'. There is exactly one instance of this typeclass; customizing the 'ImportGraph's for a new type is done by defining an instance of 'CustomImportGraphAlgebra' instead. -- -- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap. From 55abf44b166731058f3c933311f0e9e2d46507ba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:09:22 -0400 Subject: [PATCH 43/68] Specialize evaluateModule. --- src/Analysis/Abstract/ImportGraph.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index d381b2aec..e2d7cf9cc 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -12,6 +12,7 @@ import Algebra.Graph.Class import Algebra.Graph.Export.Dot import Control.Abstract.Analysis import Data.Abstract.FreeVariables +import Data.Abstract.Module import Data.Set (member) import qualified Data.Syntax as Syntax import qualified Data.Syntax.Declaration as Declaration @@ -46,6 +47,8 @@ instance MonadAnalysis term value (m term value effects) => MonadAnalysis term v analyzeTerm = liftAnalyze analyzeTerm + evaluateModule m@Module{..} = ImportGraphing (evaluateModule m) + -- | Types which contribute to a 'ImportGraph'. There is exactly one instance of this typeclass; customizing the 'ImportGraph's for a new type is done by defining an instance of 'CustomImportGraphAlgebra' instead. -- From cb790c9b9c0bb3c363e5efc0d744fe1ddc9987a6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:12:10 -0400 Subject: [PATCH 44/68] Add a state effect for the module graph. --- src/Analysis/Abstract/ImportGraph.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index e2d7cf9cc..c4d14d7dc 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.ImportGraph ( ImportGraph(..) , ImportGraphing @@ -42,8 +42,11 @@ deriving instance MonadModuleTable term value (m term value effects) => MonadMod deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (ImportGraphing m term value effects) -instance 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) = RequiredEffects term value (m term value effects) +instance ( 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 From fd2dee040f52784e8e6eb27331d04a6e0c217f48 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:17:10 -0400 Subject: [PATCH 45/68] :fire: the algebra/advanced overlap stuff. --- src/Analysis/Abstract/ImportGraph.hs | 74 +--------------------------- 1 file changed, 1 insertion(+), 73 deletions(-) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index c4d14d7dc..dc7f86366 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -1,10 +1,8 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.ImportGraph ( ImportGraph(..) -, ImportGraphing , renderImportGraph -, buildImportGraph -, ImportGraphAlgebra(..) +, ImportGraphing ) where import qualified Algebra.Graph as G @@ -13,21 +11,12 @@ import Algebra.Graph.Export.Dot import Control.Abstract.Analysis import Data.Abstract.FreeVariables import Data.Abstract.Module -import Data.Set (member) -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Declaration as Declaration -import Data.Term 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) --- | Build the 'ImportGraph' for a 'Term' recursively. -buildImportGraph :: (ImportGraphAlgebra syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> ImportGraph -buildImportGraph = foldSubterms importGraphAlgebra - - -- | Render a 'ImportGraph' to a 'ByteString' in DOT notation. renderImportGraph :: ImportGraph -> ByteString renderImportGraph = export (defaultStyle friendlyName) . unImportGraph @@ -53,67 +42,6 @@ instance ( Member (State ImportGraph) effects evaluateModule m@Module{..} = ImportGraphing (evaluateModule m) --- | Types which contribute to a 'ImportGraph'. There is exactly one instance of this typeclass; customizing the 'ImportGraph's for a new type is done by defining an instance of 'CustomImportGraphAlgebra' instead. --- --- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap. -class ImportGraphAlgebra syntax where - -- | A 'SubtermAlgebra' computing the 'ImportGraph' for a piece of @syntax@. - importGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> ImportGraph)) -> Set Name -> ImportGraph - -instance (ImportGraphAlgebraStrategy syntax ~ strategy, ImportGraphAlgebraWithStrategy strategy syntax) => ImportGraphAlgebra syntax where - importGraphAlgebra = importGraphAlgebraWithStrategy (Proxy :: Proxy strategy) - - --- | Types whose contribution to a 'ImportGraph' is customized. If an instance’s definition is not being used, ensure that the type is mapped to 'Custom' in the 'ImportGraphAlgebraStrategy'. -class CustomImportGraphAlgebra syntax where - customImportGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> ImportGraph)) -> Set Name -> ImportGraph - --- | 'Declaration.Function's produce a vertex for their name, with edges to any free variables in their body. -instance CustomImportGraphAlgebra Declaration.Function where - customImportGraphAlgebra Declaration.Function{..} bound = foldMap vertex (freeVariables (subterm functionName)) `connect` subtermValue functionBody (foldMap (freeVariables . subterm) functionParameters <> bound) - --- | 'Declaration.Method's produce a vertex for their name, with edges to any free variables in their body. -instance CustomImportGraphAlgebra Declaration.Method where - customImportGraphAlgebra Declaration.Method{..} bound = foldMap vertex (freeVariables (subterm methodName)) `connect` subtermValue methodBody (foldMap (freeVariables . subterm) methodParameters <> bound) - --- | 'Syntax.Identifier's produce a vertex iff it’s unbound in the 'Set'. -instance CustomImportGraphAlgebra Syntax.Identifier where - customImportGraphAlgebra (Syntax.Identifier name) bound - | name `member` bound = empty - | otherwise = vertex name - -instance Apply ImportGraphAlgebra syntaxes => CustomImportGraphAlgebra (Union syntaxes) where - customImportGraphAlgebra = Prologue.apply (Proxy :: Proxy ImportGraphAlgebra) importGraphAlgebra - -instance ImportGraphAlgebra syntax => CustomImportGraphAlgebra (TermF syntax a) where - customImportGraphAlgebra = importGraphAlgebra . termFOut - - --- | The mechanism selecting 'Default'/'Custom' implementations for 'importGraphAlgebra' depending on the @syntax@ type. -class ImportGraphAlgebraWithStrategy (strategy :: Strategy) syntax where - importGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term (Set Name -> ImportGraph)) -> Set Name -> ImportGraph - --- | The 'Default' definition of 'importGraphAlgebra' combines all of the 'ImportGraph's within the @syntax@ 'Monoid'ally. -instance Foldable syntax => ImportGraphAlgebraWithStrategy 'Default syntax where - importGraphAlgebraWithStrategy _ = foldMap subtermValue - --- | The 'Custom' strategy calls out to the 'customImportGraphAlgebra' method. -instance CustomImportGraphAlgebra syntax => ImportGraphAlgebraWithStrategy 'Custom syntax where - importGraphAlgebraWithStrategy _ = customImportGraphAlgebra - - --- | Which instance of 'CustomImportGraphAlgebra' to use for a given @syntax@ type. -data Strategy = Default | Custom - --- | A mapping of @syntax@ types onto 'Strategy's. -type family ImportGraphAlgebraStrategy syntax where - ImportGraphAlgebraStrategy Declaration.Function = 'Custom - ImportGraphAlgebraStrategy Declaration.Method = 'Custom - ImportGraphAlgebraStrategy Syntax.Identifier = 'Custom - ImportGraphAlgebraStrategy (Union fs) = 'Custom - ImportGraphAlgebraStrategy (TermF f a) = 'Custom - ImportGraphAlgebraStrategy a = 'Default - instance Semigroup ImportGraph where (<>) = overlay From fad70ebc37308e073f00d8df1aa03b7a3f761a2c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:25:34 -0400 Subject: [PATCH 46/68] :fire: a redundant import. --- src/Control/Abstract/Evaluator.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 1b7159ee1..d6847f8bd 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -25,7 +25,6 @@ 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. From f38a7d67de2ead38d60e9ab2356e68f824ede00d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:26:11 -0400 Subject: [PATCH 47/68] Add a stack of currently-evaluating modules. --- src/Analysis/Abstract/Evaluating.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 41ec70099..97889fe41 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -30,6 +30,7 @@ deriving instance Member NonDetEff effects => MonadNonDet (Evaluating term value -- | Effects necessary for evaluating (whether concrete or abstract). type EvaluatingEffects term value = '[ 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 [Module term]) -- Cache of unevaluated modules From 6abf2a85fe8b808aa8dfd8d828c2ed671e5a69a1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:28:35 -0400 Subject: [PATCH 48/68] Push the current module onto the stack. --- src/Analysis/Abstract/Evaluating.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 97889fe41..c158e5b6b 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -88,3 +88,8 @@ instance ( Evaluatable (Base term) type RequiredEffects term value (Evaluating term value effects) = EvaluatingEffects term value analyzeTerm = eval + + evaluateModule m = pushModule m (evaluateTerm (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 From 27c2f6603b1f570cf31e5dafd57bb077583a790e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:29:06 -0400 Subject: [PATCH 49/68] Define a method to ask for the current module stack. --- src/Analysis/Abstract/Collecting.hs | 2 ++ src/Analysis/Abstract/Evaluating.hs | 2 ++ src/Control/Abstract/Evaluator.hs | 3 +++ 3 files changed, 7 insertions(+) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 54a975688..c479404b5 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -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)) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index c158e5b6b..bddabe935 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -76,6 +76,8 @@ instance Members '[Reader (ModuleTable [Module term]), State (ModuleTable (Envir 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 diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index d6847f8bd..8cb07dcd9 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -43,6 +43,9 @@ class ( MonadControl term m -- | Get the current 'Configuration' with a passed-in term. getConfiguration :: Ord (LocationFor value) => term -> m (ConfigurationFor term value) + askModuleStack :: m [Module term] + + -- | A 'Monad' abstracting local and global environments. class Monad m => MonadEnvironment value m | m -> value where -- | Retrieve the environment. From ed7513452bc7de43783d988990257d22e194184a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:29:14 -0400 Subject: [PATCH 50/68] :memo: askModuleStack. --- src/Control/Abstract/Evaluator.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 8cb07dcd9..1dc440827 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -43,6 +43,7 @@ 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. askModuleStack :: m [Module term] From c782a8f2665f72c92270e8b9076d5629423bc483 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:29:42 -0400 Subject: [PATCH 51/68] Warn against divergence. --- src/Control/Abstract/Evaluator.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 1dc440827..c2eb778ef 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -44,6 +44,8 @@ class ( MonadControl term m 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] From dad4cf5490522e52cd582bad6efc7afdb6e79488 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:37:43 -0400 Subject: [PATCH 52/68] Define a helper to modify the import graph. --- src/Analysis/Abstract/ImportGraph.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index dc7f86366..e04afad1c 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -41,6 +41,9 @@ instance ( Member (State ImportGraph) effects evaluateModule m@Module{..} = ImportGraphing (evaluateModule m) +modifyImportGraph :: (Effectful (m term value), Member (State ImportGraph) effects) => (ImportGraph -> ImportGraph) -> ImportGraphing m term value effects () +modifyImportGraph = raise . modify + instance Semigroup ImportGraph where (<>) = overlay From 7bd0c0f4370e9deec482f11336ee42cd36654916 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:38:13 -0400 Subject: [PATCH 53/68] Define >< as a convenient synonym for connect. --- src/Analysis/Abstract/ImportGraph.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index e04afad1c..6b55b42f5 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -41,6 +41,11 @@ instance ( Member (State ImportGraph) effects evaluateModule m@Module{..} = ImportGraphing (evaluateModule 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 From bf7edd1179d22e5c7588d6a0bcf2c5623717a42b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:38:34 -0400 Subject: [PATCH 54/68] Extend the graph as modules are imported. --- src/Analysis/Abstract/ImportGraph.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 6b55b42f5..deb43ea94 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -31,7 +31,8 @@ deriving instance MonadModuleTable term value (m term value effects) => MonadMod deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (ImportGraphing m term value effects) -instance ( Member (State ImportGraph) 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 @@ -39,7 +40,11 @@ instance ( Member (State ImportGraph) effects analyzeTerm = liftAnalyze analyzeTerm - evaluateModule m@Module{..} = ImportGraphing (evaluateModule m) + evaluateModule m = do + ms <- askModuleStack + let parent = maybe empty (vertex . moduleName) (listToMaybe ms) + modifyImportGraph (parent >< vertex (moduleName m) <>) + ImportGraphing (evaluateModule m) (><) :: Graph a => a -> a -> a (><) = connect From 28401e4cbec545a2ecc191f3bb878f6cba05b5ed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:56:38 -0400 Subject: [PATCH 55/68] Extract a helper to parse a list of files. --- src/Semantic/Util.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 96131dade..a2a26cdb3 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -93,6 +93,10 @@ parseFile parser rootDir path = runTask $ do blob <- file path 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 file path = fromJust <$> IO.readFile path (languageForFilePath path) From e29005d0fc3baa03ab2806d482e0cebe0c22da57 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 12:57:25 -0400 Subject: [PATCH 56/68] Use parseFiles in evaluateFiles. --- src/Semantic/Util.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index a2a26cdb3..978676f0f 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -82,8 +82,7 @@ evaluateFiles :: forall term effects -> [FilePath] -> IO (Final effects Value) evaluateFiles parser paths = do - let rootDir = dropFileName (head paths) - entry:xs <- traverse (parseFile parser (Just rootDir)) paths + entry:xs <- parseFiles parser paths pure . runAnalysis @(Evaluating term Value) . withModules xs $ evaluateModule entry From b05bf7d732a2adcc2316e1cbbe340468aa73966a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 13:02:49 -0400 Subject: [PATCH 57/68] Define an evaluateModules helper. --- src/Control/Abstract/Analysis.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index f6fa6b3c6..6ff94dfb4 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -4,6 +4,7 @@ module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm , withModules +, evaluateModules , require , load , liftAnalyze @@ -61,6 +62,10 @@ evaluateTerm = foldSubterms analyzeTerm withModules :: MonadAnalysis term value m => [Module term] -> m a -> m a withModules = localModuleTable . const . ModuleTable.fromList +evaluateModules :: MonadAnalysis term value m => [Module term] -> m value +evaluateModules [] = fail "evaluateModules: empty list" +evaluateModules (m:ms) = withModules ms (evaluateModule m) + -- | Require/import another term/file and return an Effect. -- From 9bd466bc19c67fe7f9b2887229d87496d7ffaa32 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 13:03:22 -0400 Subject: [PATCH 58/68] :memo: evaluateModules. --- src/Control/Abstract/Analysis.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 6ff94dfb4..c2be738eb 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -62,6 +62,7 @@ evaluateTerm = foldSubterms analyzeTerm 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) From ae7483291af6fff55f7b67358a5b9db93cc01edf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 13:03:59 -0400 Subject: [PATCH 59/68] Define evaluateFiles using evaluateModules. --- src/Semantic/Util.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 978676f0f..94f1b9883 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -81,9 +81,7 @@ evaluateFiles :: forall term effects => Parser term -> [FilePath] -> IO (Final effects Value) -evaluateFiles parser paths = do - entry:xs <- parseFiles parser paths - pure . runAnalysis @(Evaluating term Value) . withModules xs $ evaluateModule entry +evaluateFiles parser paths = runAnalysis @(Evaluating term Value) . evaluateModules <$> parseFiles parser paths -- Read and parse a file. From b353b1aa5dbde684457862d72ce30006d4086d1b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 13:45:46 -0400 Subject: [PATCH 60/68] Generalize liftAnalyze to any base functor. --- src/Control/Abstract/Analysis.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index c2be738eb..dd7f4e46e 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -108,10 +108,10 @@ load name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup n -- | 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)) From 2db0e7151b7923fc69edf5c7d4518aee08a5b81c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 13:59:32 -0400 Subject: [PATCH 61/68] Define an analyzeModule method on MonadAnalysis. This allows us to chain per-module analysis in the same manner as per-term analysis. --- src/Analysis/Abstract/Caching.hs | 6 +++--- src/Analysis/Abstract/Collecting.hs | 2 ++ src/Analysis/Abstract/Dead.hs | 6 +++--- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Analysis/Abstract/ImportGraph.hs | 4 ++-- src/Analysis/Abstract/Tracing.hs | 2 ++ src/Control/Abstract/Analysis.hs | 9 ++++++--- 7 files changed, 19 insertions(+), 12 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index cec22e4fe..525aef775 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -94,8 +94,8 @@ instance ( Corecursive term pairs <- consultOracle c caching c pairs (liftAnalyze analyzeTerm e) - evaluateModule m = do - c <- getConfiguration (moduleBody m) + 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) @@ -106,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 m)))) 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. diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index c479404b5..9198a7ba6 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -48,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) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 7ea2a7f4a..76302dc03 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -52,6 +52,6 @@ instance ( Corecursive term revive (embedSubterm term) liftAnalyze analyzeTerm term - evaluateModule m = do - killAll (subterms (moduleBody m)) - DeadCode (evaluateModule m) + analyzeModule m = do + killAll (subterms (subterm (moduleBody m))) + liftAnalyze analyzeModule m diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index bddabe935..a1f14262a 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -91,7 +91,7 @@ instance ( Evaluatable (Base term) analyzeTerm = eval - evaluateModule m = pushModule m (evaluateTerm (moduleBody m)) + 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 diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index deb43ea94..ae1a5cf73 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -40,11 +40,11 @@ instance ( Effectful (m term value) analyzeTerm = liftAnalyze analyzeTerm - evaluateModule m = do + analyzeModule m = do ms <- askModuleStack let parent = maybe empty (vertex . moduleName) (listToMaybe ms) modifyImportGraph (parent >< vertex (moduleName m) <>) - ImportGraphing (evaluateModule m) + liftAnalyze analyzeModule m (><) :: Graph a => a -> a -> a (><) = connect diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index d21f8b3c3..8d38a18f7 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -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 diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index dd7f4e46e..992e72e10 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -3,6 +3,7 @@ module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm +, evaluateModule , withModules , evaluateModules , require @@ -43,9 +44,7 @@ class (MonadEvaluator term value m, Recursive term) => MonadAnalysis term value -- | 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. 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 :: Module term -> m value - evaluateModule = evaluateTerm . moduleBody + analyzeModule :: SubtermAlgebra Module term (m value) -- | Isolate the given action with an empty global environment and exports. isolate :: m a -> m a @@ -57,6 +56,10 @@ 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 From 00ef2ba8598e0fc8ff5322a1fc0c1ac96942fdd4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 14:58:57 -0400 Subject: [PATCH 62/68] Correct the docs for analyzeTerm. --- src/Control/Abstract/Analysis.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 992e72e10..4735d4ba6 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -41,7 +41,7 @@ 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) analyzeModule :: SubtermAlgebra Module term (m value) From 61ac6d42cb055b5fff1039f191d3fcd31e3b1571 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 22 Mar 2018 14:59:17 -0400 Subject: [PATCH 63/68] :memo: analyzeModule. --- src/Control/Abstract/Analysis.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 4735d4ba6..9fe7cc926 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -44,6 +44,7 @@ class (MonadEvaluator term value m, Recursive term) => MonadAnalysis term value -- | 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) + -- | 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. From 659bcc43a9254b1cf3691b051dc0a5238054c265 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 24 Mar 2018 00:42:31 -0400 Subject: [PATCH 64/68] Align some things. --- src/Analysis/Abstract/ImportGraph.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index ae1a5cf73..65d931643 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -64,12 +64,12 @@ instance Monoid ImportGraph where 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.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.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.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 From b14db1821f62652dd1dfddca54b9c72c91b3abd8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 09:49:14 -0400 Subject: [PATCH 65/68] Fix up Semantic.Util. --- src/Semantic/Util.hs | 35 +++++++++++++++++------------------ 1 file changed, 17 insertions(+), 18 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 0e78281cb..8fa67c19e 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -84,18 +84,17 @@ evaluateWith :: forall value term effects , Recursive term , Show (LocationFor value) ) - => term - -> term + => Module term + -> Module term -> Final effects value -evaluateWith prelude t = runAnalysis @(Evaluating term value) $ do - -- evaluateTerm here rather than evaluateModule +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 <- evaluateTerm prelude *> getEnv - withDefaultEnvironment preludeEnv (evaluateModule t) + preludeEnv <- evaluateModule prelude *> getEnv + withDefaultEnvironment preludeEnv (evaluateModule m) evaluateWithPrelude :: forall term effects . ( Evaluatable (Base term) @@ -111,9 +110,9 @@ 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). @@ -140,13 +139,13 @@ evaluatesWith :: forall value term 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 + => 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 pairs (b, t) = runAnalysis @(Evaluating term value) $ do - preludeEnv <- evaluateTerm prelude *> getEnv - withDefaultEnvironment preludeEnv (withModules b pairs (evaluateModule t)) +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) @@ -162,9 +161,9 @@ 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 -> Maybe FilePath -> FilePath -> IO (Module term) From 781399de4b9fb0f4425ad2a4e6b4fe264917b9a3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 09:52:37 -0400 Subject: [PATCH 66/68] Whitespace tweaks. --- src/Semantic/Util.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 8fa67c19e..7c8141710 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -143,7 +143,7 @@ evaluatesWith :: forall value term effects -> [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 +evaluatesWith prelude modules m = runAnalysis @(Evaluating term value) $ do preludeEnv <- evaluateModule prelude *> getEnv withDefaultEnvironment preludeEnv (withModules modules (evaluateModule m)) @@ -165,6 +165,7 @@ evaluateFilesWithPrelude parser paths = do entry:xs <- traverse (parseFile parser Nothing) paths pure $ evaluatesWith @Value prelude xs entry + -- Read and parse a file. parseFile :: Parser term -> Maybe FilePath -> FilePath -> IO (Module term) parseFile parser rootDir path = runTask $ do From 9c57481efdb50000fcdc45d9b60497cd290bc288 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 09:53:25 -0400 Subject: [PATCH 67/68] Fix up prelude use for Python. --- src/Semantic/Util.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 7c8141710..3c7dc6f3b 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -46,8 +46,8 @@ evaluateGoFiles = evaluateFiles goParser typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluateModule <$> parseFile goParser Nothing path -- Python -evaluatePythonFile = evaluateFile pythonParser -evaluatePythonFiles = evaluateFiles pythonParser +evaluatePythonFile = evaluateWithPrelude pythonParser +evaluatePythonFiles = 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 From 31eef41359348df7a9490e76b8b5f3dc8b57ad42 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 11:35:37 -0400 Subject: [PATCH 68/68] Dedent. --- src/Data/Abstract/Module.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index b07cad360..719cefede 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -25,7 +25,7 @@ moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the mo 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 + -- TODO: Need a better way to handle module registration and resolution modulePath = dropExtensions . maybe takeFileName makeRelative rootDir moduleNameForPath :: FilePath -> ModuleName