From 228ec0ea5954154b03e4d75a9b6407ebf6dadd9e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 11:34:42 -0400 Subject: [PATCH 01/89] Stub in a module for a package abstraction. --- semantic.cabal | 1 + src/Data/Abstract/Package.hs | 1 + 2 files changed, 2 insertions(+) create mode 100644 src/Data/Abstract/Package.hs diff --git a/semantic.cabal b/semantic.cabal index f287d9807..1d12bb8b3 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -59,6 +59,7 @@ library , Data.Abstract.ModuleTable , Data.Abstract.Number , Data.Abstract.Origin + , Data.Abstract.Package , Data.Abstract.Path , Data.Abstract.Type , Data.Abstract.Value diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs new file mode 100644 index 000000000..f642e3426 --- /dev/null +++ b/src/Data/Abstract/Package.hs @@ -0,0 +1 @@ +module Data.Abstract.Package where From a27d35607204290c04359114943ba1cdc707ae24 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 11:39:39 -0400 Subject: [PATCH 02/89] Define a Package datatype. --- src/Data/Abstract/Package.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index f642e3426..c3f945708 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -1 +1,5 @@ module Data.Abstract.Package where + +data Package term = Package + { packageName :: String + } From 63d252b2add29eeb9ab53d8347788edbf6a0cc4a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 11:39:45 -0400 Subject: [PATCH 03/89] Packages have modules. --- src/Data/Abstract/Package.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index c3f945708..afed2c891 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -1,5 +1,9 @@ module Data.Abstract.Package where +import Data.Abstract.Module +import qualified Data.Map as Map + data Package term = Package { packageName :: String + , packageModules :: Map.Map ModuleName [Module term] } From 1c6c860f78a16056cc24eb282eb55474233ce520 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 11:40:34 -0400 Subject: [PATCH 04/89] Define a PackageName synonym. --- src/Data/Abstract/Package.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index afed2c891..48d168217 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -1,9 +1,12 @@ module Data.Abstract.Package where +import Data.Abstract.FreeVariables import Data.Abstract.Module import qualified Data.Map as Map +type PackageName = Name + data Package term = Package - { packageName :: String + { packageName :: PackageName , packageModules :: Map.Map ModuleName [Module term] } From d9a33a1a8e227d6e993501a9780446f00cf3bee5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 11:42:51 -0400 Subject: [PATCH 05/89] Packages may have entry points. --- src/Data/Abstract/Package.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 48d168217..c31d30f83 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -7,6 +7,11 @@ import qualified Data.Map as Map type PackageName = Name data Package term = Package - { packageName :: PackageName - , packageModules :: Map.Map ModuleName [Module term] + { packageName :: PackageName + , packageModules :: Map.Map ModuleName [Module term] + , packageEntryPoints :: [EntryPoint] + } + +data EntryPoint = EntryPoint + { entryPointModuleName :: ModuleName } From 3567ad112662d688c3ab8e96a32d7e92cd0d5de5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 11:43:23 -0400 Subject: [PATCH 06/89] Entry points may have symbols. --- src/Data/Abstract/Package.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index c31d30f83..c9d4cd2bb 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -14,4 +14,5 @@ data Package term = Package data EntryPoint = EntryPoint { entryPointModuleName :: ModuleName + , entryPointSymbol :: Maybe Name } From 4373928d387550f3e2dd2be57a813b157f4589f0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 11:45:05 -0400 Subject: [PATCH 07/89] Packages may have versions. --- src/Data/Abstract/Package.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index c9d4cd2bb..46acf3a3a 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -8,6 +8,7 @@ type PackageName = Name data Package term = Package { packageName :: PackageName + , packageVersion :: Maybe Version , packageModules :: Map.Map ModuleName [Module term] , packageEntryPoints :: [EntryPoint] } @@ -16,3 +17,5 @@ data EntryPoint = EntryPoint { entryPointModuleName :: ModuleName , entryPointSymbol :: Maybe Name } + +newtype Version = Version { versionString :: String } From e84747cd3dbe98aa91dd8176b71dbcc26ed050cd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 11:49:36 -0400 Subject: [PATCH 08/89] Package names are optional. --- src/Data/Abstract/Package.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 46acf3a3a..d99def34f 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -7,7 +7,7 @@ import qualified Data.Map as Map type PackageName = Name data Package term = Package - { packageName :: PackageName + { packageName :: Maybe PackageName , packageVersion :: Maybe Version , packageModules :: Map.Map ModuleName [Module term] , packageEntryPoints :: [EntryPoint] From 9c74435e459bc378a071b92fa43d4b854d464f63 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 11:50:20 -0400 Subject: [PATCH 09/89] Define Semigroup & Monoid instances for Package. --- src/Data/Abstract/Package.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index d99def34f..9b3da3433 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -3,6 +3,7 @@ module Data.Abstract.Package where import Data.Abstract.FreeVariables import Data.Abstract.Module import qualified Data.Map as Map +import Prologue type PackageName = Name @@ -19,3 +20,11 @@ data EntryPoint = EntryPoint } newtype Version = Version { versionString :: String } + + +instance Semigroup (Package term) where + _ <> b = b + +instance Monoid (Package term) where + mempty = Package Nothing Nothing Map.empty [] + mappend = (<>) From fe8d855c1ad4843d8d2dc1da67fcda3e4d925132 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 13:15:02 -0400 Subject: [PATCH 10/89] Derive some instances. --- src/Data/Abstract/Package.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 9b3da3433..dea135195 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -13,13 +13,16 @@ data Package term = Package , packageModules :: Map.Map ModuleName [Module term] , packageEntryPoints :: [EntryPoint] } + deriving (Eq, Ord, Show) data EntryPoint = EntryPoint { entryPointModuleName :: ModuleName , entryPointSymbol :: Maybe Name } + deriving (Eq, Ord, Show) newtype Version = Version { versionString :: String } + deriving (Eq, Ord, Show) instance Semigroup (Package term) where From 7cd0932197ab95871d1032442e278fcabc1c53fa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 13:28:48 -0400 Subject: [PATCH 11/89] Origins hold packages/modules/terms directly. --- src/Analysis/Abstract/Evaluating.hs | 16 +++--- src/Data/Abstract/Located.hs | 8 +-- src/Data/Abstract/Origin.hs | 89 +++++++++++++++++++++-------- src/Semantic/Util.hs | 25 ++++---- 4 files changed, 89 insertions(+), 49 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 98cbeb88c..0de5172ad 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -38,7 +38,7 @@ type EvaluatingEffects location term value , Fail -- Failure with an error message , Fresh -- For allocating new addresses and/or type variables. , Reader [Module term] -- The stack of currently-evaluating modules. - , Reader Origin -- The current term’s origin. + , Reader (SomeOrigin term) -- The current term’s origin. , Reader (ModuleTable [Module term]) -- Cache of unevaluated modules , Reader (Environment location value) -- Default environment used as a fallback in lookupEnv , State (EvaluatingState location term value) -- Environment, heap, modules, exports, and jumps. @@ -141,21 +141,19 @@ instance Members (EvaluatingEffects location term value) effects askModuleStack = raise ask -instance ( Members (EvaluatingEffects location term value) effects +instance ( Corecursive term + , Members (EvaluatingEffects location term value) effects , MonadValue location value (Evaluating location term value effects) - , HasOrigin (Base term) ) => MonadAnalysis location term value (Evaluating location term value effects) where type Effects location term value (Evaluating location term value effects) = EvaluatingEffects location term value - analyzeTerm eval term = do - ms <- askModuleStack - pushOrigin (originFor ms term) (eval term) + analyzeTerm eval term = pushOrigin (termOrigin (embedSubterm term)) (eval term) - analyzeModule eval m = pushModule (subterm <$> m) (eval m) + analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (pushModule (subterm <$> m) (eval m)) pushModule :: Member (Reader [Module term]) effects => Module term -> Evaluating location term value effects a -> Evaluating location term value effects a pushModule m = raise . local (m :) . lower -pushOrigin :: Member (Reader Origin) effects => Origin -> Evaluating location term value effects a -> Evaluating location term value effects a -pushOrigin o = raise . local (const o) . lower +pushOrigin :: Member (Reader (SomeOrigin term)) effects => SomeOrigin term -> Evaluating location term value effects a -> Evaluating location term value effects a +pushOrigin o = raise . local (<> o) . lower diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index 7309bae55..c2d323e17 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -5,13 +5,13 @@ import Control.Abstract.Addressable import Data.Abstract.Address import Data.Abstract.Origin -data Located location = Located { location :: location, origin :: !Origin } +data Located location term = Located { location :: location, origin :: !(SomeOrigin term) } deriving (Eq, Ord, Show) -instance Location location => Location (Located location) where - type Cell (Located location) = Cell location +instance (Location location, Ord term) => Location (Located location term) where + type Cell (Located location term) = Cell location -instance (MonadAddressable location m, MonadOrigin m) => MonadAddressable (Located location) m where +instance (MonadAddressable location m, MonadOrigin term m, Ord term) => MonadAddressable (Located location term) m where derefCell (Address (Located loc _)) = derefCell (Address loc) allocLoc name = Located <$> allocLoc name <*> askOrigin diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 0ec5ac806..5315a7b9e 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -1,45 +1,88 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs, UndecidableInstances #-} module Data.Abstract.Origin where import Control.Effect import Control.Monad.Effect.Reader -import Data.Abstract.Module -import Data.Range -import Data.Record -import Data.Span -import Data.Term +import qualified Data.Abstract.Module as M +import qualified Data.Abstract.Package as P import Prologue -- TODO: Upstream dependencies -data Origin - = Unknown - | Local !ModuleName !FilePath !Range !Span +data Origin term ty where + Unknown :: Origin term any + Package :: P.Package term -> Origin term 'P + Module :: Origin term 'P -> M.Module term -> Origin term 'M + Term :: Origin term 'M -> term -> Origin term 'T + +packageOrigin :: P.Package term -> SomeOrigin term +packageOrigin = SomeOrigin . Package + +moduleOrigin :: M.Module term -> SomeOrigin term +moduleOrigin = SomeOrigin . Module Unknown + +termOrigin :: term -> SomeOrigin term +termOrigin = SomeOrigin . Term Unknown + +deriving instance Eq term => Eq (Origin term ty) +deriving instance Show term => Show (Origin term ty) + +eqOrigins :: Eq term => Origin term ty1 -> Origin term ty2 -> Bool +eqOrigins Unknown Unknown = True +eqOrigins (Package p1) (Package p2) = p1 == p2 +eqOrigins (Module p1 m1) (Module p2 m2) = p1 == p2 && m1 == m2 +eqOrigins (Term m1 t1) (Term m2 t2) = m1 == m2 && t1 == t2 +eqOrigins _ _ = False + +compareOrigins :: Ord term => Origin term ty1 -> Origin term ty2 -> Ordering +compareOrigins Unknown Unknown = EQ +compareOrigins Unknown _ = LT +compareOrigins _ Unknown = GT +compareOrigins (Package p1) (Package p2) = compare p1 p2 +compareOrigins (Package _) _ = LT +compareOrigins _ (Package _) = GT +compareOrigins (Module p1 m1) (Module p2 m2) = compare p1 p2 <> compare m1 m2 +compareOrigins (Module _ _) _ = LT +compareOrigins _ (Module _ _) = GT +compareOrigins (Term m1 t1) (Term m2 t2) = compare m1 m2 <> compare t1 t2 + +instance Ord term => Ord (Origin term ty) where + compare = compareOrigins + +data OriginType = P | M | T deriving (Eq, Ord, Show) +data SomeOrigin term where + SomeOrigin :: Origin term ty -> SomeOrigin term -class HasOrigin f where - originFor :: [Module a] -> f b -> Origin +instance Eq term => Eq (SomeOrigin term) where + SomeOrigin o1 == SomeOrigin o2 = eqOrigins o1 o2 -instance (HasField fields Range, HasField fields Span) => HasOrigin (TermF syntax (Record fields)) where - originFor [] _ = Unknown - originFor (m:_) (In ann _) = Local (moduleName m) (modulePath m) (getField ann) (getField ann) +instance Ord term => Ord (SomeOrigin term) where + compare (SomeOrigin o1) (SomeOrigin o2) = compareOrigins o1 o2 + +deriving instance Show term => Show (SomeOrigin term) -class Monad m => MonadOrigin m where - askOrigin :: m Origin +class Monad m => MonadOrigin term m where + askOrigin :: m (SomeOrigin term) instance ( Effectful m - , Member (Reader Origin) effects + , Member (Reader (SomeOrigin term)) effects , Monad (m effects) ) - => MonadOrigin (m effects) where + => MonadOrigin term (m effects) where askOrigin = raise ask -instance Semigroup Origin where - a <> Unknown = a - _ <> b = b +merge :: Origin term ty1 -> Origin term ty2 -> SomeOrigin term +merge a Unknown = SomeOrigin a +merge (Package p) (Module Unknown m) = SomeOrigin (Module (Package p) m) +merge (Module p m) (Term Unknown t) = SomeOrigin (Term (Module p m) t) +merge _ b = SomeOrigin b -instance Monoid Origin where - mempty = Unknown +instance Semigroup (SomeOrigin term) where + SomeOrigin a <> SomeOrigin b = merge a b + +instance Monoid (SomeOrigin term) where + mempty = SomeOrigin Unknown mappend = (<>) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index f520a6353..9b1064d11 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -15,7 +15,6 @@ import Control.Monad.IO.Class import Data.Abstract.Evaluatable hiding (head) import Data.Abstract.Address import Data.Abstract.Module -import Data.Abstract.Origin import Data.Abstract.Type import Data.Abstract.Value import Data.Blob @@ -70,10 +69,10 @@ evaluateTypeScriptFiles = evaluateFiles typescriptParser -- Evalute a single file. evaluateFile :: forall term effects - . ( Evaluatable (Base term) + . ( Corecursive term + , Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) - , HasOrigin (Base term) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) , Recursive term ) @@ -83,10 +82,10 @@ evaluateFile :: forall term effects evaluateFile parser path = runAnalysis @(Evaluating Precise term (Value Precise)) . evaluateModule <$> parseFile parser Nothing path evaluateWith :: forall location value term effects - . ( effects ~ Effects location term value (Evaluating location term value effects) + . ( Corecursive term + , effects ~ Effects location term value (Evaluating location term value effects) , Evaluatable (Base term) , FreeVariables term - , HasOrigin (Base term) , MonadAddressable location (Evaluating location term value effects) , MonadValue location value (Evaluating location term value effects) , Recursive term @@ -106,10 +105,10 @@ evaluateWith prelude m = runAnalysis @(Evaluating location term value) $ do withDefaultEnvironment preludeEnv (evaluateModule m) evaluateWithPrelude :: forall term effects - . ( Evaluatable (Base term) + . ( Corecursive term + , Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) - , HasOrigin (Base term) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) , Recursive term , TypeLevel.KnownSymbol (PreludePath term) @@ -126,10 +125,10 @@ evaluateWithPrelude parser path = do -- Evaluate a list of files (head of file list is considered the entry point). evaluateFiles :: forall term effects - . ( Evaluatable (Base term) + . ( Corecursive term + , Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) - , HasOrigin (Base term) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) , Recursive term ) @@ -140,10 +139,10 @@ evaluateFiles parser paths = runAnalysis @(Evaluating Precise term (Value Precis -- | Evaluate terms and an entry point to a value with a given prelude. evaluatesWith :: forall location value term effects - . ( effects ~ Effects location term value (Evaluating location term value effects) + . ( Corecursive term + , effects ~ Effects location term value (Evaluating location term value effects) , Evaluatable (Base term) , FreeVariables term - , HasOrigin (Base term) , MonadAddressable location (Evaluating location term value effects) , MonadValue location value (Evaluating location term value effects) , Recursive term @@ -159,10 +158,10 @@ evaluatesWith prelude modules m = runAnalysis @(Evaluating location term value) withDefaultEnvironment preludeEnv (withModules modules (evaluateModule m)) evaluateFilesWithPrelude :: forall term effects - . ( Evaluatable (Base term) + . ( Corecursive term + , Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) - , HasOrigin (Base term) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) , Recursive term , TypeLevel.KnownSymbol (PreludePath term) From 7e4e01fee6a4e68edc7167d5eabcf0e819d2a8f3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 13:37:07 -0400 Subject: [PATCH 12/89] Define a projection of modules out of origins. --- src/Data/Abstract/Origin.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 5315a7b9e..266a8d5b0 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -23,6 +23,11 @@ moduleOrigin = SomeOrigin . Module Unknown termOrigin :: term -> SomeOrigin term termOrigin = SomeOrigin . Term Unknown +originModule :: SomeOrigin term -> Maybe (M.Module term) +originModule (SomeOrigin (Term (Module _ m) _)) = Just m +originModule (SomeOrigin (Module _ m)) = Just m +originModule _ = Nothing + deriving instance Eq term => Eq (Origin term ty) deriving instance Show term => Show (Origin term ty) From 59c187c22f2b2669b8434fb0ee718e4c022305f5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 13:38:24 -0400 Subject: [PATCH 13/89] Merging copies the module from terms. --- src/Data/Abstract/Origin.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 266a8d5b0..d10b70652 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -83,6 +83,7 @@ merge :: Origin term ty1 -> Origin term ty2 -> SomeOrigin term merge a Unknown = SomeOrigin a merge (Package p) (Module Unknown m) = SomeOrigin (Module (Package p) m) merge (Module p m) (Term Unknown t) = SomeOrigin (Term (Module p m) t) +merge (Term m _) (Term Unknown t) = SomeOrigin (Term m t) merge _ b = SomeOrigin b instance Semigroup (SomeOrigin term) where From 754dfe78894e6dfce10b1d6f337730ddee274697 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 13:39:12 -0400 Subject: [PATCH 14/89] Use the origin effect for the current module. --- src/Analysis/Abstract/Collecting.hs | 2 -- src/Analysis/Abstract/Evaluating.hs | 8 +------- src/Analysis/Abstract/ImportGraph.hs | 15 ++++++++++----- src/Control/Abstract/Evaluator.hs | 5 ----- 4 files changed, 11 insertions(+), 19 deletions(-) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index c93901aa4..5ee0b7916 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -25,8 +25,6 @@ instance ( Effectful m => MonadEvaluator location term value (Collecting m effects) where getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap - askModuleStack = Collecting askModuleStack - instance ( Effectful m , Foldable (Cell location) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 0de5172ad..55e779260 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -37,7 +37,6 @@ type EvaluatingEffects location term value , Resumable (Unspecialized value) , Fail -- Failure with an error message , Fresh -- For allocating new addresses and/or type variables. - , Reader [Module term] -- The stack of currently-evaluating modules. , Reader (SomeOrigin term) -- The current term’s origin. , Reader (ModuleTable [Module term]) -- Cache of unevaluated modules , Reader (Environment location value) -- Default environment used as a fallback in lookupEnv @@ -139,8 +138,6 @@ instance Members (EvaluatingEffects location term value) effects => MonadEvaluator location term value (Evaluating location term value effects) where getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap - askModuleStack = raise ask - instance ( Corecursive term , Members (EvaluatingEffects location term value) effects , MonadValue location value (Evaluating location term value effects) @@ -150,10 +147,7 @@ instance ( Corecursive term analyzeTerm eval term = pushOrigin (termOrigin (embedSubterm term)) (eval term) - analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (pushModule (subterm <$> m) (eval m)) - -pushModule :: Member (Reader [Module term]) effects => Module term -> Evaluating location term value effects a -> Evaluating location term value effects a -pushModule m = raise . local (m :) . lower + analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (eval m) pushOrigin :: Member (Reader (SomeOrigin term)) effects => SomeOrigin term -> Evaluating location term value effects a -> Evaluating location term value effects a pushOrigin o = raise . local (<> o) . lower diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 6f3396247..a18630410 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -13,6 +13,7 @@ import Control.Abstract.Analysis import Data.Abstract.Evaluatable (LoadError (..)) import Data.Abstract.FreeVariables import Data.Abstract.Module +import Data.Abstract.Origin import Prologue hiding (empty) -- | The graph of function definitions to symbols used in a given program. @@ -34,6 +35,7 @@ deriving instance MonadEvaluator location term value (m effects) => MonadEvalu instance ( Effectful m + , Member (Reader (SomeOrigin term)) effects , Member (State ImportGraph) effects , MonadAnalysis location term value (m effects) , Member (Resumable (LoadError term value)) effects @@ -50,14 +52,17 @@ instance ( Effectful m insertVertexName (moduleName m) liftAnalyze analyzeModule recur m -insertVertexName :: (Effectful m - , Member (State ImportGraph) effects - , MonadEvaluator location term value (m effects)) +insertVertexName :: forall m location term value effects + . ( Effectful m + , Member (Reader (SomeOrigin term)) effects + , Member (State ImportGraph) effects + , MonadEvaluator location term value (m effects) + ) => NonEmpty ByteString -> ImportGraphing m effects () insertVertexName name = do - ms <- askModuleStack - let parent = maybe empty (vertex . moduleName) (listToMaybe ms) + o <- askOrigin + let parent = maybe empty (vertex . moduleName) (originModule @term o) modifyImportGraph (parent >< vertex name <>) (><) :: Graph a => a -> a -> a diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 1dc950491..5ae6f2694 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -46,11 +46,6 @@ class ( MonadControl term m -- | Get the current 'Configuration' with a passed-in term. getConfiguration :: Ord location => term -> m (Configuration location term value) - -- | Retrieve the stack of modules currently being evaluated. - -- - -- With great power comes great responsibility. If you 'evaluateModule' any of these, you probably deserve what you get. - askModuleStack :: m [Module term] - -- | A 'Monad' abstracting local and global environments. class Monad m => MonadEnvironment location value m | m -> value, m -> location where From 1a376820847947041b36f6e4bf4fb8f990047692 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 13:42:49 -0400 Subject: [PATCH 15/89] :fire: MonadOrigin. --- src/Analysis/Abstract/ImportGraph.hs | 2 +- src/Data/Abstract/Located.hs | 14 +++++++++++--- src/Data/Abstract/Origin.hs | 13 ------------- 3 files changed, 12 insertions(+), 17 deletions(-) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index a18630410..9e1261859 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -61,7 +61,7 @@ insertVertexName :: forall m location term value effects => NonEmpty ByteString -> ImportGraphing m effects () insertVertexName name = do - o <- askOrigin + o <- raise ask let parent = maybe empty (vertex . moduleName) (originModule @term o) modifyImportGraph (parent >< vertex name <>) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index c2d323e17..2a3f26227 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -1,9 +1,12 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies, UndecidableInstances #-} module Data.Abstract.Located where import Control.Abstract.Addressable +import Control.Effect +import Control.Monad.Effect.Reader import Data.Abstract.Address import Data.Abstract.Origin +import Prologue data Located location term = Located { location :: location, origin :: !(SomeOrigin term) } deriving (Eq, Ord, Show) @@ -11,7 +14,12 @@ data Located location term = Located { location :: location, origin :: !(SomeOri instance (Location location, Ord term) => Location (Located location term) where type Cell (Located location term) = Cell location -instance (MonadAddressable location m, MonadOrigin term m, Ord term) => MonadAddressable (Located location term) m where +instance ( Effectful m + , Member (Reader (SomeOrigin term)) effects + , MonadAddressable location (m effects) + , Ord term + ) + => MonadAddressable (Located location term) (m effects) where derefCell (Address (Located loc _)) = derefCell (Address loc) - allocLoc name = Located <$> allocLoc name <*> askOrigin + allocLoc name = Located <$> allocLoc name <*> raise ask diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index d10b70652..c3b180412 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -1,8 +1,6 @@ {-# LANGUAGE GADTs, UndecidableInstances #-} module Data.Abstract.Origin where -import Control.Effect -import Control.Monad.Effect.Reader import qualified Data.Abstract.Module as M import qualified Data.Abstract.Package as P import Prologue @@ -68,17 +66,6 @@ instance Ord term => Ord (SomeOrigin term) where deriving instance Show term => Show (SomeOrigin term) -class Monad m => MonadOrigin term m where - askOrigin :: m (SomeOrigin term) - -instance ( Effectful m - , Member (Reader (SomeOrigin term)) effects - , Monad (m effects) - ) - => MonadOrigin term (m effects) where - askOrigin = raise ask - - merge :: Origin term ty1 -> Origin term ty2 -> SomeOrigin term merge a Unknown = SomeOrigin a merge (Package p) (Module Unknown m) = SomeOrigin (Module (Package p) m) From f4d1d21e6ef9b094262b536016812c9dc8a1c26a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 13:46:35 -0400 Subject: [PATCH 16/89] Align the constructors. --- src/Data/Abstract/Origin.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index c3b180412..ae6e1a88c 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -7,10 +7,10 @@ import Prologue -- TODO: Upstream dependencies data Origin term ty where - Unknown :: Origin term any - Package :: P.Package term -> Origin term 'P - Module :: Origin term 'P -> M.Module term -> Origin term 'M - Term :: Origin term 'M -> term -> Origin term 'T + Unknown :: Origin term any + Package :: P.Package term -> Origin term 'P + Module :: Origin term 'P -> M.Module term -> Origin term 'M + Term :: Origin term 'M -> term -> Origin term 'T packageOrigin :: P.Package term -> SomeOrigin term packageOrigin = SomeOrigin . Package From 3852a7207f8057d3a096f9ed84f5ff2b29e2cc35 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 13:47:24 -0400 Subject: [PATCH 17/89] Define a Functor instance for Package. --- src/Data/Abstract/Package.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index dea135195..b5472f4c8 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -13,7 +13,7 @@ data Package term = Package , packageModules :: Map.Map ModuleName [Module term] , packageEntryPoints :: [EntryPoint] } - deriving (Eq, Ord, Show) + deriving (Eq, Functor, Ord, Show) data EntryPoint = EntryPoint { entryPointModuleName :: ModuleName From 8796f915d42b80f29920a5771afe04d27b9f5898 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 13:55:21 -0400 Subject: [PATCH 18/89] Parameterize origin fields by () rather than term. --- src/Analysis/Abstract/Evaluating.hs | 4 ++-- src/Data/Abstract/Located.hs | 9 +++++--- src/Data/Abstract/Origin.hs | 34 ++++++++++++++--------------- src/Semantic/Util.hs | 18 +++++---------- 4 files changed, 31 insertions(+), 34 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 55e779260..74b343217 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -138,14 +138,14 @@ instance Members (EvaluatingEffects location term value) effects => MonadEvaluator location term value (Evaluating location term value effects) where getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap -instance ( Corecursive term +instance ( Functor (Base term) , Members (EvaluatingEffects location term value) effects , MonadValue location value (Evaluating location term value effects) ) => MonadAnalysis location term value (Evaluating location term value effects) where type Effects location term value (Evaluating location term value effects) = EvaluatingEffects location term value - analyzeTerm eval term = pushOrigin (termOrigin (embedSubterm term)) (eval term) + analyzeTerm eval term = pushOrigin (termOrigin term) (eval term) analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (eval m) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index 2a3f26227..7414f3041 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -9,15 +9,18 @@ import Data.Abstract.Origin import Prologue data Located location term = Located { location :: location, origin :: !(SomeOrigin term) } - deriving (Eq, Ord, Show) -instance (Location location, Ord term) => Location (Located location term) where +deriving instance (Eq location, Eq (Base term ())) => Eq (Located location term) +deriving instance (Ord location, Ord (Base term ())) => Ord (Located location term) +deriving instance (Show location, Show (Base term ())) => Show (Located location term) + +instance (Location location, Ord (Base term ())) => Location (Located location term) where type Cell (Located location term) = Cell location instance ( Effectful m , Member (Reader (SomeOrigin term)) effects , MonadAddressable location (m effects) - , Ord term + , Ord (Base term ()) ) => MonadAddressable (Located location term) (m effects) where derefCell (Address (Located loc _)) = derefCell (Address loc) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index ae6e1a88c..660f8e109 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -7,36 +7,36 @@ import Prologue -- TODO: Upstream dependencies data Origin term ty where - Unknown :: Origin term any - Package :: P.Package term -> Origin term 'P - Module :: Origin term 'P -> M.Module term -> Origin term 'M - Term :: Origin term 'M -> term -> Origin term 'T + Unknown :: Origin term any + Package :: P.Package () -> Origin term 'P + Module :: Origin term 'P -> M.Module () -> Origin term 'M + Term :: Origin term 'M -> Base term () -> Origin term 'T packageOrigin :: P.Package term -> SomeOrigin term -packageOrigin = SomeOrigin . Package +packageOrigin = SomeOrigin . Package . (() <$) moduleOrigin :: M.Module term -> SomeOrigin term -moduleOrigin = SomeOrigin . Module Unknown +moduleOrigin = SomeOrigin . Module Unknown . (() <$) -termOrigin :: term -> SomeOrigin term -termOrigin = SomeOrigin . Term Unknown +termOrigin :: Functor (Base term) => Base term a -> SomeOrigin term +termOrigin = SomeOrigin . Term Unknown . (() <$) -originModule :: SomeOrigin term -> Maybe (M.Module term) +originModule :: SomeOrigin term -> Maybe (M.Module ()) originModule (SomeOrigin (Term (Module _ m) _)) = Just m originModule (SomeOrigin (Module _ m)) = Just m originModule _ = Nothing -deriving instance Eq term => Eq (Origin term ty) -deriving instance Show term => Show (Origin term ty) +deriving instance Eq (Base term ()) => Eq (Origin term ty) +deriving instance Show (Base term ()) => Show (Origin term ty) -eqOrigins :: Eq term => Origin term ty1 -> Origin term ty2 -> Bool +eqOrigins :: Eq (Base term ()) => Origin term ty1 -> Origin term ty2 -> Bool eqOrigins Unknown Unknown = True eqOrigins (Package p1) (Package p2) = p1 == p2 eqOrigins (Module p1 m1) (Module p2 m2) = p1 == p2 && m1 == m2 eqOrigins (Term m1 t1) (Term m2 t2) = m1 == m2 && t1 == t2 eqOrigins _ _ = False -compareOrigins :: Ord term => Origin term ty1 -> Origin term ty2 -> Ordering +compareOrigins :: Ord (Base term ()) => Origin term ty1 -> Origin term ty2 -> Ordering compareOrigins Unknown Unknown = EQ compareOrigins Unknown _ = LT compareOrigins _ Unknown = GT @@ -48,7 +48,7 @@ compareOrigins (Module _ _) _ = LT compareOrigins _ (Module _ _) = GT compareOrigins (Term m1 t1) (Term m2 t2) = compare m1 m2 <> compare t1 t2 -instance Ord term => Ord (Origin term ty) where +instance Ord (Base term ()) => Ord (Origin term ty) where compare = compareOrigins data OriginType = P | M | T @@ -57,13 +57,13 @@ data OriginType = P | M | T data SomeOrigin term where SomeOrigin :: Origin term ty -> SomeOrigin term -instance Eq term => Eq (SomeOrigin term) where +instance Eq (Base term ()) => Eq (SomeOrigin term) where SomeOrigin o1 == SomeOrigin o2 = eqOrigins o1 o2 -instance Ord term => Ord (SomeOrigin term) where +instance Ord (Base term ()) => Ord (SomeOrigin term) where compare (SomeOrigin o1) (SomeOrigin o2) = compareOrigins o1 o2 -deriving instance Show term => Show (SomeOrigin term) +deriving instance Show (Base term ()) => Show (SomeOrigin term) merge :: Origin term ty1 -> Origin term ty2 -> SomeOrigin term diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 9b1064d11..830278f86 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -69,8 +69,7 @@ evaluateTypeScriptFiles = evaluateFiles typescriptParser -- Evalute a single file. evaluateFile :: forall term effects - . ( Corecursive term - , Evaluatable (Base term) + . ( Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) @@ -82,8 +81,7 @@ evaluateFile :: forall term effects evaluateFile parser path = runAnalysis @(Evaluating Precise term (Value Precise)) . evaluateModule <$> parseFile parser Nothing path evaluateWith :: forall location value term effects - . ( Corecursive term - , effects ~ Effects location term value (Evaluating location term value effects) + . ( effects ~ Effects location term value (Evaluating location term value effects) , Evaluatable (Base term) , FreeVariables term , MonadAddressable location (Evaluating location term value effects) @@ -105,8 +103,7 @@ evaluateWith prelude m = runAnalysis @(Evaluating location term value) $ do withDefaultEnvironment preludeEnv (evaluateModule m) evaluateWithPrelude :: forall term effects - . ( Corecursive term - , Evaluatable (Base term) + . ( Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) @@ -125,8 +122,7 @@ evaluateWithPrelude parser path = do -- Evaluate a list of files (head of file list is considered the entry point). evaluateFiles :: forall term effects - . ( Corecursive term - , Evaluatable (Base term) + . ( Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) @@ -139,8 +135,7 @@ evaluateFiles parser paths = runAnalysis @(Evaluating Precise term (Value Precis -- | Evaluate terms and an entry point to a value with a given prelude. evaluatesWith :: forall location value term effects - . ( Corecursive term - , effects ~ Effects location term value (Evaluating location term value effects) + . ( effects ~ Effects location term value (Evaluating location term value effects) , Evaluatable (Base term) , FreeVariables term , MonadAddressable location (Evaluating location term value effects) @@ -158,8 +153,7 @@ evaluatesWith prelude modules m = runAnalysis @(Evaluating location term value) withDefaultEnvironment preludeEnv (withModules modules (evaluateModule m)) evaluateFilesWithPrelude :: forall term effects - . ( Corecursive term - , Evaluatable (Base term) + . ( Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) From f1a44db1390eb89ce78fa0f8f844c3ca8b7b139e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 13:59:05 -0400 Subject: [PATCH 19/89] =?UTF-8?q?Merge=20modules=E2=80=99=20packages.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Abstract/Origin.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 660f8e109..3d635288f 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -69,6 +69,7 @@ deriving instance Show (Base term ()) => Show (SomeOrigin term) merge :: Origin term ty1 -> Origin term ty2 -> SomeOrigin term merge a Unknown = SomeOrigin a merge (Package p) (Module Unknown m) = SomeOrigin (Module (Package p) m) +merge (Module p _) (Module Unknown m) = SomeOrigin (Module p m) merge (Module p m) (Term Unknown t) = SomeOrigin (Term (Module p m) t) merge (Term m _) (Term Unknown t) = SomeOrigin (Term m t) merge _ b = SomeOrigin b From 88749f47ce89aed80efd9e2ef840095c7aefe285 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 16:42:46 -0400 Subject: [PATCH 20/89] :fire: the Semigroup/Monoid instances for Package. --- src/Data/Abstract/Package.hs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index b5472f4c8..421569c92 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -3,7 +3,6 @@ module Data.Abstract.Package where import Data.Abstract.FreeVariables import Data.Abstract.Module import qualified Data.Map as Map -import Prologue type PackageName = Name @@ -23,11 +22,3 @@ data EntryPoint = EntryPoint newtype Version = Version { versionString :: String } deriving (Eq, Ord, Show) - - -instance Semigroup (Package term) where - _ <> b = b - -instance Monoid (Package term) where - mempty = Package Nothing Nothing Map.empty [] - mappend = (<>) From 60f9fe4608d48089a0894a8eb4222a82543f245f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 16:44:00 -0400 Subject: [PATCH 21/89] Stub in an evaluator for packages. --- src/Data/Abstract/Evaluatable.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 4acb24065..b4213a4ab 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -8,6 +8,7 @@ module Data.Abstract.Evaluatable , EvalError(..) , evaluateTerm , evaluateModule +, evaluatePackage , withModules , evaluateModules , throwLoadError @@ -23,6 +24,7 @@ import qualified Data.Abstract.Exports as Exports import Data.Abstract.FreeVariables as X import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable +import Data.Abstract.Package import Data.Semigroup.App import Data.Semigroup.Foldable import Data.Semigroup.Reducer hiding (unit) @@ -178,3 +180,8 @@ evaluateModules :: MonadEvaluatable location term value m -> m value evaluateModules [] = fail "evaluateModules: empty list" evaluateModules (m:ms) = withModules ms (evaluateModule m) + +evaluatePackage :: MonadEvaluatable location term value m + => Package term + -> m value +evaluatePackage _ = fail "nope" From 06b59fe9da658e6e5a8dd8ed4edda662eff55916 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 16:48:21 -0400 Subject: [PATCH 22/89] Push the package into scope. --- src/Data/Abstract/Evaluatable.hs | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index b4213a4ab..c38cb0beb 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -24,6 +24,7 @@ import qualified Data.Abstract.Exports as Exports import Data.Abstract.FreeVariables as X import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable +import Data.Abstract.Origin (SomeOrigin, packageOrigin) import Data.Abstract.Package import Data.Semigroup.App import Data.Semigroup.Foldable @@ -181,7 +182,18 @@ evaluateModules :: MonadEvaluatable location term value m evaluateModules [] = fail "evaluateModules: empty list" evaluateModules (m:ms) = withModules ms (evaluateModule m) -evaluatePackage :: MonadEvaluatable location term value m +evaluatePackage :: ( Effectful m + , Member (Reader (SomeOrigin term)) effects + , MonadEvaluatable location term value (m effects) + ) => Package term - -> m value -evaluatePackage _ = fail "nope" + -> m effects value +evaluatePackage p = pushPackage p (fail "nope") + +pushPackage :: ( Effectful m + , Member (Reader (SomeOrigin term)) effects + ) + => Package term + -> m effects a + -> m effects a +pushPackage p = raise . local (<> packageOrigin p) . lower From b32372e1bc1cfacc110706a77062fbf06dee8a38 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:04:35 -0400 Subject: [PATCH 23/89] =?UTF-8?q?Reuse=20ModuleTable=20for=20a=20package?= =?UTF-8?q?=E2=80=99s=20modules.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Abstract/Package.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 421569c92..f32cbde02 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -2,14 +2,14 @@ module Data.Abstract.Package where import Data.Abstract.FreeVariables import Data.Abstract.Module -import qualified Data.Map as Map +import Data.Abstract.ModuleTable type PackageName = Name data Package term = Package { packageName :: Maybe PackageName , packageVersion :: Maybe Version - , packageModules :: Map.Map ModuleName [Module term] + , packageModules :: ModuleTable [Module term] , packageEntryPoints :: [EntryPoint] } deriving (Eq, Functor, Ord, Show) From d63d956cc8cb6b15f259e6a6492a97daa8c47478 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:05:48 -0400 Subject: [PATCH 24/89] Set up the local module table. --- src/Data/Abstract/Evaluatable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index c38cb0beb..fea69d5c7 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -188,7 +188,7 @@ evaluatePackage :: ( Effectful m ) => Package term -> m effects value -evaluatePackage p = pushPackage p (fail "nope") +evaluatePackage p = pushPackage p (localModuleTable (const (packageModules p)) (fail "nope")) pushPackage :: ( Effectful m , Member (Reader (SomeOrigin term)) effects From a8d03f2f3ec8bd472b6b252096c23f860c2ec67b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:13:21 -0400 Subject: [PATCH 25/89] Rename the ModuleTable symbols. --- src/Data/Abstract/Evaluatable.hs | 6 +++--- src/Data/Abstract/ModuleTable.hs | 13 +++++++------ src/Language/Ruby/Syntax.hs | 4 ++-- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index fea69d5c7..1eeb3e9e8 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -119,7 +119,7 @@ instance Evaluatable [] where require :: MonadEvaluatable location term value m => ModuleName -> m (Environment location value, value) -require name = getModuleTable >>= maybe (load name) pure . moduleTableLookup name +require name = getModuleTable >>= maybe (load name) pure . ModuleTable.lookup name -- | Load another module by name and return it's environment and value. -- @@ -127,7 +127,7 @@ require name = getModuleTable >>= maybe (load name) pure . moduleTableLookup nam load :: MonadEvaluatable location term value m => ModuleName -> m (Environment location value, value) -load name = askModuleTable >>= maybe notFound pure . moduleTableLookup name >>= evalAndCache +load name = askModuleTable >>= maybe notFound pure . ModuleTable.lookup name >>= evalAndCache where notFound = throwLoadError (LoadError name) @@ -141,7 +141,7 @@ load name = askModuleTable >>= maybe notFound pure . moduleTableLookup name >>= evalAndCache' x = do v <- evaluateModule x env <- filterEnv <$> getExports <*> getEnv - modifyModuleTable (moduleTableInsert name (env, v)) + modifyModuleTable (ModuleTable.insert name (env, v)) pure (env, v) -- TODO: If the set of exports is empty because no exports have been diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index 53f697b36..b016caa3c 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -2,8 +2,8 @@ module Data.Abstract.ModuleTable ( ModuleName , ModuleTable (..) -, moduleTableLookup -, moduleTableInsert +, lookup +, insert , fromList ) where @@ -11,15 +11,16 @@ import Data.Abstract.Module import qualified Data.Map as Map import Data.Semigroup import GHC.Generics (Generic1) +import Prelude hiding (lookup) newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModuleName a } deriving (Eq, Foldable, Functor, Generic1, Monoid, Ord, Semigroup, Show, Traversable) -moduleTableLookup :: ModuleName -> ModuleTable a -> Maybe a -moduleTableLookup k = Map.lookup k . unModuleTable +lookup :: ModuleName -> ModuleTable a -> Maybe a +lookup k = Map.lookup k . unModuleTable -moduleTableInsert :: ModuleName -> a -> ModuleTable a -> ModuleTable a -moduleTableInsert k v ModuleTable{..} = ModuleTable (Map.insert k v unModuleTable) +insert :: ModuleName -> a -> ModuleTable a -> ModuleTable a +insert k v ModuleTable{..} = ModuleTable (Map.insert k v unModuleTable) -- | Construct a 'ModuleTable' from a list of 'Module's. diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 3c3d49a93..5a47c4b3b 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -3,7 +3,7 @@ module Language.Ruby.Syntax where import Control.Monad (unless) import Data.Abstract.Evaluatable -import Data.Abstract.ModuleTable +import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Path import Diffing.Algorithm import Prelude hiding (fail) @@ -30,7 +30,7 @@ doRequire :: MonadEvaluatable location term value m -> m (Environment location value, value) doRequire name = do moduleTable <- getModuleTable - case moduleTableLookup name moduleTable of + case ModuleTable.lookup name moduleTable of Nothing -> (,) <$> (fst <$> load name) <*> boolean True Just (env, _) -> (,) <$> pure env <*> boolean False From 0d3dadb143c488cd0ea0791940c315c554fbddcd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:14:39 -0400 Subject: [PATCH 26/89] Functor laws. --- src/Language/Ruby/Syntax.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 5a47c4b3b..84b3b6c32 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -31,8 +31,8 @@ doRequire :: MonadEvaluatable location term value m doRequire name = do moduleTable <- getModuleTable case ModuleTable.lookup name moduleTable of - Nothing -> (,) <$> (fst <$> load name) <*> boolean True - Just (env, _) -> (,) <$> pure env <*> boolean False + Nothing -> (,) . fst <$> load name <*> boolean True + Just (env, _) -> (,) env <$> boolean False newtype Load a = Load { loadArgs :: [a] } From ccbeb00eb05405e4c18e39abd2328e62328c3b55 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:15:30 -0400 Subject: [PATCH 27/89] Entry points are represented as a map of module names to symbols. --- src/Data/Abstract/Package.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index f32cbde02..d21752bbd 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -10,15 +10,9 @@ data Package term = Package { packageName :: Maybe PackageName , packageVersion :: Maybe Version , packageModules :: ModuleTable [Module term] - , packageEntryPoints :: [EntryPoint] + , packageEntryPoints :: ModuleTable (Maybe Name) } deriving (Eq, Functor, Ord, Show) -data EntryPoint = EntryPoint - { entryPointModuleName :: ModuleName - , entryPointSymbol :: Maybe Name - } - deriving (Eq, Ord, Show) - newtype Version = Version { versionString :: String } deriving (Eq, Ord, Show) From 7d2fa60ae39d143c5c15d8883e012bc7c5c5f942 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:16:33 -0400 Subject: [PATCH 28/89] Semigroup. --- src/Data/Abstract/Evaluatable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 1eeb3e9e8..0672aff7a 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -188,7 +188,7 @@ evaluatePackage :: ( Effectful m ) => Package term -> m effects value -evaluatePackage p = pushPackage p (localModuleTable (const (packageModules p)) (fail "nope")) +evaluatePackage p = pushPackage p (localModuleTable (<> packageModules p) (fail "nope")) pushPackage :: ( Effectful m , Member (Reader (SomeOrigin term)) effects From 7d911bde7c2dcbd8b3c6f14dee06007026238319 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:18:44 -0400 Subject: [PATCH 29/89] Define a toPairs eliminator for ModuleTable. --- src/Data/Abstract/ModuleTable.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index b016caa3c..fa7f8e034 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -5,6 +5,7 @@ module Data.Abstract.ModuleTable , lookup , insert , fromList +, toPairs ) where import Data.Abstract.Module @@ -27,3 +28,6 @@ insert k v ModuleTable{..} = ModuleTable (Map.insert k v unModuleTable) fromList :: [Module term] -> ModuleTable [Module term] fromList modules = ModuleTable (Map.fromListWith (<>) (map toEntry modules)) where toEntry m = (moduleName m, [m]) + +toPairs :: ModuleTable a -> [(ModuleName, a)] +toPairs = Map.toList . unModuleTable From f488e1996e8f31b5129d663e421de50ccccacde6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:22:46 -0400 Subject: [PATCH 30/89] Define fromList tacitly. --- 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 fa7f8e034..c3b606254 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -26,7 +26,7 @@ insert 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)) +fromList = ModuleTable . Map.fromListWith (<>) . map toEntry where toEntry m = (moduleName m, [m]) toPairs :: ModuleTable a -> [(ModuleName, a)] From a165d09e7f245b7a1d8afe0057ef3dfb49ec3647 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:24:01 -0400 Subject: [PATCH 31/89] More Functor laws. --- src/Data/Abstract/Evaluatable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 0672aff7a..529a05c27 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -131,7 +131,7 @@ load name = askModuleTable >>= maybe notFound pure . ModuleTable.lookup name >>= where notFound = throwLoadError (LoadError name) - evalAndCache [] = (,) <$> pure mempty <*> unit + evalAndCache [] = (,) mempty <$> unit evalAndCache [x] = evalAndCache' x evalAndCache (x:xs) = do (env, _) <- evalAndCache' x From 22ba2340103ab049b7cc7fdea6bfd11f105d28c7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:24:57 -0400 Subject: [PATCH 32/89] Use maybeM. --- src/Data/Abstract/Evaluatable.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 529a05c27..d7136bdfd 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -119,7 +119,7 @@ instance Evaluatable [] where require :: MonadEvaluatable location term value m => ModuleName -> m (Environment location value, value) -require name = getModuleTable >>= maybe (load name) pure . ModuleTable.lookup name +require name = getModuleTable >>= maybeM (load name) . ModuleTable.lookup name -- | Load another module by name and return it's environment and value. -- @@ -127,7 +127,7 @@ require name = getModuleTable >>= maybe (load name) pure . ModuleTable.lookup na load :: MonadEvaluatable location term value m => ModuleName -> m (Environment location value, value) -load name = askModuleTable >>= maybe notFound pure . ModuleTable.lookup name >>= evalAndCache +load name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= evalAndCache where notFound = throwLoadError (LoadError name) From c3bd31ffc7ac4aee4f07927d2e3490378ec467f1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:38:21 -0400 Subject: [PATCH 33/89] Evaluate every entry point. --- src/Data/Abstract/Evaluatable.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index d7136bdfd..839688c16 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -187,8 +187,17 @@ evaluatePackage :: ( Effectful m , MonadEvaluatable location term value (m effects) ) => Package term - -> m effects value -evaluatePackage p = pushPackage p (localModuleTable (<> packageModules p) (fail "nope")) + -> m effects [value] +evaluatePackage p = pushPackage p (localModuleTable (<> packageModules p) (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints p)))) + where evaluateEntryPoint (m, sym) = do + (_, v) <- require m + case sym of + Just sym -> do + f <- lookupWith deref sym + case f of + Just f -> X.apply f [] + Nothing -> fail $ "free variable: " <> show sym + Nothing -> pure v pushPackage :: ( Effectful m , Member (Reader (SomeOrigin term)) effects From 0355d81065bd342c46e5c390c02f3dd18522c205 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:38:33 -0400 Subject: [PATCH 34/89] Reformat evaluatePackage. --- src/Data/Abstract/Evaluatable.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 839688c16..ecd1a8178 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -188,7 +188,8 @@ evaluatePackage :: ( Effectful m ) => Package term -> m effects [value] -evaluatePackage p = pushPackage p (localModuleTable (<> packageModules p) (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints p)))) +evaluatePackage p = pushPackage p (localModuleTable (<> packageModules p) + (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints p)))) where evaluateEntryPoint (m, sym) = do (_, v) <- require m case sym of From fe3b9730c4b13f820000485e9aaf832a77f9f44b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:41:49 -0400 Subject: [PATCH 35/89] Use maybeM to evaluate identifiers. --- src/Data/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 68a43b086..a20424f92 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -106,7 +106,7 @@ instance Ord1 Identifier where liftCompare = genericLiftCompare instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Identifier where - eval (Identifier name) = lookupWith deref name >>= maybe (throwException $ FreeVariableError name) pure + eval (Identifier name) = lookupWith deref name >>= maybeM (throwException (FreeVariableError name)) instance FreeVariables1 Identifier where liftFreeVariables _ (Identifier x) = pure x From 92011e8ef25eb8326eb41e6e59b99a45434b528b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:45:48 -0400 Subject: [PATCH 36/89] Define a variable convenience. --- src/Data/Abstract/Evaluatable.hs | 4 ++++ src/Data/Syntax.hs | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index ecd1a8178..70e57763e 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -6,6 +6,7 @@ module Data.Abstract.Evaluatable , Unspecialized(..) , LoadError(..) , EvalError(..) +, variable , evaluateTerm , evaluateModule , evaluatePackage @@ -65,6 +66,9 @@ data EvalError value resume where -- Indicates we weren't able to dereference a name from the evaluated environment. FreeVariableError :: Name -> EvalError value value +variable :: MonadEvaluatable location term value m => Name -> m value +variable name = lookupWith deref name >>= maybeM (throwException (FreeVariableError name)) + deriving instance Eq (EvalError a b) deriving instance Show (EvalError a b) instance Show1 (EvalError value) where diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index a20424f92..6415e8ca7 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -106,7 +106,7 @@ instance Ord1 Identifier where liftCompare = genericLiftCompare instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Identifier where - eval (Identifier name) = lookupWith deref name >>= maybeM (throwException (FreeVariableError name)) + eval (Identifier name) = variable name instance FreeVariables1 Identifier where liftFreeVariables _ (Identifier x) = pure x From f3b319196950cfa805509731c318dfd365c95517 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:46:48 -0400 Subject: [PATCH 37/89] :memo: variable. --- src/Data/Abstract/Evaluatable.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 70e57763e..163903725 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -66,6 +66,7 @@ data EvalError value resume where -- Indicates we weren't able to dereference a name from the evaluated environment. FreeVariableError :: Name -> EvalError value value +-- | Look up and dereference the given 'Name', throwing an exception for free variables. variable :: MonadEvaluatable location term value m => Name -> m value variable name = lookupWith deref name >>= maybeM (throwException (FreeVariableError name)) From 89e5183af0239a265345ad25a6ae7ebae77678b1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:48:11 -0400 Subject: [PATCH 38/89] Use the variable helper to call entry points. --- src/Data/Abstract/Evaluatable.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 163903725..843c25952 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -197,13 +197,7 @@ evaluatePackage p = pushPackage p (localModuleTable (<> packageModules p) (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints p)))) where evaluateEntryPoint (m, sym) = do (_, v) <- require m - case sym of - Just sym -> do - f <- lookupWith deref sym - case f of - Just f -> X.apply f [] - Nothing -> fail $ "free variable: " <> show sym - Nothing -> pure v + maybe (pure v) ((`X.apply` []) <=< variable) sym pushPackage :: ( Effectful m , Member (Reader (SomeOrigin term)) effects From aa0ff616ab70c0b2e9965f521af7524ccd99ae02 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:49:34 -0400 Subject: [PATCH 39/89] Rename apply to call. --- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Evaluatable.hs | 2 +- src/Data/Abstract/Type.hs | 2 +- src/Data/Abstract/Value.hs | 2 +- src/Data/Syntax/Expression.hs | 4 ++-- 5 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 643abebeb..aa78efdc2 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -126,7 +126,7 @@ class (Monad m, Show value) => MonadValue location value m | m value -> location -- | Evaluate an abstraction (a binder like a lambda or method definition). abstract :: (FreeVariables term, MonadControl term m) => [Name] -> Subterm term (m value) -> m value -- | Evaluate an application (like a function call). - apply :: value -> [m value] -> m value + call :: value -> [m value] -> m value -- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion. -- diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 843c25952..dc6850090 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -197,7 +197,7 @@ evaluatePackage p = pushPackage p (localModuleTable (<> packageModules p) (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints p)))) where evaluateEntryPoint (m, sym) = do (_, v) <- require m - maybe (pure v) ((`X.apply` []) <=< variable) sym + maybe (pure v) ((`call` []) <=< variable) sym pushPackage :: ( Effectful m , Member (Reader (SomeOrigin term)) effects diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index f432e95fa..ab523d6e0 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -118,7 +118,7 @@ instance ( Alternative m (Int, Float) -> pure Int _ -> unify left right $> Bool - apply op params = do + call op params = do tvar <- fresh paramTypes <- sequenceA params _ :-> ret <- op `unify` (Product paramTypes :-> Var tvar) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 004e08306..4227c914d 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -300,7 +300,7 @@ instance (Monad m, MonadEvaluatable location term (Value location) m) => MonadVa l <- label body injValue . Closure names l . Env.bind (foldr Set.delete (Set.fromList (freeVariables body)) names) <$> getEnv - apply op params = do + call op params = do Closure names label env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op) bindings <- foldr (\ (name, param) rest -> do v <- param diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index e597889a2..79adda0e2 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -6,7 +6,7 @@ import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent) import Data.Fixed import Diffing.Algorithm import Prelude -import Prologue hiding (apply) +import Prologue -- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell. data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a } @@ -19,7 +19,7 @@ instance Show1 Call where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Call where eval Call{..} = do op <- subtermValue callFunction - apply op (map subtermValue callParams) + call op (map subtermValue callParams) data Comparison a = LessThan !a !a From fec4e09c253adfe186d883d1d51c9bf6b8e8e58f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:50:59 -0400 Subject: [PATCH 40/89] Rename abstract to lambda. --- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Type.hs | 2 +- src/Data/Abstract/Value.hs | 2 +- src/Data/Syntax/Declaration.hs | 4 ++-- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index aa78efdc2..de152f1e1 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -124,7 +124,7 @@ class (Monad m, Show value) => MonadValue location value m | m value -> location scopedEnvironment :: value -> m (Environment location value) -- | Evaluate an abstraction (a binder like a lambda or method definition). - abstract :: (FreeVariables term, MonadControl term m) => [Name] -> Subterm term (m value) -> m value + lambda :: (FreeVariables term, MonadControl term m) => [Name] -> Subterm term (m value) -> m value -- | Evaluate an application (like a function call). call :: value -> [m value] -> m value diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index ab523d6e0..04ef327b9 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -60,7 +60,7 @@ instance ( Alternative m , Reducer Type (Cell location Type) ) => MonadValue location Type m where - abstract names (Subterm _ body) = do + lambda names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name tvar <- Var <$> fresh diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 4227c914d..f16894f32 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -296,7 +296,7 @@ instance (Monad m, MonadEvaluatable location term (Value location) m) => MonadVa | otherwise = fail ("Type error: invalid binary bitwise operation on " <> show pair) where pair = (left, right) - abstract names (Subterm body _) = do + lambda names (Subterm body _) = do l <- label body injValue . Closure names l . Env.bind (foldr Set.delete (Set.fromList (freeVariables body)) names) <$> getEnv diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index ef847db09..2708c5375 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -22,7 +22,7 @@ instance Show1 Function where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Function where eval Function{..} = do - (v, addr) <- letrec name (abstract (paramNames functionParameters) functionBody) + (v, addr) <- letrec name (lambda (paramNames functionParameters) functionBody) modifyEnv (Env.insert name addr) pure v where paramNames = foldMap (freeVariables . subterm) @@ -43,7 +43,7 @@ instance Show1 Method where liftShowsPrec = genericLiftShowsPrec -- local environment. instance Evaluatable Method where eval Method{..} = do - (v, addr) <- letrec name (abstract (paramNames methodParameters) methodBody) + (v, addr) <- letrec name (lambda (paramNames methodParameters) methodBody) modifyEnv (Env.insert name addr) pure v where paramNames = foldMap (freeVariables . subterm) From be84d9ff7882036db542574014714212ca28267d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:55:15 -0400 Subject: [PATCH 41/89] Rename fromList to fromModules. --- src/Data/Abstract/Evaluatable.hs | 2 +- src/Data/Abstract/ModuleTable.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index dc6850090..1fa94330a 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -178,7 +178,7 @@ withModules :: MonadEvaluatable location term value m => [Module term] -> m a -> m a -withModules = localModuleTable . const . ModuleTable.fromList +withModules = localModuleTable . const . ModuleTable.fromModules -- | Evaluate with a list of modules in scope, taking the head module as the entry point. evaluateModules :: MonadEvaluatable location term value m diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index c3b606254..37d378094 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -4,7 +4,7 @@ module Data.Abstract.ModuleTable , ModuleTable (..) , lookup , insert -, fromList +, fromModules , toPairs ) where @@ -25,8 +25,8 @@ insert 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 = ModuleTable . Map.fromListWith (<>) . map toEntry +fromModules :: [Module term] -> ModuleTable [Module term] +fromModules = ModuleTable . Map.fromListWith (<>) . map toEntry where toEntry m = (moduleName m, [m]) toPairs :: ModuleTable a -> [(ModuleName, a)] From e1f9e346590ac764ddb4e04536da55ef0ae9a0d8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 18:58:23 -0400 Subject: [PATCH 42/89] Define a helper to construct a package from a list of modules. --- src/Data/Abstract/Package.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index d21752bbd..850a751c5 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -2,7 +2,7 @@ module Data.Abstract.Package where import Data.Abstract.FreeVariables import Data.Abstract.Module -import Data.Abstract.ModuleTable +import Data.Abstract.ModuleTable as ModuleTable type PackageName = Name @@ -16,3 +16,7 @@ data Package term = Package newtype Version = Version { versionString :: String } deriving (Eq, Ord, Show) + + +fromModules :: [Module term] -> Package term +fromModules modules = Package Nothing Nothing (ModuleTable.fromModules modules) mempty From f7325120cadd03f5692945b5395f0a825ebe80d7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 19:00:39 -0400 Subject: [PATCH 43/89] Define a singleton module table constructor. --- src/Data/Abstract/ModuleTable.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index 37d378094..c320a6b00 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -2,6 +2,7 @@ module Data.Abstract.ModuleTable ( ModuleName , ModuleTable (..) +, singleton , lookup , insert , fromModules @@ -17,6 +18,9 @@ import Prelude hiding (lookup) newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModuleName a } deriving (Eq, Foldable, Functor, Generic1, Monoid, Ord, Semigroup, Show, Traversable) +singleton :: ModuleName -> a -> ModuleTable a +singleton name = ModuleTable . Map.singleton name + lookup :: ModuleName -> ModuleTable a -> Maybe a lookup k = Map.lookup k . unModuleTable From 52fa4c9c0fd3cf7685361d9703bc678b7acde25d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 19:01:17 -0400 Subject: [PATCH 44/89] Define an entry point for packages constructed from modules. --- src/Data/Abstract/Package.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 850a751c5..63e45dcff 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -19,4 +19,5 @@ newtype Version = Version { versionString :: String } fromModules :: [Module term] -> Package term -fromModules modules = Package Nothing Nothing (ModuleTable.fromModules modules) mempty +fromModules [] = Package Nothing Nothing mempty mempty +fromModules (m:ms) = Package Nothing Nothing (ModuleTable.fromModules (m:ms)) (ModuleTable.singleton (moduleName m) Nothing) From 4e3c607c37a1810659d56f81a1f258b5d420cadd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 19:05:32 -0400 Subject: [PATCH 45/89] Define evaluateModules in terms of evaluatePackage. --- src/Data/Abstract/Evaluatable.hs | 12 +++++++----- src/Semantic/Util.hs | 2 +- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 1fa94330a..fdfa242ee 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -26,7 +26,7 @@ import Data.Abstract.FreeVariables as X import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Origin (SomeOrigin, packageOrigin) -import Data.Abstract.Package +import Data.Abstract.Package as Package import Data.Semigroup.App import Data.Semigroup.Foldable import Data.Semigroup.Reducer hiding (unit) @@ -181,11 +181,13 @@ withModules :: MonadEvaluatable location term value m withModules = localModuleTable . const . ModuleTable.fromModules -- | Evaluate with a list of modules in scope, taking the head module as the entry point. -evaluateModules :: MonadEvaluatable location term value m +evaluateModules :: ( Effectful m + , Member (Reader (SomeOrigin term)) effects + , MonadEvaluatable location term value (m effects) + ) => [Module term] - -> m value -evaluateModules [] = fail "evaluateModules: empty list" -evaluateModules (m:ms) = withModules ms (evaluateModule m) + -> m effects [value] +evaluateModules = evaluatePackage . Package.fromModules evaluatePackage :: ( Effectful m , Member (Reader (SomeOrigin term)) effects diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 830278f86..4b257267b 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -130,7 +130,7 @@ evaluateFiles :: forall term effects ) => Parser term -> [FilePath] - -> IO (Final effects (Value Precise)) + -> IO (Final effects [Value Precise]) evaluateFiles parser paths = runAnalysis @(Evaluating Precise term (Value Precise)) . evaluateModules <$> parseFiles parser paths -- | Evaluate terms and an entry point to a value with a given prelude. From e86db91b5a9c0f046e5362cf1de6d5ca1c8553cf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 19:06:13 -0400 Subject: [PATCH 46/89] Return the head value. --- src/Data/Abstract/Evaluatable.hs | 4 ++-- src/Semantic/Util.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index fdfa242ee..5ea3acd33 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -186,8 +186,8 @@ evaluateModules :: ( Effectful m , MonadEvaluatable location term value (m effects) ) => [Module term] - -> m effects [value] -evaluateModules = evaluatePackage . Package.fromModules + -> m effects value +evaluateModules = fmap Prelude.head . evaluatePackage . Package.fromModules evaluatePackage :: ( Effectful m , Member (Reader (SomeOrigin term)) effects diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 4b257267b..830278f86 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -130,7 +130,7 @@ evaluateFiles :: forall term effects ) => Parser term -> [FilePath] - -> IO (Final effects [Value Precise]) + -> IO (Final effects (Value Precise)) evaluateFiles parser paths = runAnalysis @(Evaluating Precise term (Value Precise)) . evaluateModules <$> parseFiles parser paths -- | Evaluate terms and an entry point to a value with a given prelude. From 5cf9dc20af436940abceb03b060b140a90e8ce9b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 19:09:03 -0400 Subject: [PATCH 47/89] Pass a single list of modules around. --- src/Semantic/Util.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 830278f86..6dc46ec41 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -145,12 +145,11 @@ evaluatesWith :: forall location value term effects , Show location ) => Module term -- ^ Prelude to evaluate once - -> [Module term] -- ^ List of (blob, term) pairs that make up the program to be evaluated - -> Module term -- ^ Entrypoint + -> [Module term] -- ^ List of modules that make up the program to be evaluated -> Final effects value -evaluatesWith prelude modules m = runAnalysis @(Evaluating location term value) $ do +evaluatesWith prelude modules = runAnalysis @(Evaluating location term value) $ do preludeEnv <- evaluateModule prelude *> getEnv - withDefaultEnvironment preludeEnv (withModules modules (evaluateModule m)) + withDefaultEnvironment preludeEnv (evaluateModules modules) evaluateFilesWithPrelude :: forall term effects . ( Evaluatable (Base term) @@ -166,8 +165,8 @@ evaluateFilesWithPrelude :: forall term effects evaluateFilesWithPrelude parser paths = do let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term)) prelude <- parseFile parser Nothing preludePath - entry:xs <- traverse (parseFile parser Nothing) paths - pure $ evaluatesWith @Precise @(Value Precise) prelude xs entry + xs <- traverse (parseFile parser Nothing) paths + pure $ evaluatesWith @Precise @(Value Precise) prelude xs -- Read and parse a file. From aed9457896efbf457ad8e6c7e5d9c390ba1d5cbe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 19:09:37 -0400 Subject: [PATCH 48/89] :fire: withModules. --- src/Data/Abstract/Evaluatable.hs | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 5ea3acd33..e005fcf45 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -9,9 +9,8 @@ module Data.Abstract.Evaluatable , variable , evaluateTerm , evaluateModule -, evaluatePackage -, withModules , evaluateModules +, evaluatePackage , throwLoadError , require , load @@ -172,14 +171,6 @@ evaluateModule :: MonadEvaluatable location term value m -> m value evaluateModule m = analyzeModule (subtermValue . moduleBody) (fmap (Subterm <*> evaluateTerm) m) - --- | Run an action with the a list of 'Module's available for imports. -withModules :: MonadEvaluatable location term value m - => [Module term] - -> m a - -> m a -withModules = localModuleTable . const . ModuleTable.fromModules - -- | Evaluate with a list of modules in scope, taking the head module as the entry point. evaluateModules :: ( Effectful m , Member (Reader (SomeOrigin term)) effects From bf94bd87e4b0e0c9c215108b089d0a7537b35dd7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 19:34:02 -0400 Subject: [PATCH 49/89] Truncate the package modules/entry points. --- src/Data/Abstract/Origin.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 3d635288f..596253f5a 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -13,7 +13,7 @@ data Origin term ty where Term :: Origin term 'M -> Base term () -> Origin term 'T packageOrigin :: P.Package term -> SomeOrigin term -packageOrigin = SomeOrigin . Package . (() <$) +packageOrigin p = SomeOrigin (Package (() <$ p { P.packageModules = mempty, P.packageEntryPoints = mempty })) moduleOrigin :: M.Module term -> SomeOrigin term moduleOrigin = SomeOrigin . Module Unknown . (() <$) From e6a63259fc4f80b4e6194ac4b65eb0aa13f90791 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 19:37:03 -0400 Subject: [PATCH 50/89] Add a helper to parse a package. --- src/Semantic/Util.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 6dc46ec41..ff32a6d47 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -15,6 +15,7 @@ import Control.Monad.IO.Class import Data.Abstract.Evaluatable hiding (head) import Data.Abstract.Address import Data.Abstract.Module +import Data.Abstract.Package as Package import Data.Abstract.Type import Data.Abstract.Value import Data.Blob @@ -178,6 +179,10 @@ parseFile parser rootDir path = runTask $ do parseFiles :: Parser term -> [FilePath] -> IO [Module term] parseFiles parser paths = traverse (parseFile parser (Just (dropFileName (head paths)))) paths +parsePackage :: PackageName -> Parser term -> [FilePath] -> IO (Package term) +parsePackage name parser files = setName . Package.fromModules <$> parseFiles parser files + where setName p = p { Package.packageName = Just name } + -- Read a file from the filesystem into a Blob. file :: MonadIO m => FilePath -> m Blob From 11c584b6ffb6597336330da699380a238635e6bf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 19:42:31 -0400 Subject: [PATCH 51/89] Split module name/path into a ModuleInfo type. --- src/Analysis/Abstract/ImportGraph.hs | 4 ++-- src/Data/Abstract/Module.hs | 9 +++++++-- src/Data/Abstract/ModuleTable.hs | 2 +- src/Data/Abstract/Package.hs | 3 ++- 4 files changed, 12 insertions(+), 6 deletions(-) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 9e1261859..08957f3be 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -49,7 +49,7 @@ instance ( Effectful m (\yield (LoadError name) -> insertVertexName name >> yield []) analyzeModule recur m = do - insertVertexName (moduleName m) + insertVertexName (moduleName (moduleInfo m)) liftAnalyze analyzeModule recur m insertVertexName :: forall m location term value effects @@ -62,7 +62,7 @@ insertVertexName :: forall m location term value effects -> ImportGraphing m effects () insertVertexName name = do o <- raise ask - let parent = maybe empty (vertex . moduleName) (originModule @term o) + let parent = maybe empty (vertex . moduleName . moduleInfo) (originModule @term o) modifyImportGraph (parent >< vertex name <>) (><) :: Graph a => a -> a -> a diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index 719cefede..d1f6ebe9e 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -1,5 +1,6 @@ module Data.Abstract.Module ( Module(..) +, ModuleInfo(..) , ModuleName , moduleForBlob ) where @@ -13,7 +14,10 @@ import System.FilePath.Posix type ModuleName = Name -data Module term = Module { moduleName :: ModuleName, modulePath :: FilePath, moduleBody :: term } +data ModuleInfo = ModuleInfo { moduleName :: ModuleName, modulePath :: FilePath } + deriving (Eq, Ord, Show) + +data Module term = Module { moduleInfo :: ModuleInfo, moduleBody :: term } deriving (Eq, Foldable, Functor, Ord, Show, Traversable) @@ -22,11 +26,12 @@ 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 = Module (moduleNameForPath (modulePathForBlob blob)) (blobPath blob) +moduleForBlob rootDir blob = Module info 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 + info = ModuleInfo (moduleNameForPath (modulePathForBlob blob)) (blobPath blob) moduleNameForPath :: FilePath -> ModuleName moduleNameForPath = qualifiedName . map BC.pack . splitWhen (== pathSeparator) diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index c320a6b00..2f7b48347 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -31,7 +31,7 @@ insert k v ModuleTable{..} = ModuleTable (Map.insert k v unModuleTable) -- | Construct a 'ModuleTable' from a list of 'Module's. fromModules :: [Module term] -> ModuleTable [Module term] fromModules = ModuleTable . Map.fromListWith (<>) . map toEntry - where toEntry m = (moduleName m, [m]) + where toEntry m = (moduleName (moduleInfo m), [m]) toPairs :: ModuleTable a -> [(ModuleName, a)] toPairs = Map.toList . unModuleTable diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 63e45dcff..1e4de3489 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -20,4 +20,5 @@ newtype Version = Version { versionString :: String } fromModules :: [Module term] -> Package term fromModules [] = Package Nothing Nothing mempty mempty -fromModules (m:ms) = Package Nothing Nothing (ModuleTable.fromModules (m:ms)) (ModuleTable.singleton (moduleName m) Nothing) +fromModules (m:ms) = Package Nothing Nothing (ModuleTable.fromModules (m:ms)) entryPoints + where entryPoints = ModuleTable.singleton (moduleName (moduleInfo m)) Nothing From 37535b1823e0286e57ba35f95ee6cd47d4fc3298 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 19:44:31 -0400 Subject: [PATCH 52/89] Origin stores ModuleInfo. --- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Analysis/Abstract/ImportGraph.hs | 2 +- src/Data/Abstract/Origin.hs | 8 ++++---- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 74b343217..3d821ff77 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -147,7 +147,7 @@ instance ( Functor (Base term) analyzeTerm eval term = pushOrigin (termOrigin term) (eval term) - analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (eval m) + analyzeModule eval m = pushOrigin (moduleOrigin (moduleInfo m)) (eval m) pushOrigin :: Member (Reader (SomeOrigin term)) effects => SomeOrigin term -> Evaluating location term value effects a -> Evaluating location term value effects a pushOrigin o = raise . local (<> o) . lower diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 08957f3be..651095f14 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -62,7 +62,7 @@ insertVertexName :: forall m location term value effects -> ImportGraphing m effects () insertVertexName name = do o <- raise ask - let parent = maybe empty (vertex . moduleName . moduleInfo) (originModule @term o) + let parent = maybe empty (vertex . moduleName) (originModule @term o) modifyImportGraph (parent >< vertex name <>) (><) :: Graph a => a -> a -> a diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 596253f5a..7f619e46d 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -9,19 +9,19 @@ import Prologue data Origin term ty where Unknown :: Origin term any Package :: P.Package () -> Origin term 'P - Module :: Origin term 'P -> M.Module () -> Origin term 'M + Module :: Origin term 'P -> M.ModuleInfo -> Origin term 'M Term :: Origin term 'M -> Base term () -> Origin term 'T packageOrigin :: P.Package term -> SomeOrigin term packageOrigin p = SomeOrigin (Package (() <$ p { P.packageModules = mempty, P.packageEntryPoints = mempty })) -moduleOrigin :: M.Module term -> SomeOrigin term -moduleOrigin = SomeOrigin . Module Unknown . (() <$) +moduleOrigin :: M.ModuleInfo -> SomeOrigin term +moduleOrigin = SomeOrigin . Module Unknown termOrigin :: Functor (Base term) => Base term a -> SomeOrigin term termOrigin = SomeOrigin . Term Unknown . (() <$) -originModule :: SomeOrigin term -> Maybe (M.Module ()) +originModule :: SomeOrigin term -> Maybe M.ModuleInfo originModule (SomeOrigin (Term (Module _ m) _)) = Just m originModule (SomeOrigin (Module _ m)) = Just m originModule _ = Nothing From 0ebf115faeacece0cac8d2af68bcdcf09c46bb38 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 19:46:25 -0400 Subject: [PATCH 53/89] Split PackageInfo into a new datatype. --- src/Data/Abstract/Package.hs | 13 +++++++++---- src/Semantic/Util.hs | 2 +- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 1e4de3489..0777d8023 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -6,9 +6,14 @@ import Data.Abstract.ModuleTable as ModuleTable type PackageName = Name +data PackageInfo = PackageInfo + { packageName :: Maybe PackageName + , packageVersion :: Maybe Version + } + deriving (Eq, Ord, Show) + data Package term = Package - { packageName :: Maybe PackageName - , packageVersion :: Maybe Version + { packageInfo :: PackageInfo , packageModules :: ModuleTable [Module term] , packageEntryPoints :: ModuleTable (Maybe Name) } @@ -19,6 +24,6 @@ newtype Version = Version { versionString :: String } fromModules :: [Module term] -> Package term -fromModules [] = Package Nothing Nothing mempty mempty -fromModules (m:ms) = Package Nothing Nothing (ModuleTable.fromModules (m:ms)) entryPoints +fromModules [] = Package (PackageInfo Nothing Nothing) mempty mempty +fromModules (m:ms) = Package (PackageInfo Nothing Nothing) (ModuleTable.fromModules (m:ms)) entryPoints where entryPoints = ModuleTable.singleton (moduleName (moduleInfo m)) Nothing diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index ff32a6d47..07f704949 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -181,7 +181,7 @@ parseFiles parser paths = traverse (parseFile parser (Just (dropFileName (head p parsePackage :: PackageName -> Parser term -> [FilePath] -> IO (Package term) parsePackage name parser files = setName . Package.fromModules <$> parseFiles parser files - where setName p = p { Package.packageName = Just name } + where setName p = p { packageInfo = PackageInfo (Just name) Nothing } -- Read a file from the filesystem into a Blob. From c73166d08984352f8a1e65a7650cf3681a678331 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 19:50:38 -0400 Subject: [PATCH 54/89] moduleOrigin takes a Module again. --- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Data/Abstract/Origin.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 3d821ff77..74b343217 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -147,7 +147,7 @@ instance ( Functor (Base term) analyzeTerm eval term = pushOrigin (termOrigin term) (eval term) - analyzeModule eval m = pushOrigin (moduleOrigin (moduleInfo m)) (eval m) + analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (eval m) pushOrigin :: Member (Reader (SomeOrigin term)) effects => SomeOrigin term -> Evaluating location term value effects a -> Evaluating location term value effects a pushOrigin o = raise . local (<> o) . lower diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 7f619e46d..e092d796e 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -15,8 +15,8 @@ data Origin term ty where packageOrigin :: P.Package term -> SomeOrigin term packageOrigin p = SomeOrigin (Package (() <$ p { P.packageModules = mempty, P.packageEntryPoints = mempty })) -moduleOrigin :: M.ModuleInfo -> SomeOrigin term -moduleOrigin = SomeOrigin . Module Unknown +moduleOrigin :: M.Module term -> SomeOrigin term +moduleOrigin = SomeOrigin . Module Unknown . M.moduleInfo termOrigin :: Functor (Base term) => Base term a -> SomeOrigin term termOrigin = SomeOrigin . Term Unknown . (() <$) From 803f36f5b2b5fe4f4d9147b92f8f4c89cd664dac Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 19:50:48 -0400 Subject: [PATCH 55/89] Origin holds PackageInfo. --- src/Data/Abstract/Origin.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index e092d796e..9c3afb88d 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -7,13 +7,13 @@ import Prologue -- TODO: Upstream dependencies data Origin term ty where - Unknown :: Origin term any - Package :: P.Package () -> Origin term 'P - Module :: Origin term 'P -> M.ModuleInfo -> Origin term 'M - Term :: Origin term 'M -> Base term () -> Origin term 'T + Unknown :: Origin term any + Package :: P.PackageInfo -> Origin term 'P + Module :: Origin term 'P -> M.ModuleInfo -> Origin term 'M + Term :: Origin term 'M -> Base term () -> Origin term 'T packageOrigin :: P.Package term -> SomeOrigin term -packageOrigin p = SomeOrigin (Package (() <$ p { P.packageModules = mempty, P.packageEntryPoints = mempty })) +packageOrigin = SomeOrigin . Package . P.packageInfo moduleOrigin :: M.Module term -> SomeOrigin term moduleOrigin = SomeOrigin . Module Unknown . M.moduleInfo From a522efcb1edccb017b8d2cde52bebf9f3fca6059 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 19:53:23 -0400 Subject: [PATCH 56/89] Hide an ambiguous symbol. --- test/SpecHelpers.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 71b10063f..375419b74 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -13,7 +13,7 @@ import Analysis.Abstract.Evaluating as X (EvaluatingState(..)) import Data.Abstract.Address as X import Data.Abstract.FreeVariables as X hiding (dropExtension) import Data.Abstract.Heap as X -import Data.Abstract.ModuleTable as X +import Data.Abstract.ModuleTable as X hiding (lookup) import Data.Blob as X import Data.Functor.Listable as X import Data.Language as X From 2e18c422f5a127dc9a2b3c1cfe7d6659b7348831 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 19:59:37 -0400 Subject: [PATCH 57/89] Take a hint. --- src/Data/Abstract/Evaluatable.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index e005fcf45..55a7cfa7f 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -30,7 +30,6 @@ import Data.Semigroup.App import Data.Semigroup.Foldable import Data.Semigroup.Reducer hiding (unit) import Data.Term -import Prelude hiding (fail) import Prologue type MonadEvaluatable location term value m = From 1de09bbb252cd56280b6eb23843a870e1d530afe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 20:05:30 -0400 Subject: [PATCH 58/89] termOrigin takes a whole term. --- src/Analysis/Abstract/Evaluating.hs | 5 +++-- src/Data/Abstract/Origin.hs | 4 ++-- src/Semantic/Util.hs | 18 ++++++++++++------ 3 files changed, 17 insertions(+), 10 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 74b343217..51a5d157f 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -138,14 +138,15 @@ instance Members (EvaluatingEffects location term value) effects => MonadEvaluator location term value (Evaluating location term value effects) where getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap -instance ( Functor (Base term) +instance ( Corecursive term , Members (EvaluatingEffects location term value) effects , MonadValue location value (Evaluating location term value effects) + , Recursive term ) => MonadAnalysis location term value (Evaluating location term value effects) where type Effects location term value (Evaluating location term value effects) = EvaluatingEffects location term value - analyzeTerm eval term = pushOrigin (termOrigin term) (eval term) + analyzeTerm eval term = pushOrigin (termOrigin (embedSubterm term)) (eval term) analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (eval m) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 9c3afb88d..c317ac11c 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -18,8 +18,8 @@ packageOrigin = SomeOrigin . Package . P.packageInfo moduleOrigin :: M.Module term -> SomeOrigin term moduleOrigin = SomeOrigin . Module Unknown . M.moduleInfo -termOrigin :: Functor (Base term) => Base term a -> SomeOrigin term -termOrigin = SomeOrigin . Term Unknown . (() <$) +termOrigin :: Recursive term => term -> SomeOrigin term +termOrigin = SomeOrigin . Term Unknown . (() <$) . project originModule :: SomeOrigin term -> Maybe M.ModuleInfo originModule (SomeOrigin (Term (Module _ m) _)) = Just m diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 07f704949..028990475 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -70,7 +70,8 @@ evaluateTypeScriptFiles = evaluateFiles typescriptParser -- Evalute a single file. evaluateFile :: forall term effects - . ( Evaluatable (Base term) + . ( Corecursive term + , Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) @@ -82,7 +83,8 @@ evaluateFile :: forall term effects evaluateFile parser path = runAnalysis @(Evaluating Precise term (Value Precise)) . evaluateModule <$> parseFile parser Nothing path evaluateWith :: forall location value term effects - . ( effects ~ Effects location term value (Evaluating location term value effects) + . ( Corecursive term + , effects ~ Effects location term value (Evaluating location term value effects) , Evaluatable (Base term) , FreeVariables term , MonadAddressable location (Evaluating location term value effects) @@ -104,7 +106,8 @@ evaluateWith prelude m = runAnalysis @(Evaluating location term value) $ do withDefaultEnvironment preludeEnv (evaluateModule m) evaluateWithPrelude :: forall term effects - . ( Evaluatable (Base term) + . ( Corecursive term + , Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) @@ -123,7 +126,8 @@ evaluateWithPrelude parser path = do -- Evaluate a list of files (head of file list is considered the entry point). evaluateFiles :: forall term effects - . ( Evaluatable (Base term) + . ( Corecursive term + , Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) @@ -136,7 +140,8 @@ evaluateFiles parser paths = runAnalysis @(Evaluating Precise term (Value Precis -- | Evaluate terms and an entry point to a value with a given prelude. evaluatesWith :: forall location value term effects - . ( effects ~ Effects location term value (Evaluating location term value effects) + . ( Corecursive term + , effects ~ Effects location term value (Evaluating location term value effects) , Evaluatable (Base term) , FreeVariables term , MonadAddressable location (Evaluating location term value effects) @@ -153,7 +158,8 @@ evaluatesWith prelude modules = runAnalysis @(Evaluating location term value) $ withDefaultEnvironment preludeEnv (evaluateModules modules) evaluateFilesWithPrelude :: forall term effects - . ( Evaluatable (Base term) + . ( Corecursive term + , Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) From 351f757ed48cb9e1906cbee1783fbea5078624cd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 20:05:40 -0400 Subject: [PATCH 59/89] Move pushOrigin into Evaluatable. --- src/Analysis/Abstract/Evaluating.hs | 3 --- src/Data/Abstract/Evaluatable.hs | 17 +++++++++-------- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 51a5d157f..f717bf345 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -149,6 +149,3 @@ instance ( Corecursive term analyzeTerm eval term = pushOrigin (termOrigin (embedSubterm term)) (eval term) analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (eval m) - -pushOrigin :: Member (Reader (SomeOrigin term)) effects => SomeOrigin term -> Evaluating location term value effects a -> Evaluating location term value effects a -pushOrigin o = raise . local (<> o) . lower diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 55a7cfa7f..62a8a2332 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -14,6 +14,7 @@ module Data.Abstract.Evaluatable , throwLoadError , require , load +, pushOrigin ) where import Control.Abstract.Addressable as X @@ -185,16 +186,16 @@ evaluatePackage :: ( Effectful m ) => Package term -> m effects [value] -evaluatePackage p = pushPackage p (localModuleTable (<> packageModules p) +evaluatePackage p = pushOrigin (packageOrigin p) (localModuleTable (<> packageModules p) (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints p)))) where evaluateEntryPoint (m, sym) = do (_, v) <- require m maybe (pure v) ((`call` []) <=< variable) sym -pushPackage :: ( Effectful m - , Member (Reader (SomeOrigin term)) effects - ) - => Package term - -> m effects a - -> m effects a -pushPackage p = raise . local (<> packageOrigin p) . lower +pushOrigin :: ( Effectful m + , Member (Reader (SomeOrigin term)) effects + ) + => SomeOrigin term + -> m effects a + -> m effects a +pushOrigin o = raise . local (<> o) . lower From 58f2821d98e05ba44756fd3d7439559ff8d4818f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 20:18:05 -0400 Subject: [PATCH 60/89] Merge fills in incomplete information everywhere. --- src/Data/Abstract/Origin.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index c317ac11c..3135380c8 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -67,12 +67,14 @@ deriving instance Show (Base term ()) => Show (SomeOrigin term) merge :: Origin term ty1 -> Origin term ty2 -> SomeOrigin term -merge a Unknown = SomeOrigin a -merge (Package p) (Module Unknown m) = SomeOrigin (Module (Package p) m) -merge (Module p _) (Module Unknown m) = SomeOrigin (Module p m) -merge (Module p m) (Term Unknown t) = SomeOrigin (Term (Module p m) t) -merge (Term m _) (Term Unknown t) = SomeOrigin (Term m t) -merge _ b = SomeOrigin b +merge a Unknown = SomeOrigin a +merge (Package p) (Module Unknown m) = SomeOrigin (Module (Package p) m) +merge (Module p _) (Module Unknown m) = SomeOrigin (Module p m) +merge (Term (Module p _) _) (Module Unknown m) = SomeOrigin (Module p m) +merge (Term (Module p _) _) (Term (Module Unknown m) t) = SomeOrigin (Term (Module p m) t) +merge (Module p m) (Term Unknown t) = SomeOrigin (Term (Module p m) t) +merge (Term m _) (Term Unknown t) = SomeOrigin (Term m t) +merge _ b = SomeOrigin b instance Semigroup (SomeOrigin term) where SomeOrigin a <> SomeOrigin b = merge a b From 4120622002415db81e1b713dc2523a0cf966a2b0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 20:20:59 -0400 Subject: [PATCH 61/89] To-DONE --- src/Data/Abstract/Origin.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 3135380c8..d3c62d5db 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -5,7 +5,6 @@ import qualified Data.Abstract.Module as M import qualified Data.Abstract.Package as P import Prologue --- TODO: Upstream dependencies data Origin term ty where Unknown :: Origin term any Package :: P.PackageInfo -> Origin term 'P From c732d302297dcd62368ba591d6d4f6f645851743 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:23:06 -0400 Subject: [PATCH 62/89] :memo: Package. --- src/Data/Abstract/Package.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 0777d8023..28a301851 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -12,6 +12,7 @@ data PackageInfo = PackageInfo } deriving (Eq, Ord, Show) +-- | A package represents the unit of dependency, i.e. something which can depend upon, or be depended upon by, other packages. Packages have modules and may have entry points from which evaluation can proceed. data Package term = Package { packageInfo :: PackageInfo , packageModules :: ModuleTable [Module term] From 3fe2e91060e54b64362c7d90b8199ee87234de4f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:23:27 -0400 Subject: [PATCH 63/89] :memo: PackageInfo. --- src/Data/Abstract/Package.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 28a301851..bfcec6c30 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -6,6 +6,7 @@ import Data.Abstract.ModuleTable as ModuleTable type PackageName = Name +-- | Metadata for a package (name and version). data PackageInfo = PackageInfo { packageName :: Maybe PackageName , packageVersion :: Maybe Version From 056a23a949b8aa262147512c0e00e5775f504955 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:24:48 -0400 Subject: [PATCH 64/89] Move Version up. --- src/Data/Abstract/Package.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index bfcec6c30..b44fdf0cc 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -13,6 +13,9 @@ data PackageInfo = PackageInfo } deriving (Eq, Ord, Show) +newtype Version = Version { versionString :: String } + deriving (Eq, Ord, Show) + -- | A package represents the unit of dependency, i.e. something which can depend upon, or be depended upon by, other packages. Packages have modules and may have entry points from which evaluation can proceed. data Package term = Package { packageInfo :: PackageInfo @@ -21,9 +24,6 @@ data Package term = Package } deriving (Eq, Functor, Ord, Show) -newtype Version = Version { versionString :: String } - deriving (Eq, Ord, Show) - fromModules :: [Module term] -> Package term fromModules [] = Package (PackageInfo Nothing Nothing) mempty mempty From 9266439e7f320b6ae864f79d6323aad945939485 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:27:31 -0400 Subject: [PATCH 65/89] Split a package body type out of Package. --- src/Data/Abstract/Evaluatable.hs | 4 ++-- src/Data/Abstract/Package.hs | 14 +++++++++----- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 62a8a2332..b5425268f 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -186,8 +186,8 @@ evaluatePackage :: ( Effectful m ) => Package term -> m effects [value] -evaluatePackage p = pushOrigin (packageOrigin p) (localModuleTable (<> packageModules p) - (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints p)))) +evaluatePackage p = pushOrigin (packageOrigin p) (localModuleTable (<> packageModules (packageBody p)) + (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints (packageBody p))))) where evaluateEntryPoint (m, sym) = do (_, v) <- require m maybe (pure v) ((`call` []) <=< variable) sym diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index b44fdf0cc..f4832945e 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -18,14 +18,18 @@ newtype Version = Version { versionString :: String } -- | A package represents the unit of dependency, i.e. something which can depend upon, or be depended upon by, other packages. Packages have modules and may have entry points from which evaluation can proceed. data Package term = Package - { packageInfo :: PackageInfo - , packageModules :: ModuleTable [Module term] + { packageInfo :: PackageInfo + , packageBody :: PackageBody term + } + deriving (Eq, Functor, Ord, Show) + +data PackageBody term = PackageBody + { packageModules :: ModuleTable [Module term] , packageEntryPoints :: ModuleTable (Maybe Name) } deriving (Eq, Functor, Ord, Show) - fromModules :: [Module term] -> Package term -fromModules [] = Package (PackageInfo Nothing Nothing) mempty mempty -fromModules (m:ms) = Package (PackageInfo Nothing Nothing) (ModuleTable.fromModules (m:ms)) entryPoints +fromModules [] = Package (PackageInfo Nothing Nothing) (PackageBody mempty mempty) +fromModules (m:ms) = Package (PackageInfo Nothing Nothing) (PackageBody (ModuleTable.fromModules (m:ms)) entryPoints) where entryPoints = ModuleTable.singleton (moduleName (moduleInfo m)) Nothing From 5d6c57312e0959b0788b4273acc681fa04b473c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:30:04 -0400 Subject: [PATCH 66/89] Split the evaluation of a package body out into a new function. --- src/Data/Abstract/Evaluatable.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index b5425268f..ec3389960 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -186,8 +186,13 @@ evaluatePackage :: ( Effectful m ) => Package term -> m effects [value] -evaluatePackage p = pushOrigin (packageOrigin p) (localModuleTable (<> packageModules (packageBody p)) - (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints (packageBody p))))) +evaluatePackage p = pushOrigin (packageOrigin p) (evaluatePackageBody (packageBody p)) + +evaluatePackageBody :: MonadEvaluatable location term value m + => PackageBody term + -> m [value] +evaluatePackageBody body = localModuleTable (<> packageModules body) + (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints body))) where evaluateEntryPoint (m, sym) = do (_, v) <- require m maybe (pure v) ((`call` []) <=< variable) sym From 6d46f2f374487b359eef3b7c21052f38a3121624 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:31:02 -0400 Subject: [PATCH 67/89] fromModules returns a PackageBody. --- src/Data/Abstract/Evaluatable.hs | 9 +++------ src/Data/Abstract/Package.hs | 6 +++--- src/Semantic/Util.hs | 3 +-- 3 files changed, 7 insertions(+), 11 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index ec3389960..a083c7f9c 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -172,13 +172,10 @@ evaluateModule :: MonadEvaluatable location term value m evaluateModule m = analyzeModule (subtermValue . moduleBody) (fmap (Subterm <*> evaluateTerm) m) -- | Evaluate with a list of modules in scope, taking the head module as the entry point. -evaluateModules :: ( Effectful m - , Member (Reader (SomeOrigin term)) effects - , MonadEvaluatable location term value (m effects) - ) +evaluateModules :: MonadEvaluatable location term value m => [Module term] - -> m effects value -evaluateModules = fmap Prelude.head . evaluatePackage . Package.fromModules + -> m value +evaluateModules = fmap Prelude.head . evaluatePackageBody . Package.fromModules evaluatePackage :: ( Effectful m , Member (Reader (SomeOrigin term)) effects diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index f4832945e..06f8fd4ea 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -29,7 +29,7 @@ data PackageBody term = PackageBody } deriving (Eq, Functor, Ord, Show) -fromModules :: [Module term] -> Package term -fromModules [] = Package (PackageInfo Nothing Nothing) (PackageBody mempty mempty) -fromModules (m:ms) = Package (PackageInfo Nothing Nothing) (PackageBody (ModuleTable.fromModules (m:ms)) entryPoints) +fromModules :: [Module term] -> PackageBody term +fromModules [] = PackageBody mempty mempty +fromModules (m:ms) = PackageBody (ModuleTable.fromModules (m:ms)) entryPoints where entryPoints = ModuleTable.singleton (moduleName (moduleInfo m)) Nothing diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 028990475..80721255b 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -186,8 +186,7 @@ parseFiles :: Parser term -> [FilePath] -> IO [Module term] parseFiles parser paths = traverse (parseFile parser (Just (dropFileName (head paths)))) paths parsePackage :: PackageName -> Parser term -> [FilePath] -> IO (Package term) -parsePackage name parser files = setName . Package.fromModules <$> parseFiles parser files - where setName p = p { packageInfo = PackageInfo (Just name) Nothing } +parsePackage name parser files = Package (PackageInfo (Just name) Nothing) . Package.fromModules <$> parseFiles parser files -- Read a file from the filesystem into a Blob. From 4569b8a48b950c4be3c0879057df53cf6460a946 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 16:55:06 -0400 Subject: [PATCH 68/89] Define a helper to project values out of SomeOrigins. --- src/Data/Abstract/Origin.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index d3c62d5db..2811940ca 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, UndecidableInstances #-} +{-# LANGUAGE GADTs, RankNTypes, UndecidableInstances #-} module Data.Abstract.Origin where import qualified Data.Abstract.Module as M @@ -56,6 +56,9 @@ data OriginType = P | M | T data SomeOrigin term where SomeOrigin :: Origin term ty -> SomeOrigin term +withSomeOrigin :: (forall ty . Origin term ty -> b) -> SomeOrigin term -> b +withSomeOrigin with (SomeOrigin o) = with o + instance Eq (Base term ()) => Eq (SomeOrigin term) where SomeOrigin o1 == SomeOrigin o2 = eqOrigins o1 o2 From aef145b55c1a2fdcbba6e08950853b3bc12da171 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:02:34 -0400 Subject: [PATCH 69/89] Use withSomeOrigin to unpack the origin. --- src/Analysis/Abstract/ImportGraph.hs | 2 +- src/Data/Abstract/Origin.hs | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 651095f14..89a5cf2f8 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -62,7 +62,7 @@ insertVertexName :: forall m location term value effects -> ImportGraphing m effects () insertVertexName name = do o <- raise ask - let parent = maybe empty (vertex . moduleName) (originModule @term o) + let parent = maybe empty (vertex . moduleName) (withSomeOrigin (originModule @term) o) modifyImportGraph (parent >< vertex name <>) (><) :: Graph a => a -> a -> a diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 2811940ca..540e80467 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -20,10 +20,10 @@ moduleOrigin = SomeOrigin . Module Unknown . M.moduleInfo termOrigin :: Recursive term => term -> SomeOrigin term termOrigin = SomeOrigin . Term Unknown . (() <$) . project -originModule :: SomeOrigin term -> Maybe M.ModuleInfo -originModule (SomeOrigin (Term (Module _ m) _)) = Just m -originModule (SomeOrigin (Module _ m)) = Just m -originModule _ = Nothing +originModule :: Origin term ty -> Maybe M.ModuleInfo +originModule (Term o _) = originModule o +originModule (Module _ m) = Just m +originModule _ = Nothing deriving instance Eq (Base term ()) => Eq (Origin term ty) deriving instance Show (Base term ()) => Show (Origin term ty) From d05e2b1e906d8fcff58a753feb27c8006b90e423 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:05:42 -0400 Subject: [PATCH 70/89] Project package info out of origins. --- src/Data/Abstract/Origin.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 540e80467..c6102dfd9 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -25,6 +25,12 @@ originModule (Term o _) = originModule o originModule (Module _ m) = Just m originModule _ = Nothing +originPackage :: Origin term ty -> Maybe P.PackageInfo +originPackage (Term o _) = originPackage o +originPackage (Module o _) = originPackage o +originPackage (Package p) = Just p +originPackage _ = Nothing + deriving instance Eq (Base term ()) => Eq (Origin term ty) deriving instance Show (Base term ()) => Show (Origin term ty) From fd8b9e6daf47e9f537f763c920310c613f21dae0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:34:42 -0400 Subject: [PATCH 71/89] Move PackageBody up. --- src/Data/Abstract/Package.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 06f8fd4ea..cfce53e92 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -16,6 +16,13 @@ data PackageInfo = PackageInfo newtype Version = Version { versionString :: String } deriving (Eq, Ord, Show) +data PackageBody term = PackageBody + { packageModules :: ModuleTable [Module term] + , packageEntryPoints :: ModuleTable (Maybe Name) + } + deriving (Eq, Functor, Ord, Show) + + -- | A package represents the unit of dependency, i.e. something which can depend upon, or be depended upon by, other packages. Packages have modules and may have entry points from which evaluation can proceed. data Package term = Package { packageInfo :: PackageInfo @@ -23,12 +30,6 @@ data Package term = Package } deriving (Eq, Functor, Ord, Show) -data PackageBody term = PackageBody - { packageModules :: ModuleTable [Module term] - , packageEntryPoints :: ModuleTable (Maybe Name) - } - deriving (Eq, Functor, Ord, Show) - fromModules :: [Module term] -> PackageBody term fromModules [] = PackageBody mempty mempty fromModules (m:ms) = PackageBody (ModuleTable.fromModules (m:ms)) entryPoints From e03461819c1b20d923506f446597aa24395ae6b6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:35:33 -0400 Subject: [PATCH 72/89] packageName is mandatory. --- src/Data/Abstract/Package.hs | 2 +- src/Semantic/Util.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index cfce53e92..701249565 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -8,7 +8,7 @@ type PackageName = Name -- | Metadata for a package (name and version). data PackageInfo = PackageInfo - { packageName :: Maybe PackageName + { packageName :: PackageName , packageVersion :: Maybe Version } deriving (Eq, Ord, Show) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 80721255b..9b8b5af4a 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -186,7 +186,7 @@ parseFiles :: Parser term -> [FilePath] -> IO [Module term] parseFiles parser paths = traverse (parseFile parser (Just (dropFileName (head paths)))) paths parsePackage :: PackageName -> Parser term -> [FilePath] -> IO (Package term) -parsePackage name parser files = Package (PackageInfo (Just name) Nothing) . Package.fromModules <$> parseFiles parser files +parsePackage name parser files = Package (PackageInfo name Nothing) . Package.fromModules <$> parseFiles parser files -- Read a file from the filesystem into a Blob. From 92116753dd6ff6297345b144266c96b7d5fa0764 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:36:11 -0400 Subject: [PATCH 73/89] Move the SomeOrigin constructors down next to SomeOrigin. --- src/Data/Abstract/Origin.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index c6102dfd9..0f24593d8 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -11,15 +11,6 @@ data Origin term ty where Module :: Origin term 'P -> M.ModuleInfo -> Origin term 'M Term :: Origin term 'M -> Base term () -> Origin term 'T -packageOrigin :: P.Package term -> SomeOrigin term -packageOrigin = SomeOrigin . Package . P.packageInfo - -moduleOrigin :: M.Module term -> SomeOrigin term -moduleOrigin = SomeOrigin . Module Unknown . M.moduleInfo - -termOrigin :: Recursive term => term -> SomeOrigin term -termOrigin = SomeOrigin . Term Unknown . (() <$) . project - originModule :: Origin term ty -> Maybe M.ModuleInfo originModule (Term o _) = originModule o originModule (Module _ m) = Just m @@ -62,6 +53,15 @@ data OriginType = P | M | T data SomeOrigin term where SomeOrigin :: Origin term ty -> SomeOrigin term +packageOrigin :: P.Package term -> SomeOrigin term +packageOrigin = SomeOrigin . Package . P.packageInfo + +moduleOrigin :: M.Module term -> SomeOrigin term +moduleOrigin = SomeOrigin . Module Unknown . M.moduleInfo + +termOrigin :: Recursive term => term -> SomeOrigin term +termOrigin = SomeOrigin . Term Unknown . (() <$) . project + withSomeOrigin :: (forall ty . Origin term ty -> b) -> SomeOrigin term -> b withSomeOrigin with (SomeOrigin o) = with o From 84dc109cde37f499b1fdeb500ffe8007a5875c37 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:37:43 -0400 Subject: [PATCH 74/89] :memo: Origin. --- src/Data/Abstract/Origin.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 0f24593d8..e202821df 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -5,6 +5,7 @@ import qualified Data.Abstract.Module as M import qualified Data.Abstract.Package as P import Prologue +-- | An 'Origin' encapsulates the location at which a name is bound or allocated. data Origin term ty where Unknown :: Origin term any Package :: P.PackageInfo -> Origin term 'P From 2c0807f0e5715eb88c95c767171337fad0aa4fa5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:38:16 -0400 Subject: [PATCH 75/89] :memo: originModule. --- src/Data/Abstract/Origin.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index e202821df..8138fe917 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -12,6 +12,7 @@ data Origin term ty where Module :: Origin term 'P -> M.ModuleInfo -> Origin term 'M Term :: Origin term 'M -> Base term () -> Origin term 'T +-- | Project the 'ModuleInfo' out of an 'Origin', if available. originModule :: Origin term ty -> Maybe M.ModuleInfo originModule (Term o _) = originModule o originModule (Module _ m) = Just m From f028d4873194928a88dca2bdfb1586d1a424c076 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:38:21 -0400 Subject: [PATCH 76/89] :memo: originPackage. --- src/Data/Abstract/Origin.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 8138fe917..523c04d27 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -18,6 +18,7 @@ originModule (Term o _) = originModule o originModule (Module _ m) = Just m originModule _ = Nothing +-- | Project the 'PackageInfo' out of an 'Origin', if available. originPackage :: Origin term ty -> Maybe P.PackageInfo originPackage (Term o _) = originPackage o originPackage (Module o _) = originPackage o From 628c1a50b9827bbb466c3b9309c6c1a991cdc05a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:39:42 -0400 Subject: [PATCH 77/89] Define the Ord instance for SomeOrigin using compareOrigins. --- src/Data/Abstract/Located.hs | 2 +- src/Data/Abstract/Origin.hs | 11 ++--------- 2 files changed, 3 insertions(+), 10 deletions(-) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index 7414f3041..17e4928c3 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -10,7 +10,7 @@ import Prologue data Located location term = Located { location :: location, origin :: !(SomeOrigin term) } -deriving instance (Eq location, Eq (Base term ())) => Eq (Located location term) +deriving instance (Eq location, Ord (Base term ())) => Eq (Located location term) deriving instance (Ord location, Ord (Base term ())) => Ord (Located location term) deriving instance (Show location, Show (Base term ())) => Show (Located location term) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 523c04d27..cd12e0e71 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -28,13 +28,6 @@ originPackage _ = Nothing deriving instance Eq (Base term ()) => Eq (Origin term ty) deriving instance Show (Base term ()) => Show (Origin term ty) -eqOrigins :: Eq (Base term ()) => Origin term ty1 -> Origin term ty2 -> Bool -eqOrigins Unknown Unknown = True -eqOrigins (Package p1) (Package p2) = p1 == p2 -eqOrigins (Module p1 m1) (Module p2 m2) = p1 == p2 && m1 == m2 -eqOrigins (Term m1 t1) (Term m2 t2) = m1 == m2 && t1 == t2 -eqOrigins _ _ = False - compareOrigins :: Ord (Base term ()) => Origin term ty1 -> Origin term ty2 -> Ordering compareOrigins Unknown Unknown = EQ compareOrigins Unknown _ = LT @@ -68,8 +61,8 @@ termOrigin = SomeOrigin . Term Unknown . (() <$) . project withSomeOrigin :: (forall ty . Origin term ty -> b) -> SomeOrigin term -> b withSomeOrigin with (SomeOrigin o) = with o -instance Eq (Base term ()) => Eq (SomeOrigin term) where - SomeOrigin o1 == SomeOrigin o2 = eqOrigins o1 o2 +instance Ord (Base term ()) => Eq (SomeOrigin term) where + SomeOrigin o1 == SomeOrigin o2 = compareOrigins o1 o2 == EQ instance Ord (Base term ()) => Ord (SomeOrigin term) where compare (SomeOrigin o1) (SomeOrigin o2) = compareOrigins o1 o2 From 2a85da46c362a18de3a603b690482ac77e975ae4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:43:37 -0400 Subject: [PATCH 78/89] Parameterize compareOrigins by the comparator. --- src/Data/Abstract/Located.hs | 2 +- src/Data/Abstract/Origin.hs | 30 +++++++++++++++--------------- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index 17e4928c3..7414f3041 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -10,7 +10,7 @@ import Prologue data Located location term = Located { location :: location, origin :: !(SomeOrigin term) } -deriving instance (Eq location, Ord (Base term ())) => Eq (Located location term) +deriving instance (Eq location, Eq (Base term ())) => Eq (Located location term) deriving instance (Ord location, Ord (Base term ())) => Ord (Located location term) deriving instance (Show location, Show (Base term ())) => Show (Located location term) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index cd12e0e71..64f9c72bb 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -28,20 +28,20 @@ originPackage _ = Nothing deriving instance Eq (Base term ()) => Eq (Origin term ty) deriving instance Show (Base term ()) => Show (Origin term ty) -compareOrigins :: Ord (Base term ()) => Origin term ty1 -> Origin term ty2 -> Ordering -compareOrigins Unknown Unknown = EQ -compareOrigins Unknown _ = LT -compareOrigins _ Unknown = GT -compareOrigins (Package p1) (Package p2) = compare p1 p2 -compareOrigins (Package _) _ = LT -compareOrigins _ (Package _) = GT -compareOrigins (Module p1 m1) (Module p2 m2) = compare p1 p2 <> compare m1 m2 -compareOrigins (Module _ _) _ = LT -compareOrigins _ (Module _ _) = GT -compareOrigins (Term m1 t1) (Term m2 t2) = compare m1 m2 <> compare t1 t2 +liftCompareOrigins :: (Base term () -> Base term () -> Ordering) -> Origin term ty1 -> Origin term ty2 -> Ordering +liftCompareOrigins _ Unknown Unknown = EQ +liftCompareOrigins _ Unknown _ = LT +liftCompareOrigins _ _ Unknown = GT +liftCompareOrigins _ (Package p1) (Package p2) = compare p1 p2 +liftCompareOrigins _ (Package _) _ = LT +liftCompareOrigins _ _ (Package _) = GT +liftCompareOrigins c (Module p1 m1) (Module p2 m2) = liftCompareOrigins c p1 p2 <> compare m1 m2 +liftCompareOrigins _ (Module _ _) _ = LT +liftCompareOrigins _ _ (Module _ _) = GT +liftCompareOrigins c (Term m1 t1) (Term m2 t2) = liftCompareOrigins c m1 m2 <> c t1 t2 instance Ord (Base term ()) => Ord (Origin term ty) where - compare = compareOrigins + compare = liftCompareOrigins compare data OriginType = P | M | T deriving (Eq, Ord, Show) @@ -61,11 +61,11 @@ termOrigin = SomeOrigin . Term Unknown . (() <$) . project withSomeOrigin :: (forall ty . Origin term ty -> b) -> SomeOrigin term -> b withSomeOrigin with (SomeOrigin o) = with o -instance Ord (Base term ()) => Eq (SomeOrigin term) where - SomeOrigin o1 == SomeOrigin o2 = compareOrigins o1 o2 == EQ +instance Eq (Base term ()) => Eq (SomeOrigin term) where + SomeOrigin o1 == SomeOrigin o2 = liftCompareOrigins (\ t1 t2 -> if t1 == t2 then EQ else LT) o1 o2 == EQ instance Ord (Base term ()) => Ord (SomeOrigin term) where - compare (SomeOrigin o1) (SomeOrigin o2) = compareOrigins o1 o2 + compare (SomeOrigin o1) (SomeOrigin o2) = liftCompareOrigins compare o1 o2 deriving instance Show (Base term ()) => Show (SomeOrigin term) From f045f2e6a01a6ddeade608f25119a09103f2f1dc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:44:21 -0400 Subject: [PATCH 79/89] :memo: liftCompareOrigin. --- src/Data/Abstract/Origin.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 64f9c72bb..7d7f09aa1 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -28,6 +28,7 @@ originPackage _ = Nothing deriving instance Eq (Base term ()) => Eq (Origin term ty) deriving instance Show (Base term ()) => Show (Origin term ty) +-- | Compare two origins with arbitrary type indices using a function to compare term functors. liftCompareOrigins :: (Base term () -> Base term () -> Ordering) -> Origin term ty1 -> Origin term ty2 -> Ordering liftCompareOrigins _ Unknown Unknown = EQ liftCompareOrigins _ Unknown _ = LT From b802247c4844e2779fcd22da16d3f781ef2e886d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:44:48 -0400 Subject: [PATCH 80/89] Move OriginType up. --- src/Data/Abstract/Origin.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 7d7f09aa1..e4d39e191 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -12,6 +12,9 @@ data Origin term ty where Module :: Origin term 'P -> M.ModuleInfo -> Origin term 'M Term :: Origin term 'M -> Base term () -> Origin term 'T +data OriginType = P | M | T + deriving (Eq, Ord, Show) + -- | Project the 'ModuleInfo' out of an 'Origin', if available. originModule :: Origin term ty -> Maybe M.ModuleInfo originModule (Term o _) = originModule o @@ -44,9 +47,6 @@ liftCompareOrigins c (Term m1 t1) (Term m2 t2) = liftCompareOrigins c m1 m2 instance Ord (Base term ()) => Ord (Origin term ty) where compare = liftCompareOrigins compare -data OriginType = P | M | T - deriving (Eq, Ord, Show) - data SomeOrigin term where SomeOrigin :: Origin term ty -> SomeOrigin term From 3a0f99bb179de6a2637f52c3e4d48ec7f969281c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:45:49 -0400 Subject: [PATCH 81/89] :memo: OriginType. --- src/Data/Abstract/Origin.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index e4d39e191..be279bddf 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -12,6 +12,7 @@ data Origin term ty where Module :: Origin term 'P -> M.ModuleInfo -> Origin term 'M Term :: Origin term 'M -> Base term () -> Origin term 'T +-- | A type index indicating the finest grain of information available in a given 'Origin'. data OriginType = P | M | T deriving (Eq, Ord, Show) From d298d63d75d831dcbdfea81e9069df705f8c90c0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:46:24 -0400 Subject: [PATCH 82/89] :memo: SomeOrigin. --- src/Data/Abstract/Origin.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index be279bddf..91f0f5d44 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -48,6 +48,7 @@ liftCompareOrigins c (Term m1 t1) (Term m2 t2) = liftCompareOrigins c m1 m2 instance Ord (Base term ()) => Ord (Origin term ty) where compare = liftCompareOrigins compare +-- | An existential abstraction over 'Origin's of different types. data SomeOrigin term where SomeOrigin :: Origin term ty -> SomeOrigin term From 76f4f79aab327283221e42b192fb05c52ba57437 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:47:25 -0400 Subject: [PATCH 83/89] :memo: the SomeOrigin smart constructors. --- src/Data/Abstract/Origin.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 91f0f5d44..89b089a4f 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -52,12 +52,15 @@ instance Ord (Base term ()) => Ord (Origin term ty) where data SomeOrigin term where SomeOrigin :: Origin term ty -> SomeOrigin term +-- | Construct a 'SomeOrigin' from 'P.Package' metadata. packageOrigin :: P.Package term -> SomeOrigin term packageOrigin = SomeOrigin . Package . P.packageInfo +-- | Construct a 'SomeOrigin' from 'M.Module' metadata. moduleOrigin :: M.Module term -> SomeOrigin term moduleOrigin = SomeOrigin . Module Unknown . M.moduleInfo +-- | Construct a 'SomeOrigin' from a recursive term type. termOrigin :: Recursive term => term -> SomeOrigin term termOrigin = SomeOrigin . Term Unknown . (() <$) . project From 4d66044cd7b29beff5da5ba7a9e5fa7ebe75928a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:48:32 -0400 Subject: [PATCH 84/89] :memo: withSomeOrigin. --- src/Data/Abstract/Origin.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 89b089a4f..28a7c890d 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -64,6 +64,7 @@ moduleOrigin = SomeOrigin . Module Unknown . M.moduleInfo termOrigin :: Recursive term => term -> SomeOrigin term termOrigin = SomeOrigin . Term Unknown . (() <$) . project +-- | Project information out of a 'SomeOrigin' using a helper function. withSomeOrigin :: (forall ty . Origin term ty -> b) -> SomeOrigin term -> b withSomeOrigin with (SomeOrigin o) = with o From 0c6bbc92e9f043e8610607f2af1777f183413a2c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:49:43 -0400 Subject: [PATCH 85/89] :memo: Origin. --- src/Data/Abstract/Origin.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 28a7c890d..874d3d976 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -77,6 +77,7 @@ instance Ord (Base term ()) => Ord (SomeOrigin term) where deriving instance Show (Base term ()) => Show (SomeOrigin term) +-- | Merge two 'Origin's of possibly differing type indices into a 'SomeOrigin' containing as much information as is available in either side, with ties broken in favour of the right-hand argument. merge :: Origin term ty1 -> Origin term ty2 -> SomeOrigin term merge a Unknown = SomeOrigin a merge (Package p) (Module Unknown m) = SomeOrigin (Module (Package p) m) From 705a6b125ff99cb6050a0a0bff6498b3139e0a3f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:53:02 -0400 Subject: [PATCH 86/89] :memo: the Origin constructors. --- src/Data/Abstract/Origin.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 874d3d976..53d832668 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -7,9 +7,13 @@ import Prologue -- | An 'Origin' encapsulates the location at which a name is bound or allocated. data Origin term ty where + -- | We don’t know anything, or there isn’t even something to know anything about. Unknown :: Origin term any + -- | We know the package. Package :: P.PackageInfo -> Origin term 'P + -- | We know the module, and possibly package. Module :: Origin term 'P -> M.ModuleInfo -> Origin term 'M + -- | We know the term, and possibly module and package. Term :: Origin term 'M -> Base term () -> Origin term 'T -- | A type index indicating the finest grain of information available in a given 'Origin'. From 5667500a1a0613c9c4e5dcc3e974982276895e42 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:54:01 -0400 Subject: [PATCH 87/89] :memo: evaluatePackageBody. --- src/Data/Abstract/Evaluatable.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index a083c7f9c..d2ca0a0fb 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -185,6 +185,7 @@ evaluatePackage :: ( Effectful m -> m effects [value] evaluatePackage p = pushOrigin (packageOrigin p) (evaluatePackageBody (packageBody p)) +-- | Evaluate a given package body (module table and entry points). evaluatePackageBody :: MonadEvaluatable location term value m => PackageBody term -> m [value] From 5b971ce4635d206baeb005db6023210ab7a4c9d7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:54:19 -0400 Subject: [PATCH 88/89] :memo: evaluatePackage. --- src/Data/Abstract/Evaluatable.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index d2ca0a0fb..2790d72a7 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -177,6 +177,7 @@ evaluateModules :: MonadEvaluatable location term value m -> m value evaluateModules = fmap Prelude.head . evaluatePackageBody . Package.fromModules +-- | Evaluate a given package. evaluatePackage :: ( Effectful m , Member (Reader (SomeOrigin term)) effects , MonadEvaluatable location term value (m effects) From 0c3f3c351a44dbf9092fac28ab59cb0149b6de7a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 Apr 2018 17:56:51 -0400 Subject: [PATCH 89/89] :memo: pushOrigin. --- src/Data/Abstract/Evaluatable.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 2790d72a7..fe4d82d3f 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -196,6 +196,7 @@ evaluatePackageBody body = localModuleTable (<> packageModules body) (_, v) <- require m maybe (pure v) ((`call` []) <=< variable) sym +-- | Push a 'SomeOrigin' onto the stack. This should be used to contextualize execution with information about the originating term, module, or package. pushOrigin :: ( Effectful m , Member (Reader (SomeOrigin term)) effects )