From 0b012558843e54f0cf6f62e34dc46124be9ad662 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 24 May 2018 12:54:17 -0400 Subject: [PATCH 001/159] Add the proto3-suite and proto3-wire repos back as submodules; --- .gitmodules | 6 ++++++ vendor/proto3-suite | 1 + vendor/proto3-wire | 1 + 3 files changed, 8 insertions(+) create mode 160000 vendor/proto3-suite create mode 160000 vendor/proto3-wire diff --git a/.gitmodules b/.gitmodules index 901dfd747..859c01cba 100644 --- a/.gitmodules +++ b/.gitmodules @@ -16,3 +16,9 @@ [submodule "vendor/fastsum"] path = vendor/fastsum url = git@github.com:patrickt/fastsum.git +[submodule "vendor/proto3-wire"] + path = vendor/proto3-wire + url = https://github.com/joshvera/proto3-wire +[submodule "vendor/proto3-suite"] + path = vendor/proto3-suite + url = https://github.com/joshvera/proto3-suite diff --git a/vendor/proto3-suite b/vendor/proto3-suite new file mode 160000 index 000000000..11c8d2bcc --- /dev/null +++ b/vendor/proto3-suite @@ -0,0 +1 @@ +Subproject commit 11c8d2bcc0d10bd540174fb28a5b2da3f404a422 diff --git a/vendor/proto3-wire b/vendor/proto3-wire new file mode 160000 index 000000000..c076246ca --- /dev/null +++ b/vendor/proto3-wire @@ -0,0 +1 @@ +Subproject commit c076246ca3d933f2145919f8f6b4809e73a8ab89 From 131ffe0fad66ec238feb71272d7086786ec60d9d Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 24 May 2018 13:43:51 -0400 Subject: [PATCH 002/159] Depend on proto3-suite and derive Named instances for Empty and Identifier --- semantic.cabal | 1 + src/Data/Syntax.hs | 5 +++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/semantic.cabal b/semantic.cabal index 0f8c6caec..4439de6e4 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -208,6 +208,7 @@ library , text >= 1.2.1.3 , these , time + , proto3-suite , unix , unordered-containers , haskell-tree-sitter diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 22adb07dc..410d6b845 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -16,6 +16,7 @@ import Prelude import Prologue import qualified Assigning.Assignment as Assignment import qualified Data.Error as Error +import Proto3.Suite.Class -- Combinators @@ -102,7 +103,7 @@ infixContext context left right operators = uncurry (&) <$> postContextualizeThr -- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable). newtype Identifier a = Identifier Name - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, Generic, Named) instance Eq1 Identifier where liftEq = genericLiftEq instance Ord1 Identifier where liftCompare = genericLiftCompare @@ -149,7 +150,7 @@ instance Evaluatable AccessibilityModifier -- -- This can be used to represent an implicit no-op, e.g. the alternative in an 'if' statement without an 'else'. data Empty a = Empty - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) instance ToJSONFields1 Empty From 7ca996996691027c5a5445b82681dd99013f0a82 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 24 May 2018 14:55:01 -0400 Subject: [PATCH 003/159] Add Message instances for JSON types --- src/Data/Syntax.hs | 2 +- src/Data/Syntax/Literal.hs | 33 +++++++++++++++++---------------- 2 files changed, 18 insertions(+), 17 deletions(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 410d6b845..cc8fff432 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -164,7 +164,7 @@ instance Evaluatable Empty where -- | Syntax representing a parsing or assignment error. data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) instance Eq1 Error where liftEq = genericLiftEq instance Ord1 Error where liftCompare = genericLiftCompare diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index c466e7bce..21888e014 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -1,20 +1,21 @@ -{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, ViewPatterns #-} +{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, ViewPatterns, ScopedTypeVariables #-} module Data.Syntax.Literal where -import Data.JSON.Fields -import Data.Abstract.Evaluatable -import Data.ByteString.Char8 (readInteger, unpack) +import Data.Abstract.Evaluatable +import Data.ByteString.Char8 (readInteger, unpack) import qualified Data.ByteString.Char8 as B -import Data.Scientific.Exts -import Diffing.Algorithm -import Prelude hiding (Float, null) -import Prologue hiding (Set, hash, null) -import Text.Read (readMaybe) +import Data.JSON.Fields +import Data.Scientific.Exts +import Diffing.Algorithm +import Prelude hiding (Float, null) +import Prologue hiding (Set, hash, null) +import Proto3.Suite.Class +import Text.Read (readMaybe) -- Boolean newtype Boolean a = Boolean Bool - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) true :: Boolean a true = Boolean True @@ -57,7 +58,7 @@ instance ToJSONFields1 Data.Syntax.Literal.Integer where -- | A literal float of unspecified width. newtype Float a = Float { floatContent :: ByteString } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare @@ -133,7 +134,7 @@ instance ToJSONFields1 InterpolationElement -- | A sequence of textual contents within a string literal. newtype TextElement a = TextElement { textElementContent :: ByteString } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) instance Eq1 TextElement where liftEq = genericLiftEq instance Ord1 TextElement where liftCompare = genericLiftCompare @@ -146,7 +147,7 @@ instance Evaluatable TextElement where eval (TextElement x) = Rval <$> string x data Null a = Null - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) instance Eq1 Null where liftEq = genericLiftEq instance Ord1 Null where liftCompare = genericLiftCompare @@ -189,7 +190,7 @@ instance Evaluatable Regex -- Collections newtype Array a = Array { arrayElements :: [a] } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) instance Eq1 Array where liftEq = genericLiftEq instance Ord1 Array where liftCompare = genericLiftCompare @@ -201,7 +202,7 @@ instance Evaluatable Array where eval (Array a) = Rval <$> (array =<< traverse subtermValue a) newtype Hash a = Hash { hashElements :: [a] } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) instance Eq1 Hash where liftEq = genericLiftEq instance Ord1 Hash where liftCompare = genericLiftCompare @@ -213,7 +214,7 @@ instance Evaluatable Hash where eval t = Rval <$> (traverse (subtermValue >=> asPair) (hashElements t) >>= hash) data KeyValue a = KeyValue { key :: !a, value :: !a } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) instance Eq1 KeyValue where liftEq = genericLiftEq instance Ord1 KeyValue where liftCompare = genericLiftCompare From 84c3bef78e6c176b7bb304e1e6c0c59366b7e2a1 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 24 May 2018 16:19:58 -0400 Subject: [PATCH 004/159] Add Identity and Product --- semantic.cabal | 1 + src/Data/Syntax.hs | 5 +++++ 2 files changed, 6 insertions(+) diff --git a/semantic.cabal b/semantic.cabal index 4439de6e4..bc21a1da0 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -209,6 +209,7 @@ library , these , time , proto3-suite + , proto3-wire , unix , unordered-containers , haskell-tree-sitter diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index cc8fff432..b35ff2a93 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -161,6 +161,11 @@ instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty" instance Evaluatable Empty where eval _ = Rval <$> unit +data Identity a = Identity a + deriving (Generic1, Message1) +data Product a b = Product a b + deriving (Generic1, Message1) + -- | Syntax representing a parsing or assignment error. data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] } From a33b4851a6fc46092906661a140805e6b0ebe4c5 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 24 May 2018 16:20:12 -0400 Subject: [PATCH 005/159] Add Message1 for Empty --- 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 b35ff2a93..89a13dd2d 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -150,7 +150,7 @@ instance Evaluatable AccessibilityModifier -- -- This can be used to represent an implicit no-op, e.g. the alternative in an 'if' statement without an 'else'. data Empty a = Empty - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message, Message1) instance ToJSONFields1 Empty From 800f2bc8585e2b6abccc96636c68d526bfb50d47 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 24 May 2018 16:23:47 -0400 Subject: [PATCH 006/159] Change type of product and remove instances from Error --- src/Data/Syntax.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 89a13dd2d..7d9060f37 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -163,13 +163,13 @@ instance Evaluatable Empty where data Identity a = Identity a deriving (Generic1, Message1) -data Product a b = Product a b +data Product a = Product a a deriving (Generic1, Message1) -- | Syntax representing a parsing or assignment error. data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 Error where liftEq = genericLiftEq instance Ord1 Error where liftCompare = genericLiftCompare From 0fb3ea0c8413f2d00700f8ee619be969f775d0f0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 24 May 2018 17:32:42 -0400 Subject: [PATCH 007/159] Add a Message1 instance for Term --- src/Data/Term.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Data/Term.hs b/src/Data/Term.hs index 4354c7d7e..0687ded50 100644 --- a/src/Data/Term.hs +++ b/src/Data/Term.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators #-} +{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators, ScopedTypeVariables #-} module Data.Term ( Term(..) , termIn @@ -16,6 +16,7 @@ import Data.Aeson import Data.JSON.Fields import Data.Record import Text.Show +import Proto3.Suite.Class -- | A Term with an abstract syntax tree and an annotation. newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) } @@ -78,6 +79,11 @@ instance Show1 f => Show1 (Term f) where instance (Show1 f, Show a) => Show (Term f a) where showsPrec = showsPrec1 +instance (Message1 f) => Message (Term f ()) where + encodeMessage num (Term (In a f)) = liftEncodeMessage encodeMessage num f + decodeMessage num = fmap (termIn ()) $ liftDecodeMessage decodeMessage num + dotProto _ = liftDotProto (dotProto @(Term f ())) (Proxy @f) + instance Ord1 f => Ord1 (Term f) where liftCompare comp = go where go t1 t2 = liftCompare2 comp go (unTerm t1) (unTerm t2) From 80cf96ecbfc5f2f9ed2bbdee884936da13f869fd Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 24 May 2018 17:33:25 -0400 Subject: [PATCH 008/159] Use aeson 1.3 and bump proto3-suite --- vendor/proto3-suite | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/proto3-suite b/vendor/proto3-suite index 11c8d2bcc..06be7e57e 160000 --- a/vendor/proto3-suite +++ b/vendor/proto3-suite @@ -1 +1 @@ -Subproject commit 11c8d2bcc0d10bd540174fb28a5b2da3f404a422 +Subproject commit 06be7e57e881e919382096098688e15debb1165e From 5dd3f6836837e33eeaba5c561a501fb5e6af311e Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 24 May 2018 17:39:01 -0400 Subject: [PATCH 009/159] hlint --- src/Data/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Term.hs b/src/Data/Term.hs index 0687ded50..cc12d86c9 100644 --- a/src/Data/Term.hs +++ b/src/Data/Term.hs @@ -80,8 +80,8 @@ instance (Show1 f, Show a) => Show (Term f a) where showsPrec = showsPrec1 instance (Message1 f) => Message (Term f ()) where - encodeMessage num (Term (In a f)) = liftEncodeMessage encodeMessage num f - decodeMessage num = fmap (termIn ()) $ liftDecodeMessage decodeMessage num + encodeMessage num (Term (In _ f)) = liftEncodeMessage encodeMessage num f + decodeMessage num = termIn () <$> liftDecodeMessage decodeMessage num dotProto _ = liftDotProto (dotProto @(Term f ())) (Proxy @f) instance Ord1 f => Ord1 (Term f) where From e33ef0f8f5a3f413e5d9549af7e60b9e9d296b48 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 24 May 2018 18:46:48 -0400 Subject: [PATCH 010/159] Stub Sum instance --- src/Data/Syntax.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 7d9060f37..8ba31761d 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -99,6 +99,11 @@ infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack, infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right +instance (Apply Message1 fs) => Message1 (Sum fs) where + liftEncodeMessage encodeMessage num fs = apply @Message1 (liftEncodeMessage encodeMessage num) fs + liftDecodeMessage decodeMessage num fs = fmap inject $ apply @Message1 (liftDecodeMessage decodeMessage num) + liftDotProto dotProto _ fs = apply @Message1 (liftDotProto dotProto (Proxy @fs)) fs + -- Common -- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable). From 1da6cec06e59c78adf4c0a177bc71bc99d8eda4f Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 24 May 2018 14:50:24 -0700 Subject: [PATCH 011/159] Add Literal.Character syntax constructor --- src/Data/Syntax/Literal.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index c466e7bce..82323e289 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -118,6 +118,17 @@ instance Evaluatable Data.Syntax.Literal.String instance ToJSONFields1 Data.Syntax.Literal.String +newtype Character a = Character { characterContent :: ByteString } + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + +instance Eq1 Data.Syntax.Literal.Character where liftEq = genericLiftEq +instance Ord1 Data.Syntax.Literal.Character where liftCompare = genericLiftCompare +instance Show1 Data.Syntax.Literal.Character where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Data.Syntax.Literal.Character + +instance ToJSONFields1 Data.Syntax.Literal.Character + -- | An interpolation element within a string literal. newtype InterpolationElement a = InterpolationElement { interpolationBody :: a } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) @@ -176,7 +187,6 @@ instance Ord1 Regex where liftCompare = genericLiftCompare instance Show1 Regex where liftShowsPrec = genericLiftShowsPrec -- TODO: Heredoc-style string literals? --- TODO: Character literals. instance ToJSONFields1 Regex where toJSONFields1 (Regex r) = noChildren ["asString" .= unpack r] From d86a41f17c7256d26d5b2d1d5cbd16396e82a1ba Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 24 May 2018 14:58:54 -0700 Subject: [PATCH 012/159] Assign character literals --- src/Language/Haskell/Assignment.hs | 7 +- test/fixtures/haskell/corpus/literals.A.hs | 33 +++ test/fixtures/haskell/corpus/literals.B.hs | 33 +++ .../haskell/corpus/literals.diffA-B.txt | 231 ++++++++++++++++- .../haskell/corpus/literals.diffB-A.txt | 245 +++++++++++++++++- .../haskell/corpus/literals.parseA.txt | 110 +++++++- .../haskell/corpus/literals.parseB.txt | 110 +++++++- 7 files changed, 748 insertions(+), 21 deletions(-) diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index 0da96796c..17fc68058 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -24,6 +24,7 @@ import Prologue type Syntax = '[ Comment.Comment , Declaration.Function + , Literal.Character , Literal.Float , Literal.Integer , Syntax.Context @@ -55,7 +56,8 @@ expression = term (handleError (choice expressionChoices)) expressionChoices :: [Assignment.Assignment [] Grammar Term] expressionChoices = [ - comment + character + , comment , constructorIdentifier , float , functionDeclaration @@ -101,6 +103,9 @@ integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source) float :: Assignment float = makeTerm <$> symbol Float <*> (Literal.Float <$> source) +character :: Assignment +character = makeTerm <$> symbol Char <*> (Literal.Character <$> source) + -- | Match a series of terms or comments until a delimiter is matched. manyTermsTill :: Assignment.Assignment [] Grammar Term -> Assignment.Assignment [] Grammar b -> Assignment.Assignment [] Grammar [Term] manyTermsTill step = manyTill (step <|> comment) diff --git a/test/fixtures/haskell/corpus/literals.A.hs b/test/fixtures/haskell/corpus/literals.A.hs index 210598ae6..982492885 100644 --- a/test/fixtures/haskell/corpus/literals.A.hs +++ b/test/fixtures/haskell/corpus/literals.A.hs @@ -35,3 +35,36 @@ aZ' = undefined a = True a = False + +a = 'a' +a = 'b' + +a = '0' +a = '1' + +a = '_' + +a = 'A' +a = 'B' + +a = ',' + +a = '!' +a = '#' +a = '$' +a = '%' +a = '&' +a = '⋆' +a = '+' +a = '.' +a = '/' +a = '<' +a = '=' +a = '>' +a = '?' +a = '^' +a = '|' +a = '-' +a = '~' +a = ':' +a = '"' diff --git a/test/fixtures/haskell/corpus/literals.B.hs b/test/fixtures/haskell/corpus/literals.B.hs index d41b1b37a..a07c780a7 100644 --- a/test/fixtures/haskell/corpus/literals.B.hs +++ b/test/fixtures/haskell/corpus/literals.B.hs @@ -35,3 +35,36 @@ bZ' = undefined b = True b = False + +b = 'a' +b = 'b' + +b = '0' +b = '1' + +b = '_' + +b = 'A' +b = 'B' + +b = ',' + +b = '!' +b = '#' +b = '$' +b = '%' +b = '&' +b = '⋆' +b = '+' +b = '.' +b = '/' +b = '<' +b = '=' +b = '>' +b = '?' +b = '^' +b = '|' +b = '-' +b = '~' +b = ':' +b = '"' diff --git a/test/fixtures/haskell/corpus/literals.diffA-B.txt b/test/fixtures/haskell/corpus/literals.diffA-B.txt index a7e1f8237..00b88a44e 100644 --- a/test/fixtures/haskell/corpus/literals.diffA-B.txt +++ b/test/fixtures/haskell/corpus/literals.diffA-B.txt @@ -1,11 +1,10 @@ (Module (Identifier) ( - (Function - { (Identifier) - ->(Identifier) } - ( - (Integer))) + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} {+(Function {+(Identifier)+} {+( @@ -118,6 +117,118 @@ {+(Identifier)+} {+( {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} {-(Function {-(Identifier)-} {-( @@ -229,4 +340,112 @@ {-(Function {-(Identifier)-} {-( - {-(Identifier)-})-})-})) + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-})) diff --git a/test/fixtures/haskell/corpus/literals.diffB-A.txt b/test/fixtures/haskell/corpus/literals.diffB-A.txt index 34000a913..00b88a44e 100644 --- a/test/fixtures/haskell/corpus/literals.diffB-A.txt +++ b/test/fixtures/haskell/corpus/literals.diffB-A.txt @@ -1,11 +1,10 @@ (Module (Identifier) ( - (Function - { (Identifier) - ->(Identifier) } - ( - (Integer))) + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} {+(Function {+(Identifier)+} {+( @@ -102,12 +101,6 @@ {+(Identifier)+} {+( {+(Identifier)+})+})+} - (Function - { (Identifier) - ->(Identifier) } - ( - {+(Identifier)+} - {-(Integer)-})) {+(Function {+(Identifier)+} {+( @@ -120,6 +113,126 @@ {+(Identifier)+} {+( {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} {-(Function {-(Identifier)-} {-( @@ -227,4 +340,112 @@ {-(Function {-(Identifier)-} {-( - {-(Identifier)-})-})-})) + {-(Identifier)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Character)-})-})-})) diff --git a/test/fixtures/haskell/corpus/literals.parseA.txt b/test/fixtures/haskell/corpus/literals.parseA.txt index 40982fe4b..9526e9674 100644 --- a/test/fixtures/haskell/corpus/literals.parseA.txt +++ b/test/fixtures/haskell/corpus/literals.parseA.txt @@ -116,4 +116,112 @@ (Function (Identifier) ( - (Identifier))))) + (Identifier))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))))) diff --git a/test/fixtures/haskell/corpus/literals.parseB.txt b/test/fixtures/haskell/corpus/literals.parseB.txt index 40982fe4b..9526e9674 100644 --- a/test/fixtures/haskell/corpus/literals.parseB.txt +++ b/test/fixtures/haskell/corpus/literals.parseB.txt @@ -116,4 +116,112 @@ (Function (Identifier) ( - (Identifier))))) + (Identifier))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))) + (Function + (Identifier) + ( + (Character))))) From ea18738a28953d03d55b20c1f294d4e3c1f39d20 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 24 May 2018 15:34:18 -0700 Subject: [PATCH 013/159] Assign string and array literals --- src/Language/Haskell/Assignment.hs | 11 ++ test/fixtures/haskell/corpus/literals.A.hs | 36 ++++++ test/fixtures/haskell/corpus/literals.B.hs | 36 ++++++ .../haskell/corpus/literals.diffA-B.txt | 104 +++++++++++++--- .../haskell/corpus/literals.diffB-A.txt | 112 ++++++++++++++---- .../haskell/corpus/literals.parseA.txt | 40 ++++++- .../haskell/corpus/literals.parseB.txt | 40 ++++++- 7 files changed, 338 insertions(+), 41 deletions(-) diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index 17fc68058..fe0cd85b1 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -24,9 +24,11 @@ import Prologue type Syntax = '[ Comment.Comment , Declaration.Function + , Literal.Array , Literal.Character , Literal.Float , Literal.Integer + , Literal.TextElement , Syntax.Context , Syntax.Empty , Syntax.Error @@ -62,7 +64,9 @@ expressionChoices = [ , float , functionDeclaration , integer + , listExpression , moduleIdentifier + , string , variableIdentifier , where' ] @@ -100,12 +104,19 @@ functionDeclaration = makeTerm integer :: Assignment integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source) +listExpression :: Assignment +listExpression = makeTerm <$> symbol ListExpression <*> children (Literal.Array <$> many listElement) + where listElement = symbol Expression *> children expression + float :: Assignment float = makeTerm <$> symbol Float <*> (Literal.Float <$> source) character :: Assignment character = makeTerm <$> symbol Char <*> (Literal.Character <$> source) +string :: Assignment +string = makeTerm <$> symbol String <*> (Literal.TextElement <$> source) + -- | Match a series of terms or comments until a delimiter is matched. manyTermsTill :: Assignment.Assignment [] Grammar Term -> Assignment.Assignment [] Grammar b -> Assignment.Assignment [] Grammar [Term] manyTermsTill step = manyTill (step <|> comment) diff --git a/test/fixtures/haskell/corpus/literals.A.hs b/test/fixtures/haskell/corpus/literals.A.hs index 982492885..531b26fff 100644 --- a/test/fixtures/haskell/corpus/literals.A.hs +++ b/test/fixtures/haskell/corpus/literals.A.hs @@ -68,3 +68,39 @@ a = '-' a = '~' a = ':' a = '"' + +a = [ "\NUL" + , "\SOH" + , "\STX" + , "\ETX" + , "\EOT" + , "\ENQ" + , "\ACK" + , "\BEL" + , "\BS" + , "\HT" + , "\LF" + , "\VT" + , "\FF" + , "\CR" + , "\SO" + , "\SI" + , "\DLE" + , "\DC1" + , "\DC2" + , "\DC3" + , "\DC4" + , "\NAK" + , "\SYN" + , "\ETB" + , "\CAN" + , "\EM" + , "\SUB" + , "\ESC" + , "\FS" + , "\GS" + , "\RS" + , "\US" + , "\SP" + , "\DEL" + ] diff --git a/test/fixtures/haskell/corpus/literals.B.hs b/test/fixtures/haskell/corpus/literals.B.hs index a07c780a7..e92685d4a 100644 --- a/test/fixtures/haskell/corpus/literals.B.hs +++ b/test/fixtures/haskell/corpus/literals.B.hs @@ -68,3 +68,39 @@ b = '-' b = '~' b = ':' b = '"' + +b = [ "\NUL" + , "\SOH" + , "\STX" + , "\ETX" + , "\EOT" + , "\ENQ" + , "\ACK" + , "\BEL" + , "\BS" + , "\HT" + , "\LF" + , "\VT" + , "\FF" + , "\CR" + , "\SO" + , "\SI" + , "\DLE" + , "\DC1" + , "\DC2" + , "\DC3" + , "\DC4" + , "\NAK" + , "\SYN" + , "\ETB" + , "\CAN" + , "\EM" + , "\SUB" + , "\ESC" + , "\FS" + , "\GS" + , "\RS" + , "\US" + , "\SP" + , "\DEL" + ] diff --git a/test/fixtures/haskell/corpus/literals.diffA-B.txt b/test/fixtures/haskell/corpus/literals.diffA-B.txt index 00b88a44e..a68609800 100644 --- a/test/fixtures/haskell/corpus/literals.diffA-B.txt +++ b/test/fixtures/haskell/corpus/literals.diffA-B.txt @@ -1,14 +1,16 @@ (Module (Identifier) ( - {+(Function - {+(Identifier)+} - {+( - {+(Integer)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Integer)+})+})+} + (Function + { (Identifier) + ->(Identifier) } + ( + (Integer))) + (Function + { (Identifier) + ->(Identifier) } + ( + (Integer))) {+(Function {+(Identifier)+} {+( @@ -225,14 +227,44 @@ {+(Identifier)+} {+( {+(Character)+})+})+} - {-(Function - {-(Identifier)-} - {-( - {-(Integer)-})-})-} - {-(Function - {-(Identifier)-} - {-( - {-(Integer)-})-})-} + {+(Function + {+(Identifier)+} + {+( + {+(Array + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+})+})+})+} {-(Function {-(Identifier)-} {-( @@ -448,4 +480,42 @@ {-(Function {-(Identifier)-} {-( - {-(Character)-})-})-})) + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Array + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-})-})-})-})) diff --git a/test/fixtures/haskell/corpus/literals.diffB-A.txt b/test/fixtures/haskell/corpus/literals.diffB-A.txt index 00b88a44e..13850fedc 100644 --- a/test/fixtures/haskell/corpus/literals.diffB-A.txt +++ b/test/fixtures/haskell/corpus/literals.diffB-A.txt @@ -1,14 +1,16 @@ (Module (Identifier) ( - {+(Function - {+(Identifier)+} - {+( - {+(Integer)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Integer)+})+})+} + (Function + { (Identifier) + ->(Identifier) } + ( + (Integer))) + (Function + { (Identifier) + ->(Identifier) } + ( + (Integer))) {+(Function {+(Identifier)+} {+( @@ -189,6 +191,12 @@ {+(Identifier)+} {+( {+(Character)+})+})+} + (Function + { (Identifier) + ->(Identifier) } + ( + {+(Character)+} + {-(Integer)-})) {+(Function {+(Identifier)+} {+( @@ -224,19 +232,41 @@ {+(Function {+(Identifier)+} {+( - {+(Character)+})+})+} - {-(Function - {-(Identifier)-} - {-( - {-(Integer)-})-})-} - {-(Function - {-(Identifier)-} - {-( - {-(Integer)-})-})-} - {-(Function - {-(Identifier)-} - {-( - {-(Integer)-})-})-} + {+(Array + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+} + {+(TextElement)+})+})+})+} {-(Function {-(Identifier)-} {-( @@ -448,4 +478,42 @@ {-(Function {-(Identifier)-} {-( - {-(Character)-})-})-})) + {-(Character)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Array + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-} + {-(TextElement)-})-})-})-})) diff --git a/test/fixtures/haskell/corpus/literals.parseA.txt b/test/fixtures/haskell/corpus/literals.parseA.txt index 9526e9674..54f104940 100644 --- a/test/fixtures/haskell/corpus/literals.parseA.txt +++ b/test/fixtures/haskell/corpus/literals.parseA.txt @@ -224,4 +224,42 @@ (Function (Identifier) ( - (Character))))) + (Character))) + (Function + (Identifier) + ( + (Array + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement)))))) diff --git a/test/fixtures/haskell/corpus/literals.parseB.txt b/test/fixtures/haskell/corpus/literals.parseB.txt index 9526e9674..54f104940 100644 --- a/test/fixtures/haskell/corpus/literals.parseB.txt +++ b/test/fixtures/haskell/corpus/literals.parseB.txt @@ -224,4 +224,42 @@ (Function (Identifier) ( - (Character))))) + (Character))) + (Function + (Identifier) + ( + (Array + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement) + (TextElement)))))) From e74bfca4bdb69676e6ea1b10c093b645dc28aad2 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 24 May 2018 19:12:22 -0700 Subject: [PATCH 014/159] Assign basic type synonym declarations --- src/Language/Haskell/Assignment.hs | 62 +++ src/Language/Haskell/Syntax.hs | 64 ++- .../haskell/corpus/literals.diffA-B.txt | 26 +- .../haskell/corpus/literals.diffB-A.txt | 388 +++++++++--------- .../haskell/corpus/type-synonyms.A.hs | 8 + .../haskell/corpus/type-synonyms.B.hs | 8 + .../haskell/corpus/type-synonyms.diffA-B.txt | 88 ++++ .../haskell/corpus/type-synonyms.diffB-A.txt | 88 ++++ .../haskell/corpus/type-synonyms.parseA.txt | 71 ++++ .../haskell/corpus/type-synonyms.parseB.txt | 73 ++++ 10 files changed, 674 insertions(+), 202 deletions(-) create mode 100644 test/fixtures/haskell/corpus/type-synonyms.A.hs create mode 100644 test/fixtures/haskell/corpus/type-synonyms.B.hs create mode 100644 test/fixtures/haskell/corpus/type-synonyms.diffA-B.txt create mode 100644 test/fixtures/haskell/corpus/type-synonyms.diffB-A.txt create mode 100644 test/fixtures/haskell/corpus/type-synonyms.parseA.txt create mode 100644 test/fixtures/haskell/corpus/type-synonyms.parseB.txt diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index fe0cd85b1..b771e5720 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -17,6 +17,7 @@ import qualified Data.Syntax as Syntax import qualified Data.Syntax.Comment as Comment import qualified Data.Syntax.Declaration as Declaration import qualified Data.Syntax.Literal as Literal +import qualified Data.Syntax.Type as Type import qualified Data.Term as Term import qualified Language.Haskell.Syntax as Syntax import Prologue @@ -32,8 +33,15 @@ type Syntax = '[ , Syntax.Context , Syntax.Empty , Syntax.Error + , Syntax.FunctionConstructor , Syntax.Identifier + , Syntax.ListConstructor , Syntax.Module + , Syntax.TupleConstructor + , Syntax.Type + , Syntax.TypeSynonym + , Syntax.UnitConstructor + , Type.TypeParameters , [] ] @@ -62,11 +70,20 @@ expressionChoices = [ , comment , constructorIdentifier , float + , functionConstructor , functionDeclaration , integer + , listConstructor , listExpression + , listType , moduleIdentifier , string + , type' + , typeConstructorIdentifier + , typeSynonymDeclaration + , typeVariableIdentifier + , tuplingConstructor + , unitConstructor , variableIdentifier , where' ] @@ -86,12 +103,21 @@ constructorIdentifier = makeTerm <$> symbol ConstructorIdentifier <*> (Syntax.Id moduleIdentifier :: Assignment moduleIdentifier = makeTerm <$> symbol ModuleIdentifier <*> (Syntax.Identifier . Name.name <$> source) +typeConstructorIdentifier :: Assignment +typeConstructorIdentifier = makeTerm <$> symbol TypeConstructorIdentifier <*> (Syntax.Identifier . Name.name <$> source) + +typeVariableIdentifier :: Assignment +typeVariableIdentifier = makeTerm <$> symbol TypeVariableIdentifier <*> (Syntax.Identifier . Name.name <$> source) + where' :: Assignment where' = makeTerm <$> (symbol Where <|> symbol Where') <*> children (many expression) functionBody :: Assignment functionBody = makeTerm <$> symbol FunctionBody <*> children (many expression) +functionConstructor :: Assignment +functionConstructor = makeTerm <$> token FunctionConstructor <*> (Syntax.FunctionConstructor <$> emptyTerm) + functionDeclaration :: Assignment functionDeclaration = makeTerm <$> symbol FunctionDeclaration @@ -104,10 +130,29 @@ functionDeclaration = makeTerm integer :: Assignment integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source) +listConstructor :: Assignment +listConstructor = makeTerm <$> token ListConstructor <*> (Syntax.ListConstructor <$> emptyTerm) + +unitConstructor :: Assignment +unitConstructor = makeTerm <$> token UnitConstructor <*> (Syntax.UnitConstructor <$> emptyTerm) + listExpression :: Assignment listExpression = makeTerm <$> symbol ListExpression <*> children (Literal.Array <$> many listElement) where listElement = symbol Expression *> children expression +listType :: Assignment +listType = makeTerm <$> symbol ListType <*> children (Literal.Array <$> many type') + +tuplingConstructor :: Assignment +tuplingConstructor = makeTerm <$> symbol TuplingConstructor <*> children (Syntax.TupleConstructor <$> emptyTerm) + +type' :: Assignment +type' = (makeTerm <$> symbol Type <*> children (Syntax.Type <$> typeConstructor <*> typeParameters)) + <|> (makeTerm <$> symbol TypePattern <*> children (Syntax.Type <$> typeConstructor <*> typeParameters)) + +typeParameters :: Assignment +typeParameters = makeTerm <$> location <*> (Type.TypeParameters <$> many expression) + float :: Assignment float = makeTerm <$> symbol Float <*> (Literal.Float <$> source) @@ -117,6 +162,23 @@ character = makeTerm <$> symbol Char <*> (Literal.Character <$> source) string :: Assignment string = makeTerm <$> symbol String <*> (Literal.TextElement <$> source) +typeConstructor :: Assignment +typeConstructor = typeConstructorIdentifier + <|> functionConstructor + <|> listConstructor + <|> listType + <|> tuplingConstructor + <|> unitConstructor + +typeSynonymDeclaration :: Assignment +typeSynonymDeclaration = makeTerm + <$> symbol TypeSynonymDeclaration + <*> children (Syntax.TypeSynonym <$> typeLeft <*> typeRight) + where + typeLeft = makeTerm <$> location <*> (Syntax.Type <$> typeConstructor <*> typeParametersLeft) + typeParametersLeft = makeTerm <$> location <*> (Type.TypeParameters <$> manyTill expression (symbol TypeSynonymBody)) + typeRight = symbol TypeSynonymBody *> children type' + -- | Match a series of terms or comments until a delimiter is matched. manyTermsTill :: Assignment.Assignment [] Grammar Term -> Assignment.Assignment [] Grammar b -> Assignment.Assignment [] Grammar [Term] manyTermsTill step = manyTill (step <|> comment) diff --git a/src/Language/Haskell/Syntax.hs b/src/Language/Haskell/Syntax.hs index a7e672818..6c2090af9 100644 --- a/src/Language/Haskell/Syntax.hs +++ b/src/Language/Haskell/Syntax.hs @@ -19,4 +19,66 @@ instance Show1 Module where liftShowsPrec = genericLiftShowsPrec instance ToJSONFields1 Module -instance Evaluatable Module where +instance Evaluatable Module + +data Type a = Type { typeIdentifier :: !a, typeParameters :: !a } + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + +instance Eq1 Type where liftEq = genericLiftEq +instance Ord1 Type where liftCompare = genericLiftCompare +instance Show1 Type where liftShowsPrec = genericLiftShowsPrec + +instance ToJSONFields1 Type + +instance Evaluatable Type + +data TypeSynonym a = TypeSynonym { typeSynonymLeft :: !a, typeSynonymRight :: !a } + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + +instance Eq1 TypeSynonym where liftEq = genericLiftEq +instance Ord1 TypeSynonym where liftCompare = genericLiftCompare +instance Show1 TypeSynonym where liftShowsPrec = genericLiftShowsPrec + +instance ToJSONFields1 TypeSynonym + +instance Evaluatable TypeSynonym + +data UnitConstructor a = UnitConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + +instance Eq1 UnitConstructor where liftEq = genericLiftEq +instance Ord1 UnitConstructor where liftCompare = genericLiftCompare +instance Show1 UnitConstructor where liftShowsPrec = genericLiftShowsPrec + +instance ToJSONFields1 UnitConstructor + +instance Evaluatable UnitConstructor + +data TupleConstructor a = TupleConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + +instance Eq1 TupleConstructor where liftEq = genericLiftEq +instance Ord1 TupleConstructor where liftCompare = genericLiftCompare +instance Show1 TupleConstructor where liftShowsPrec = genericLiftShowsPrec + +instance ToJSONFields1 TupleConstructor + +instance Evaluatable TupleConstructor + +data ListConstructor a = ListConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + +instance Eq1 ListConstructor where liftEq = genericLiftEq +instance Ord1 ListConstructor where liftCompare = genericLiftCompare +instance Show1 ListConstructor where liftShowsPrec = genericLiftShowsPrec + +instance ToJSONFields1 ListConstructor + +instance Evaluatable ListConstructor + +data FunctionConstructor a = FunctionConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + +instance Eq1 FunctionConstructor where liftEq = genericLiftEq +instance Ord1 FunctionConstructor where liftCompare = genericLiftCompare +instance Show1 FunctionConstructor where liftShowsPrec = genericLiftShowsPrec + +instance ToJSONFields1 FunctionConstructor + +instance Evaluatable FunctionConstructor diff --git a/test/fixtures/haskell/corpus/literals.diffA-B.txt b/test/fixtures/haskell/corpus/literals.diffA-B.txt index a68609800..fd74fe329 100644 --- a/test/fixtures/haskell/corpus/literals.diffA-B.txt +++ b/test/fixtures/haskell/corpus/literals.diffA-B.txt @@ -1,16 +1,14 @@ (Module (Identifier) ( - (Function - { (Identifier) - ->(Identifier) } - ( - (Integer))) - (Function - { (Identifier) - ->(Identifier) } - ( - (Integer))) + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} {+(Function {+(Identifier)+} {+( @@ -281,6 +279,14 @@ {-(Identifier)-} {-( {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} {-(Function {-(Identifier)-} {-( diff --git a/test/fixtures/haskell/corpus/literals.diffB-A.txt b/test/fixtures/haskell/corpus/literals.diffB-A.txt index 13850fedc..eaedd9bad 100644 --- a/test/fixtures/haskell/corpus/literals.diffB-A.txt +++ b/test/fixtures/haskell/corpus/literals.diffB-A.txt @@ -1,202 +1,200 @@ (Module (Identifier) ( + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Integer)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} (Function { (Identifier) ->(Identifier) } ( - (Integer))) - (Function - { (Identifier) - ->(Identifier) } - ( - (Integer))) - {+(Function - {+(Identifier)+} - {+( - {+(Integer)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Integer)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Integer)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Integer)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Float)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Identifier)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Identifier)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Identifier)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Identifier)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Identifier)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Identifier)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Identifier)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Identifier)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Identifier)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - {+(Function - {+(Identifier)+} - {+( - {+(Character)+})+})+} - (Function - { (Identifier) - ->(Identifier) } - ( - {+(Character)+} + {+(Float)+} {-(Integer)-})) + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Float)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Character)+})+})+} {+(Function {+(Identifier)+} {+( @@ -279,6 +277,14 @@ {-(Identifier)-} {-( {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} + {-(Function + {-(Identifier)-} + {-( + {-(Integer)-})-})-} {-(Function {-(Identifier)-} {-( diff --git a/test/fixtures/haskell/corpus/type-synonyms.A.hs b/test/fixtures/haskell/corpus/type-synonyms.A.hs new file mode 100644 index 000000000..21c796fdd --- /dev/null +++ b/test/fixtures/haskell/corpus/type-synonyms.A.hs @@ -0,0 +1,8 @@ +type Foo = Bar +type List = [] +type Foo a = Bar a +type Rec a = [Circ a] +type V = () +type X = (,) +type Y = (,,) +type Z = (->) diff --git a/test/fixtures/haskell/corpus/type-synonyms.B.hs b/test/fixtures/haskell/corpus/type-synonyms.B.hs new file mode 100644 index 000000000..762c8e1c3 --- /dev/null +++ b/test/fixtures/haskell/corpus/type-synonyms.B.hs @@ -0,0 +1,8 @@ +type Bar = Foo +type List' = [] +type Foo a b = Bar a b +type Rec a = [Triangle a] +type X = () +type Y = (,,) +type Z = (,) +type T = (->) diff --git a/test/fixtures/haskell/corpus/type-synonyms.diffA-B.txt b/test/fixtures/haskell/corpus/type-synonyms.diffA-B.txt new file mode 100644 index 000000000..9543534a8 --- /dev/null +++ b/test/fixtures/haskell/corpus/type-synonyms.diffA-B.txt @@ -0,0 +1,88 @@ +(Module + (Empty) + ( + (TypeSynonym + (Type + { (Identifier) + ->(Identifier) } + (TypeParameters)) + (Type + { (Identifier) + ->(Identifier) } + (TypeParameters))) + (TypeSynonym + (Type + { (Identifier) + ->(Identifier) } + (TypeParameters)) + (Type + (ListConstructor + (Empty)) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters + (Identifier) + {+(Identifier)+})) + (Type + (Identifier) + (TypeParameters + (Identifier) + {+(Identifier)+}))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters + (Identifier))) + (Type + (Array + (Type + { (Identifier) + ->(Identifier) } + (TypeParameters + (Identifier)))) + (TypeParameters))) + (TypeSynonym + (Type + { (Identifier) + ->(Identifier) } + (TypeParameters)) + (Type + (UnitConstructor + (Empty)) + (TypeParameters))) + {-(TypeSynonym + {-(Type + {-(Identifier)-} + {-(TypeParameters)-})-} + {-(Type + {-(TupleConstructor + {-(Empty)-})-} + {-(TypeParameters)-})-})-} + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + (TupleConstructor + (Empty)) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + { (FunctionConstructor + {-(Empty)-}) + ->(TupleConstructor + {+(Empty)+}) } + (TypeParameters))) + {+(TypeSynonym + {+(Type + {+(Identifier)+} + {+(TypeParameters)+})+} + {+(Type + {+(FunctionConstructor + {+(Empty)+})+} + {+(TypeParameters)+})+})+})) diff --git a/test/fixtures/haskell/corpus/type-synonyms.diffB-A.txt b/test/fixtures/haskell/corpus/type-synonyms.diffB-A.txt new file mode 100644 index 000000000..3db8a0ea3 --- /dev/null +++ b/test/fixtures/haskell/corpus/type-synonyms.diffB-A.txt @@ -0,0 +1,88 @@ +(Module + (Empty) + ( + (TypeSynonym + (Type + { (Identifier) + ->(Identifier) } + (TypeParameters)) + (Type + { (Identifier) + ->(Identifier) } + (TypeParameters))) + (TypeSynonym + (Type + { (Identifier) + ->(Identifier) } + (TypeParameters)) + (Type + (ListConstructor + (Empty)) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters + (Identifier) + {-(Identifier)-})) + (Type + (Identifier) + (TypeParameters + (Identifier) + {-(Identifier)-}))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters + (Identifier))) + (Type + (Array + (Type + { (Identifier) + ->(Identifier) } + (TypeParameters + (Identifier)))) + (TypeParameters))) + (TypeSynonym + (Type + { (Identifier) + ->(Identifier) } + (TypeParameters)) + (Type + (UnitConstructor + (Empty)) + (TypeParameters))) + {+(TypeSynonym + {+(Type + {+(Identifier)+} + {+(TypeParameters)+})+} + {+(Type + {+(TupleConstructor + {+(Empty)+})+} + {+(TypeParameters)+})+})+} + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + (TupleConstructor + (Empty)) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + { (TupleConstructor + {-(Empty)-}) + ->(FunctionConstructor + {+(Empty)+}) } + (TypeParameters))) + {-(TypeSynonym + {-(Type + {-(Identifier)-} + {-(TypeParameters)-})-} + {-(Type + {-(FunctionConstructor + {-(Empty)-})-} + {-(TypeParameters)-})-})-})) diff --git a/test/fixtures/haskell/corpus/type-synonyms.parseA.txt b/test/fixtures/haskell/corpus/type-synonyms.parseA.txt new file mode 100644 index 000000000..86eca5b2b --- /dev/null +++ b/test/fixtures/haskell/corpus/type-synonyms.parseA.txt @@ -0,0 +1,71 @@ +(Module + (Empty) + ( + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + (Identifier) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + (ListConstructor + (Empty)) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters + (Identifier))) + (Type + (Identifier) + (TypeParameters + (Identifier)))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters + (Identifier))) + (Type + (Array + (Type + (Identifier) + (TypeParameters + (Identifier)))) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + (UnitConstructor + (Empty)) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + (TupleConstructor + (Empty)) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + (TupleConstructor + (Empty)) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + (FunctionConstructor + (Empty)) + (TypeParameters))))) diff --git a/test/fixtures/haskell/corpus/type-synonyms.parseB.txt b/test/fixtures/haskell/corpus/type-synonyms.parseB.txt new file mode 100644 index 000000000..9153c086a --- /dev/null +++ b/test/fixtures/haskell/corpus/type-synonyms.parseB.txt @@ -0,0 +1,73 @@ +(Module + (Empty) + ( + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + (Identifier) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + (ListConstructor + (Empty)) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters + (Identifier) + (Identifier))) + (Type + (Identifier) + (TypeParameters + (Identifier) + (Identifier)))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters + (Identifier))) + (Type + (Array + (Type + (Identifier) + (TypeParameters + (Identifier)))) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + (UnitConstructor + (Empty)) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + (TupleConstructor + (Empty)) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + (TupleConstructor + (Empty)) + (TypeParameters))) + (TypeSynonym + (Type + (Identifier) + (TypeParameters)) + (Type + (FunctionConstructor + (Empty)) + (TypeParameters))))) From 3dbf0ec68c80946cc1661003a77812e560746141 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Fri, 25 May 2018 01:54:21 -0500 Subject: [PATCH 015/159] Convert to newtype --- src/Language/Haskell/Syntax.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Syntax.hs b/src/Language/Haskell/Syntax.hs index 6c2090af9..906fe0fec 100644 --- a/src/Language/Haskell/Syntax.hs +++ b/src/Language/Haskell/Syntax.hs @@ -43,7 +43,7 @@ instance ToJSONFields1 TypeSynonym instance Evaluatable TypeSynonym -data UnitConstructor a = UnitConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +newtype UnitConstructor a = UnitConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 UnitConstructor where liftEq = genericLiftEq instance Ord1 UnitConstructor where liftCompare = genericLiftCompare @@ -53,7 +53,7 @@ instance ToJSONFields1 UnitConstructor instance Evaluatable UnitConstructor -data TupleConstructor a = TupleConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +newtype TupleConstructor a = TupleConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 TupleConstructor where liftEq = genericLiftEq instance Ord1 TupleConstructor where liftCompare = genericLiftCompare @@ -63,7 +63,7 @@ instance ToJSONFields1 TupleConstructor instance Evaluatable TupleConstructor -data ListConstructor a = ListConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +newtype ListConstructor a = ListConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 ListConstructor where liftEq = genericLiftEq instance Ord1 ListConstructor where liftCompare = genericLiftCompare @@ -73,7 +73,7 @@ instance ToJSONFields1 ListConstructor instance Evaluatable ListConstructor -data FunctionConstructor a = FunctionConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +newtype FunctionConstructor a = FunctionConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 FunctionConstructor where liftEq = genericLiftEq instance Ord1 FunctionConstructor where liftCompare = genericLiftCompare From c3619782713ee39c1a284afa5653816b600681a7 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 25 May 2018 09:59:23 -0400 Subject: [PATCH 016/159] Add liftDecodeMessage --- src/Data/Syntax.hs | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 8ba31761d..34dd36a5b 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables #-} +{-# LANGUAGE DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, KindSignatures #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack module Data.Syntax where @@ -17,6 +17,8 @@ import Prologue import qualified Assigning.Assignment as Assignment import qualified Data.Error as Error import Proto3.Suite.Class +import Proto3.Wire.Decode +import Proto3.Wire.Types -- Combinators @@ -98,12 +100,24 @@ infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack, -> m (Sum fs (Term (Sum fs) a)) infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right - instance (Apply Message1 fs) => Message1 (Sum fs) where liftEncodeMessage encodeMessage num fs = apply @Message1 (liftEncodeMessage encodeMessage num) fs - liftDecodeMessage decodeMessage num fs = fmap inject $ apply @Message1 (liftDecodeMessage decodeMessage num) + liftDecodeMessage decodeMessage num = oneof undefined listOfParsers + where + listOfParsers = + zipWith (\i generator -> (FieldNumber i, generator (FieldNumber i))) [1..] (generate @fs @fs (Proxy @fs) decodeMessage) liftDotProto dotProto _ fs = apply @Message1 (liftDotProto dotProto (Proxy @fs)) fs +class Generate (all :: [* -> *]) (fs :: [* -> *]) where + generate :: proxy fs -> (FieldNumber -> Parser RawMessage a) -> [FieldNumber -> Parser RawField (Sum all a)] + +instance Generate all '[] where + generate _ _ = [] + +instance (Element f all, Generate all fs, Message1 f) => Generate all (f ': fs) where + generate _ decodeMessage = (\ num -> fromJust <$> embedded (inject @f @all <$> liftDecodeMessage @f decodeMessage num)) : generate (Proxy @fs) decodeMessage + + -- Common -- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable). From 07cd7233c3ecce9517e0e952d85a9d8da3a1bdfa Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 25 May 2018 12:38:06 -0400 Subject: [PATCH 017/159] Add liftDotProto for Sums over lists of functors with Message1 and NameOf1 instances --- src/Data/Syntax.hs | 40 +++++++++++++++++++++++++++++----------- 1 file changed, 29 insertions(+), 11 deletions(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 34dd36a5b..a0e6a8328 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, KindSignatures #-} +{-# LANGUAGE AllowAmbiguousTypes, DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, KindSignatures, RankNTypes, ConstraintKinds #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack module Data.Syntax where @@ -19,7 +19,10 @@ import qualified Data.Error as Error import Proto3.Suite.Class import Proto3.Wire.Decode import Proto3.Wire.Types - +import GHC.Types (Constraint) +import GHC.TypeLits +import qualified Proto3.Suite.DotProto as Proto +import Data.Char (toLower) -- Combinators -- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children. @@ -100,23 +103,38 @@ infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack, -> m (Sum fs (Term (Sum fs) a)) infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right -instance (Apply Message1 fs) => Message1 (Sum fs) where +instance (Apply Message1 fs, Generate Message1 fs fs, Generate NameOf1 fs fs) => Message1 (Sum fs) where liftEncodeMessage encodeMessage num fs = apply @Message1 (liftEncodeMessage encodeMessage num) fs liftDecodeMessage decodeMessage num = oneof undefined listOfParsers where listOfParsers = - zipWith (\i generator -> (FieldNumber i, generator (FieldNumber i))) [1..] (generate @fs @fs (Proxy @fs) decodeMessage) - liftDotProto dotProto _ fs = apply @Message1 (liftDotProto dotProto (Proxy @fs)) fs + -- zipWith (\i generator -> (FieldNumber i, generator (FieldNumber i))) [1..] (generate @fs @fs (Proxy @fs) decodeMessage) + generate @Message1 @fs @fs (\ (proxy :: proxy f) i -> let num = FieldNumber (fromInteger (succ i)) in [(num, fromJust <$> embedded (inject @f @fs <$> liftDecodeMessage decodeMessage num))]) + liftDotProto dotProto _ = + [Proto.DotProtoMessageOneOf (Proto.Single "syntax") (generate @NameOf1 @fs @fs (\ (proxy :: proxy f) i -> + let + num = FieldNumber (fromInteger (succ i)) + fieldType = Proto.Prim (Proto.Named . Proto.Single $ nameOf1 (Proxy @f)) + fieldName = Proto.Single (camelCase $ nameOf1 (Proxy @f)) + camelCase (x : xs) = toLower x : xs + camelCase [] = [] + in + [ Proto.DotProtoField num fieldType fieldName [] Nothing ]))] -class Generate (all :: [* -> *]) (fs :: [* -> *]) where - generate :: proxy fs -> (FieldNumber -> Parser RawMessage a) -> [FieldNumber -> Parser RawField (Sum all a)] +class NameOf1 (f :: * -> *) where + nameOf1 :: proxy f -> String -instance Generate all '[] where - generate _ _ = [] +instance (Generic1 f, Rep1 f ~ D1 c f, Datatype c) => NameOf1 f where + nameOf1 _ = datatypeName (undefined :: t c f a) -instance (Element f all, Generate all fs, Message1 f) => Generate all (f ': fs) where - generate _ decodeMessage = (\ num -> fromJust <$> embedded (inject @f @all <$> liftDecodeMessage @f decodeMessage num)) : generate (Proxy @fs) decodeMessage +class Generate (c :: (* -> *) -> Constraint) (all :: [* -> *]) (fs :: [* -> *]) where + generate :: Monoid b => (forall f proxy. (Element f all, c f) => proxy f -> Integer -> b) -> b +instance Generate c all '[] where + generate _ = mempty + +instance (Element f all, c f, Generate c all fs) => Generate c all (f ': fs) where + generate each = (each (Proxy @f) (natVal (Proxy @(ElemIndex f all)))) `mappend` generate @c @all @fs each -- Common From a921d5a279e06e3c554586bdb9a706b70db1a06e Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 25 May 2018 12:38:15 -0400 Subject: [PATCH 018/159] ++fastsum --- vendor/fastsum | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/fastsum b/vendor/fastsum index 2310af6de..dbeff0af5 160000 --- a/vendor/fastsum +++ b/vendor/fastsum @@ -1 +1 @@ -Subproject commit 2310af6de3d3c337d671cdf9fe3e007990fdb1e4 +Subproject commit dbeff0af57fcea85bca07ff5a8149301dd3b084c From 9a7d9a4abf273af803ad3b05b5a70c7b5ce43260 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 25 May 2018 12:39:22 -0400 Subject: [PATCH 019/159] ++proto3-suite --- vendor/proto3-suite | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/proto3-suite b/vendor/proto3-suite index 06be7e57e..f4f7b48af 160000 --- a/vendor/proto3-suite +++ b/vendor/proto3-suite @@ -1 +1 @@ -Subproject commit 06be7e57e881e919382096098688e15debb1165e +Subproject commit f4f7b48af99b754bfdb62288a9de4da6fac2ca30 From 1e5899dfa86a223bcde7ccae28951ae48625851d Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 25 May 2018 18:28:12 -0400 Subject: [PATCH 020/159] Replace NameOf1 with GenericNamed --- src/Data/Syntax.hs | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index a0e6a8328..ac303fb02 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -103,7 +103,7 @@ infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack, -> m (Sum fs (Term (Sum fs) a)) infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right -instance (Apply Message1 fs, Generate Message1 fs fs, Generate NameOf1 fs fs) => Message1 (Sum fs) where +instance (Apply Message1 fs, Generate Message1 fs fs, Generate GenericNamed fs fs) => Message1 (Sum fs) where liftEncodeMessage encodeMessage num fs = apply @Message1 (liftEncodeMessage encodeMessage num) fs liftDecodeMessage decodeMessage num = oneof undefined listOfParsers where @@ -111,22 +111,16 @@ instance (Apply Message1 fs, Generate Message1 fs fs, Generate NameOf1 fs fs) => -- zipWith (\i generator -> (FieldNumber i, generator (FieldNumber i))) [1..] (generate @fs @fs (Proxy @fs) decodeMessage) generate @Message1 @fs @fs (\ (proxy :: proxy f) i -> let num = FieldNumber (fromInteger (succ i)) in [(num, fromJust <$> embedded (inject @f @fs <$> liftDecodeMessage decodeMessage num))]) liftDotProto dotProto _ = - [Proto.DotProtoMessageOneOf (Proto.Single "syntax") (generate @NameOf1 @fs @fs (\ (proxy :: proxy f) i -> + [Proto.DotProtoMessageOneOf (Proto.Single "syntax") (generate @GenericNamed @fs @fs (\ (proxy :: proxy f) i -> let num = FieldNumber (fromInteger (succ i)) - fieldType = Proto.Prim (Proto.Named . Proto.Single $ nameOf1 (Proxy @f)) - fieldName = Proto.Single (camelCase $ nameOf1 (Proxy @f)) + fieldType = Proto.Prim (Proto.Named . Proto.Single $ genericNameOf (Proxy @f)) + fieldName = Proto.Single (camelCase $ genericNameOf (Proxy @f)) camelCase (x : xs) = toLower x : xs camelCase [] = [] in [ Proto.DotProtoField num fieldType fieldName [] Nothing ]))] -class NameOf1 (f :: * -> *) where - nameOf1 :: proxy f -> String - -instance (Generic1 f, Rep1 f ~ D1 c f, Datatype c) => NameOf1 f where - nameOf1 _ = datatypeName (undefined :: t c f a) - class Generate (c :: (* -> *) -> Constraint) (all :: [* -> *]) (fs :: [* -> *]) where generate :: Monoid b => (forall f proxy. (Element f all, c f) => proxy f -> Integer -> b) -> b From 8c933df67dacecd5b4c4f5455c08bbfad7a4d638 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 25 May 2018 18:28:45 -0400 Subject: [PATCH 021/159] ++proto3-suite --- vendor/proto3-suite | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/proto3-suite b/vendor/proto3-suite index f4f7b48af..dcf366d19 160000 --- a/vendor/proto3-suite +++ b/vendor/proto3-suite @@ -1 +1 @@ -Subproject commit f4f7b48af99b754bfdb62288a9de4da6fac2ca30 +Subproject commit dcf366d1934953478d2629c66669bec19a0f6590 From 64a2f8100157f22f0327c263c12b619893f44e5f Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 25 May 2018 18:59:58 -0400 Subject: [PATCH 022/159] Try to derive Message1 for Array --- src/Data/Syntax/Literal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 21888e014..f7c83045e 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -190,7 +190,7 @@ instance Evaluatable Regex -- Collections newtype Array a = Array { arrayElements :: [a] } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message1) instance Eq1 Array where liftEq = genericLiftEq instance Ord1 Array where liftCompare = genericLiftCompare From 2410589fb6fef5aa32f13fd7dcff0726f7e9f986 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 25 May 2018 19:00:37 -0400 Subject: [PATCH 023/159] ++proto3-suite --- vendor/proto3-suite | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/proto3-suite b/vendor/proto3-suite index dcf366d19..727228855 160000 --- a/vendor/proto3-suite +++ b/vendor/proto3-suite @@ -1 +1 @@ -Subproject commit dcf366d1934953478d2629c66669bec19a0f6590 +Subproject commit 727228855d409af9be440e52cc3dc2a4e7ae4b6f From dec43883abaa7016d09c2cf39d6bfd93774e745d Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 29 May 2018 14:27:29 -0400 Subject: [PATCH 024/159] Update Data.Term instance for dotProto --- src/Data/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Term.hs b/src/Data/Term.hs index cc12d86c9..f1c077763 100644 --- a/src/Data/Term.hs +++ b/src/Data/Term.hs @@ -82,7 +82,7 @@ instance (Show1 f, Show a) => Show (Term f a) where instance (Message1 f) => Message (Term f ()) where encodeMessage num (Term (In _ f)) = liftEncodeMessage encodeMessage num f decodeMessage num = termIn () <$> liftDecodeMessage decodeMessage num - dotProto _ = liftDotProto (dotProto @(Term f ())) (Proxy @f) + dotProto _ = liftDotProto (dotProto @(Term f ())) (Proxy @(f (Term f ()))) instance Ord1 f => Ord1 (Term f) where liftCompare comp = go where go t1 t2 = liftCompare2 comp go (unTerm t1) (unTerm t2) From e7f017b5b595ee4e5ea17be0025d734274613e28 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 29 May 2018 14:28:15 -0400 Subject: [PATCH 025/159] Remove old definitions of Identity and Product --- src/Data/Syntax.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index ac303fb02..d34c2a92a 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -192,12 +192,6 @@ instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty" instance Evaluatable Empty where eval _ = Rval <$> unit -data Identity a = Identity a - deriving (Generic1, Message1) -data Product a = Product a a - deriving (Generic1, Message1) - - -- | Syntax representing a parsing or assignment error. data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) From e6ad8fc4393b56d384db9b7c37cdcfb9946e70f0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 29 May 2018 15:12:16 -0400 Subject: [PATCH 026/159] Add Message1 instances for JSON types --- src/Data/Syntax/Literal.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index f7c83045e..aa2a35790 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -15,7 +15,7 @@ import Text.Read (readMaybe) -- Boolean newtype Boolean a = Boolean Bool - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message1) true :: Boolean a true = Boolean True @@ -58,7 +58,7 @@ instance ToJSONFields1 Data.Syntax.Literal.Integer where -- | A literal float of unspecified width. newtype Float a = Float { floatContent :: ByteString } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message1) instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare @@ -134,7 +134,7 @@ instance ToJSONFields1 InterpolationElement -- | A sequence of textual contents within a string literal. newtype TextElement a = TextElement { textElementContent :: ByteString } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message1) instance Eq1 TextElement where liftEq = genericLiftEq instance Ord1 TextElement where liftCompare = genericLiftCompare @@ -147,7 +147,7 @@ instance Evaluatable TextElement where eval (TextElement x) = Rval <$> string x data Null a = Null - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message1) instance Eq1 Null where liftEq = genericLiftEq instance Ord1 Null where liftCompare = genericLiftCompare @@ -202,7 +202,7 @@ instance Evaluatable Array where eval (Array a) = Rval <$> (array =<< traverse subtermValue a) newtype Hash a = Hash { hashElements :: [a] } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message1) instance Eq1 Hash where liftEq = genericLiftEq instance Ord1 Hash where liftCompare = genericLiftCompare @@ -214,7 +214,7 @@ instance Evaluatable Hash where eval t = Rval <$> (traverse (subtermValue >=> asPair) (hashElements t) >>= hash) data KeyValue a = KeyValue { key :: !a, value :: !a } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message) + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message1) instance Eq1 KeyValue where liftEq = genericLiftEq instance Ord1 KeyValue where liftCompare = genericLiftCompare From 79b1c8e1a61ce1e0a94bc6d340dbf650b0ae2fd0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 29 May 2018 15:12:25 -0400 Subject: [PATCH 027/159] Add a Named instance for Term --- src/Data/Term.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Term.hs b/src/Data/Term.hs index f1c077763..e460be6e3 100644 --- a/src/Data/Term.hs +++ b/src/Data/Term.hs @@ -84,6 +84,9 @@ instance (Message1 f) => Message (Term f ()) where decodeMessage num = termIn () <$> liftDecodeMessage decodeMessage num dotProto _ = liftDotProto (dotProto @(Term f ())) (Proxy @(f (Term f ()))) +instance Named (Term f ()) where + nameOf _ = "Term" + instance Ord1 f => Ord1 (Term f) where liftCompare comp = go where go t1 t2 = liftCompare2 comp go (unTerm t1) (unTerm t2) From 634af7e88654c922ab0ce7fd8dff1dbf0ddc33ca Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 29 May 2018 15:13:57 -0400 Subject: [PATCH 028/159] ++proto3-suite --- vendor/proto3-suite | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/proto3-suite b/vendor/proto3-suite index 727228855..ec16a218e 160000 --- a/vendor/proto3-suite +++ b/vendor/proto3-suite @@ -1 +1 @@ -Subproject commit 727228855d409af9be440e52cc3dc2a4e7ae4b6f +Subproject commit ec16a218e27f59ae65a66c0162931d4e51f57d18 From e190a66b0204af7c17cd9cb77faf39a1873ec498 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 29 May 2018 16:30:56 -0400 Subject: [PATCH 029/159] import semantic-types in semantic.proto --- semantic.proto | 1 + 1 file changed, 1 insertion(+) diff --git a/semantic.proto b/semantic.proto index 605c78a21..406d5b067 100644 --- a/semantic.proto +++ b/semantic.proto @@ -1,4 +1,5 @@ syntax = "proto3"; +import "semantic-types.proto"; package semantic; message HealthCheckRequest { From d2ca8c7f29402c5534ff275a276edfc13d285b7d Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 29 May 2018 16:32:53 -0400 Subject: [PATCH 030/159] Add field name to Boolean --- src/Data/Syntax/Literal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index aa2a35790..3e0871cd7 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -14,7 +14,7 @@ import Text.Read (readMaybe) -- Boolean -newtype Boolean a = Boolean Bool +newtype Boolean a = Boolean { booleanContent :: Bool } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Generic, Named, Message1) true :: Boolean a From 8eca025beb019624a2dab7cbbb0abfc74bae3722 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:01:50 -0400 Subject: [PATCH 031/159] Stub in an Env effect. --- src/Control/Abstract/Environment.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index a2306cabf..58502ded1 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -11,6 +11,7 @@ module Control.Abstract.Environment , localEnv , localize , lookupEnv +, Env(..) , EnvironmentError(..) , freeVariableError , runEnvironmentError @@ -70,6 +71,10 @@ lookupEnv :: (Member (Reader (Environment location)) effects, Member (State (Env lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment) +data Env location return where + Lookup :: Name -> Env location (Maybe location) + + -- | Errors involving the environment. data EnvironmentError location return where FreeVariable :: Name -> EnvironmentError location location From 0d226bb72d7c7fb9fa395523f59811b8b77f2fe1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:02:42 -0400 Subject: [PATCH 032/159] Add a handler for Env. --- src/Control/Abstract/Environment.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 58502ded1..0c809dd9c 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -12,6 +12,7 @@ module Control.Abstract.Environment , localize , lookupEnv , Env(..) +, runEnv , EnvironmentError(..) , freeVariableError , runEnvironmentError @@ -75,6 +76,10 @@ data Env location return where Lookup :: Name -> Env location (Maybe location) +runEnv :: (Member (Reader (Environment location)) effects, Member (State (Environment location)) effects) => Evaluator location value (Env location ': effects) a -> Evaluator location value effects a +runEnv = interpret (\ (Lookup name) -> (<|>) <$> (fmap unAddress . Env.lookup name <$> getEnv) <*> (fmap unAddress . Env.lookup name <$> defaultEnvironment)) + + -- | Errors involving the environment. data EnvironmentError location return where FreeVariable :: Name -> EnvironmentError location location From 6535eebf0a32a2a5a2ddd577b68ee416e69ec4a1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:02:55 -0400 Subject: [PATCH 033/159] Add a reinterpreting handler for Env. --- src/Control/Abstract/Environment.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 0c809dd9c..bb407605a 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -13,6 +13,7 @@ module Control.Abstract.Environment , lookupEnv , Env(..) , runEnv +, reinterpretEnv , EnvironmentError(..) , freeVariableError , runEnvironmentError @@ -79,6 +80,9 @@ data Env location return where runEnv :: (Member (Reader (Environment location)) effects, Member (State (Environment location)) effects) => Evaluator location value (Env location ': effects) a -> Evaluator location value effects a runEnv = interpret (\ (Lookup name) -> (<|>) <$> (fmap unAddress . Env.lookup name <$> getEnv) <*> (fmap unAddress . Env.lookup name <$> defaultEnvironment)) +reinterpretEnv :: Evaluator location value (Env location ': effects) a -> Evaluator location value (Reader (Environment location) ': State (Environment location) ': effects) a +reinterpretEnv = reinterpret2 (\ (Lookup name) -> (<|>) <$> (fmap unAddress . Env.lookup name <$> getEnv) <*> (fmap unAddress . Env.lookup name <$> defaultEnvironment)) + -- | Errors involving the environment. data EnvironmentError location return where From afc99742c619e2cbc06ce1e39e66d371a79c0fbe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:03:22 -0400 Subject: [PATCH 034/159] lookupEnv is an Env request. --- src/Control/Abstract/Environment.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index bb407605a..71a9f4521 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -69,8 +69,8 @@ localize :: Member (State (Environment location)) effects => Evaluator location localize = localEnv id -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. -lookupEnv :: (Member (Reader (Environment location)) effects, Member (State (Environment location)) effects) => Name -> Evaluator location value effects (Maybe (Address location value)) -lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment) +lookupEnv :: Member (Env location) effects => Name -> Evaluator location value effects (Maybe (Address location value)) +lookupEnv name = fmap Address <$> send (Lookup name) data Env location return where From 576dba9b0c4ed1ed869e2192747544b8340bd8d4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:04:24 -0400 Subject: [PATCH 035/159] Use Env effects in Heap. --- src/Control/Abstract/Heap.hs | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 05eec53e0..def51bb2a 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -64,8 +64,7 @@ assign address = modifyHeap . heapInsert address -- | Look up or allocate an address for a 'Name'. lookupOrAlloc :: ( Member (Allocator location value) effects - , Member (Reader (Environment location)) effects - , Member (State (Environment location)) effects + , Member (Env location) effects ) => Name -> Evaluator location value effects (Address location value) @@ -73,8 +72,7 @@ lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure letrec :: ( Member (Allocator location value) effects - , Member (Reader (Environment location)) effects - , Member (State (Environment location)) effects + , Member (Env location) effects , Member (State (Heap location (Cell location) value)) effects , Ord location , Reducer value (Cell location value) @@ -90,8 +88,7 @@ letrec name body = do -- Lookup/alloc a name passing the address to a body evaluated in a new local environment. letrec' :: ( Member (Allocator location value) effects - , Member (Reader (Environment location)) effects - , Member (State (Environment location)) effects + , Member (Env location) effects ) => Name -> (Address location value -> Evaluator location value effects value) @@ -104,9 +101,8 @@ letrec' name body = do -- | Look up and dereference the given 'Name', throwing an exception for free variables. variable :: ( Member (Allocator location value) effects - , Member (Reader (Environment location)) effects + , Member (Env location) effects , Member (Resumable (EnvironmentError location)) effects - , Member (State (Environment location)) effects ) => Name -> Evaluator location value effects value From 9b88dcbaf717f11807226714c827d376a4be53e6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:16:17 -0400 Subject: [PATCH 036/159] =?UTF-8?q?Don=E2=80=99t=20use=20Address=20in=20th?= =?UTF-8?q?e=20data,=20only=20in=20the=20effects.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Environment.hs | 4 ++-- src/Control/Abstract/Exports.hs | 2 +- src/Data/Abstract/Environment.hs | 17 ++++++++--------- src/Data/Abstract/Exports.hs | 7 +++---- src/Data/Abstract/Heap.hs | 2 +- src/Data/Abstract/Live.hs | 23 +++++++++++------------ 6 files changed, 26 insertions(+), 29 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 71a9f4521..f207e57ae 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -78,10 +78,10 @@ data Env location return where runEnv :: (Member (Reader (Environment location)) effects, Member (State (Environment location)) effects) => Evaluator location value (Env location ': effects) a -> Evaluator location value effects a -runEnv = interpret (\ (Lookup name) -> (<|>) <$> (fmap unAddress . Env.lookup name <$> getEnv) <*> (fmap unAddress . Env.lookup name <$> defaultEnvironment)) +runEnv = interpret (\ (Lookup name) -> (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)) reinterpretEnv :: Evaluator location value (Env location ': effects) a -> Evaluator location value (Reader (Environment location) ': State (Environment location) ': effects) a -reinterpretEnv = reinterpret2 (\ (Lookup name) -> (<|>) <$> (fmap unAddress . Env.lookup name <$> getEnv) <*> (fmap unAddress . Env.lookup name <$> defaultEnvironment)) +reinterpretEnv = reinterpret2 (\ (Lookup name) -> (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)) -- | Errors involving the environment. diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs index e31e8d376..b9c8a307d 100644 --- a/src/Control/Abstract/Exports.hs +++ b/src/Control/Abstract/Exports.hs @@ -26,7 +26,7 @@ modifyExports = modify' -- | Add an export to the global export state. addExport :: Member (State (Exports location)) effects => Name -> Name -> Maybe (Address location value) -> Evaluator location value effects () -addExport name alias = modifyExports . insert name alias +addExport name alias = modifyExports . insert name alias . fmap unAddress -- | Sets the global export state for the lifetime of the given action. withExports :: Member (State (Exports location)) effects => Exports location -> Evaluator location value effects a -> Evaluator location value effects a diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 924df9d4a..19a9d8858 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -18,7 +18,6 @@ module Data.Abstract.Environment , roots ) where -import Data.Abstract.Address import Data.Abstract.Live import Data.Abstract.Name import Data.Align @@ -72,22 +71,22 @@ mergeNewer (Environment a) (Environment b) = -- -- >>> pairs shadowed -- [("foo",Precise 1)] -pairs :: Environment location -> [(Name, Address location value)] -pairs = map (second Address) . Map.toList . fold . unEnvironment +pairs :: Environment location -> [(Name, location)] +pairs = Map.toList . fold . unEnvironment -unpairs :: [(Name, Address location value)] -> Environment location -unpairs = Environment . pure . Map.fromList . map (second unAddress) +unpairs :: [(Name, location)] -> Environment location +unpairs = Environment . pure . Map.fromList -- | Lookup a 'Name' in the environment. -- -- >>> lookup (name "foo") shadowed -- Just (Precise 1) -lookup :: Name -> Environment location -> Maybe (Address location value) -lookup k = fmap Address . foldMapA (Map.lookup k) . unEnvironment +lookup :: Name -> Environment location -> Maybe location +lookup k = foldMapA (Map.lookup k) . unEnvironment -- | Insert a 'Name' in the environment. -insert :: Name -> Address location value -> Environment location -> Environment location -insert name (Address value) (Environment (a :| as)) = Environment (Map.insert name value a :| as) +insert :: Name -> location -> Environment location -> Environment location +insert name address (Environment (a :| as)) = Environment (Map.insert name address a :| as) -- | Remove a 'Name' from the environment. -- diff --git a/src/Data/Abstract/Exports.hs b/src/Data/Abstract/Exports.hs index 4c71e508d..bc31a099d 100644 --- a/src/Data/Abstract/Exports.hs +++ b/src/Data/Abstract/Exports.hs @@ -9,7 +9,6 @@ module Data.Abstract.Exports import Prelude hiding (null) import Prologue hiding (null) -import Data.Abstract.Address import Data.Abstract.Environment (Environment, unpairs) import Data.Abstract.Name import qualified Data.Map as Map @@ -23,10 +22,10 @@ null :: Exports location -> Bool null = Map.null . unExports toEnvironment :: Exports location -> Environment location -toEnvironment exports = unpairs (mapMaybe (traverse (fmap Address)) (toList (unExports exports))) +toEnvironment exports = unpairs (mapMaybe sequenceA (toList (unExports exports))) -insert :: Name -> Name -> Maybe (Address location value) -> Exports location -> Exports location -insert name alias address = Exports . Map.insert name (alias, unAddress <$> address) . unExports +insert :: Name -> Name -> Maybe location -> Exports location -> Exports location +insert name alias address = Exports . Map.insert name (alias, address) . unExports -- TODO: Should we filter for duplicates here? aliases :: Exports location -> [(Name, Name)] diff --git a/src/Data/Abstract/Heap.hs b/src/Data/Abstract/Heap.hs index a383a5e42..0a878d03b 100644 --- a/src/Data/Abstract/Heap.hs +++ b/src/Data/Abstract/Heap.hs @@ -34,7 +34,7 @@ heapSize = Monoidal.size . unHeap -- | Restrict a 'Heap' to only those 'Address'es in the given 'Live' set (in essence garbage collecting the rest). heapRestrict :: Ord location => Heap location cell value -> Live location value -> Heap location cell value -heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> Address address `liveMember` roots) m) +heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> address `liveMember` roots) m) instance (Ord location, Reducer value (cell value)) => Reducer (Address location value, value) (Heap location cell value) where diff --git a/src/Data/Abstract/Live.hs b/src/Data/Abstract/Live.hs index 930350395..345d9f873 100644 --- a/src/Data/Abstract/Live.hs +++ b/src/Data/Abstract/Live.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-} module Data.Abstract.Live where -import Data.Abstract.Address import Data.Semilattice.Lower import Data.Set as Set import Prologue @@ -10,32 +9,32 @@ import Prologue newtype Live location value = Live { unLive :: Set location } deriving (Eq, Lower, Monoid, Ord, Semigroup) -fromAddresses :: (Foldable t, Ord location) => t (Address location value) -> Live location value +fromAddresses :: (Foldable t, Ord location) => t location -> Live location value fromAddresses = Prologue.foldr liveInsert lowerBound -- | Construct a 'Live' set containing only the given address. -liveSingleton :: Address location value -> Live location value -liveSingleton = Live . Set.singleton . unAddress +liveSingleton :: location -> Live location value +liveSingleton = Live . Set.singleton -- | Insert an address into a 'Live' set. -liveInsert :: Ord location => Address location value -> Live location value -> Live location value -liveInsert addr = Live . Set.insert (unAddress addr) . unLive +liveInsert :: Ord location => location -> Live location value -> Live location value +liveInsert addr = Live . Set.insert addr . unLive -- | Delete an address from a 'Live' set, if present. -liveDelete :: Ord location => Address location value -> Live location value -> Live location value -liveDelete addr = Live . Set.delete (unAddress addr) . unLive +liveDelete :: Ord location => location -> Live location value -> Live location value +liveDelete addr = Live . Set.delete addr . unLive -- | Compute the (asymmetric) difference of two 'Live' sets, i.e. delete every element of the second set from the first set. liveDifference :: Ord location => Live location value -> Live location value -> Live location value liveDifference = fmap Live . (Set.difference `on` unLive) -- | Test whether an 'Address' is in a 'Live' set. -liveMember :: Ord location => Address location value -> Live location value -> Bool -liveMember addr = Set.member (unAddress addr) . unLive +liveMember :: Ord location => location -> Live location value -> Bool +liveMember addr = Set.member addr . unLive -- | Decompose a 'Live' set into a pair of one member address and the remaining set, or 'Nothing' if empty. -liveSplit :: Live location value -> Maybe (Address location value, Live location value) -liveSplit = fmap (bimap Address Live) . Set.minView . unLive +liveSplit :: Live location value -> Maybe (location, Live location value) +liveSplit = fmap (fmap Live) . Set.minView . unLive instance Show location => Show (Live location value) where From aad72ca048f12aac35d022a3cc25082606091d0a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:23:17 -0400 Subject: [PATCH 037/159] Missed a couple. --- src/Control/Abstract/Heap.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index def51bb2a..092a91b45 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -82,7 +82,7 @@ letrec :: ( Member (Allocator location value) effects -> Evaluator location value effects (value, Address location value) letrec name body = do addr <- lookupOrAlloc name - v <- localEnv (insert name addr) body + v <- localEnv (insert name (unAddress addr)) body assign addr v pure (v, addr) @@ -96,7 +96,7 @@ letrec' :: ( Member (Allocator location value) effects letrec' name body = do addr <- lookupOrAlloc name v <- localEnv id (body addr) - v <$ modifyEnv (insert name addr) + v <$ modifyEnv (insert name (unAddress addr)) -- | Look up and dereference the given 'Name', throwing an exception for free variables. From 35a305fa76fe5c5a87d678c9e96b9324a7b137e3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:25:00 -0400 Subject: [PATCH 038/159] :fire: fullEnvironment. --- src/Control/Abstract/Environment.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index f207e57ae..cc6a13644 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -7,7 +7,6 @@ module Control.Abstract.Environment , withEnv , defaultEnvironment , withDefaultEnvironment -, fullEnvironment , localEnv , localize , lookupEnv @@ -52,11 +51,6 @@ defaultEnvironment = ask withDefaultEnvironment :: Member (Reader (Environment location)) effects => Environment location -> Evaluator location value effects a -> Evaluator location value effects a withDefaultEnvironment e = local (const e) --- | Obtain an environment that is the composition of the current and default environments. --- Useful for debugging. -fullEnvironment :: (Member (Reader (Environment location)) effects, Member (State (Environment location)) effects) => Evaluator location value effects (Environment location) -fullEnvironment = mergeEnvs <$> getEnv <*> defaultEnvironment - -- | Run an action with a locally-modified environment. localEnv :: Member (State (Environment location)) effects => (Environment location -> Environment location) -> Evaluator location value effects a -> Evaluator location value effects a localEnv f a = do From 2f16ed9585add87772ea29642f23d10d7a33c79e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:28:02 -0400 Subject: [PATCH 039/159] defaultEnvironment is implementation detail. --- src/Control/Abstract/Environment.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index cc6a13644..3be4c214f 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -5,7 +5,6 @@ module Control.Abstract.Environment , putEnv , modifyEnv , withEnv -, defaultEnvironment , withDefaultEnvironment , localEnv , localize @@ -42,10 +41,6 @@ withEnv :: Member (State (Environment location)) effects => Environment location withEnv = localState . const --- | Retrieve the default environment. -defaultEnvironment :: Member (Reader (Environment location)) effects => Evaluator location value effects (Environment location) -defaultEnvironment = ask - -- | Set the default environment for the lifetime of an action. -- Usually only invoked in a top-level evaluation function. withDefaultEnvironment :: Member (Reader (Environment location)) effects => Environment location -> Evaluator location value effects a -> Evaluator location value effects a @@ -78,6 +73,11 @@ reinterpretEnv :: Evaluator location value (Env location ': effects) a -> Evalua reinterpretEnv = reinterpret2 (\ (Lookup name) -> (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)) +-- | Retrieve the default environment. +defaultEnvironment :: Member (Reader (Environment location)) effects => Evaluator location value effects (Environment location) +defaultEnvironment = ask + + -- | Errors involving the environment. data EnvironmentError location return where FreeVariable :: Name -> EnvironmentError location location From 78c32db27129f1a2618dc239811af57f95be9b31 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:31:12 -0400 Subject: [PATCH 040/159] Close over the default environment. --- src/Control/Abstract/Environment.hs | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 3be4c214f..fc1422f7a 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -66,16 +66,11 @@ data Env location return where Lookup :: Name -> Env location (Maybe location) -runEnv :: (Member (Reader (Environment location)) effects, Member (State (Environment location)) effects) => Evaluator location value (Env location ': effects) a -> Evaluator location value effects a -runEnv = interpret (\ (Lookup name) -> (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)) +runEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value effects a +runEnv defaultEnvironment = interpret (\ (Lookup name) -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv) -reinterpretEnv :: Evaluator location value (Env location ': effects) a -> Evaluator location value (Reader (Environment location) ': State (Environment location) ': effects) a -reinterpretEnv = reinterpret2 (\ (Lookup name) -> (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)) - - --- | Retrieve the default environment. -defaultEnvironment :: Member (Reader (Environment location)) effects => Evaluator location value effects (Environment location) -defaultEnvironment = ask +reinterpretEnv :: Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value (State (Environment location) ': effects) a +reinterpretEnv defaultEnvironment = reinterpret (\ (Lookup name) -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv) -- | Errors involving the environment. From d2e9974a0cd1b674eae790a72aceefbfe9898777 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:31:56 -0400 Subject: [PATCH 041/159] :fire: withDefaultEnvironment. --- src/Control/Abstract/Environment.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index fc1422f7a..dd5cf1683 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -5,7 +5,6 @@ module Control.Abstract.Environment , putEnv , modifyEnv , withEnv -, withDefaultEnvironment , localEnv , localize , lookupEnv @@ -41,11 +40,6 @@ withEnv :: Member (State (Environment location)) effects => Environment location withEnv = localState . const --- | Set the default environment for the lifetime of an action. --- Usually only invoked in a top-level evaluation function. -withDefaultEnvironment :: Member (Reader (Environment location)) effects => Environment location -> Evaluator location value effects a -> Evaluator location value effects a -withDefaultEnvironment e = local (const e) - -- | Run an action with a locally-modified environment. localEnv :: Member (State (Environment location)) effects => (Environment location -> Environment location) -> Evaluator location value effects a -> Evaluator location value effects a localEnv f a = do From 71dba01c1db413ce7ad07d074e03fc79343f469f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:34:12 -0400 Subject: [PATCH 042/159] =?UTF-8?q?Don=E2=80=99t=20use=20localize.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 893da6b67..d9733e3e6 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -167,7 +167,7 @@ forLoop :: ( AbstractValue location value effects -> Evaluator location value effects value -- ^ Body -> Evaluator location value effects value forLoop initial cond step body = - localize (initial *> while cond (body *> step)) + localEnv id (initial *> while cond (body *> step)) -- | The fundamental looping primitive, built on top of 'ifthenelse'. while :: AbstractValue location value effects From 6f89e256280362d693cd75e3e65c85787b963bc7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:34:26 -0400 Subject: [PATCH 043/159] :fire: localize. --- src/Control/Abstract/Environment.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index dd5cf1683..f4a884f45 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -6,7 +6,6 @@ module Control.Abstract.Environment , modifyEnv , withEnv , localEnv -, localize , lookupEnv , Env(..) , runEnv @@ -47,10 +46,6 @@ localEnv f a = do result <- a result <$ modifyEnv Env.pop --- | Run a computation in a new local environment. -localize :: Member (State (Environment location)) effects => Evaluator location value effects a -> Evaluator location value effects a -localize = localEnv id - -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. lookupEnv :: Member (Env location) effects => Name -> Evaluator location value effects (Maybe (Address location value)) lookupEnv name = fmap Address <$> send (Lookup name) From a1d05dcd3d94e1848668642750fcb5e9ecf06871 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 18:41:07 -0400 Subject: [PATCH 044/159] Rename Env.bind to Env.intersect. --- src/Data/Abstract/Environment.hs | 6 +++--- src/Data/Abstract/Value.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 19a9d8858..6cc11f42a 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -1,7 +1,6 @@ module Data.Abstract.Environment ( Environment(..) , addresses - , bind , delete , head , emptyEnv @@ -10,6 +9,7 @@ module Data.Abstract.Environment , insert , lookup , names + , intersect , overwrite , pairs , unpairs @@ -99,8 +99,8 @@ trim :: Environment location -> Environment location trim (Environment (a :| as)) = Environment (a :| filtered) where filtered = filter (not . Map.null) as -bind :: Foldable t => t Name -> Environment location -> Environment location -bind names env = unpairs (mapMaybe lookupName (toList names)) +intersect :: Foldable t => t Name -> Environment location -> Environment location +intersect names env = unpairs (mapMaybe lookupName (toList names)) where lookupName name = (,) name <$> lookup name env diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index b15db00f7..430d88cee 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -72,7 +72,7 @@ instance ( Coercible body (Eff effects) packageInfo <- currentPackage moduleInfo <- currentModule i <- fresh - Closure packageInfo moduleInfo parameters (ClosureBody i (coerce (lowerEff body))) . Env.bind (foldr Set.delete freeVariables parameters) <$> getEnv + Closure packageInfo moduleInfo parameters (ClosureBody i (coerce (lowerEff body))) . Env.intersect (foldr Set.delete freeVariables parameters) <$> getEnv call op params = do case op of From 6b4d7db19262b9482314247329ca577a75b07767 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 18:43:10 -0400 Subject: [PATCH 045/159] Add a constructor to bind names. --- src/Control/Abstract/Environment.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index f4a884f45..1ec388b5c 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, RankNTypes, TypeOperators #-} +{-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeOperators #-} module Control.Abstract.Environment ( Environment , getEnv @@ -52,14 +52,19 @@ lookupEnv name = fmap Address <$> send (Lookup name) data Env location return where - Lookup :: Name -> Env location (Maybe location) + Lookup :: Name -> Env location (Maybe location) + Bind :: Name -> location -> Env location () runEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value effects a -runEnv defaultEnvironment = interpret (\ (Lookup name) -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv) +runEnv defaultEnvironment = interpret $ \case + Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv + Bind name addr -> modifyEnv (Env.insert name addr) reinterpretEnv :: Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value (State (Environment location) ': effects) a -reinterpretEnv defaultEnvironment = reinterpret (\ (Lookup name) -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv) +reinterpretEnv defaultEnvironment = reinterpret $ \case + Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv + Bind name addr -> modifyEnv (Env.insert name addr) -- | Errors involving the environment. From cebcfab528e51641ac06e638c56ba9ee64d31cc1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 18:47:32 -0400 Subject: [PATCH 046/159] Define a smart constructor to bind names to addresses. --- src/Control/Abstract/Environment.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 1ec388b5c..ce535d370 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -7,6 +7,7 @@ module Control.Abstract.Environment , withEnv , localEnv , lookupEnv +, bind , Env(..) , runEnv , reinterpretEnv @@ -50,6 +51,10 @@ localEnv f a = do lookupEnv :: Member (Env location) effects => Name -> Evaluator location value effects (Maybe (Address location value)) lookupEnv name = fmap Address <$> send (Lookup name) +-- | Bind a 'Name' to an 'Address' in the environment. +bind :: Member (Env location) effects => Name -> Address location value -> Evaluator location value effects () +bind name addr = send (Bind name (unAddress addr)) + data Env location return where Lookup :: Name -> Env location (Maybe location) From 39d2a568de5c6714f6c8c81e2cff1d9226c715b4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 18:48:45 -0400 Subject: [PATCH 047/159] =?UTF-8?q?Use=20bind=20wherever=20we=E2=80=99re?= =?UTF-8?q?=20inserting=20names=20manually.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Heap.hs | 2 +- src/Control/Abstract/Primitive.hs | 7 +++---- src/Data/Syntax/Declaration.hs | 10 ++++------ src/Data/Syntax/Statement.hs | 2 +- src/Language/TypeScript/Syntax.hs | 4 ++-- 5 files changed, 11 insertions(+), 14 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 092a91b45..9084315a5 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -96,7 +96,7 @@ letrec' :: ( Member (Allocator location value) effects letrec' name body = do addr <- lookupOrAlloc name v <- localEnv id (body addr) - v <$ modifyEnv (insert name (unAddress addr)) + v <$ bind name addr -- | Look up and dereference the given 'Name', throwing an exception for free variables. diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index f0b280bec..7b5fca148 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -15,9 +15,9 @@ import Prologue builtin :: ( HasCallStack , Member (Allocator location value) effects + , Member (Env location) effects , Member (Reader ModuleInfo) effects , Member (Reader Span) effects - , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) value)) effects , Ord location , Reducer value (Cell location value) @@ -28,7 +28,7 @@ builtin :: ( HasCallStack builtin s def = withCurrentCallStack callStack $ do let name' = name (pack ("__semantic_" <> s)) addr <- alloc name' - modifyEnv (insert name' addr) + bind name' addr def >>= assign addr lambda :: (AbstractFunction location value effects, Member Fresh effects) @@ -41,12 +41,11 @@ lambda body = do defineBuiltins :: ( AbstractValue location value effects , HasCallStack , Member (Allocator location value) effects + , Member (Env location) effects , Member Fresh effects - , Member (Reader (Environment location)) effects , Member (Reader ModuleInfo) effects , Member (Reader Span) effects , Member (Resumable (EnvironmentError location)) effects - , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) value)) effects , Member Trace effects , Ord location diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 7b3d618bb..67f0a3941 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -27,8 +27,7 @@ instance Evaluatable Function where eval Function{..} = do name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm functionName) (v, addr) <- letrec name (closure (paramNames functionParameters) (Set.fromList (freeVariables functionBody)) (subtermValue functionBody)) - modifyEnv (Env.insert name addr) - pure (Rval v) + Rval v <$ bind name addr where paramNames = foldMap (freeVariables . subterm) instance Declarations a => Declarations (Function a) where @@ -53,8 +52,7 @@ instance Evaluatable Method where eval Method{..} = do name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm methodName) (v, addr) <- letrec name (closure (paramNames methodParameters) (Set.fromList (freeVariables methodBody)) (subtermValue methodBody)) - modifyEnv (Env.insert name addr) - pure (Rval v) + Rval v <$ bind name addr where paramNames = foldMap (freeVariables . subterm) @@ -187,7 +185,7 @@ instance Evaluatable Class where void $ subtermValue classBody classEnv <- Env.head <$> getEnv klass name supers classEnv - Rval <$> (v <$ modifyEnv (Env.insert name addr)) + Rval v <$ bind name addr -- | A decorator in Python data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a } @@ -278,7 +276,7 @@ instance Evaluatable TypeAlias where v <- subtermValue typeAliasKind addr <- lookupOrAlloc name assign addr v - Rval <$> (modifyEnv (Env.insert name addr) $> v) + Rval v <$> bind name addr instance Declarations a => Declarations (TypeAlias a) where declaredName TypeAlias{..} = declaredName typeAliasIdentifier diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index aee3158db..e772d2153 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -119,7 +119,7 @@ instance Evaluatable Assignment where LvalLocal nam -> do addr <- lookupOrAlloc nam assign addr rhs - modifyEnv (Env.insert nam addr) + bind name addr LvalMember _ _ -> -- we don't yet support mutable object properties: pure () diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 8fa467554..cac08b9c5 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -272,7 +272,7 @@ instance Evaluatable DefaultExport where addr <- lookupOrAlloc name assign addr v addExport name name Nothing - void $ modifyEnv (Env.insert name addr) + bind name addr Nothing -> throwEvalError DefaultExportError pure (Rval unit) @@ -852,7 +852,7 @@ instance Evaluatable AbstractClass where void $ subtermValue classBody classEnv <- Env.head <$> getEnv klass name supers classEnv - Rval <$> (v <$ modifyEnv (Env.insert name addr)) + Rval v <$ bind name addr data JsxElement a = JsxElement { _jsxOpeningElement :: !a, _jsxElements :: ![a], _jsxClosingElement :: !a } From df1e39bc25f8954cf0958269405848a5ffef4c83 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 20:40:41 -0400 Subject: [PATCH 048/159] Add push/pop constructors. --- src/Control/Abstract/Environment.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index ce535d370..a5340f4e4 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -59,17 +59,23 @@ bind name addr = send (Bind name (unAddress addr)) data Env location return where Lookup :: Name -> Env location (Maybe location) Bind :: Name -> location -> Env location () + Push :: Env location () + Pop :: Env location () runEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value effects a runEnv defaultEnvironment = interpret $ \case Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv Bind name addr -> modifyEnv (Env.insert name addr) + Push -> modifyEnv Env.push + Pop -> modifyEnv Env.pop reinterpretEnv :: Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value (State (Environment location) ': effects) a reinterpretEnv defaultEnvironment = reinterpret $ \case Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv Bind name addr -> modifyEnv (Env.insert name addr) + Push -> modifyEnv Env.push + Pop -> modifyEnv Env.pop -- | Errors involving the environment. From 0ba8046f28481d1575394430017ee644fe6d49c0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 20:48:27 -0400 Subject: [PATCH 049/159] Define a helper to push a local scope. --- src/Control/Abstract/Environment.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index a5340f4e4..5e79bacde 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeOperators #-} +{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-} module Control.Abstract.Environment ( Environment , getEnv @@ -6,6 +6,7 @@ module Control.Abstract.Environment , modifyEnv , withEnv , localEnv +, locally , lookupEnv , bind , Env(..) @@ -19,7 +20,8 @@ module Control.Abstract.Environment import Control.Abstract.Evaluator import Data.Abstract.Address -import Data.Abstract.Environment as Env +import Data.Abstract.Environment (Environment) +import qualified Data.Abstract.Environment as Env import Data.Abstract.Name import Prologue @@ -47,6 +49,12 @@ localEnv f a = do result <- a result <$ modifyEnv Env.pop +locally :: forall location value effects a . Member (Env location) effects => Evaluator location value effects a -> Evaluator location value effects a +locally a = do + send (Push @location) + a' <- a + a' <$ send (Pop @location) + -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. lookupEnv :: Member (Env location) effects => Name -> Evaluator location value effects (Maybe (Address location value)) lookupEnv name = fmap Address <$> send (Lookup name) From 43f774e0c3d070b97e0c52587c26d088d7392733 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 20:49:53 -0400 Subject: [PATCH 050/159] Use locally in the Heap actions. --- src/Control/Abstract/Heap.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 9084315a5..c913f2969 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -24,7 +24,6 @@ import Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Monad.Effect.Internal import Data.Abstract.Address -import Data.Abstract.Environment import Data.Abstract.Heap import Data.Abstract.Name import Data.Semigroup.Reducer @@ -82,7 +81,9 @@ letrec :: ( Member (Allocator location value) effects -> Evaluator location value effects (value, Address location value) letrec name body = do addr <- lookupOrAlloc name - v <- localEnv (insert name (unAddress addr)) body + v <- locally $ do + bind name addr + body assign addr v pure (v, addr) @@ -95,7 +96,7 @@ letrec' :: ( Member (Allocator location value) effects -> Evaluator location value effects value letrec' name body = do addr <- lookupOrAlloc name - v <- localEnv id (body addr) + v <- locally (body addr) v <$ bind name addr From a878f85bdb6cdabc05a2f01e8e9aa6e36e69cc90 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 20:52:57 -0400 Subject: [PATCH 051/159] Hide an export. --- src/Control/Abstract.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract.hs b/src/Control/Abstract.hs index 681a3dd13..d33e384ff 100644 --- a/src/Control/Abstract.hs +++ b/src/Control/Abstract.hs @@ -5,7 +5,7 @@ module Control.Abstract import Control.Abstract.Addressable as X import Control.Abstract.Configuration as X import Control.Abstract.Context as X -import Control.Abstract.Environment as X +import Control.Abstract.Environment as X hiding (Lookup) import Control.Abstract.Evaluator as X import Control.Abstract.Exports as X import Control.Abstract.Heap as X From 4feee938399eb7d1ef23e906d935ad1cc3c93940 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 20:53:03 -0400 Subject: [PATCH 052/159] Use the Env effect. --- src/Control/Abstract/Value.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d9733e3e6..313a8072b 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -220,7 +220,7 @@ evaluateInScopedEnv scopedEnvTerm term = do -- | Evaluates a 'Value' returning the referenced value value :: ( AbstractValue location value effects , Member (Allocator location value) effects - , Member (Reader (Environment location)) effects + , Member (Env location) effects , Member (Resumable (EnvironmentError location)) effects , Member (State (Environment location)) effects ) @@ -233,7 +233,7 @@ value (Rval val) = pure val -- | Evaluates a 'Subterm' to its rval subtermValue :: ( AbstractValue location value effects , Member (Allocator location value) effects - , Member (Reader (Environment location)) effects + , Member (Env location) effects , Member (Resumable (EnvironmentError location)) effects , Member (State (Environment location)) effects ) From 7c7204eec828311333cca083ef4dedf72dff3b62 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:05:52 -0400 Subject: [PATCH 053/159] Define a bindAll operation. --- src/Control/Abstract/Environment.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 5e79bacde..8b7e081d0 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -9,6 +9,7 @@ module Control.Abstract.Environment , locally , lookupEnv , bind +, bindAll , Env(..) , runEnv , reinterpretEnv @@ -63,6 +64,9 @@ lookupEnv name = fmap Address <$> send (Lookup name) bind :: Member (Env location) effects => Name -> Address location value -> Evaluator location value effects () bind name addr = send (Bind name (unAddress addr)) +bindAll :: Member (Env location) effects => Environment location -> Evaluator location value effects () +bindAll = foldr ((>>) . uncurry bind . second Address) (pure ()) . Env.pairs + data Env location return where Lookup :: Name -> Env location (Maybe location) From b73de43e9775723aff4d82be45aa02ad829c041e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:09:00 -0400 Subject: [PATCH 054/159] Add a constructor for closure over the environment. --- src/Control/Abstract/Environment.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 8b7e081d0..efd89b1fa 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -10,6 +10,7 @@ module Control.Abstract.Environment , lookupEnv , bind , bindAll +, close , Env(..) , runEnv , reinterpretEnv @@ -67,10 +68,14 @@ bind name addr = send (Bind name (unAddress addr)) bindAll :: Member (Env location) effects => Environment location -> Evaluator location value effects () bindAll = foldr ((>>) . uncurry bind . second Address) (pure ()) . Env.pairs +close :: Member (Env location) effects => Set Name -> Evaluator location value effects (Environment location) +close = send . Close + data Env location return where Lookup :: Name -> Env location (Maybe location) Bind :: Name -> location -> Env location () + Close :: Set Name -> Env location (Environment location) Push :: Env location () Pop :: Env location () @@ -79,6 +84,7 @@ runEnv :: Member (State (Environment location)) effects => Environment location runEnv defaultEnvironment = interpret $ \case Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv Bind name addr -> modifyEnv (Env.insert name addr) + Close names -> Env.intersect names <$> getEnv Push -> modifyEnv Env.push Pop -> modifyEnv Env.pop @@ -86,6 +92,7 @@ reinterpretEnv :: Environment location -> Evaluator location value (Env location reinterpretEnv defaultEnvironment = reinterpret $ \case Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv Bind name addr -> modifyEnv (Env.insert name addr) + Close names -> Env.intersect names <$> getEnv Push -> modifyEnv Env.push Pop -> modifyEnv Env.pop From 02d021fed5349fa8b37d6c8770c9a1a01083e526 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:11:10 -0400 Subject: [PATCH 055/159] Add a single handler which we interpret/reinterpret. --- src/Control/Abstract/Environment.hs | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index efd89b1fa..50eba859a 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -79,22 +79,19 @@ data Env location return where Push :: Env location () Pop :: Env location () +handleEnv :: Member (State (Environment location)) effects => Environment location -> Env location result -> Evaluator location value effects result +handleEnv defaultEnvironment = \case + Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv + Bind name addr -> modifyEnv (Env.insert name addr) + Close names -> Env.intersect names <$> getEnv + Push -> modifyEnv Env.push + Pop -> modifyEnv Env.pop runEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value effects a -runEnv defaultEnvironment = interpret $ \case - Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv - Bind name addr -> modifyEnv (Env.insert name addr) - Close names -> Env.intersect names <$> getEnv - Push -> modifyEnv Env.push - Pop -> modifyEnv Env.pop +runEnv defaultEnvironment = interpret (handleEnv defaultEnvironment) reinterpretEnv :: Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value (State (Environment location) ': effects) a -reinterpretEnv defaultEnvironment = reinterpret $ \case - Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv - Bind name addr -> modifyEnv (Env.insert name addr) - Close names -> Env.intersect names <$> getEnv - Push -> modifyEnv Env.push - Pop -> modifyEnv Env.pop +reinterpretEnv defaultEnvironment = reinterpret (handleEnv defaultEnvironment) -- | Errors involving the environment. From f8e31c87d64ac0e36daa1247b529aa4ebc202be0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:11:49 -0400 Subject: [PATCH 056/159] :fire: a redundant import. --- src/Control/Abstract/Primitive.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 7b5fca148..20b8349dc 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -6,7 +6,6 @@ import Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Abstract.Heap import Control.Abstract.Value -import Data.Abstract.Environment import Data.Abstract.Name import Data.ByteString.Char8 (pack, unpack) import Data.Semigroup.Reducer hiding (unit) From 213841576ddfeb8e412f2d8ce8700886ac2cbce0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:12:03 -0400 Subject: [PATCH 057/159] Bind locally in evaluateScopedEnv. --- src/Control/Abstract/Value.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 313a8072b..bee66bcef 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -19,7 +19,7 @@ import Control.Abstract.Addressable import Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Abstract.Heap -import Data.Abstract.Address (Address) +import Data.Abstract.Address (Address(..)) import Data.Abstract.Environment as Env import Data.Abstract.Live (Live) import Data.Abstract.Name @@ -207,14 +207,14 @@ makeNamespace name addr super = do -- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'. evaluateInScopedEnv :: ( AbstractValue location value effects - , Member (State (Environment location)) effects + , Member (Env location) effects ) => Evaluator location value effects value -> Evaluator location value effects value -> Evaluator location value effects value evaluateInScopedEnv scopedEnvTerm term = do scopedEnv <- scopedEnvTerm >>= scopedEnvironment - maybe term (flip localEnv term . mergeEnvs) scopedEnv + maybe term (\ env -> locally $ bindAll env >> term) scopedEnv -- | Evaluates a 'Value' returning the referenced value @@ -222,7 +222,6 @@ value :: ( AbstractValue location value effects , Member (Allocator location value) effects , Member (Env location) effects , Member (Resumable (EnvironmentError location)) effects - , Member (State (Environment location)) effects ) => ValueRef value -> Evaluator location value effects value @@ -235,7 +234,6 @@ subtermValue :: ( AbstractValue location value effects , Member (Allocator location value) effects , Member (Env location) effects , Member (Resumable (EnvironmentError location)) effects - , Member (State (Environment location)) effects ) => Subterm term (Evaluator location value effects (ValueRef value)) -> Evaluator location value effects value From 4d62cb3f9181dc67d7bfcacc2da76e5d9d7a8ecd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:15:26 -0400 Subject: [PATCH 058/159] Use Env in Value. --- src/Data/Abstract/Value.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 430d88cee..0aac2151b 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -2,6 +2,7 @@ module Data.Abstract.Value where import Control.Abstract +import Data.Abstract.Address import Data.Abstract.Environment (Environment, emptyEnv, mergeEnvs) import qualified Data.Abstract.Environment as Env import Data.Abstract.Name @@ -56,12 +57,12 @@ instance AbstractHole (Value location body) where instance ( Coercible body (Eff effects) , Member (Allocator location (Value location body)) effects + , Member (Env location) effects , Member Fresh effects , Member (Reader ModuleInfo) effects , Member (Reader PackageInfo) effects , Member (Resumable (ValueError location body)) effects , Member (Return (Value location body)) effects - , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) (Value location body))) effects , Ord location , Reducer (Value location body) (Cell location (Value location body)) @@ -72,7 +73,7 @@ instance ( Coercible body (Eff effects) packageInfo <- currentPackage moduleInfo <- currentModule i <- fresh - Closure packageInfo moduleInfo parameters (ClosureBody i (coerce (lowerEff body))) . Env.intersect (foldr Set.delete freeVariables parameters) <$> getEnv + Closure packageInfo moduleInfo parameters (ClosureBody i (coerce (lowerEff body))) <$> close (foldr Set.delete freeVariables parameters) call op params = do case op of @@ -81,11 +82,11 @@ instance ( Coercible body (Eff effects) -- charge them to the closure's origin. withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do bindings <- foldr (\ (name, param) rest -> do - v <- param - a <- alloc name - assign a v - Env.insert name a <$> rest) (pure env) (zip names params) - localEnv (mergeEnvs bindings) (raiseEff (coerce body) `catchReturn` \ (Return value) -> pure value) + value <- param + addr <- alloc name + assign addr value + Env.insert name (unAddress addr) <$> rest) (pure env) (zip names params) + locally (bindAll bindings >> raiseEff (coerce body) `catchReturn` \ (Return value) -> pure value) _ -> throwValueError (CallError op) @@ -109,14 +110,13 @@ instance Show location => AbstractIntro (Value location body) where -- | Construct a 'Value' wrapping the value arguments (if any). instance ( Coercible body (Eff effects) , Member (Allocator location (Value location body)) effects + , Member (Env location) effects , Member Fresh effects , Member (LoopControl (Value location body)) effects - , Member (Reader (Environment location)) effects , Member (Reader ModuleInfo) effects , Member (Reader PackageInfo) effects , Member (Resumable (ValueError location body)) effects , Member (Return (Value location body)) effects - , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) (Value location body))) effects , Ord location , Reducer (Value location body) (Cell location (Value location body)) From 95b54332338a067b075733a801b1afaaa65f74de Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:16:44 -0400 Subject: [PATCH 059/159] Use Env in Type. --- src/Data/Abstract/Type.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 9d7e6ed54..41b3dde23 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -8,6 +8,7 @@ module Data.Abstract.Type ) where import Control.Abstract +import Data.Abstract.Address import Data.Abstract.Environment as Env import Data.Semigroup.Foldable (foldMap1) import Data.Semigroup.Reducer (Reducer) @@ -117,10 +118,10 @@ instance AbstractIntro Type where instance ( Member (Allocator location Type) effects + , Member (Env location) effects , Member Fresh effects , Member (Resumable TypeError) effects , Member (Return Type) effects - , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) Type)) effects , Ord location , Reducer Type (Cell location Type) @@ -128,11 +129,11 @@ instance ( Member (Allocator location Type) effects => AbstractFunction location Type effects where closure names _ body = do (env, tvars) <- foldr (\ name rest -> do - a <- alloc name + addr <- alloc name tvar <- Var <$> fresh - assign a tvar - bimap (Env.insert name a) (tvar :) <$> rest) (pure (emptyEnv, [])) names - (zeroOrMoreProduct tvars :->) <$> localEnv (mergeEnvs env) (body `catchReturn` \ (Return value) -> pure value) + assign addr tvar + bimap (Env.insert name (unAddress addr)) (tvar :) <$> rest) (pure (emptyEnv, [])) names + (zeroOrMoreProduct tvars :->) <$> locally (bindAll env >> body `catchReturn` \ (Return value) -> pure value) call op params = do tvar <- fresh @@ -146,11 +147,11 @@ instance ( Member (Allocator location Type) effects -- | Discard the value arguments (if any), constructing a 'Type' instead. instance ( Member (Allocator location Type) effects + , Member (Env location) effects , Member Fresh effects , Member NonDet effects , Member (Resumable TypeError) effects , Member (Return Type) effects - , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) Type)) effects , Ord location , Reducer Type (Cell location Type) From 5110a936a006f5011bddee808c268e6224d3aeff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:21:43 -0400 Subject: [PATCH 060/159] :fire: the value parameter to Live. --- src/Analysis/Abstract/Caching.hs | 4 ++-- src/Analysis/Abstract/Collecting.hs | 10 +++++----- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Configuration.hs | 2 +- src/Control/Abstract/Roots.hs | 4 ++-- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Configuration.hs | 2 +- src/Data/Abstract/Environment.hs | 4 ++-- src/Data/Abstract/Heap.hs | 2 +- src/Data/Abstract/Live.hs | 18 +++++++++--------- 10 files changed, 25 insertions(+), 25 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 13e76a502..07b7402ef 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -60,7 +60,7 @@ cachingTerms :: ( Cacheable term location (Cell location) value , Corecursive term , Member NonDet effects , Member (Reader (Cache term location (Cell location) value)) effects - , Member (Reader (Live location value)) effects + , Member (Reader (Live location)) effects , Member (State (Cache term location (Cell location) value)) effects , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) value)) effects @@ -83,7 +83,7 @@ convergingModules :: ( AbstractValue location value effects , Member NonDet effects , Member (Reader (Cache term location (Cell location) value)) effects , Member (Reader (Environment location)) effects - , Member (Reader (Live location value)) effects + , Member (Reader (Live location)) effects , Member (Resumable (EnvironmentError location)) effects , Member (State (Cache term location (Cell location) value)) effects , Member (State (Environment location)) effects diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 2b3a33353..521574d6e 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -12,7 +12,7 @@ import Prologue -- | An analysis performing GC after every instruction. collectingTerms :: ( Foldable (Cell location) - , Member (Reader (Live location value)) effects + , Member (Reader (Live location)) effects , Member (State (Heap location (Cell location) value)) effects , Ord location , ValueRoots location value @@ -29,7 +29,7 @@ gc :: ( Ord location , Foldable (Cell location) , ValueRoots location value ) - => Live location value -- ^ The set of addresses to consider rooted. + => Live location -- ^ The set of addresses to consider rooted. -> Heap location (Cell location) value -- ^ A heap to collect unreachable addresses within. -> Heap location (Cell location) value -- ^ A garbage-collected heap. gc roots heap = heapRestrict heap (reachable roots heap) @@ -39,9 +39,9 @@ reachable :: ( Ord location , Foldable (Cell location) , ValueRoots location value ) - => Live location value -- ^ The set of root addresses. + => Live location -- ^ The set of root addresses. -> Heap location (Cell location) value -- ^ The heap to trace addresses through. - -> Live location value -- ^ The set of addresses reachable from the root set. + -> Live location -- ^ The set of addresses reachable from the root set. reachable roots heap = go mempty roots where go seen set = case liveSplit set of Nothing -> seen @@ -50,5 +50,5 @@ reachable roots heap = go mempty roots _ -> seen) -providingLiveSet :: Effectful (m location value) => m location value (Reader (Live location value) ': effects) a -> m location value effects a +providingLiveSet :: Effectful (m location value) => m location value (Reader (Live location) ': effects) a -> m location value effects a providingLiveSet = runReader lowerBound diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 62d43d152..d0919b42b 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -13,7 +13,7 @@ import Prologue -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. tracingTerms :: ( Corecursive term - , Member (Reader (Live location value)) effects + , Member (Reader (Live location)) effects , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) value)) effects , Member (Writer (trace (Configuration term location (Cell location) value))) effects diff --git a/src/Control/Abstract/Configuration.hs b/src/Control/Abstract/Configuration.hs index 4ff37c9c3..42bb8eec2 100644 --- a/src/Control/Abstract/Configuration.hs +++ b/src/Control/Abstract/Configuration.hs @@ -12,5 +12,5 @@ import Control.Abstract.TermEvaluator import Data.Abstract.Configuration -- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: (Member (Reader (Live location value)) effects, Member (State (Environment location)) effects, Member (State (Heap location (Cell location) value)) effects) => term -> TermEvaluator term location value effects (Configuration term location (Cell location) value) +getConfiguration :: (Member (Reader (Live location)) effects, Member (State (Environment location)) effects, Member (State (Heap location (Cell location) value)) effects) => term -> TermEvaluator term location value effects (Configuration term location (Cell location) value) getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEnv <*> TermEvaluator getHeap diff --git a/src/Control/Abstract/Roots.hs b/src/Control/Abstract/Roots.hs index 375940ef4..4c5277258 100644 --- a/src/Control/Abstract/Roots.hs +++ b/src/Control/Abstract/Roots.hs @@ -9,9 +9,9 @@ import Data.Abstract.Live import Prologue -- | Retrieve the local 'Live' set. -askRoots :: Member (Reader (Live location value)) effects => Evaluator location value effects (Live location value) +askRoots :: Member (Reader (Live location)) effects => Evaluator location value effects (Live location) askRoots = ask -- | Run a computation with the given 'Live' set added to the local root set. -extraRoots :: (Member (Reader (Live location value)) effects, Ord location) => Live location value -> Evaluator location value effects a -> Evaluator location value effects a +extraRoots :: (Member (Reader (Live location)) effects, Ord location) => Live location -> Evaluator location value effects a -> Evaluator location value effects a extraRoots roots = local (<> roots) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index bee66bcef..0e36c279c 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -243,4 +243,4 @@ subtermValue = value <=< subtermRef -- | Value types, e.g. closures, which can root a set of addresses. class ValueRoots location value where -- | Compute the set of addresses rooted by a given value. - valueRoots :: value -> Live location value + valueRoots :: value -> Live location diff --git a/src/Data/Abstract/Configuration.hs b/src/Data/Abstract/Configuration.hs index 72913421b..fe8e1f9fa 100644 --- a/src/Data/Abstract/Configuration.hs +++ b/src/Data/Abstract/Configuration.hs @@ -7,7 +7,7 @@ import Data.Abstract.Live -- | A single point in a program’s execution. data Configuration term location cell value = Configuration { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. - , configurationRoots :: Live location value -- ^ The set of rooted addresses. + , configurationRoots :: Live location -- ^ The set of rooted addresses. , configurationEnvironment :: Environment location -- ^ The environment binding any free variables in 'configurationTerm'. , configurationHeap :: Heap location cell value -- ^ The heap of values. } diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 6cc11f42a..20f801c6e 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -117,10 +117,10 @@ overwrite pairs env = unpairs $ mapMaybe lookupAndAlias pairs -- | Retrieve the 'Live' set of addresses to which the given free variable names are bound. -- -- Unbound names are silently dropped. -roots :: (Ord location, Foldable t) => Environment location -> t Name -> Live location value +roots :: (Ord location, Foldable t) => Environment location -> t Name -> Live location roots env = foldMap (maybe mempty liveSingleton . flip lookup env) -addresses :: Ord location => Environment location -> Live location value +addresses :: Ord location => Environment location -> Live location addresses = fromAddresses . map snd . pairs diff --git a/src/Data/Abstract/Heap.hs b/src/Data/Abstract/Heap.hs index 0a878d03b..9d3e251e1 100644 --- a/src/Data/Abstract/Heap.hs +++ b/src/Data/Abstract/Heap.hs @@ -33,7 +33,7 @@ heapSize :: Heap location cell value -> Int heapSize = Monoidal.size . unHeap -- | Restrict a 'Heap' to only those 'Address'es in the given 'Live' set (in essence garbage collecting the rest). -heapRestrict :: Ord location => Heap location cell value -> Live location value -> Heap location cell value +heapRestrict :: Ord location => Heap location cell value -> Live location -> Heap location cell value heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> address `liveMember` roots) m) diff --git a/src/Data/Abstract/Live.hs b/src/Data/Abstract/Live.hs index 345d9f873..a1b0fde05 100644 --- a/src/Data/Abstract/Live.hs +++ b/src/Data/Abstract/Live.hs @@ -6,36 +6,36 @@ import Data.Set as Set import Prologue -- | A set of live addresses (whether roots or reachable). -newtype Live location value = Live { unLive :: Set location } +newtype Live location = Live { unLive :: Set location } deriving (Eq, Lower, Monoid, Ord, Semigroup) -fromAddresses :: (Foldable t, Ord location) => t location -> Live location value +fromAddresses :: (Foldable t, Ord location) => t location -> Live location fromAddresses = Prologue.foldr liveInsert lowerBound -- | Construct a 'Live' set containing only the given address. -liveSingleton :: location -> Live location value +liveSingleton :: location -> Live location liveSingleton = Live . Set.singleton -- | Insert an address into a 'Live' set. -liveInsert :: Ord location => location -> Live location value -> Live location value +liveInsert :: Ord location => location -> Live location -> Live location liveInsert addr = Live . Set.insert addr . unLive -- | Delete an address from a 'Live' set, if present. -liveDelete :: Ord location => location -> Live location value -> Live location value +liveDelete :: Ord location => location -> Live location -> Live location liveDelete addr = Live . Set.delete addr . unLive -- | Compute the (asymmetric) difference of two 'Live' sets, i.e. delete every element of the second set from the first set. -liveDifference :: Ord location => Live location value -> Live location value -> Live location value +liveDifference :: Ord location => Live location -> Live location -> Live location liveDifference = fmap Live . (Set.difference `on` unLive) -- | Test whether an 'Address' is in a 'Live' set. -liveMember :: Ord location => location -> Live location value -> Bool +liveMember :: Ord location => location -> Live location -> Bool liveMember addr = Set.member addr . unLive -- | Decompose a 'Live' set into a pair of one member address and the remaining set, or 'Nothing' if empty. -liveSplit :: Live location value -> Maybe (location, Live location value) +liveSplit :: Live location -> Maybe (location, Live location) liveSplit = fmap (fmap Live) . Set.minView . unLive -instance Show location => Show (Live location value) where +instance Show location => Show (Live location) where showsPrec d = showsUnaryWith showsPrec "Live" d . Set.toList . unLive From 65d6e268d1a5d2e73741b1366b0144b4044f1b63 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:22:20 -0400 Subject: [PATCH 061/159] Correct a doc comment. --- src/Data/Abstract/Live.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Live.hs b/src/Data/Abstract/Live.hs index a1b0fde05..38b103cac 100644 --- a/src/Data/Abstract/Live.hs +++ b/src/Data/Abstract/Live.hs @@ -28,7 +28,7 @@ liveDelete addr = Live . Set.delete addr . unLive liveDifference :: Ord location => Live location -> Live location -> Live location liveDifference = fmap Live . (Set.difference `on` unLive) --- | Test whether an 'Address' is in a 'Live' set. +-- | Test whether an address is in a 'Live' set. liveMember :: Ord location => location -> Live location -> Bool liveMember addr = Set.member addr . unLive From 9a8acdc32875a85ba34c70cd3c4b51806a682206 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:23:50 -0400 Subject: [PATCH 062/159] Wrap an Address. --- src/Analysis/Abstract/Collecting.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 521574d6e..87f0f2d42 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -5,6 +5,7 @@ module Analysis.Abstract.Collecting ) where import Control.Abstract +import Data.Abstract.Address import Data.Abstract.Heap import Data.Abstract.Live import Data.Semilattice.Lower @@ -45,7 +46,7 @@ reachable :: ( Ord location reachable roots heap = go mempty roots where go seen set = case liveSplit set of Nothing -> seen - Just (a, as) -> go (liveInsert a seen) (case heapLookupAll a heap of + Just (a, as) -> go (liveInsert a seen) (case heapLookupAll (Address a) heap of Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen _ -> seen) From d4d5cc04d5b82cb224c3c5c2fd9946e8efcf3088 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:41:04 -0400 Subject: [PATCH 063/159] =?UTF-8?q?Don=E2=80=99t=20provide=20a=20Reader=20?= =?UTF-8?q?for=20the=20default=20environment.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/Evaluating.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 3cc429c3d..47e89d01d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -23,7 +23,6 @@ deriving instance (Show (Cell location value), Show location, Show value) => Sho evaluating :: Evaluator location value ( Fail ': Fresh - ': Reader (Environment location) ': State (Environment location) ': State (Heap location (Cell location) value) ': State (ModuleTable (Maybe (Environment location, value))) @@ -36,6 +35,5 @@ evaluating . runState lowerBound -- State (ModuleTable (Maybe (Environment location, value))) . runState lowerBound -- State (Heap location (Cell location) value) . runState lowerBound -- State (Environment location) - . runReader lowerBound -- Reader (Environment location) . runFresh 0 . runFail From c58d0df57fd5b4ab9b1c5f0a8a36f1ce2f49750d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 22:03:54 -0400 Subject: [PATCH 064/159] Run the Env effect. --- src/Data/Abstract/Evaluatable.hs | 43 +++++++++++++++++--------------- 1 file changed, 23 insertions(+), 20 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 8b87f5dc6..37b3403af 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -56,9 +56,9 @@ type EvaluatableConstraints location term value effects = , Declarations term , FreeVariables term , Member (Allocator location value) effects + , Member (Env location) effects , Member (LoopControl value) effects , Member (Modules location value) effects - , Member (Reader (Environment location)) effects , Member (Reader ModuleInfo) effects , Member (Reader PackageInfo) effects , Member (Reader Span) effects @@ -67,7 +67,6 @@ type EvaluatableConstraints location term value effects = , Member (Resumable ResolutionError) effects , Member (Resumable (Unspecialized value)) effects , Member (Return value) effects - , Member (State (Environment location)) effects , Member (State (Exports location)) effects , Member (State (Heap location (Cell location) value)) effects , Member Trace effects @@ -77,14 +76,13 @@ type EvaluatableConstraints location term value effects = -- | Evaluate a given package. -evaluatePackageWith :: forall location term value inner outer - -- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' locations require knowledge of 'currentModule' to run. Can we fix that? If not, can we factor this effect list out? - . ( Addressable location (Reader ModuleInfo ': Modules location value ': Reader Span ': Reader PackageInfo ': outer) +evaluatePackageWith :: forall location term value inner inner' inner'' outer + -- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' locations require knowledge of 'currentModule' to run. Can we fix that? + . ( Addressable location inner' , Evaluatable (Base term) , EvaluatableConstraints location term value inner , Member Fail outer , Member Fresh outer - , Member (Reader (Environment location)) outer , Member (Resumable (AddressError location value)) outer , Member (Resumable (LoadError location value)) outer , Member (State (Environment location)) outer @@ -93,7 +91,9 @@ evaluatePackageWith :: forall location term value inner outer , Member (State (ModuleTable (Maybe (Environment location, value)))) outer , Member Trace outer , Recursive term - , inner ~ (LoopControl value ': Return value ': Allocator location value ': Reader ModuleInfo ': Modules location value ': Reader Span ': Reader PackageInfo ': outer) + , inner ~ (LoopControl value ': Return value ': Env location ': Allocator location value ': inner') + , inner' ~ (Reader ModuleInfo ': inner'') + , inner'' ~ (Modules location value ': Reader Span ': Reader PackageInfo ': outer) ) => (SubtermAlgebra Module term (TermEvaluator term location value inner value) -> SubtermAlgebra Module term (TermEvaluator term location value inner value)) -> (SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef value)) -> SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef value))) @@ -104,35 +104,38 @@ evaluatePackageWith analyzeModule analyzeTerm package . runReader lowerBound . runReader (packageModules (packageBody package)) . withPrelude (packagePrelude (packageBody package)) - . raiseHandler (runModules (runTermEvaluator . evalModule)) - $ traverse (uncurry evaluateEntryPoint) (ModuleTable.toPairs (packageEntryPoints (packageBody package))) + $ \ preludeEnv + -> raiseHandler (runModules (runTermEvaluator . evalModule preludeEnv)) + . traverse (uncurry (evaluateEntryPoint preludeEnv)) + $ ModuleTable.toPairs (packageEntryPoints (packageBody package)) where - evalModule m + evalModule preludeEnv m = pairValueWithEnv - . runInModule (moduleInfo m) + . runInModule preludeEnv (moduleInfo m) . analyzeModule (subtermRef . moduleBody) $ evalTerm <$> m evalTerm term = Subterm term (TermEvaluator (value =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term))) - runInModule info + runInModule preludeEnv info = runReader info . raiseHandler runAllocator + . raiseHandler (runEnv preludeEnv) . raiseHandler runReturn . raiseHandler runLoopControl - evaluateEntryPoint :: ModulePath -> Maybe Name -> TermEvaluator term location value (Modules location value ': Reader Span ': Reader PackageInfo ': outer) value - evaluateEntryPoint m sym = runInModule (ModuleInfo m) . TermEvaluator $ do + evaluateEntryPoint :: Environment location -> ModulePath -> Maybe Name -> TermEvaluator term location value inner'' value + evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do v <- maybe unit snd <$> require m maybe (pure v) ((`call` []) <=< variable) sym - evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule)) $ do - _ <- runInModule moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit)) - fst <$> evalModule prelude + evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule emptyEnv)) $ do + _ <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit)) + fst <$> evalModule emptyEnv prelude - withPrelude Nothing a = a - withPrelude (Just prelude) a = do + withPrelude Nothing f = f emptyEnv + withPrelude (Just prelude) f = do preludeEnv <- evalPrelude prelude - raiseHandler (withDefaultEnvironment preludeEnv) a + f preludeEnv -- TODO: If the set of exports is empty because no exports have been -- defined, do we export all terms, or no terms? This behavior varies across From 23a2f7ee7b563491ac923d4be6785871d8fb56e7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 07:45:12 -0400 Subject: [PATCH 065/159] Fix a typo. --- src/Data/Syntax/Declaration.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 67f0a3941..0b6dcce94 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -276,7 +276,7 @@ instance Evaluatable TypeAlias where v <- subtermValue typeAliasKind addr <- lookupOrAlloc name assign addr v - Rval v <$> bind name addr + Rval v <$ bind name addr instance Declarations a => Declarations (TypeAlias a) where declaredName TypeAlias{..} = declaredName typeAliasIdentifier From d9a0d4dad7f0d080b3a4c5d6c098084cf2b1c00c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 07:51:22 -0400 Subject: [PATCH 066/159] forLoop runs in Env. --- src/Control/Abstract/Value.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 0e36c279c..8f2ef910a 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -159,7 +159,7 @@ asBool value = ifthenelse value (pure True) (pure False) -- | C-style for loops. forLoop :: ( AbstractValue location value effects - , Member (State (Environment location)) effects + , Member (Env location) effects ) => Evaluator location value effects value -- ^ Initial statement -> Evaluator location value effects value -- ^ Condition @@ -167,7 +167,7 @@ forLoop :: ( AbstractValue location value effects -> Evaluator location value effects value -- ^ Body -> Evaluator location value effects value forLoop initial cond step body = - localEnv id (initial *> while cond (body *> step)) + locally (initial *> while cond (body *> step)) -- | The fundamental looping primitive, built on top of 'ifthenelse'. while :: AbstractValue location value effects From d8aa3c9a41ebd62305403a49564525220ebc249f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 07:53:54 -0400 Subject: [PATCH 067/159] Use bindAll most places. --- src/Language/Go/Syntax.hs | 4 ++-- src/Language/PHP/Syntax.hs | 5 ++--- src/Language/Python/Syntax.hs | 9 ++++----- src/Language/Ruby/Syntax.hs | 4 ++-- src/Language/TypeScript/Syntax.hs | 10 +++++----- 5 files changed, 15 insertions(+), 17 deletions(-) diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index c37a784f8..af200e6dc 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -70,7 +70,7 @@ instance Evaluatable Import where for_ paths $ \path -> do traceResolve (unPath importPath) path importedEnv <- maybe emptyEnv fst <$> isolate (require path) - modifyEnv (mergeEnvs importedEnv) + bindAll importedEnv pure (Rval unit) @@ -94,7 +94,7 @@ instance Evaluatable QualifiedImport where for_ paths $ \p -> do traceResolve (unPath importPath) p importedEnv <- maybe emptyEnv fst <$> isolate (require p) - modifyEnv (mergeEnvs importedEnv) + bindAll importedEnv makeNamespace alias addr Nothing pure (Rval unit) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 28094cc45..b11d1fc6a 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -54,11 +54,10 @@ resolvePHPName n = do include :: ( AbstractValue location value effects , Member (Allocator location value) effects + , Member (Env location) effects , Member (Modules location value) effects - , Member (Reader (Environment location)) effects , Member (Resumable ResolutionError) effects , Member (Resumable (EnvironmentError location)) effects - , Member (State (Environment location)) effects , Member (State (Exports location)) effects , Member Trace effects ) @@ -70,7 +69,7 @@ include pathTerm f = do path <- resolvePHPName name traceResolve name path (importedEnv, v) <- isolate (f path) >>= maybeM (pure (emptyEnv, unit)) - modifyEnv (mergeEnvs importedEnv) + bindAll importedEnv pure (Rval v) newtype Require a = Require a diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 1aa99d740..7a275a258 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -117,7 +117,7 @@ instance Evaluatable Import where -- Last module path is the one we want to import let path = NonEmpty.last modulePaths importedEnv <- maybe emptyEnv fst <$> isolate (require path) - modifyEnv (mergeEnvs (select importedEnv)) + bindAll (select importedEnv) pure (Rval unit) where select importedEnv @@ -128,9 +128,8 @@ instance Evaluatable Import where -- Evaluate a qualified import evalQualifiedImport :: ( AbstractValue location value effects , Member (Allocator location value) effects + , Member (Env location) effects , Member (Modules location value) effects - , Member (Reader (Environment location)) effects - , Member (State (Environment location)) effects , Member (State (Exports location)) effects , Member (State (Heap location (Cell location) value)) effects , Ord location @@ -139,7 +138,7 @@ evalQualifiedImport :: ( AbstractValue location value effects => Name -> ModulePath -> Evaluator location value effects value evalQualifiedImport name path = letrec' name $ \addr -> do importedEnv <- maybe emptyEnv fst <$> isolate (require path) - modifyEnv (mergeEnvs importedEnv) + bindAll importedEnv unit <$ makeNamespace name addr Nothing newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: QualifiedName } @@ -188,7 +187,7 @@ instance Evaluatable QualifiedAliasedImport where Rval <$> letrec' alias (\addr -> do let path = NonEmpty.last modulePaths importedEnv <- maybe emptyEnv fst <$> isolate (require path) - modifyEnv (mergeEnvs importedEnv) + bindAll importedEnv unit <$ makeNamespace alias addr Nothing) -- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index ddc1db58d..f91f80e8f 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -109,9 +109,9 @@ instance Evaluatable Load where eval (Load _) = raiseEff (fail "invalid argument supplied to load, path is required") doLoad :: ( AbstractValue location value effects + , Member (Env location) effects , Member (Modules location value) effects , Member (Resumable ResolutionError) effects - , Member (State (Environment location)) effects , Member (State (Exports location)) effects , Member Trace effects ) @@ -122,7 +122,7 @@ doLoad path shouldWrap = do path' <- resolveRubyPath path traceResolve path path' importedEnv <- maybe emptyEnv fst <$> isolate (load path') - unless shouldWrap $ modifyEnv (mergeEnvs importedEnv) + unless shouldWrap $ bindAll importedEnv pure (boolean Prelude.True) -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load -- TODO: autoload diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index cac08b9c5..2659c28a6 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} module Language.TypeScript.Syntax where +import Data.Abstract.Address import qualified Data.Abstract.Environment as Env import Data.Abstract.Evaluatable import qualified Data.Abstract.Module as M @@ -134,9 +135,8 @@ javascriptExtensions = ["js"] evalRequire :: ( AbstractValue location value effects , Member (Allocator location value) effects + , Member (Env location) effects , Member (Modules location value) effects - , Member (Reader (Environment location)) effects - , Member (State (Environment location)) effects , Member (State (Exports location)) effects , Member (State (Heap location (Cell location) value)) effects , Ord location @@ -147,7 +147,7 @@ evalRequire :: ( AbstractValue location value effects -> Evaluator location value effects value evalRequire modulePath alias = letrec' alias $ \addr -> do importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath) - modifyEnv (mergeEnvs importedEnv) + bindAll importedEnv unit <$ makeNamespace alias addr Nothing data Import a = Import { importSymbols :: ![(Name, Name)], importFrom :: ImportPath } @@ -164,7 +164,7 @@ instance Evaluatable Import where eval (Import symbols importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath) - modifyEnv (mergeEnvs (renamed importedEnv)) $> Rval unit + bindAll (renamed importedEnv) $> Rval unit where renamed importedEnv | Prologue.null symbols = importedEnv @@ -252,7 +252,7 @@ instance Evaluatable QualifiedExportFrom where -- Look up addresses in importedEnv and insert the aliases with addresses into the exports. for_ exportSymbols $ \(name, alias) -> do let address = Env.lookup name importedEnv - maybe (throwEvalError $ ExportError modulePath name) (addExport name alias . Just) address + maybe (throwEvalError $ ExportError modulePath name) (addExport name alias . Just . Address) address pure (Rval unit) newtype DefaultExport a = DefaultExport { defaultExport :: a } From 5499528ac07817da1cafb7bb8906ea1b99d3dbe7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 10:24:25 -0400 Subject: [PATCH 068/159] Define a Ref datatype for references to values in the heap. --- src/Data/Abstract/Ref.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Abstract/Ref.hs b/src/Data/Abstract/Ref.hs index c7412cde4..2b15de34a 100644 --- a/src/Data/Abstract/Ref.hs +++ b/src/Data/Abstract/Ref.hs @@ -12,3 +12,6 @@ data ValueRef value where -- | An object member. LvalMember :: value -> Name -> ValueRef value deriving (Eq, Ord, Show) + + +data Ref address value = Ref address From de3bf57072b85161a6d90892c53dc38c751f3e5d Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 30 May 2018 10:32:17 -0400 Subject: [PATCH 069/159] Remove comment --- src/Data/Syntax.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index d34c2a92a..249ce33f8 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -108,7 +108,6 @@ instance (Apply Message1 fs, Generate Message1 fs fs, Generate GenericNamed fs f liftDecodeMessage decodeMessage num = oneof undefined listOfParsers where listOfParsers = - -- zipWith (\i generator -> (FieldNumber i, generator (FieldNumber i))) [1..] (generate @fs @fs (Proxy @fs) decodeMessage) generate @Message1 @fs @fs (\ (proxy :: proxy f) i -> let num = FieldNumber (fromInteger (succ i)) in [(num, fromJust <$> embedded (inject @f @fs <$> liftDecodeMessage decodeMessage num))]) liftDotProto dotProto _ = [Proto.DotProtoMessageOneOf (Proto.Single "syntax") (generate @GenericNamed @fs @fs (\ (proxy :: proxy f) i -> From 8bcc9f4cb14ceef3ff26b4c0ea86d49ce547b4dd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 10:33:28 -0400 Subject: [PATCH 070/159] Placate hlint. --- src/Data/Abstract/Ref.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Ref.hs b/src/Data/Abstract/Ref.hs index 2b15de34a..4e218a598 100644 --- a/src/Data/Abstract/Ref.hs +++ b/src/Data/Abstract/Ref.hs @@ -14,4 +14,4 @@ data ValueRef value where deriving (Eq, Ord, Show) -data Ref address value = Ref address +newtype Ref address value = Ref address From 6adc5d7413db475f22816120bd677ed51a10df61 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 10:33:51 -0400 Subject: [PATCH 071/159] Placate hlint some more. --- test/SpecHelpers.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 49eec19db..6aee58368 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -34,7 +34,6 @@ import Data.Project as X import Data.Functor.Listable as X import Data.Language as X import Data.List.NonEmpty as X (NonEmpty(..)) -import Data.Monoid as X (Last(..)) import Data.Range as X import Data.Record as X import Data.Source as X From 9caf8893b69c10f0019bd6f5a91f4c3045fcd3dd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 10:36:16 -0400 Subject: [PATCH 072/159] Correct a couple of hints. --- HLint.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/HLint.hs b/HLint.hs index f488a4907..f0efa0933 100644 --- a/HLint.hs +++ b/HLint.hs @@ -17,8 +17,8 @@ error "Avoid return" = return ==> pure where note = "return is obsolete as of GHC 7.10" -error "use extract" = termAnnotation . unTerm ==> extract -error "use unwrap" = termOut . unTerm ==> unwrap +error "use termAnnotation" = termFAnnotation . unTerm ==> termAnnotation +error "use termOut" = termFOut . unTerm ==> termOut error "avoid head" = head where note = "head is partial; consider using Data.Maybe.listToMaybe" From 90ad5bc45ef850a33f0a2c5b49eac0d74ec24f81 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 10:37:16 -0400 Subject: [PATCH 073/159] Add a hint about maybeM. --- HLint.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/HLint.hs b/HLint.hs index f0efa0933..e02ff38b5 100644 --- a/HLint.hs +++ b/HLint.hs @@ -31,3 +31,5 @@ error "avoid init" = init error "avoid last" = last where note = "last is partial; consider pattern-matching" + +error "use maybeM" = maybe a pure ==> maybeM a From 12c6c39861c3a2e1523a0e09c4882833b4099d79 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Wed, 30 May 2018 09:48:16 -0500 Subject: [PATCH 074/159] cut State Environment over to Env effect --- src/Analysis/Abstract/Caching.hs | 4 ++-- src/Analysis/Abstract/Evaluating.hs | 4 ++-- src/Analysis/Abstract/Graph.hs | 4 ++-- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Configuration.hs | 2 +- src/Control/Abstract/Environment.hs | 16 ++++++++-------- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Evaluatable.hs | 4 ++-- src/Semantic/Graph.hs | 2 +- 9 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index be0cc40c6..e1584ea0c 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -62,7 +62,7 @@ cachingTerms :: ( Cacheable term address (Cell address) value , Member (Reader (Cache term address (Cell address) value)) effects , Member (Reader (Live address)) effects , Member (State (Cache term address (Cell address) value)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects ) => SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef value)) @@ -86,7 +86,7 @@ convergingModules :: ( AbstractValue address value effects , Member (Reader (Live address)) effects , Member (Resumable (EnvironmentError address)) effects , Member (State (Cache term address (Cell address) value)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects ) => SubtermAlgebra Module term (TermEvaluator term address value effects value) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index c126f5e1d..86a4670c6 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -23,7 +23,7 @@ deriving instance (Show (Cell address value), Show address, Show value) => Show evaluating :: Evaluator address value ( Fail ': Fresh - ': State (Environment address) + ': Env address ': State (Heap address (Cell address) value) ': State (ModuleTable (Maybe (Environment address, value))) ': State (Exports address) @@ -34,6 +34,6 @@ evaluating . runState lowerBound -- State (Exports address) . runState lowerBound -- State (ModuleTable (Maybe (Environment address, value))) . runState lowerBound -- State (Heap address (Cell address) value) - . runState lowerBound -- State (Environment address) + . runState lowerBound -- Env address . runFresh 0 . runFail diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 970b7cef3..62765dd9c 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -54,7 +54,7 @@ style = (defaultStyle (byteString . vertexName)) graphingTerms :: ( Element Syntax.Identifier syntax , Member (Reader (Environment (Hole (Located address)))) effects , Member (Reader ModuleInfo) effects - , Member (State (Environment (Hole (Located address)))) effects + , Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects , term ~ Term (Sum syntax) ann ) @@ -122,7 +122,7 @@ moduleInclusion v = do -- | Add an edge from the passed variable name to the module it originated within. variableDefinition :: ( Member (Reader (Environment (Hole (Located address)))) effects - , Member (State (Environment (Hole (Located address)))) effects + , Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects ) => Name diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 80b35d067..ee6cc58b6 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -14,7 +14,7 @@ import Prologue -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. tracingTerms :: ( Corecursive term , Member (Reader (Live address)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects , Member (Writer (trace (Configuration term address (Cell address) value))) effects , Reducer (Configuration term address (Cell address) value) (trace (Configuration term address (Cell address) value)) diff --git a/src/Control/Abstract/Configuration.hs b/src/Control/Abstract/Configuration.hs index 764168d8e..d89905f02 100644 --- a/src/Control/Abstract/Configuration.hs +++ b/src/Control/Abstract/Configuration.hs @@ -12,5 +12,5 @@ import Control.Abstract.TermEvaluator import Data.Abstract.Configuration -- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: (Member (Reader (Live address)) effects, Member (State (Environment address)) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value) +getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value) getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEnv <*> TermEvaluator getHeap diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index a01b56d1c..592750514 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -25,19 +25,19 @@ import Data.Abstract.Name import Prologue -- | Retrieve the environment. -getEnv :: Member (State (Environment address)) effects => Evaluator address value effects (Environment address) +getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) getEnv = get -- | Set the environment. -putEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects () +putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects () putEnv = put -- | Update the global environment. -modifyEnv :: Member (State (Environment address)) effects => (Environment address -> Environment address) -> Evaluator address value effects () +modifyEnv :: Member (Env address) effects => (Environment address -> Environment address) -> Evaluator address value effects () modifyEnv = modify' -- | Sets the environment for the lifetime of the given action. -withEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a +withEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a withEnv = localState . const @@ -66,12 +66,12 @@ close = send . Close data Env address return where Lookup :: Name -> Env address (Maybe address) - Bind :: Name -> address -> Env address () + Bind :: Name -> address -> Env address () Close :: Set Name -> Env address (Environment address) Push :: Env address () Pop :: Env address () -handleEnv :: Member (State (Environment address)) effects => Environment address -> Env address result -> Evaluator address value effects result +handleEnv :: Member (Env address) effects => Environment address -> Env address result -> Evaluator address value effects result handleEnv defaultEnvironment = \case Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv Bind name addr -> modifyEnv (Env.insert name addr) @@ -79,10 +79,10 @@ handleEnv defaultEnvironment = \case Push -> modifyEnv Env.push Pop -> modifyEnv Env.pop -runEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects a +runEnv :: Member (Env address) effects => Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects a runEnv defaultEnvironment = interpret (handleEnv defaultEnvironment) -reinterpretEnv :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value (State (Environment address) ': effects) a +reinterpretEnv :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value (Env address ': effects) a reinterpretEnv defaultEnvironment = reinterpret (handleEnv defaultEnvironment) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 913a729f9..b4aa39867 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -187,7 +187,7 @@ doWhile body cond = loop $ \ continue -> body *> do ifthenelse this continue (pure unit) makeNamespace :: ( AbstractValue address value effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects , Ord address , Reducer value (Cell address value) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 4d569512a..f591a79bb 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -85,7 +85,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer , Member Fresh outer , Member (Resumable (AddressError address value)) outer , Member (Resumable (LoadError address value)) outer - , Member (State (Environment address)) outer + , Member (Env address) outer , Member (State (Exports address)) outer , Member (State (Heap address (Cell address) value)) outer , Member (State (ModuleTable (Maybe (Environment address, value)))) outer @@ -147,7 +147,7 @@ evaluatePackageWith analyzeModule analyzeTerm package -- | Isolate the given action with an empty global environment and exports. -isolate :: (Member (State (Environment address)) effects, Member (State (Exports address)) effects) => Evaluator address value effects a -> Evaluator address value effects a +isolate :: (Member (Env address) effects, Member (State (Exports address)) effects) => Evaluator address value effects a -> Evaluator address value effects a isolate = withEnv lowerBound . withExports lowerBound traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects () diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 32f2c0be4..c5dbe114d 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -129,7 +129,7 @@ resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> s UnallocatedAddress _ -> pure lowerBound UninitializedAddress _ -> pure hole) -resumingValueError :: (Member (State (Environment address)) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a +resumingValueError :: (Member (Env address) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of CallError val -> pure val StringError val -> pure (pack (show val)) From a28a4c15f6564e33f64b19a904b56e962b2a87ee Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 30 May 2018 11:20:02 -0400 Subject: [PATCH 075/159] Add semantic-types.proto and bump proto3-suite --- semantic-types.proto | 25 +++++++++++++++++++++++++ vendor/proto3-suite | 2 +- 2 files changed, 26 insertions(+), 1 deletion(-) create mode 100644 semantic-types.proto diff --git a/semantic-types.proto b/semantic-types.proto new file mode 100644 index 000000000..187f8c024 --- /dev/null +++ b/semantic-types.proto @@ -0,0 +1,25 @@ +syntax = "proto3"; +package semantic; +message Array { repeated Term arrayElements = 1; + } +message Boolean { bool booleanContent = 1; + } +message Hash { repeated Term hashElements = 1; + } +message Float { bytes floatContent = 1; + } +message KeyValue { Term key = 1; + Term value = 2; + } +message Null { + } +message TextElement { bytes textElementContent = 1; + } +message Term { oneof syntax {Array array = 1; + Boolean boolean = 2; + Hash hash = 3; + Float float = 4; + KeyValue keyValue = 5; + Null null = 6; + TextElement textElement = 7;} + } \ No newline at end of file diff --git a/vendor/proto3-suite b/vendor/proto3-suite index ec16a218e..63fb9c3c2 160000 --- a/vendor/proto3-suite +++ b/vendor/proto3-suite @@ -1 +1 @@ -Subproject commit ec16a218e27f59ae65a66c0162931d4e51f57d18 +Subproject commit 63fb9c3c2c43fd425f9d93da127a57e3c17e23b6 From 8336c60f54298eee72f81abef94080cb7fe9fac2 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Wed, 30 May 2018 09:48:16 -0500 Subject: [PATCH 076/159] cut State Environment over to Env effect --- src/Analysis/Abstract/Caching.hs | 4 ++-- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Analysis/Abstract/Graph.hs | 4 ++-- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Configuration.hs | 2 +- src/Control/Abstract/Environment.hs | 25 +++++++++++++++++-------- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Evaluatable.hs | 2 +- src/Semantic/Graph.hs | 2 +- 9 files changed, 27 insertions(+), 18 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index be0cc40c6..e1584ea0c 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -62,7 +62,7 @@ cachingTerms :: ( Cacheable term address (Cell address) value , Member (Reader (Cache term address (Cell address) value)) effects , Member (Reader (Live address)) effects , Member (State (Cache term address (Cell address) value)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects ) => SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef value)) @@ -86,7 +86,7 @@ convergingModules :: ( AbstractValue address value effects , Member (Reader (Live address)) effects , Member (Resumable (EnvironmentError address)) effects , Member (State (Cache term address (Cell address) value)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects ) => SubtermAlgebra Module term (TermEvaluator term address value effects value) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index c126f5e1d..ab2cd383d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -34,6 +34,6 @@ evaluating . runState lowerBound -- State (Exports address) . runState lowerBound -- State (ModuleTable (Maybe (Environment address, value))) . runState lowerBound -- State (Heap address (Cell address) value) - . runState lowerBound -- State (Environment address) + . runState lowerBound -- Env address . runFresh 0 . runFail diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 970b7cef3..62765dd9c 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -54,7 +54,7 @@ style = (defaultStyle (byteString . vertexName)) graphingTerms :: ( Element Syntax.Identifier syntax , Member (Reader (Environment (Hole (Located address)))) effects , Member (Reader ModuleInfo) effects - , Member (State (Environment (Hole (Located address)))) effects + , Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects , term ~ Term (Sum syntax) ann ) @@ -122,7 +122,7 @@ moduleInclusion v = do -- | Add an edge from the passed variable name to the module it originated within. variableDefinition :: ( Member (Reader (Environment (Hole (Located address)))) effects - , Member (State (Environment (Hole (Located address)))) effects + , Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects ) => Name diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 80b35d067..ee6cc58b6 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -14,7 +14,7 @@ import Prologue -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. tracingTerms :: ( Corecursive term , Member (Reader (Live address)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects , Member (Writer (trace (Configuration term address (Cell address) value))) effects , Reducer (Configuration term address (Cell address) value) (trace (Configuration term address (Cell address) value)) diff --git a/src/Control/Abstract/Configuration.hs b/src/Control/Abstract/Configuration.hs index 764168d8e..d89905f02 100644 --- a/src/Control/Abstract/Configuration.hs +++ b/src/Control/Abstract/Configuration.hs @@ -12,5 +12,5 @@ import Control.Abstract.TermEvaluator import Data.Abstract.Configuration -- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: (Member (Reader (Live address)) effects, Member (State (Environment address)) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value) +getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value) getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEnv <*> TermEvaluator getHeap diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index a01b56d1c..8e6f2fd91 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -25,19 +25,19 @@ import Data.Abstract.Name import Prologue -- | Retrieve the environment. -getEnv :: Member (State (Environment address)) effects => Evaluator address value effects (Environment address) +getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) getEnv = get -- | Set the environment. -putEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects () +putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects () putEnv = put -- | Update the global environment. -modifyEnv :: Member (State (Environment address)) effects => (Environment address -> Environment address) -> Evaluator address value effects () +modifyEnv :: Member (Env address) effects => (Environment address -> Environment address) -> Evaluator address value effects () modifyEnv = modify' -- | Sets the environment for the lifetime of the given action. -withEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a +withEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a withEnv = localState . const @@ -66,12 +66,16 @@ close = send . Close data Env address return where Lookup :: Name -> Env address (Maybe address) - Bind :: Name -> address -> Env address () + Bind :: Name -> address -> Env address () Close :: Set Name -> Env address (Environment address) Push :: Env address () Pop :: Env address () -handleEnv :: Member (State (Environment address)) effects => Environment address -> Env address result -> Evaluator address value effects result +handleEnv :: forall address effects value result + . Member (State (Environment address)) effects + => Environment address + -> Env address result + -> Evaluator address value effects result handleEnv defaultEnvironment = \case Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv Bind name addr -> modifyEnv (Env.insert name addr) @@ -79,10 +83,15 @@ handleEnv defaultEnvironment = \case Push -> modifyEnv Env.push Pop -> modifyEnv Env.pop -runEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects a +runEnv :: Member (State (Environment address)) effects + => Environment address + -> Evaluator address value (Env address ': effects) a + -> Evaluator address value effects a runEnv defaultEnvironment = interpret (handleEnv defaultEnvironment) -reinterpretEnv :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value (State (Environment address) ': effects) a +reinterpretEnv :: Environment address + -> Evaluator address value (Env address ': effects) a + -> Evaluator address value (State (Environment address) ': effects) a reinterpretEnv defaultEnvironment = reinterpret (handleEnv defaultEnvironment) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 913a729f9..b4aa39867 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -187,7 +187,7 @@ doWhile body cond = loop $ \ continue -> body *> do ifthenelse this continue (pure unit) makeNamespace :: ( AbstractValue address value effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects , Ord address , Reducer value (Cell address value) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 4d569512a..641895e6a 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -147,7 +147,7 @@ evaluatePackageWith analyzeModule analyzeTerm package -- | Isolate the given action with an empty global environment and exports. -isolate :: (Member (State (Environment address)) effects, Member (State (Exports address)) effects) => Evaluator address value effects a -> Evaluator address value effects a +isolate :: (Member (Env address) effects, Member (State (Exports address)) effects) => Evaluator address value effects a -> Evaluator address value effects a isolate = withEnv lowerBound . withExports lowerBound traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects () diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 32f2c0be4..c5dbe114d 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -129,7 +129,7 @@ resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> s UnallocatedAddress _ -> pure lowerBound UninitializedAddress _ -> pure hole) -resumingValueError :: (Member (State (Environment address)) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a +resumingValueError :: (Member (Env address) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of CallError val -> pure val StringError val -> pure (pack (show val)) From 820eac34804ca24a2a3d51e6c1a25152f8f28e32 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Wed, 30 May 2018 10:20:06 -0500 Subject: [PATCH 077/159] rename location type var to address --- src/Data/Abstract/Type.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 77c4569f5..e112ce257 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -121,7 +121,7 @@ instance ( Member (Allocator address Type) effects , Member Fresh effects , Member (Resumable TypeError) effects , Member (Return Type) effects - , Member (State (Heap location (Cell address) Type)) effects + , Member (State (Heap address (Cell address) Type)) effects , Ord address , Reducer Type (Cell address Type) ) @@ -151,7 +151,7 @@ instance ( Member (Allocator address Type) effects , Member NonDet effects , Member (Resumable TypeError) effects , Member (Return Type) effects - , Member (State (Heap location (Cell address) Type)) effects + , Member (State (Heap address (Cell address) Type)) effects , Ord address , Reducer Type (Cell address Type) ) From d13a5da554b5e483e12f4d130def3b54440f32bf Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Wed, 30 May 2018 11:38:35 -0500 Subject: [PATCH 078/159] WIP :pear: --- src/Control/Abstract/Environment.hs | 40 ++++++++++++++++------------- 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 8e6f2fd91..a0a821871 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -26,19 +26,20 @@ import Prologue -- | Retrieve the environment. getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) -getEnv = get +getEnv = send GetEnv -- | Set the environment. putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects () -putEnv = put - --- | Update the global environment. -modifyEnv :: Member (Env address) effects => (Environment address -> Environment address) -> Evaluator address value effects () -modifyEnv = modify' +putEnv = send . PutEnv -- | Sets the environment for the lifetime of the given action. withEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a -withEnv = localState . const +withEnv env m = do + oldEnv <- getEnv + putEnv env + result <- m + putEnv oldEnv + pure result -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. @@ -63,13 +64,14 @@ locally a = do close :: Member (Env address) effects => Set Name -> Evaluator address value effects (Environment address) close = send . Close - data Env address return where - Lookup :: Name -> Env address (Maybe address) - Bind :: Name -> address -> Env address () - Close :: Set Name -> Env address (Environment address) - Push :: Env address () - Pop :: Env address () + Lookup :: Name -> Env address (Maybe address) + Bind :: Name -> address -> Env address () + Close :: Set Name -> Env address (Environment address) + Push :: Env address () + Pop :: Env address () + GetEnv :: Env address (Environment address) + PutEnv :: Environment address -> Env address () handleEnv :: forall address effects value result . Member (State (Environment address)) effects @@ -77,11 +79,13 @@ handleEnv :: forall address effects value result -> Env address result -> Evaluator address value effects result handleEnv defaultEnvironment = \case - Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv - Bind name addr -> modifyEnv (Env.insert name addr) - Close names -> Env.intersect names <$> getEnv - Push -> modifyEnv Env.push - Pop -> modifyEnv Env.pop + Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> get + Bind name addr -> modify (Env.insert name addr) + Close names -> Env.intersect names <$> get + Push -> modify (Env.push @address) + Pop -> modify (Env.pop @address) + GetEnv -> get + PutEnv e -> put e runEnv :: Member (State (Environment address)) effects => Environment address From 99b92d336f016ae215d93c6aa42c2c3d5c73af83 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 12:41:04 -0400 Subject: [PATCH 079/159] :fire: redundant constraint. --- src/Analysis/Abstract/Caching.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index e1584ea0c..05c3fd135 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -82,7 +82,6 @@ convergingModules :: ( AbstractValue address value effects , Member Fresh effects , Member NonDet effects , Member (Reader (Cache term address (Cell address) value)) effects - , Member (Reader (Environment address)) effects , Member (Reader (Live address)) effects , Member (Resumable (EnvironmentError address)) effects , Member (State (Cache term address (Cell address) value)) effects From 8fca2b5ab54f284d1edbbb92017dd67e1f1ca0ae Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 12:50:51 -0400 Subject: [PATCH 080/159] pairValueWithEnv acts in State, not Env. --- 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 f591a79bb..bb7d52b03 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -85,7 +85,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer , Member Fresh outer , Member (Resumable (AddressError address value)) outer , Member (Resumable (LoadError address value)) outer - , Member (Env address) outer + , Member (State (Environment address)) outer , Member (State (Exports address)) outer , Member (State (Heap address (Cell address) value)) outer , Member (State (ModuleTable (Maybe (Environment address, value)))) outer @@ -143,7 +143,7 @@ evaluatePackageWith analyzeModule analyzeTerm package filterEnv ports env | Exports.null ports = env | otherwise = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env - pairValueWithEnv action = flip (,) <$> action <*> (filterEnv <$> TermEvaluator getExports <*> TermEvaluator getEnv) + pairValueWithEnv action = flip (,) <$> action <*> (filterEnv <$> TermEvaluator getExports <*> TermEvaluator (get @(Environment address))) -- | Isolate the given action with an empty global environment and exports. From 707c5819df5c7e16dc36f1e576bf5988b8a2273d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 12:51:16 -0400 Subject: [PATCH 081/159] :fire: redundant constraints. --- src/Analysis/Abstract/Graph.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 62765dd9c..84931de66 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -52,7 +52,6 @@ style = (defaultStyle (byteString . vertexName)) -- | Add vertices to the graph for evaluated identifiers. graphingTerms :: ( Element Syntax.Identifier syntax - , Member (Reader (Environment (Hole (Located address)))) effects , Member (Reader ModuleInfo) effects , Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects @@ -121,8 +120,7 @@ moduleInclusion v = do appendGraph (vertex (moduleVertex m) `connect` vertex v) -- | Add an edge from the passed variable name to the module it originated within. -variableDefinition :: ( Member (Reader (Environment (Hole (Located address)))) effects - , Member (Env (Hole (Located address))) effects +variableDefinition :: ( Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects ) => Name From a243f2d8379ee23c59bb044fcd4df8d1fee67a6b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 12:52:30 -0400 Subject: [PATCH 082/159] Evaluating runs the env state. --- src/Analysis/Abstract/Evaluating.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 86a4670c6..c126f5e1d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -23,7 +23,7 @@ deriving instance (Show (Cell address value), Show address, Show value) => Show evaluating :: Evaluator address value ( Fail ': Fresh - ': Env address + ': State (Environment address) ': State (Heap address (Cell address) value) ': State (ModuleTable (Maybe (Environment address, value))) ': State (Exports address) @@ -34,6 +34,6 @@ evaluating . runState lowerBound -- State (Exports address) . runState lowerBound -- State (ModuleTable (Maybe (Environment address, value))) . runState lowerBound -- State (Heap address (Cell address) value) - . runState lowerBound -- Env address + . runState lowerBound -- State (Environment address) . runFresh 0 . runFail From a5072958b55a2bb2ca9c899c6104c9ff37ab7e7e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 12:53:57 -0400 Subject: [PATCH 083/159] Run resumingValueError in State instead of Env. --- src/Semantic/Graph.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index c5dbe114d..bbcfaaf77 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -129,7 +129,7 @@ resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> s UnallocatedAddress _ -> pure lowerBound UninitializedAddress _ -> pure hole) -resumingValueError :: (Member (Env address) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a +resumingValueError :: (Member (State (Environment address)) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of CallError val -> pure val StringError val -> pure (pack (show val)) @@ -139,7 +139,7 @@ resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err NumericError{} -> pure hole Numeric2Error{} -> pure hole ComparisonError{} -> pure hole - NamespaceError{} -> getEnv + NamespaceError{} -> get @(Environment _) BitwiseError{} -> pure hole Bitwise2Error{} -> pure hole KeyValueError{} -> pure (hole, hole) From 9e464d2e6404a244efad0da9fb454bf86b4d5296 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 30 May 2018 12:58:08 -0400 Subject: [PATCH 084/159] Remove dotProto args --- src/Data/Syntax.hs | 2 +- src/Data/Term.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 249ce33f8..ed9f7cd51 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -109,7 +109,7 @@ instance (Apply Message1 fs, Generate Message1 fs fs, Generate GenericNamed fs f where listOfParsers = generate @Message1 @fs @fs (\ (proxy :: proxy f) i -> let num = FieldNumber (fromInteger (succ i)) in [(num, fromJust <$> embedded (inject @f @fs <$> liftDecodeMessage decodeMessage num))]) - liftDotProto dotProto _ = + liftDotProto _ = [Proto.DotProtoMessageOneOf (Proto.Single "syntax") (generate @GenericNamed @fs @fs (\ (proxy :: proxy f) i -> let num = FieldNumber (fromInteger (succ i)) diff --git a/src/Data/Term.hs b/src/Data/Term.hs index e460be6e3..232cf2f9e 100644 --- a/src/Data/Term.hs +++ b/src/Data/Term.hs @@ -82,7 +82,7 @@ instance (Show1 f, Show a) => Show (Term f a) where instance (Message1 f) => Message (Term f ()) where encodeMessage num (Term (In _ f)) = liftEncodeMessage encodeMessage num f decodeMessage num = termIn () <$> liftDecodeMessage decodeMessage num - dotProto _ = liftDotProto (dotProto @(Term f ())) (Proxy @(f (Term f ()))) + dotProto _ = liftDotProto (Proxy @(f (Term f ()))) instance Named (Term f ()) where nameOf _ = "Term" From bdd1d58c6024f7bba8443fdff9f2a261e98ac3f4 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 30 May 2018 12:58:22 -0400 Subject: [PATCH 085/159] Add Message/Named instance for Blob --- src/Data/Blob.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index b1d52f79c..426b9712c 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} module Data.Blob ( Blob(..) , nullBlob @@ -14,6 +15,7 @@ module Data.Blob ) where import Prologue +import Proto3.Suite import Data.Aeson import Data.JSON.Fields import Data.Language @@ -26,7 +28,7 @@ data Blob = Blob , blobPath :: FilePath -- ^ The file path to the blob. , blobLanguage :: Maybe Language -- ^ The language of this blob. Nothing denotes a langauge we don't support yet. } - deriving (Show, Eq) + deriving (Show, Eq, Generic, Message, Named) nullBlob :: Blob -> Bool nullBlob Blob{..} = nullSource blobSource From 429d42f71e2b269390db2a583eee253f271b33cd Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 30 May 2018 12:58:37 -0400 Subject: [PATCH 086/159] Add Enum/Finite/Named/Message instances for Language --- src/Data/Language.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Language.hs b/src/Data/Language.hs index 14db0019f..c9d734989 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -3,6 +3,7 @@ module Data.Language where import Prologue import Data.Aeson +import Proto3.Suite -- | A programming language. data Language @@ -16,7 +17,7 @@ data Language | Ruby | TypeScript | PHP - deriving (Eq, Generic, Ord, Read, Show, ToJSON) + deriving (Eq, Generic, Ord, Read, Show, ToJSON, Named, Enum, Finite, Message) -- | Returns a Language based on the file extension (including the "."). languageForType :: String -> Maybe Language From 864fb09bc93f127e9327e585400ca4898e78ab57 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 30 May 2018 12:59:12 -0400 Subject: [PATCH 087/159] Add MessageField instance for Source --- src/Data/Source.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Data/Source.hs b/src/Data/Source.hs index 3de66b0cd..52cf03a47 100644 --- a/src/Data/Source.hs +++ b/src/Data/Source.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Source ( Source , sourceBytes @@ -36,10 +36,11 @@ import Data.Span import Data.String (IsString(..)) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Proto3.Suite -- | The contents of a source file, represented as a 'ByteString'. newtype Source = Source { sourceBytes :: B.ByteString } - deriving (Eq, IsString, Show) + deriving (Eq, IsString, Show, Generic, MessageField) fromBytes :: B.ByteString -> Source fromBytes = Source From 234d65dd3ca37931eadb8a2a1081b34c42ab4dcb Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 30 May 2018 12:59:38 -0400 Subject: [PATCH 088/159] Add generated declarations to the proto file --- semantic-types.proto | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/semantic-types.proto b/semantic-types.proto index 187f8c024..c9dfd9b65 100644 --- a/semantic-types.proto +++ b/semantic-types.proto @@ -1,5 +1,19 @@ syntax = "proto3"; package semantic; +enum Language {Go = 0; + Haskell = 1; + JavaScript = 2; + JSON = 3; + JSX = 4; + Markdown = 5; + Python = 6; + Ruby = 7; + TypeScript = 8; + PHP = 9;} +message Blob { bytes blobSource = 1; + string blobPath = 2; + Language blobLanguage = 3; + } message Array { repeated Term arrayElements = 1; } message Boolean { bool booleanContent = 1; From 91dc71c3de3a8860d02293d1b9b78d68734333f1 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 30 May 2018 13:03:09 -0400 Subject: [PATCH 089/159] ++proto3-suite for :+: GenericMessage instance --- vendor/proto3-suite | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/proto3-suite b/vendor/proto3-suite index 63fb9c3c2..5598f2209 160000 --- a/vendor/proto3-suite +++ b/vendor/proto3-suite @@ -1 +1 @@ -Subproject commit 63fb9c3c2c43fd425f9d93da127a57e3c17e23b6 +Subproject commit 5598f2209d3baa0494f790e1b8e402d8e4f7b9af From f9c7f2836d99124042d99d0e2f026038e2774787 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 13:03:50 -0400 Subject: [PATCH 090/159] runEnv in the evaluator spec. --- test/Control/Abstract/Evaluator/Spec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index ddfb4c016..afcb2bc1e 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -38,6 +38,7 @@ evaluate . runEnvironmentError . runAddressError . runAllocator + . runEnv lowerBound . runReturn . runLoopControl From 3c81b7024a310cfae39557169b66b665b482e521 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 13:30:30 -0400 Subject: [PATCH 091/159] Define a runEnvState handler. --- src/Control/Abstract/Environment.hs | 31 +++++++++++++++++++---------- 1 file changed, 21 insertions(+), 10 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index a0a821871..06255097b 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -12,6 +12,7 @@ module Control.Abstract.Environment , Env(..) , runEnv , reinterpretEnv +, runEnvState , EnvironmentError(..) , freeVariableError , runEnvironmentError @@ -75,11 +76,10 @@ data Env address return where handleEnv :: forall address effects value result . Member (State (Environment address)) effects - => Environment address - -> Env address result + => Env address result -> Evaluator address value effects result -handleEnv defaultEnvironment = \case - Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> get +handleEnv = \case + Lookup name -> Env.lookup name <$> get Bind name addr -> modify (Env.insert name addr) Close names -> Env.intersect names <$> get Push -> modify (Env.push @address) @@ -88,15 +88,26 @@ handleEnv defaultEnvironment = \case PutEnv e -> put e runEnv :: Member (State (Environment address)) effects - => Environment address - -> Evaluator address value (Env address ': effects) a + => Evaluator address value (Env address ': effects) a -> Evaluator address value effects a -runEnv defaultEnvironment = interpret (handleEnv defaultEnvironment) +runEnv = interpret handleEnv -reinterpretEnv :: Environment address - -> Evaluator address value (Env address ': effects) a +reinterpretEnv :: Evaluator address value (Env address ': effects) a -> Evaluator address value (State (Environment address) ': effects) a -reinterpretEnv defaultEnvironment = reinterpret (handleEnv defaultEnvironment) +reinterpretEnv = reinterpret handleEnv + +runEnvState :: forall address value effects a + . Environment address + -> Evaluator address value (Env address ': effects) a + -> Evaluator address value effects (a, Environment address) +runEnvState initial = relayState initial (\ s a -> pure (a, s)) $ \ s eff yield -> case eff of + Lookup name -> yield s (Env.lookup name s) + Bind name addr -> yield (Env.insert name addr s) () + Close names -> yield s (Env.intersect names s) + Push -> yield (Env.push @address s) () + Pop -> yield (Env.pop @address s) () + GetEnv -> yield s s + PutEnv e -> yield e () -- | Errors involving the environment. From d4e6d87756153d23a3d291b4fe7520df92235beb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 13:46:29 -0400 Subject: [PATCH 092/159] Run the environment state in evaluatePackageWith. --- src/Control/Abstract/Modules.hs | 19 ++++++++++--------- src/Data/Abstract/Evaluatable.hs | 16 +++++++++------- 2 files changed, 19 insertions(+), 16 deletions(-) diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index fb22b61bd..2853de21f 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -23,6 +23,7 @@ import Data.Abstract.Environment import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import Data.Language +import Data.Tuple (swap) import Prologue -- | Retrieve an evaluated module, if any. The outer 'Maybe' indicates whether we’ve begun loading the module or not, while the inner 'Maybe' indicates whether we’ve completed loading it or not. Thus, @Nothing@ means we’ve never tried to load it, @Just Nothing@ means we’ve started but haven’t yet finished loading it, and @Just (Just (env, value))@ indicates the result of a completed load. @@ -47,11 +48,11 @@ require path = lookupModule path >>= maybeM (load path) -- -- Always loads/evaluates. load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value)) -load = send . Load +load path = fmap swap <$> send (Load path) data Modules address value return where - Load :: ModulePath -> Modules address value (Maybe (Environment address, value)) + Load :: ModulePath -> Modules address value (Maybe (value, Environment address)) Lookup :: ModulePath -> Modules address value (Maybe (Maybe (Environment address, value))) Resolve :: [FilePath] -> Modules address value (Maybe ModulePath) List :: FilePath -> Modules address value [ModulePath] @@ -64,7 +65,7 @@ runModules :: forall term address value effects a , Member (State (ModuleTable (Maybe (Environment address, value)))) effects , Member Trace effects ) - => (Module term -> Evaluator address value (Modules address value ': effects) (Environment address, value)) + => (Module term -> Evaluator address value (Modules address value ': effects) (value, Environment address)) -> Evaluator address value (Modules address value ': effects) a -> Evaluator address value (Reader (ModuleTable [Module term]) ': effects) a runModules evaluateModule = go @@ -92,19 +93,19 @@ runModules evaluateModule = go getModuleTable :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => Evaluator address value effects (ModuleTable (Maybe (Environment address, value))) getModuleTable = get -cacheModule :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => ModulePath -> Maybe (Environment address, value) -> Evaluator address value effects (Maybe (Environment address, value)) -cacheModule path result = modify' (ModuleTable.insert path result) $> result +cacheModule :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => ModulePath -> Maybe (value, Environment address) -> Evaluator address value effects (Maybe (value, Environment address)) +cacheModule path result = modify' (ModuleTable.insert path (swap <$> result)) $> result askModuleTable :: Member (Reader (ModuleTable [Module term])) effects => Evaluator address value effects (ModuleTable [Module term]) askModuleTable = ask -newtype Merging m address value = Merging { runMerging :: m (Maybe (Environment address, value)) } +newtype Merging m address value = Merging { runMerging :: m (Maybe (value, Environment address)) } instance Applicative m => Semigroup (Merging m address value) where Merging a <> Merging b = Merging (merge <$> a <*> b) where merge a b = mergeJusts <$> a <*> b <|> a <|> b - mergeJusts (env1, _) (env2, v) = (mergeEnvs env1 env2, v) + mergeJusts (_, env1) (v, env2) = (v, mergeEnvs env1 env2) instance Applicative m => Monoid (Merging m address value) where mappend = (<>) @@ -113,7 +114,7 @@ instance Applicative m => Monoid (Merging m address value) where -- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name. data LoadError address value resume where - ModuleNotFound :: ModulePath -> LoadError address value (Maybe (Environment address, value)) + ModuleNotFound :: ModulePath -> LoadError address value (Maybe (value, Environment address)) deriving instance Eq (LoadError address value resume) deriving instance Show (LoadError address value resume) @@ -122,7 +123,7 @@ instance Show1 (LoadError address value) where instance Eq1 (LoadError address value) where liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b -moduleNotFound :: Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value)) +moduleNotFound :: Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (value, Environment address)) moduleNotFound = throwResumable . ModuleNotFound resumeLoadError :: Member (Resumable (LoadError address value)) effects => Evaluator address value effects a -> (forall resume . LoadError address value resume -> Evaluator address value effects resume) -> Evaluator address value effects a diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index bb7d52b03..c74e2af57 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -85,7 +85,6 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer , Member Fresh outer , Member (Resumable (AddressError address value)) outer , Member (Resumable (LoadError address value)) outer - , Member (State (Environment address)) outer , Member (State (Exports address)) outer , Member (State (Heap address (Cell address) value)) outer , Member (State (ModuleTable (Maybe (Environment address, value)))) outer @@ -98,7 +97,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer => (SubtermAlgebra Module term (TermEvaluator term address value inner value) -> SubtermAlgebra Module term (TermEvaluator term address value inner value)) -> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value))) -> Package term - -> TermEvaluator term address value outer [value] + -> TermEvaluator term address value outer [(value, Environment address)] evaluatePackageWith analyzeModule analyzeTerm package = runReader (packageInfo package) . runReader lowerBound @@ -119,22 +118,22 @@ evaluatePackageWith analyzeModule analyzeTerm package runInModule preludeEnv info = runReader info . raiseHandler runAllocator - . raiseHandler (runEnv preludeEnv) + . raiseHandler (runEnvState preludeEnv) . raiseHandler runReturn . raiseHandler runLoopControl - evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' value + evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' (value, Environment address) evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do v <- maybe unit snd <$> require m maybe (pure v) ((`call` []) <=< variable) sym evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule emptyEnv)) $ do _ <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit)) - fst <$> evalModule emptyEnv prelude + evalModule emptyEnv prelude withPrelude Nothing f = f emptyEnv withPrelude (Just prelude) f = do - preludeEnv <- evalPrelude prelude + (_, preludeEnv) <- evalPrelude prelude f preludeEnv -- TODO: If the set of exports is empty because no exports have been @@ -143,7 +142,10 @@ evaluatePackageWith analyzeModule analyzeTerm package filterEnv ports env | Exports.null ports = env | otherwise = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env - pairValueWithEnv action = flip (,) <$> action <*> (filterEnv <$> TermEvaluator getExports <*> TermEvaluator (get @(Environment address))) + pairValueWithEnv action = do + (a, env) <- action + filtered <- filterEnv <$> TermEvaluator getExports <*> pure env + pure (a, filtered) -- | Isolate the given action with an empty global environment and exports. From 152ba7f5491a8e4f26cc303f3c9243143a0bfdcb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 13:52:39 -0400 Subject: [PATCH 093/159] Placate hlint. --- src/Language/PHP/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 492e5159a..8b8e47c5c 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -48,7 +48,7 @@ resolvePHPName :: ( Member (Modules address value) effects -> Evaluator address value effects ModulePath resolvePHPName n = do modulePath <- resolve [name] - maybe (throwResumable $ NotFoundError name [name] Language.PHP) pure modulePath + maybeM (throwResumable $ NotFoundError name [name] Language.PHP) modulePath where name = toName n toName = BC.unpack . dropRelativePrefix . stripQuotes From 36dabb27e65477c0100003c24568052c105512e9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 13:53:55 -0400 Subject: [PATCH 094/159] We can use fromMaybe now. --- src/Language/PHP/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 8b8e47c5c..71094fe68 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -68,7 +68,7 @@ include pathTerm f = do name <- subtermValue pathTerm >>= asString path <- resolvePHPName name traceResolve name path - (importedEnv, v) <- isolate (f path) >>= maybeM (pure (emptyEnv, unit)) + (importedEnv, v) <- fromMaybe (emptyEnv, unit) <$> isolate (f path) bindAll importedEnv pure (Rval v) From 0e6db98fa5bbd8f64a9f35a1c2c0856676326210 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 13:58:10 -0400 Subject: [PATCH 095/159] =?UTF-8?q?We=20shouldn=E2=80=99t=20need=20to=20is?= =?UTF-8?q?olate=20any=20more.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Language/Go/Syntax.hs | 6 +++--- src/Language/PHP/Syntax.hs | 3 +-- src/Language/Python/Syntax.hs | 13 ++++++------- src/Language/Ruby/Syntax.hs | 5 ++--- src/Language/TypeScript/Syntax.hs | 9 ++++----- 5 files changed, 16 insertions(+), 20 deletions(-) diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index b7ca2ab16..c9ab540a5 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -69,7 +69,7 @@ instance Evaluatable Import where paths <- resolveGoImport importPath for_ paths $ \path -> do traceResolve (unPath importPath) path - importedEnv <- maybe emptyEnv fst <$> isolate (require path) + importedEnv <- maybe emptyEnv fst <$> require path bindAll importedEnv pure (Rval unit) @@ -93,7 +93,7 @@ instance Evaluatable QualifiedImport where void $ letrec' alias $ \addr -> do for_ paths $ \p -> do traceResolve (unPath importPath) p - importedEnv <- maybe emptyEnv fst <$> isolate (require p) + importedEnv <- maybe emptyEnv fst <$> require p bindAll importedEnv makeNamespace alias addr Nothing pure (Rval unit) @@ -112,7 +112,7 @@ instance Evaluatable SideEffectImport where eval (SideEffectImport importPath _) = do paths <- resolveGoImport importPath traceResolve (unPath importPath) paths - for_ paths $ \path -> isolate (require path) + for_ paths require pure (Rval unit) -- A composite literal in Go diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 71094fe68..2dd1175fb 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -58,7 +58,6 @@ include :: ( AbstractValue address value effects , Member (Modules address value) effects , Member (Resumable ResolutionError) effects , Member (Resumable (EnvironmentError address)) effects - , Member (State (Exports address)) effects , Member Trace effects ) => Subterm term (Evaluator address value effects (ValueRef value)) @@ -68,7 +67,7 @@ include pathTerm f = do name <- subtermValue pathTerm >>= asString path <- resolvePHPName name traceResolve name path - (importedEnv, v) <- fromMaybe (emptyEnv, unit) <$> isolate (f path) + (importedEnv, v) <- fromMaybe (emptyEnv, unit) <$> f path bindAll importedEnv pure (Rval v) diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 91c1651ce..9caa04fd0 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -112,11 +112,11 @@ instance Evaluatable Import where modulePaths <- resolvePythonModules name -- Eval parent modules first - for_ (NonEmpty.init modulePaths) (isolate . require) + for_ (NonEmpty.init modulePaths) require -- Last module path is the one we want to import let path = NonEmpty.last modulePaths - importedEnv <- maybe emptyEnv fst <$> isolate (require path) + importedEnv <- maybe emptyEnv fst <$> require path bindAll (select importedEnv) pure (Rval unit) where @@ -130,14 +130,13 @@ evalQualifiedImport :: ( AbstractValue address value effects , Member (Allocator address value) effects , Member (Env address) effects , Member (Modules address value) effects - , Member (State (Exports address)) effects , Member (State (Heap address (Cell address) value)) effects , Ord address , Reducer.Reducer value (Cell address value) ) => Name -> ModulePath -> Evaluator address value effects value evalQualifiedImport name path = letrec' name $ \addr -> do - importedEnv <- maybe emptyEnv fst <$> isolate (require path) + importedEnv <- maybe emptyEnv fst <$> require path bindAll importedEnv unit <$ makeNamespace name addr Nothing @@ -161,7 +160,7 @@ instance Evaluatable QualifiedImport where go ((name, path) :| []) = evalQualifiedImport name path -- Evaluate each parent module, just creating a namespace go ((name, path) :| xs) = letrec' name $ \addr -> do - void $ isolate (require path) + void $ require path void $ go (NonEmpty.fromList xs) makeNamespace name addr Nothing @@ -180,13 +179,13 @@ instance Evaluatable QualifiedAliasedImport where modulePaths <- resolvePythonModules name -- Evaluate each parent module - for_ (NonEmpty.init modulePaths) (isolate . require) + for_ (NonEmpty.init modulePaths) require -- Evaluate and import the last module, aliasing and updating the environment alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm) Rval <$> letrec' alias (\addr -> do let path = NonEmpty.last modulePaths - importedEnv <- maybe emptyEnv fst <$> isolate (require path) + importedEnv <- maybe emptyEnv fst <$> require path bindAll importedEnv unit <$ makeNamespace alias addr Nothing) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index aeb76ece3..ec39e7577 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -73,7 +73,7 @@ instance Evaluatable Require where name <- subtermValue x >>= asString path <- resolveRubyName name traceResolve name path - (importedEnv, v) <- isolate (doRequire path) + (importedEnv, v) <- doRequire path bindAll importedEnv pure (Rval v) -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require @@ -112,7 +112,6 @@ doLoad :: ( AbstractValue address value effects , Member (Env address) effects , Member (Modules address value) effects , Member (Resumable ResolutionError) effects - , Member (State (Exports address)) effects , Member Trace effects ) => ByteString @@ -121,7 +120,7 @@ doLoad :: ( AbstractValue address value effects doLoad path shouldWrap = do path' <- resolveRubyPath path traceResolve path path' - importedEnv <- maybe emptyEnv fst <$> isolate (load path') + importedEnv <- maybe emptyEnv fst <$> load path' unless shouldWrap $ bindAll importedEnv pure (boolean Prelude.True) -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 7082fa8a2..ffe8b85ac 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -136,7 +136,6 @@ evalRequire :: ( AbstractValue address value effects , Member (Allocator address value) effects , Member (Env address) effects , Member (Modules address value) effects - , Member (State (Exports address)) effects , Member (State (Heap address (Cell address) value)) effects , Ord address , Reducer value (Cell address value) @@ -145,7 +144,7 @@ evalRequire :: ( AbstractValue address value effects -> Name -> Evaluator address value effects value evalRequire modulePath alias = letrec' alias $ \addr -> do - importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath) + importedEnv <- maybe emptyEnv fst <$> require modulePath bindAll importedEnv unit <$ makeNamespace alias addr Nothing @@ -162,7 +161,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Import where eval (Import symbols importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath) + importedEnv <- maybe emptyEnv fst <$> require modulePath bindAll (renamed importedEnv) $> Rval unit where renamed importedEnv @@ -212,7 +211,7 @@ instance ToJSONFields1 SideEffectImport instance Evaluatable SideEffectImport where eval (SideEffectImport importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - void $ isolate (require modulePath) + void $ require modulePath pure (Rval unit) @@ -247,7 +246,7 @@ instance ToJSONFields1 QualifiedExportFrom instance Evaluatable QualifiedExportFrom where eval (QualifiedExportFrom importPath exportSymbols) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath) + importedEnv <- maybe emptyEnv fst <$> require modulePath -- Look up addresses in importedEnv and insert the aliases with addresses into the exports. for_ exportSymbols $ \(name, alias) -> do let address = Env.lookup name importedEnv From 728829afb090180693d683ef09a6f8827c8f7230 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 13:58:37 -0400 Subject: [PATCH 096/159] :fire: isolate. --- src/Data/Abstract/Evaluatable.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index c74e2af57..2aee4c875 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -3,7 +3,6 @@ module Data.Abstract.Evaluatable ( module X , Evaluatable(..) , evaluatePackageWith -, isolate , traceResolve -- | Effects , EvalError(..) @@ -148,10 +147,6 @@ evaluatePackageWith analyzeModule analyzeTerm package pure (a, filtered) --- | Isolate the given action with an empty global environment and exports. -isolate :: (Member (Env address) effects, Member (State (Exports address)) effects) => Evaluator address value effects a -> Evaluator address value effects a -isolate = withEnv lowerBound . withExports lowerBound - traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects () traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) From c9360b2c61c924e903adaceed55add439b2bcbca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:00:29 -0400 Subject: [PATCH 097/159] Compose runState on to deal with the state. --- src/Control/Abstract/Environment.hs | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 06255097b..a62dedaf5 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -96,18 +96,10 @@ reinterpretEnv :: Evaluator address value (Env address ': effects) a -> Evaluator address value (State (Environment address) ': effects) a reinterpretEnv = reinterpret handleEnv -runEnvState :: forall address value effects a - . Environment address +runEnvState :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects (a, Environment address) -runEnvState initial = relayState initial (\ s a -> pure (a, s)) $ \ s eff yield -> case eff of - Lookup name -> yield s (Env.lookup name s) - Bind name addr -> yield (Env.insert name addr s) () - Close names -> yield s (Env.intersect names s) - Push -> yield (Env.push @address s) () - Pop -> yield (Env.pop @address s) () - GetEnv -> yield s s - PutEnv e -> yield e () +runEnvState initial = runState initial . reinterpretEnv -- | Errors involving the environment. From adfa93f6c98c018d850191fef80f3e141862aaea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:03:19 -0400 Subject: [PATCH 098/159] :fire: withEnv. --- src/Control/Abstract/Environment.hs | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index a62dedaf5..845802051 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -3,7 +3,6 @@ module Control.Abstract.Environment ( Environment , getEnv , putEnv -, withEnv , lookupEnv , bind , bindAll @@ -33,15 +32,6 @@ getEnv = send GetEnv putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects () putEnv = send . PutEnv --- | Sets the environment for the lifetime of the given action. -withEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a -withEnv env m = do - oldEnv <- getEnv - putEnv env - result <- m - putEnv oldEnv - pure result - -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. lookupEnv :: Member (Env address) effects => Name -> Evaluator address value effects (Maybe address) From 10d94548955c91f8b2b93edc13aa453e4347c579 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:05:42 -0400 Subject: [PATCH 099/159] Converge locally w.r.t. the environment. --- src/Analysis/Abstract/Caching.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 05c3fd135..aaf19fe21 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -93,7 +93,7 @@ convergingModules :: ( AbstractValue address value effects convergingModules recur m = do c <- getConfiguration (subterm (moduleBody m)) -- Convergence here is predicated upon an Eq instance, not α-equivalence - cache <- converge lowerBound (\ prevCache -> isolateCache $ do + cache <- converge lowerBound (\ prevCache -> isolateCache $ raiseHandler locally $ do TermEvaluator (putEnv (configurationEnvironment c)) TermEvaluator (putHeap (configurationHeap c)) -- We need to reset fresh generation so that this invocation converges. From 19d4ebefa49c68bfcd1664ada8ff1021ad4e49aa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:08:57 -0400 Subject: [PATCH 100/159] :fire: putEnv. --- src/Analysis/Abstract/Caching.hs | 1 - src/Control/Abstract/Environment.hs | 7 ------- 2 files changed, 8 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index aaf19fe21..f9056858a 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -94,7 +94,6 @@ convergingModules recur m = do c <- getConfiguration (subterm (moduleBody m)) -- Convergence here is predicated upon an Eq instance, not α-equivalence cache <- converge lowerBound (\ prevCache -> isolateCache $ raiseHandler locally $ do - TermEvaluator (putEnv (configurationEnvironment c)) TermEvaluator (putHeap (configurationHeap c)) -- We need to reset fresh generation so that this invocation converges. resetFresh 0 $ diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 845802051..6da2bd8f9 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -2,7 +2,6 @@ module Control.Abstract.Environment ( Environment , getEnv -, putEnv , lookupEnv , bind , bindAll @@ -28,10 +27,6 @@ import Prologue getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) getEnv = send GetEnv --- | Set the environment. -putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects () -putEnv = send . PutEnv - -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. lookupEnv :: Member (Env address) effects => Name -> Evaluator address value effects (Maybe address) @@ -62,7 +57,6 @@ data Env address return where Push :: Env address () Pop :: Env address () GetEnv :: Env address (Environment address) - PutEnv :: Environment address -> Env address () handleEnv :: forall address effects value result . Member (State (Environment address)) effects @@ -75,7 +69,6 @@ handleEnv = \case Push -> modify (Env.push @address) Pop -> modify (Env.pop @address) GetEnv -> get - PutEnv e -> put e runEnv :: Member (State (Environment address)) effects => Evaluator address value (Env address ': effects) a From f9ea94b8dae76817b2d83699b15ed6d8fcdaa1b0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:09:07 -0400 Subject: [PATCH 101/159] Placate hlint. --- src/Control/Abstract/Heap.hs | 2 +- src/Language/Python/Syntax.hs | 2 +- src/Language/Ruby/Syntax.hs | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 152a9c9e4..6650abb55 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -66,7 +66,7 @@ lookupOrAlloc :: ( Member (Allocator address value) effects ) => Name -> Evaluator address value effects address -lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure +lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name) letrec :: ( Member (Allocator address value) effects diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 9caa04fd0..9a1de3925 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -81,7 +81,7 @@ resolvePythonModules q = do , path <.> ".py" ] modulePath <- resolve searchPaths - maybe (throwResumable $ NotFoundError path searchPaths Language.Python) pure modulePath + maybeM (throwResumable $ NotFoundError path searchPaths Language.Python) modulePath -- | Import declarations (symbols are added directly to the calling environment). diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index ec39e7577..1eb89f5cd 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -26,7 +26,7 @@ resolveRubyName name = do let name' = cleanNameOrPath name let paths = [name' <.> "rb"] modulePath <- resolve paths - maybe (throwResumable $ NotFoundError name' paths Language.Ruby) pure modulePath + maybeM (throwResumable $ NotFoundError name' paths Language.Ruby) modulePath -- load "/root/src/file.rb" resolveRubyPath :: ( Member (Modules address value) effects @@ -37,7 +37,7 @@ resolveRubyPath :: ( Member (Modules address value) effects resolveRubyPath path = do let name' = cleanNameOrPath path modulePath <- resolve [name'] - maybe (throwResumable $ NotFoundError name' [name'] Language.Ruby) pure modulePath + maybeM (throwResumable $ NotFoundError name' [name'] Language.Ruby) modulePath cleanNameOrPath :: ByteString -> String cleanNameOrPath = BC.unpack . dropRelativePrefix . stripQuotes From 5d9b9657d762f0df8de5cbbef4ad4223702a9d5b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:15:32 -0400 Subject: [PATCH 102/159] Dedent. --- src/Control/Abstract/Environment.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 6da2bd8f9..d13399306 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -51,12 +51,12 @@ close :: Member (Env address) effects => Set Name -> Evaluator address value eff close = send . Close data Env address return where - Lookup :: Name -> Env address (Maybe address) - Bind :: Name -> address -> Env address () - Close :: Set Name -> Env address (Environment address) - Push :: Env address () - Pop :: Env address () - GetEnv :: Env address (Environment address) + Lookup :: Name -> Env address (Maybe address) + Bind :: Name -> address -> Env address () + Close :: Set Name -> Env address (Environment address) + Push :: Env address () + Pop :: Env address () + GetEnv :: Env address (Environment address) handleEnv :: forall address effects value result . Member (State (Environment address)) effects From f4c33d4d8fd087e301dd762a554d391c6f450fcf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:19:39 -0400 Subject: [PATCH 103/159] =?UTF-8?q?Don=E2=80=99t=20export=20modifyExports.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Exports.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs index 5ad8bc1f3..a296acd9a 100644 --- a/src/Control/Abstract/Exports.hs +++ b/src/Control/Abstract/Exports.hs @@ -2,7 +2,6 @@ module Control.Abstract.Exports ( Exports , getExports , putExports -, modifyExports , addExport , withExports ) where From 7d67ee390539b621419db81077391e0295d8a797 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:20:01 -0400 Subject: [PATCH 104/159] :fire: putExports. --- src/Control/Abstract/Exports.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs index a296acd9a..847a2cd45 100644 --- a/src/Control/Abstract/Exports.hs +++ b/src/Control/Abstract/Exports.hs @@ -1,7 +1,6 @@ module Control.Abstract.Exports ( Exports , getExports -, putExports , addExport , withExports ) where @@ -14,10 +13,6 @@ import Data.Abstract.Name getExports :: Member (State (Exports address)) effects => Evaluator address value effects (Exports address) getExports = get --- | Set the global export state. -putExports :: Member (State (Exports address)) effects => Exports address -> Evaluator address value effects () -putExports = put - -- | Update the global export state. modifyExports :: Member (State (Exports address)) effects => (Exports address -> Exports address) -> Evaluator address value effects () modifyExports = modify' From 3ae5cc171ade7392fb378607c21f017ae795a0fe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:20:23 -0400 Subject: [PATCH 105/159] :fire: withExports. --- src/Control/Abstract/Exports.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs index 847a2cd45..15059cfbc 100644 --- a/src/Control/Abstract/Exports.hs +++ b/src/Control/Abstract/Exports.hs @@ -2,7 +2,6 @@ module Control.Abstract.Exports ( Exports , getExports , addExport -, withExports ) where import Control.Abstract.Evaluator @@ -20,7 +19,3 @@ modifyExports = modify' -- | Add an export to the global export state. addExport :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () addExport name alias = modifyExports . insert name alias - --- | Sets the global export state for the lifetime of the given action. -withExports :: Member (State (Exports address)) effects => Exports address -> Evaluator address value effects a -> Evaluator address value effects a -withExports = localState . const From eff98cfb03720a19eb5f1c2f4ab85f69ce69dbed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:21:13 -0400 Subject: [PATCH 106/159] :fire: modifyExports. --- src/Control/Abstract/Exports.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs index 15059cfbc..cec8701ad 100644 --- a/src/Control/Abstract/Exports.hs +++ b/src/Control/Abstract/Exports.hs @@ -12,10 +12,6 @@ import Data.Abstract.Name getExports :: Member (State (Exports address)) effects => Evaluator address value effects (Exports address) getExports = get --- | Update the global export state. -modifyExports :: Member (State (Exports address)) effects => (Exports address -> Exports address) -> Evaluator address value effects () -modifyExports = modify' - -- | Add an export to the global export state. addExport :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () -addExport name alias = modifyExports . insert name alias +addExport name alias = modify' . insert name alias From 11a92c0cb6d1e5b14617cf3e090977dc057d4e30 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:27:32 -0400 Subject: [PATCH 107/159] Move getExports & addExport into Control.Abstract.Environment. --- semantic.cabal | 1 - src/Control/Abstract.hs | 1 - src/Control/Abstract/Environment.hs | 12 ++++++++++++ src/Control/Abstract/Exports.hs | 17 ----------------- src/Data/Abstract/Evaluatable.hs | 1 - 5 files changed, 12 insertions(+), 20 deletions(-) delete mode 100644 src/Control/Abstract/Exports.hs diff --git a/semantic.cabal b/semantic.cabal index 1aa7f9d1f..83c6a7d23 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -41,7 +41,6 @@ library , Control.Abstract.Context , Control.Abstract.Environment , Control.Abstract.Evaluator - , Control.Abstract.Exports , Control.Abstract.Heap , Control.Abstract.Hole , Control.Abstract.Matching diff --git a/src/Control/Abstract.hs b/src/Control/Abstract.hs index d33e384ff..6c6ad0cc1 100644 --- a/src/Control/Abstract.hs +++ b/src/Control/Abstract.hs @@ -7,7 +7,6 @@ import Control.Abstract.Configuration as X import Control.Abstract.Context as X import Control.Abstract.Environment as X hiding (Lookup) import Control.Abstract.Evaluator as X -import Control.Abstract.Exports as X import Control.Abstract.Heap as X import Control.Abstract.Hole as X import Control.Abstract.Modules as X diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index d13399306..12171c8f4 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -1,7 +1,10 @@ {-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-} module Control.Abstract.Environment ( Environment +, Exports , getEnv +, getExports +, addExport , lookupEnv , bind , bindAll @@ -19,6 +22,7 @@ module Control.Abstract.Environment import Control.Abstract.Evaluator import Data.Abstract.Environment (Environment) +import Data.Abstract.Exports import qualified Data.Abstract.Environment as Env import Data.Abstract.Name import Prologue @@ -27,6 +31,14 @@ import Prologue getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) getEnv = send GetEnv +-- | Get the global export state. +getExports :: Member (State (Exports address)) effects => Evaluator address value effects (Exports address) +getExports = get + +-- | Add an export to the global export state. +addExport :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () +addExport name alias = modify' . insert name alias + -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. lookupEnv :: Member (Env address) effects => Name -> Evaluator address value effects (Maybe address) diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs deleted file mode 100644 index cec8701ad..000000000 --- a/src/Control/Abstract/Exports.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Control.Abstract.Exports -( Exports -, getExports -, addExport -) where - -import Control.Abstract.Evaluator -import Data.Abstract.Exports -import Data.Abstract.Name - --- | Get the global export state. -getExports :: Member (State (Exports address)) effects => Evaluator address value effects (Exports address) -getExports = get - --- | Add an export to the global export state. -addExport :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () -addExport name alias = modify' . insert name alias diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 2aee4c875..99321e541 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -19,7 +19,6 @@ import Control.Abstract import Control.Abstract.Context as X import Control.Abstract.Environment as X hiding (runEnvironmentError, runEnvironmentErrorWith) import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn) -import Control.Abstract.Exports as X import Control.Abstract.Heap as X hiding (AddressError(..), runAddressError, runAddressErrorWith) import Control.Abstract.Modules as X (Modules, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve) import Control.Abstract.Value as X From 6a3f4ba6898e3c6ed8d2286fcc2b9f50d408b8ea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:30:02 -0400 Subject: [PATCH 108/159] Rename addExport to export. --- src/Control/Abstract/Environment.hs | 6 +++--- src/Language/TypeScript/Syntax.hs | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 12171c8f4..253834aa2 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -4,7 +4,7 @@ module Control.Abstract.Environment , Exports , getEnv , getExports -, addExport +, export , lookupEnv , bind , bindAll @@ -36,8 +36,8 @@ getExports :: Member (State (Exports address)) effects => Evaluator address valu getExports = get -- | Add an export to the global export state. -addExport :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () -addExport name alias = modify' . insert name alias +export :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () +export name alias = modify' . insert name alias -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index ffe8b85ac..9cd3fe0cc 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -229,7 +229,7 @@ instance Evaluatable QualifiedExport where eval (QualifiedExport exportSymbols) = do -- Insert the aliases with no addresses. for_ exportSymbols $ \(name, alias) -> - addExport name alias Nothing + export name alias Nothing pure (Rval unit) @@ -250,7 +250,7 @@ instance Evaluatable QualifiedExportFrom where -- Look up addresses in importedEnv and insert the aliases with addresses into the exports. for_ exportSymbols $ \(name, alias) -> do let address = Env.lookup name importedEnv - maybe (throwEvalError $ ExportError modulePath name) (addExport name alias . Just) address + maybe (throwEvalError $ ExportError modulePath name) (export name alias . Just) address pure (Rval unit) newtype DefaultExport a = DefaultExport { defaultExport :: a } @@ -269,7 +269,7 @@ instance Evaluatable DefaultExport where Just name -> do addr <- lookupOrAlloc name assign addr v - addExport name name Nothing + export name name Nothing bind name addr Nothing -> throwEvalError DefaultExportError pure (Rval unit) From e82b90fba2f098c6cea51f423c8e182f0c865ced Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 30 May 2018 14:48:31 -0400 Subject: [PATCH 109/159] Use Named1 instance --- src/Data/Syntax.hs | 12 ++++++------ src/Data/Syntax/Literal.hs | 14 +++++++------- src/Data/Term.hs | 4 ++-- vendor/proto3-suite | 2 +- 4 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 4332fd4dd..b59d772ac 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -103,18 +103,18 @@ infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack, -> m (Sum fs (Term (Sum fs) a)) infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right -instance (Apply Message1 fs, Generate Message1 fs fs, Generate GenericNamed fs fs) => Message1 (Sum fs) where +instance (Apply Message1 fs, Generate Message1 fs fs, Generate Named1 fs fs) => Message1 (Sum fs) where liftEncodeMessage encodeMessage num fs = apply @Message1 (liftEncodeMessage encodeMessage num) fs liftDecodeMessage decodeMessage num = oneof undefined listOfParsers where listOfParsers = generate @Message1 @fs @fs (\ (proxy :: proxy f) i -> let num = FieldNumber (fromInteger (succ i)) in [(num, fromJust <$> embedded (inject @f @fs <$> liftDecodeMessage decodeMessage num))]) liftDotProto _ = - [Proto.DotProtoMessageOneOf (Proto.Single "syntax") (generate @GenericNamed @fs @fs (\ (proxy :: proxy f) i -> + [Proto.DotProtoMessageOneOf (Proto.Single "syntax") (generate @Named1 @fs @fs (\ (proxy :: proxy f) i -> let num = FieldNumber (fromInteger (succ i)) - fieldType = Proto.Prim (Proto.Named . Proto.Single $ genericNameOf (Proxy @f)) - fieldName = Proto.Single (camelCase $ genericNameOf (Proxy @f)) + fieldType = Proto.Prim (Proto.Named . Proto.Single $ nameOf1 (Proxy @f)) + fieldName = Proto.Single (camelCase $ nameOf1 (Proxy @f)) camelCase (x : xs) = toLower x : xs camelCase [] = [] in @@ -133,7 +133,7 @@ instance (Element f all, c f, Generate c all fs) => Generate c all (f ': fs) whe -- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable). newtype Identifier a = Identifier Name - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, Named) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, Named1) instance Eq1 Identifier where liftEq = genericLiftEq instance Ord1 Identifier where liftCompare = genericLiftCompare @@ -180,7 +180,7 @@ instance Evaluatable AccessibilityModifier -- -- This can be used to represent an implicit no-op, e.g. the alternative in an 'if' statement without an 'else'. data Empty a = Empty - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1) instance ToJSONFields1 Empty diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 788eca37e..428bac00d 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -15,7 +15,7 @@ import Text.Read (readMaybe) -- Boolean newtype Boolean a = Boolean { booleanContent :: Bool } - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1) true :: Boolean a true = Boolean True @@ -58,7 +58,7 @@ instance ToJSONFields1 Data.Syntax.Literal.Integer where -- | A literal float of unspecified width. newtype Float a = Float { floatContent :: ByteString } - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1) instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare @@ -134,7 +134,7 @@ instance ToJSONFields1 InterpolationElement -- | A sequence of textual contents within a string literal. newtype TextElement a = TextElement { textElementContent :: ByteString } - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1) instance Eq1 TextElement where liftEq = genericLiftEq instance Ord1 TextElement where liftCompare = genericLiftCompare @@ -147,7 +147,7 @@ instance Evaluatable TextElement where eval (TextElement x) = pure (Rval (string x)) data Null a = Null - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1) instance Eq1 Null where liftEq = genericLiftEq instance Ord1 Null where liftCompare = genericLiftCompare @@ -190,7 +190,7 @@ instance Evaluatable Regex -- Collections newtype Array a = Array { arrayElements :: [a] } - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1) instance Eq1 Array where liftEq = genericLiftEq instance Ord1 Array where liftCompare = genericLiftCompare @@ -202,7 +202,7 @@ instance Evaluatable Array where eval (Array a) = Rval <$> (array =<< traverse subtermValue a) newtype Hash a = Hash { hashElements :: [a] } - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1) instance Eq1 Hash where liftEq = genericLiftEq instance Ord1 Hash where liftCompare = genericLiftCompare @@ -214,7 +214,7 @@ instance Evaluatable Hash where eval t = Rval . hash <$> traverse (subtermValue >=> asPair) (hashElements t) data KeyValue a = KeyValue { key :: !a, value :: !a } - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1) instance Eq1 KeyValue where liftEq = genericLiftEq instance Ord1 KeyValue where liftCompare = genericLiftCompare diff --git a/src/Data/Term.hs b/src/Data/Term.hs index 232cf2f9e..116cb7944 100644 --- a/src/Data/Term.hs +++ b/src/Data/Term.hs @@ -79,12 +79,12 @@ instance Show1 f => Show1 (Term f) where instance (Show1 f, Show a) => Show (Term f a) where showsPrec = showsPrec1 -instance (Message1 f) => Message (Term f ()) where +instance Message1 f => Message (Term f ()) where encodeMessage num (Term (In _ f)) = liftEncodeMessage encodeMessage num f decodeMessage num = termIn () <$> liftDecodeMessage decodeMessage num dotProto _ = liftDotProto (Proxy @(f (Term f ()))) -instance Named (Term f ()) where +instance Named (Term f a) where nameOf _ = "Term" instance Ord1 f => Ord1 (Term f) where diff --git a/vendor/proto3-suite b/vendor/proto3-suite index 5598f2209..d5a32ec02 160000 --- a/vendor/proto3-suite +++ b/vendor/proto3-suite @@ -1 +1 @@ -Subproject commit 5598f2209d3baa0494f790e1b8e402d8e4f7b9af +Subproject commit d5a32ec02cad44383fa2e2aaff2cedc0bbc752e8 From 9393a000f04677651eec0701cc11fd7a068a37a5 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 30 May 2018 15:07:31 -0400 Subject: [PATCH 110/159] ++proto3-suite --- vendor/proto3-suite | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/proto3-suite b/vendor/proto3-suite index d5a32ec02..f5378dabf 160000 --- a/vendor/proto3-suite +++ b/vendor/proto3-suite @@ -1 +1 @@ -Subproject commit d5a32ec02cad44383fa2e2aaff2cedc0bbc752e8 +Subproject commit f5378dabf599e7acf02a2ac23bd9788485d43bfc From 0f6ad38a4e3f8683de28a8842ae34d3e27206d3d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:11:24 -0400 Subject: [PATCH 111/159] Move export into Env. --- src/Control/Abstract/Environment.hs | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 253834aa2..50d089db2 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -22,9 +22,10 @@ module Control.Abstract.Environment import Control.Abstract.Evaluator import Data.Abstract.Environment (Environment) -import Data.Abstract.Exports import qualified Data.Abstract.Environment as Env +import Data.Abstract.Exports as Exports import Data.Abstract.Name +import Data.Semilattice.Lower import Prologue -- | Retrieve the environment. @@ -69,9 +70,12 @@ data Env address return where Push :: Env address () Pop :: Env address () GetEnv :: Env address (Environment address) + Export :: Name -> Name -> Maybe address -> Env address () handleEnv :: forall address effects value result - . Member (State (Environment address)) effects + . ( Member (State (Environment address)) effects + , Member (State (Exports address)) effects + ) => Env address result -> Evaluator address value effects result handleEnv = \case @@ -81,20 +85,23 @@ handleEnv = \case Push -> modify (Env.push @address) Pop -> modify (Env.pop @address) GetEnv -> get + Export name alias addr -> modify (Exports.insert name alias addr) -runEnv :: Member (State (Environment address)) effects +runEnv :: ( Member (State (Environment address)) effects + , Member (State (Exports address)) effects + ) => Evaluator address value (Env address ': effects) a -> Evaluator address value effects a runEnv = interpret handleEnv reinterpretEnv :: Evaluator address value (Env address ': effects) a - -> Evaluator address value (State (Environment address) ': effects) a -reinterpretEnv = reinterpret handleEnv + -> Evaluator address value (State (Environment address) ': State (Exports address) ': effects) a +reinterpretEnv = reinterpret2 handleEnv runEnvState :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects (a, Environment address) -runEnvState initial = runState initial . reinterpretEnv +runEnvState initial = fmap fst . runState lowerBound . runState initial . reinterpretEnv -- | Errors involving the environment. From cb961fa994cef243d645f73f9ee83816be19d36d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:14:02 -0400 Subject: [PATCH 112/159] Handle exports in Env. --- src/Control/Abstract/Environment.hs | 8 +++++++- src/Data/Abstract/Evaluatable.hs | 16 +--------------- 2 files changed, 8 insertions(+), 16 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 50d089db2..f13cab6bd 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -101,7 +101,13 @@ reinterpretEnv = reinterpret2 handleEnv runEnvState :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects (a, Environment address) -runEnvState initial = fmap fst . runState lowerBound . runState initial . reinterpretEnv +runEnvState initial = fmap (uncurry filterEnv) . runState lowerBound . runState initial . reinterpretEnv + where -- TODO: If the set of exports is empty because no exports have been + -- defined, do we export all terms, or no terms? This behavior varies across + -- languages. We need better semantics rather than doing it ad-hoc. + filterEnv (a, env) ports + | Exports.null ports = (a, env) + | otherwise = (a, Exports.toEnvironment ports `Env.mergeEnvs` Env.overwrite (Exports.aliases ports) env) -- | Errors involving the environment. diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 99321e541..238b57ebe 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -24,7 +24,6 @@ import Control.Abstract.Modules as X (Modules, ResolutionError(..), load, lookup import Control.Abstract.Value as X import Data.Abstract.Declarations as X import Data.Abstract.Environment as X -import Data.Abstract.Exports as Exports import Data.Abstract.FreeVariables as X import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable @@ -83,7 +82,6 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer , Member Fresh outer , Member (Resumable (AddressError address value)) outer , Member (Resumable (LoadError address value)) outer - , Member (State (Exports address)) outer , Member (State (Heap address (Cell address) value)) outer , Member (State (ModuleTable (Maybe (Environment address, value)))) outer , Member Trace outer @@ -107,8 +105,7 @@ evaluatePackageWith analyzeModule analyzeTerm package $ ModuleTable.toPairs (packageEntryPoints (packageBody package)) where evalModule preludeEnv m - = pairValueWithEnv - . runInModule preludeEnv (moduleInfo m) + = runInModule preludeEnv (moduleInfo m) . analyzeModule (subtermRef . moduleBody) $ evalTerm <$> m evalTerm term = Subterm term (TermEvaluator (value =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term))) @@ -134,17 +131,6 @@ evaluatePackageWith analyzeModule analyzeTerm package (_, preludeEnv) <- evalPrelude prelude f preludeEnv - -- TODO: If the set of exports is empty because no exports have been - -- defined, do we export all terms, or no terms? This behavior varies across - -- languages. We need better semantics rather than doing it ad-hoc. - filterEnv ports env - | Exports.null ports = env - | otherwise = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env - pairValueWithEnv action = do - (a, env) <- action - filtered <- filterEnv <$> TermEvaluator getExports <*> pure env - pure (a, filtered) - traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects () traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) From da79d76872e31c7d5e9dd3d68b36ec2eb1eaff67 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:14:17 -0400 Subject: [PATCH 113/159] :fire: getExports. --- src/Control/Abstract/Environment.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index f13cab6bd..98cb652f1 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -3,7 +3,6 @@ module Control.Abstract.Environment ( Environment , Exports , getEnv -, getExports , export , lookupEnv , bind @@ -32,10 +31,6 @@ import Prologue getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) getEnv = send GetEnv --- | Get the global export state. -getExports :: Member (State (Exports address)) effects => Evaluator address value effects (Exports address) -getExports = get - -- | Add an export to the global export state. export :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () export name alias = modify' . insert name alias From 293d76a32fbc9cf90fab0a68b9995165d7c5b210 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:17:02 -0400 Subject: [PATCH 114/159] export sends Export. --- src/Control/Abstract/Environment.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 98cb652f1..8f1a9c515 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -32,8 +32,8 @@ getEnv :: Member (Env address) effects => Evaluator address value effects (Envir getEnv = send GetEnv -- | Add an export to the global export state. -export :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () -export name alias = modify' . insert name alias +export :: Member (Env address) effects => Name -> Name -> Maybe address -> Evaluator address value effects () +export name alias addr = send (Export name alias addr) -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. From 5bef9603e9342b3b2b9bd3a283bfa11157486e07 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:17:23 -0400 Subject: [PATCH 115/159] :fire: the export effect in Evaluatable instances. --- 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 238b57ebe..6e55cd876 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -64,7 +64,6 @@ type EvaluatableConstraints address term value effects = , Member (Resumable ResolutionError) effects , Member (Resumable (Unspecialized value)) effects , Member (Return value) effects - , Member (State (Exports address)) effects , Member (State (Heap address (Cell address) value)) effects , Member Trace effects , Ord address From d01ef4e0b73f97cb8bcf12600c1885cbf54caeb1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:17:35 -0400 Subject: [PATCH 116/159] :fire: the exports in the evaluating state. --- src/Analysis/Abstract/Evaluating.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index c126f5e1d..7af44030c 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -12,7 +12,6 @@ data EvaluatingState address value = EvaluatingState { environment :: Environment address , heap :: Heap address (Cell address) value , modules :: ModuleTable (Maybe (Environment address, value)) - , exports :: Exports address } deriving instance (Eq (Cell address value), Eq address, Eq value) => Eq (EvaluatingState address value) @@ -26,12 +25,10 @@ evaluating :: Evaluator address value ': State (Environment address) ': State (Heap address (Cell address) value) ': State (ModuleTable (Maybe (Environment address, value))) - ': State (Exports address) ': effects) result -> Evaluator address value effects (Either String result, EvaluatingState address value) evaluating - = fmap (\ ((((result, env), heap), modules), exports) -> (result, EvaluatingState env heap modules exports)) - . runState lowerBound -- State (Exports address) + = fmap (\ (((result, env), heap), modules) -> (result, EvaluatingState env heap modules)) . runState lowerBound -- State (ModuleTable (Maybe (Environment address, value))) . runState lowerBound -- State (Heap address (Cell address) value) . runState lowerBound -- State (Environment address) From 7072b1f8ddf97c8ed9a69ee310b3f570914e404b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:19:50 -0400 Subject: [PATCH 117/159] =?UTF-8?q?Don=E2=80=99t=20re-export=20Fail.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/Evaluating.hs | 1 + src/Control/Abstract/TermEvaluator.hs | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 7af44030c..53abb3c52 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -5,6 +5,7 @@ module Analysis.Abstract.Evaluating ) where import Control.Abstract +import Control.Monad.Effect.Fail import Data.Semilattice.Lower -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. diff --git a/src/Control/Abstract/TermEvaluator.hs b/src/Control/Abstract/TermEvaluator.hs index 40912ad44..553261078 100644 --- a/src/Control/Abstract/TermEvaluator.hs +++ b/src/Control/Abstract/TermEvaluator.hs @@ -7,7 +7,6 @@ module Control.Abstract.TermEvaluator import Control.Abstract.Evaluator import Control.Monad.Effect as X -import Control.Monad.Effect.Fail as X import Control.Monad.Effect.Fresh as X import Control.Monad.Effect.NonDet as X import Control.Monad.Effect.Reader as X From 66594cf6314b639ee962372ab7ee8ae4fac71973 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:32:29 -0400 Subject: [PATCH 118/159] =?UTF-8?q?Don=E2=80=99t=20expect=20an=20env=20in?= =?UTF-8?q?=20resumingValueError.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Semantic/Graph.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index bbcfaaf77..a4b8f07a7 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -129,7 +129,7 @@ resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> s UnallocatedAddress _ -> pure lowerBound UninitializedAddress _ -> pure hole) -resumingValueError :: (Member (State (Environment address)) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a +resumingValueError :: (Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of CallError val -> pure val StringError val -> pure (pack (show val)) @@ -139,7 +139,7 @@ resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err NumericError{} -> pure hole Numeric2Error{} -> pure hole ComparisonError{} -> pure hole - NamespaceError{} -> get @(Environment _) + NamespaceError{} -> pure emptyEnv BitwiseError{} -> pure hole Bitwise2Error{} -> pure hole KeyValueError{} -> pure (hole, hole) From a6025262c5bfa0510d7c5fced6bcca3576377be3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:32:54 -0400 Subject: [PATCH 119/159] :fire: the environment from EvaluatingState. --- src/Analysis/Abstract/Evaluating.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 53abb3c52..b6307cf0c 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -10,8 +10,7 @@ import Data.Semilattice.Lower -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. data EvaluatingState address value = EvaluatingState - { environment :: Environment address - , heap :: Heap address (Cell address) value + { heap :: Heap address (Cell address) value , modules :: ModuleTable (Maybe (Environment address, value)) } @@ -23,15 +22,13 @@ deriving instance (Show (Cell address value), Show address, Show value) => Show evaluating :: Evaluator address value ( Fail ': Fresh - ': State (Environment address) ': State (Heap address (Cell address) value) ': State (ModuleTable (Maybe (Environment address, value))) ': effects) result -> Evaluator address value effects (Either String result, EvaluatingState address value) evaluating - = fmap (\ (((result, env), heap), modules) -> (result, EvaluatingState env heap modules)) + = fmap (\ ((result, heap), modules) -> (result, EvaluatingState heap modules)) . runState lowerBound -- State (ModuleTable (Maybe (Environment address, value))) . runState lowerBound -- State (Heap address (Cell address) value) - . runState lowerBound -- State (Environment address) . runFresh 0 . runFail From bf35d9db79e4dc6882d3f15437404481959b46bc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:33:56 -0400 Subject: [PATCH 120/159] We only need one handler. --- src/Control/Abstract/Environment.hs | 15 +-------------- 1 file changed, 1 insertion(+), 14 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 8f1a9c515..8cd7dc206 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -10,8 +10,6 @@ module Control.Abstract.Environment , locally , close , Env(..) -, runEnv -, reinterpretEnv , runEnvState , EnvironmentError(..) , freeVariableError @@ -82,21 +80,10 @@ handleEnv = \case GetEnv -> get Export name alias addr -> modify (Exports.insert name alias addr) -runEnv :: ( Member (State (Environment address)) effects - , Member (State (Exports address)) effects - ) - => Evaluator address value (Env address ': effects) a - -> Evaluator address value effects a -runEnv = interpret handleEnv - -reinterpretEnv :: Evaluator address value (Env address ': effects) a - -> Evaluator address value (State (Environment address) ': State (Exports address) ': effects) a -reinterpretEnv = reinterpret2 handleEnv - runEnvState :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects (a, Environment address) -runEnvState initial = fmap (uncurry filterEnv) . runState lowerBound . runState initial . reinterpretEnv +runEnvState initial = fmap (uncurry filterEnv) . runState lowerBound . runState initial . reinterpret2 handleEnv where -- TODO: If the set of exports is empty because no exports have been -- defined, do we export all terms, or no terms? This behavior varies across -- languages. We need better semantics rather than doing it ad-hoc. From fab1c4011c0b329592bc9cf898f00cad2172426c Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 30 May 2018 17:00:05 -0400 Subject: [PATCH 121/159] ++proto3-wire and proto3-suite --- vendor/proto3-suite | 2 +- vendor/proto3-wire | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/vendor/proto3-suite b/vendor/proto3-suite index f5378dabf..40d8a7281 160000 --- a/vendor/proto3-suite +++ b/vendor/proto3-suite @@ -1 +1 @@ -Subproject commit f5378dabf599e7acf02a2ac23bd9788485d43bfc +Subproject commit 40d8a7281e25e3ca3cbfbbd05028d45861f32a3c diff --git a/vendor/proto3-wire b/vendor/proto3-wire index c076246ca..4621daf87 160000 --- a/vendor/proto3-wire +++ b/vendor/proto3-wire @@ -1 +1 @@ -Subproject commit c076246ca3d933f2145919f8f6b4809e73a8ab89 +Subproject commit 4621daf8798173c96b859aa2bb7e598947f88fb3 From deaaa80a521d4b4f07a2e748cf666b4caad1c10b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 17:17:01 -0400 Subject: [PATCH 122/159] Rename runEnvState to runEnv. --- src/Control/Abstract/Environment.hs | 10 +++++----- src/Data/Abstract/Evaluatable.hs | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 8cd7dc206..551d6054a 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -10,7 +10,7 @@ module Control.Abstract.Environment , locally , close , Env(..) -, runEnvState +, runEnv , EnvironmentError(..) , freeVariableError , runEnvironmentError @@ -80,10 +80,10 @@ handleEnv = \case GetEnv -> get Export name alias addr -> modify (Exports.insert name alias addr) -runEnvState :: Environment address - -> Evaluator address value (Env address ': effects) a - -> Evaluator address value effects (a, Environment address) -runEnvState initial = fmap (uncurry filterEnv) . runState lowerBound . runState initial . reinterpret2 handleEnv +runEnv :: Environment address + -> Evaluator address value (Env address ': effects) a + -> Evaluator address value effects (a, Environment address) +runEnv initial = fmap (uncurry filterEnv) . runState lowerBound . runState initial . reinterpret2 handleEnv where -- TODO: If the set of exports is empty because no exports have been -- defined, do we export all terms, or no terms? This behavior varies across -- languages. We need better semantics rather than doing it ad-hoc. diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 6e55cd876..3cfbb174e 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -112,7 +112,7 @@ evaluatePackageWith analyzeModule analyzeTerm package runInModule preludeEnv info = runReader info . raiseHandler runAllocator - . raiseHandler (runEnvState preludeEnv) + . raiseHandler (runEnv preludeEnv) . raiseHandler runReturn . raiseHandler runLoopControl From bcf9338b751f46af8cdfd548bfed45d55532edf0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 17:19:05 -0400 Subject: [PATCH 123/159] Update the language specs to respect the env-per-entry-point thing. --- test/Analysis/Go/Spec.hs | 12 +++++------ test/Analysis/PHP/Spec.hs | 22 +++++++++---------- test/Analysis/Python/Spec.hs | 24 ++++++++++----------- test/Analysis/Ruby/Spec.hs | 37 ++++++++++++++++---------------- test/Analysis/TypeScript/Spec.hs | 16 +++++++------- 5 files changed, 55 insertions(+), 56 deletions(-) diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index b0b43cd97..7c4cfd105 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -11,16 +11,16 @@ spec :: Spec spec = parallel $ do describe "evaluates Go" $ do it "imports and wildcard imports" $ do - ((_, state), _) <- evaluate "main.go" - Env.names (environment state) `shouldBe` [ "Bar", "Rab", "foo", "main" ] + ((Right [(_, env)], state), _) <- evaluate "main.go" + Env.names env `shouldBe` [ "Bar", "Rab", "foo", "main" ] - (derefQName (heap state) ("foo" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("foo", ["New"]) + (derefQName (heap state) ("foo" :| []) env >>= deNamespace) `shouldBe` Just ("foo", ["New"]) it "imports with aliases (and side effects only)" $ do - ((_, state), _) <- evaluate "main1.go" - Env.names (environment state) `shouldBe` [ "f", "main" ] + ((Right [(_, env)], state), _) <- evaluate "main1.go" + Env.names env `shouldBe` [ "f", "main" ] - (derefQName (heap state) ("f" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("f", ["New"]) + (derefQName (heap state) ("f" :| []) env >>= deNamespace) `shouldBe` Just ("f", ["New"]) where fixtures = "test/fixtures/go/analysis/" diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index 619136202..168139d48 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -12,22 +12,22 @@ spec :: Spec spec = parallel $ do describe "PHP" $ do it "evaluates include and require" $ do - ((res, state), _) <- evaluate "main.php" - res `shouldBe` Right [unit] - Env.names (environment state) `shouldBe` [ "bar", "foo" ] + ((Right [(res, env)], state), _) <- evaluate "main.php" + res `shouldBe` unit + Env.names env `shouldBe` [ "bar", "foo" ] it "evaluates include_once and require_once" $ do - ((res, state), _) <- evaluate "main_once.php" - res `shouldBe` Right [unit] - Env.names (environment state) `shouldBe` [ "bar", "foo" ] + ((Right [(res, env)], state), _) <- evaluate "main_once.php" + res `shouldBe` unit + Env.names env `shouldBe` [ "bar", "foo" ] it "evaluates namespaces" $ do - ((_, state), _) <- evaluate "namespaces.php" - Env.names (environment state) `shouldBe` [ "Foo", "NS1" ] + ((Right [(_, env)], state), _) <- evaluate "namespaces.php" + Env.names env `shouldBe` [ "Foo", "NS1" ] - (derefQName (heap state) ("NS1" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"]) - (derefQName (heap state) ("NS1" :| ["Sub1"]) (environment state) >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"]) - (derefQName (heap state) ("NS1" :| ["Sub1", "Sub2"]) (environment state) >>= deNamespace) `shouldBe` Just ("Sub2", ["f"]) + (derefQName (heap state) ("NS1" :| []) env >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"]) + (derefQName (heap state) ("NS1" :| ["Sub1"]) env >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"]) + (derefQName (heap state) ("NS1" :| ["Sub1", "Sub2"]) env >>= deNamespace) `shouldBe` Just ("Sub2", ["f"]) where fixtures = "test/fixtures/php/analysis/" diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 9bd89b98c..66ad0df48 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -14,33 +14,33 @@ spec :: Spec spec = parallel $ do describe "evaluates Python" $ do it "imports" $ do - ((_, state), _) <- evaluate "main.py" - Env.names (environment state) `shouldContain` [ "a", "b" ] + ((Right [(_, env)], state), _) <- evaluate "main.py" + Env.names env `shouldContain` [ "a", "b" ] - (derefQName (heap state) ("a" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("a", ["foo"]) - (derefQName (heap state) ("b" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("b", ["c"]) - (derefQName (heap state) ("b" :| ["c"]) (environment state) >>= deNamespace) `shouldBe` Just ("c", ["baz"]) + (derefQName (heap state) ("a" :| []) env >>= deNamespace) `shouldBe` Just ("a", ["foo"]) + (derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", ["c"]) + (derefQName (heap state) ("b" :| ["c"]) env >>= deNamespace) `shouldBe` Just ("c", ["baz"]) it "imports with aliases" $ do - env <- environment . snd . fst <$> evaluate "main1.py" + ((Right [(_, env)], _), _) <- evaluate "main1.py" Env.names env `shouldContain` [ "b", "e" ] it "imports using 'from' syntax" $ do - env <- environment . snd . fst <$> evaluate "main2.py" + ((Right [(_, env)], _), _) <- evaluate "main2.py" Env.names env `shouldContain` [ "bar", "foo" ] it "imports with relative syntax" $ do - ((_, state), _) <- evaluate "main3.py" - Env.names (environment state) `shouldContain` [ "utils" ] - (derefQName (heap state) ("utils" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("utils", ["to_s"]) + ((Right [(_, env)], state), _) <- evaluate "main3.py" + Env.names env `shouldContain` [ "utils" ] + (derefQName (heap state) ("utils" :| []) env >>= deNamespace) `shouldBe` Just ("utils", ["to_s"]) it "subclasses" $ do ((res, _), _) <- evaluate "subclass.py" - res `shouldBe` Right [String "\"bar\""] + fmap fst <$> res `shouldBe` Right [String "\"bar\""] it "handles multiple inheritance left-to-right" $ do ((res, _), _) <- evaluate "multiple_inheritance.py" - res `shouldBe` Right [String "\"foo!\""] + fmap fst <$> res `shouldBe` Right [String "\"foo!\""] where ns n = Just . Latest . Last . Just . Namespace n diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 5b9743906..83958cde8 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -20,58 +20,57 @@ spec :: Spec spec = parallel $ do describe "Ruby" $ do it "evaluates require_relative" $ do - ((res, state), _) <- evaluate "main.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 1)] - Env.names (environment state) `shouldContain` ["foo"] + ((Right [(res, env)], state), _) <- evaluate "main.rb" + res `shouldBe` Value.Integer (Number.Integer 1) + Env.names env `shouldContain` ["foo"] it "evaluates load" $ do - env <- environment . snd . fst <$> evaluate "load.rb" + ((Right [(_, env)], _), _) <- evaluate "load.rb" Env.names env `shouldContain` ["foo"] it "evaluates load with wrapper" $ do ((res, state), _) <- evaluate "load-wrap.rb" res `shouldBe` Left (SomeExc (inject @(EnvironmentError Precise) (FreeVariable "foo"))) - Env.names (environment state) `shouldContain` [ "Object" ] it "evaluates subclass" $ do - ((res, state), _) <- evaluate "subclass.rb" - res `shouldBe` Right [String "\"\""] - Env.names (environment state) `shouldContain` [ "Bar", "Foo" ] + ((Right [(res, env)], state), _) <- evaluate "subclass.rb" + res `shouldBe` String "\"\"" + Env.names env `shouldContain` [ "Bar", "Foo" ] - (derefQName (heap state) ("Bar" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"]) + (derefQName (heap state) ("Bar" :| []) env >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"]) it "evaluates modules" $ do - ((res, state), _) <- evaluate "modules.rb" - res `shouldBe` Right [String "\"\""] - Env.names (environment state) `shouldContain` [ "Bar" ] + ((Right [(res, env)], state), _) <- evaluate "modules.rb" + res `shouldBe` String "\"\"" + Env.names env `shouldContain` [ "Bar" ] it "handles break correctly" $ do ((res, _), _) <- evaluate "break.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 3)] + fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 3)] it "handles break correctly" $ do ((res, _), _) <- evaluate "next.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 8)] + fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 8)] it "calls functions with arguments" $ do ((res, _), _) <- evaluate "call.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 579)] + fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 579)] it "evaluates early return statements" $ do ((res, _), _) <- evaluate "early-return.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 123)] + fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 123)] it "has prelude" $ do ((res, _), _) <- evaluate "preluded.rb" - res `shouldBe` Right [String "\"\""] + fmap fst <$> res `shouldBe` Right [String "\"\""] it "evaluates __LINE__" $ do ((res, _), _) <- evaluate "line.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 4)] + fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 4)] it "resolves builtins used in the prelude" $ do ((res, _), traces) <- evaluate "puts.rb" - res `shouldBe` Right [Unit] + fmap fst <$> res `shouldBe` Right [Unit] traces `shouldContain` [ "\"hello\"" ] where diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index bb5a29b5b..acb871251 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -15,19 +15,19 @@ spec :: Spec spec = parallel $ do describe "evaluates TypeScript" $ do it "imports with aliased symbols" $ do - env <- environment . snd . fst <$> evaluate "main.ts" + ((Right [(_, env)], _), _) <- evaluate "main.ts" Env.names env `shouldBe` [ "bar", "quz" ] it "imports with qualified names" $ do - ((_, state), _) <- evaluate "main1.ts" - Env.names (environment state) `shouldBe` [ "b", "z" ] + ((Right [(_, env)], state), _) <- evaluate "main1.ts" + Env.names env `shouldBe` [ "b", "z" ] - (derefQName (heap state) ("b" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ]) - (derefQName (heap state) ("z" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ]) + (derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ]) + (derefQName (heap state) ("z" :| []) env >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ]) it "side effect only imports" $ do - env <- environment . snd . fst <$> evaluate "main2.ts" - env `shouldBe` emptyEnv + ((res, _), _) <- evaluate "main2.ts" + fmap snd <$> res `shouldBe` Right [emptyEnv] it "fails exporting symbols not defined in the module" $ do ((res, _), _) <- evaluate "bad-export.ts" @@ -35,7 +35,7 @@ spec = parallel $ do it "evaluates early return statements" $ do ((res, _), _) <- evaluate "early-return.ts" - res `shouldBe` Right [Value.Float (Number.Decimal 123.0)] + fmap fst <$> res `shouldBe` Right [Value.Float (Number.Decimal 123.0)] where fixtures = "test/fixtures/typescript/analysis/" From 08cf65718f03cbb01dfd30ae11fb2225b770b5e6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 17:20:08 -0400 Subject: [PATCH 124/159] Fix the evaluator spec. --- test/Control/Abstract/Evaluator/Spec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index afcb2bc1e..28100f6b1 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -20,13 +20,13 @@ spec :: Spec spec = parallel $ do it "constructs integers" $ do (expected, _) <- evaluate (pure (integer 123)) - expected `shouldBe` Right (Value.Integer (Number.Integer 123)) + fst <$> expected `shouldBe` Right (Value.Integer (Number.Integer 123)) it "calls functions" $ do (expected, _) <- evaluate $ do identity <- closure [name "x"] lowerBound (variable (name "x")) call identity [pure (integer 123)] - expected `shouldBe` Right (Value.Integer (Number.Integer 123)) + fst <$> expected `shouldBe` Right (Value.Integer (Number.Integer 123)) evaluate = runM From 7e68c0723aba2df7b7e8bd0812447ca6e4eba564 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 17:40:53 -0400 Subject: [PATCH 125/159] Fix the Show instance for ClosureBody to not break prettyShow. --- src/Data/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 9adcae192..f81646456 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -42,7 +42,7 @@ instance Ord (ClosureBody address body) where compare = compare `on` closureBodyId instance Show (ClosureBody address body) where - showsPrec d (ClosureBody i _) = showsBinaryWith showsPrec (const showChar) "ClosureBody" d i '_' + showsPrec d (ClosureBody i _) = showsUnaryWith showsPrec "ClosureBody" d i instance Ord address => ValueRoots address (Value address body) where From 3701493debd8476d2d74d6285b72f5563c791be2 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 30 May 2018 17:41:48 -0400 Subject: [PATCH 126/159] ++proto3 --- vendor/proto3-suite | 2 +- vendor/proto3-wire | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/vendor/proto3-suite b/vendor/proto3-suite index 40d8a7281..4828d77ef 160000 --- a/vendor/proto3-suite +++ b/vendor/proto3-suite @@ -1 +1 @@ -Subproject commit 40d8a7281e25e3ca3cbfbbd05028d45861f32a3c +Subproject commit 4828d77ef5218cf309a8a78e2d97c488c4fe857a diff --git a/vendor/proto3-wire b/vendor/proto3-wire index 4621daf87..c8792bc33 160000 --- a/vendor/proto3-wire +++ b/vendor/proto3-wire @@ -1 +1 @@ -Subproject commit 4621daf8798173c96b859aa2bb7e598947f88fb3 +Subproject commit c8792bc33154e849239b1c91ffe06af2e765d734 From 11a48035b6078a9be0af4c861d0d0b655e75a4f9 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 30 May 2018 17:42:14 -0400 Subject: [PATCH 127/159] Generate Pos and Span messages --- semantic-types.proto | 6 ++++++ semantic.proto | 6 ------ src/Data/Span.hs | 15 +++++++++++++-- 3 files changed, 19 insertions(+), 8 deletions(-) diff --git a/semantic-types.proto b/semantic-types.proto index c9dfd9b65..d06c84fcf 100644 --- a/semantic-types.proto +++ b/semantic-types.proto @@ -14,6 +14,12 @@ message Blob { bytes blobSource = 1; string blobPath = 2; Language blobLanguage = 3; } +message Pos { int64 posLine = 1; + int64 posColumn = 2; + } +message Span { Pos spanStart = 1; + Pos spanEnd = 2; + } message Array { repeated Term arrayElements = 1; } message Boolean { bool booleanContent = 1; diff --git a/semantic.proto b/semantic.proto index 406d5b067..fbe0ac2f2 100644 --- a/semantic.proto +++ b/semantic.proto @@ -34,12 +34,6 @@ message BlobPair { Blob after = 2; } -message Blob { - string source = 1; - string path = 2; - string language = 3; -} - message SummariesResponse { repeated Summary changes = 1; repeated Error errors = 2; diff --git a/src/Data/Span.hs b/src/Data/Span.hs index afbbcf94f..37749d2c8 100644 --- a/src/Data/Span.hs +++ b/src/Data/Span.hs @@ -11,6 +11,9 @@ module Data.Span ) where import Data.Aeson ((.=), (.:)) +import Proto3.Suite +import Proto3.Wire.Decode as Decode +import Proto3.Wire.Encode as Encode import qualified Data.Aeson as A import Data.JSON.Fields import Data.Semilattice.Lower @@ -22,7 +25,15 @@ data Pos = Pos { posLine :: !Int , posColumn :: !Int } - deriving (Show, Read, Eq, Ord, Generic, Hashable) + deriving (Show, Read, Eq, Ord, Generic, Hashable, Named, Message) + +instance MessageField Pos where + encodeMessageField num = (Encode.embedded num . encodeMessage (fieldNumber 1)) + decodeMessageField = fromMaybe def <$> Decode.embedded (decodeMessage (fieldNumber 1)) + protoType pr = messageField (Prim $ Named (Single (nameOf pr))) Nothing + +instance HasDefault Pos where + def = Pos 1 1 instance A.ToJSON Pos where toJSON Pos{..} = @@ -37,7 +48,7 @@ data Span = Span { spanStart :: Pos , spanEnd :: Pos } - deriving (Show, Read, Eq, Ord, Generic, Hashable) + deriving (Show, Read, Eq, Ord, Generic, Hashable, Named, Message) spanFromSrcLoc :: SrcLoc -> Span spanFromSrcLoc = Span . (Pos . srcLocStartLine <*> srcLocStartCol) <*> (Pos . srcLocEndLine <*> srcLocEndCol) From 5fc9090ad1e24578e7a2ba105d92077c0c589bf8 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 30 May 2018 18:04:07 -0400 Subject: [PATCH 128/159] Regenerate Semantic.hs --- semantic.proto | 2 +- src/Data/Syntax.hs | 8 ++++---- semantic-types.proto => types.proto | 0 3 files changed, 5 insertions(+), 5 deletions(-) rename semantic-types.proto => types.proto (100%) diff --git a/semantic.proto b/semantic.proto index fbe0ac2f2..80d5e3758 100644 --- a/semantic.proto +++ b/semantic.proto @@ -1,5 +1,5 @@ syntax = "proto3"; -import "semantic-types.proto"; +import "types.proto"; package semantic; message HealthCheckRequest { diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index b59d772ac..b0c8690f8 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -1,5 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes, DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, KindSignatures, RankNTypes, ConstraintKinds #-} -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack +{-# OPTIONS_GHC -Wno-redundant-constraints -fno-warn-orphans #-} -- For HasCallStack module Data.Syntax where import Data.Abstract.Evaluatable @@ -105,12 +105,12 @@ infixContext context left right operators = uncurry (&) <$> postContextualizeThr instance (Apply Message1 fs, Generate Message1 fs fs, Generate Named1 fs fs) => Message1 (Sum fs) where liftEncodeMessage encodeMessage num fs = apply @Message1 (liftEncodeMessage encodeMessage num) fs - liftDecodeMessage decodeMessage num = oneof undefined listOfParsers + liftDecodeMessage decodeMessage _ = oneof undefined listOfParsers where listOfParsers = - generate @Message1 @fs @fs (\ (proxy :: proxy f) i -> let num = FieldNumber (fromInteger (succ i)) in [(num, fromJust <$> embedded (inject @f @fs <$> liftDecodeMessage decodeMessage num))]) + generate @Message1 @fs @fs (\ (_ :: proxy f) i -> let num = FieldNumber (fromInteger (succ i)) in [(num, fromJust <$> embedded (inject @f @fs <$> liftDecodeMessage decodeMessage num))]) liftDotProto _ = - [Proto.DotProtoMessageOneOf (Proto.Single "syntax") (generate @Named1 @fs @fs (\ (proxy :: proxy f) i -> + [Proto.DotProtoMessageOneOf (Proto.Single "syntax") (generate @Named1 @fs @fs (\ (_ :: proxy f) i -> let num = FieldNumber (fromInteger (succ i)) fieldType = Proto.Prim (Proto.Named . Proto.Single $ nameOf1 (Proxy @f)) diff --git a/semantic-types.proto b/types.proto similarity index 100% rename from semantic-types.proto rename to types.proto From 334f8738c02cdbeff7911ffc097bbbe72620aa80 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 18:13:36 -0400 Subject: [PATCH 129/159] Keep the builtins around. --- 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 3cfbb174e..31d761ebb 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -122,8 +122,8 @@ evaluatePackageWith analyzeModule analyzeTerm package maybe (pure v) ((`call` []) <=< variable) sym evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule emptyEnv)) $ do - _ <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit)) - evalModule emptyEnv prelude + (_, builtinsEnv) <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit)) + second (mergeEnvs builtinsEnv) <$> evalModule builtinsEnv prelude withPrelude Nothing f = f emptyEnv withPrelude (Just prelude) f = do From d441d984561144505dffce035f8981beb35150e2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 18:29:30 -0400 Subject: [PATCH 130/159] Copy the environment back out for entry points. --- src/Data/Abstract/Evaluatable.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 31d761ebb..cadaf3cf1 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -118,8 +118,9 @@ evaluatePackageWith analyzeModule analyzeTerm package evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' (value, Environment address) evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do - v <- maybe unit snd <$> require m - maybe (pure v) ((`call` []) <=< variable) sym + (env, value) <- fromMaybe (emptyEnv, unit) <$> require m + bindAll env + maybe (pure value) ((`call` []) <=< variable) sym evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule emptyEnv)) $ do (_, builtinsEnv) <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit)) From 68e4c4615e4f9d505d53e53741eea7efde6fb03e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 18:35:38 -0400 Subject: [PATCH 131/159] Push the prelude env & drop it before filtering. --- src/Control/Abstract/Environment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 551d6054a..c91254b53 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -83,7 +83,7 @@ handleEnv = \case runEnv :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects (a, Environment address) -runEnv initial = fmap (uncurry filterEnv) . runState lowerBound . runState initial . reinterpret2 handleEnv +runEnv initial = fmap (uncurry filterEnv . first (fmap Env.head)) . runState lowerBound . runState (Env.push initial) . reinterpret2 handleEnv where -- TODO: If the set of exports is empty because no exports have been -- defined, do we export all terms, or no terms? This behavior varies across -- languages. We need better semantics rather than doing it ad-hoc. From 969d31adbf3eeb77791cf2b21e0181618dfc1107 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 18:54:58 -0400 Subject: [PATCH 132/159] Swap the ordering of the evaluated module table. --- src/Analysis/Abstract/Evaluating.hs | 6 +++--- src/Control/Abstract/Modules.hs | 19 +++++++++---------- src/Data/Abstract/Evaluatable.hs | 4 ++-- src/Language/Go/Syntax.hs | 4 ++-- src/Language/PHP/Syntax.hs | 4 ++-- src/Language/Python/Syntax.hs | 6 +++--- src/Language/Ruby/Syntax.hs | 10 +++++----- src/Language/TypeScript/Syntax.hs | 6 +++--- 8 files changed, 29 insertions(+), 30 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index b6307cf0c..b927bdbd5 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -11,7 +11,7 @@ import Data.Semilattice.Lower -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. data EvaluatingState address value = EvaluatingState { heap :: Heap address (Cell address) value - , modules :: ModuleTable (Maybe (Environment address, value)) + , modules :: ModuleTable (Maybe (value, Environment address)) } deriving instance (Eq (Cell address value), Eq address, Eq value) => Eq (EvaluatingState address value) @@ -23,12 +23,12 @@ evaluating :: Evaluator address value ( Fail ': Fresh ': State (Heap address (Cell address) value) - ': State (ModuleTable (Maybe (Environment address, value))) + ': State (ModuleTable (Maybe (value, Environment address))) ': effects) result -> Evaluator address value effects (Either String result, EvaluatingState address value) evaluating = fmap (\ ((result, heap), modules) -> (result, EvaluatingState heap modules)) - . runState lowerBound -- State (ModuleTable (Maybe (Environment address, value))) + . runState lowerBound -- State (ModuleTable (Maybe (value, Environment address))) . runState lowerBound -- State (Heap address (Cell address) value) . runFresh 0 . runFail diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index 2853de21f..6c738a3a1 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -23,11 +23,10 @@ import Data.Abstract.Environment import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import Data.Language -import Data.Tuple (swap) import Prologue -- | Retrieve an evaluated module, if any. The outer 'Maybe' indicates whether we’ve begun loading the module or not, while the inner 'Maybe' indicates whether we’ve completed loading it or not. Thus, @Nothing@ means we’ve never tried to load it, @Just Nothing@ means we’ve started but haven’t yet finished loading it, and @Just (Just (env, value))@ indicates the result of a completed load. -lookupModule :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Maybe (Environment address, value))) +lookupModule :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Maybe (value, Environment address))) lookupModule = send . Lookup -- | Resolve a list of module paths to a possible module table entry. @@ -41,19 +40,19 @@ listModulesInDir = sendModules . List -- | Require/import another module by name and return its environment and value. -- -- Looks up the module's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module. -require :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value)) +require :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (value, Environment address)) require path = lookupModule path >>= maybeM (load path) -- | Load another module by name and return its environment and value. -- -- Always loads/evaluates. -load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value)) -load path = fmap swap <$> send (Load path) +load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (value, Environment address)) +load path = send (Load path) data Modules address value return where Load :: ModulePath -> Modules address value (Maybe (value, Environment address)) - Lookup :: ModulePath -> Modules address value (Maybe (Maybe (Environment address, value))) + Lookup :: ModulePath -> Modules address value (Maybe (Maybe (value, Environment address))) Resolve :: [FilePath] -> Modules address value (Maybe ModulePath) List :: FilePath -> Modules address value [ModulePath] @@ -62,7 +61,7 @@ sendModules = send runModules :: forall term address value effects a . ( Member (Resumable (LoadError address value)) effects - , Member (State (ModuleTable (Maybe (Environment address, value)))) effects + , Member (State (ModuleTable (Maybe (value, Environment address)))) effects , Member Trace effects ) => (Module term -> Evaluator address value (Modules address value ': effects) (value, Environment address)) @@ -90,11 +89,11 @@ runModules evaluateModule = go pure (find isMember names) List dir -> modulePathsInDir dir <$> askModuleTable @term) -getModuleTable :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => Evaluator address value effects (ModuleTable (Maybe (Environment address, value))) +getModuleTable :: Member (State (ModuleTable (Maybe (value, Environment address)))) effects => Evaluator address value effects (ModuleTable (Maybe (value, Environment address))) getModuleTable = get -cacheModule :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => ModulePath -> Maybe (value, Environment address) -> Evaluator address value effects (Maybe (value, Environment address)) -cacheModule path result = modify' (ModuleTable.insert path (swap <$> result)) $> result +cacheModule :: Member (State (ModuleTable (Maybe (value, Environment address)))) effects => ModulePath -> Maybe (value, Environment address) -> Evaluator address value effects (Maybe (value, Environment address)) +cacheModule path result = modify' (ModuleTable.insert path result) $> result askModuleTable :: Member (Reader (ModuleTable [Module term])) effects => Evaluator address value effects (ModuleTable [Module term]) askModuleTable = ask diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index cadaf3cf1..3229fade5 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -82,7 +82,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer , Member (Resumable (AddressError address value)) outer , Member (Resumable (LoadError address value)) outer , Member (State (Heap address (Cell address) value)) outer - , Member (State (ModuleTable (Maybe (Environment address, value)))) outer + , Member (State (ModuleTable (Maybe (value, Environment address)))) outer , Member Trace outer , Recursive term , inner ~ (LoopControl value ': Return value ': Env address ': Allocator address value ': inner') @@ -118,7 +118,7 @@ evaluatePackageWith analyzeModule analyzeTerm package evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' (value, Environment address) evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do - (env, value) <- fromMaybe (emptyEnv, unit) <$> require m + (value, env) <- fromMaybe (unit, emptyEnv) <$> require m bindAll env maybe (pure value) ((`call` []) <=< variable) sym diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index c9ab540a5..48dc44489 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -69,7 +69,7 @@ instance Evaluatable Import where paths <- resolveGoImport importPath for_ paths $ \path -> do traceResolve (unPath importPath) path - importedEnv <- maybe emptyEnv fst <$> require path + importedEnv <- maybe emptyEnv snd <$> require path bindAll importedEnv pure (Rval unit) @@ -93,7 +93,7 @@ instance Evaluatable QualifiedImport where void $ letrec' alias $ \addr -> do for_ paths $ \p -> do traceResolve (unPath importPath) p - importedEnv <- maybe emptyEnv fst <$> require p + importedEnv <- maybe emptyEnv snd <$> require p bindAll importedEnv makeNamespace alias addr Nothing pure (Rval unit) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 2dd1175fb..2fc416904 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -61,13 +61,13 @@ include :: ( AbstractValue address value effects , Member Trace effects ) => Subterm term (Evaluator address value effects (ValueRef value)) - -> (ModulePath -> Evaluator address value effects (Maybe (Environment address, value))) + -> (ModulePath -> Evaluator address value effects (Maybe (value, Environment address))) -> Evaluator address value effects (ValueRef value) include pathTerm f = do name <- subtermValue pathTerm >>= asString path <- resolvePHPName name traceResolve name path - (importedEnv, v) <- fromMaybe (emptyEnv, unit) <$> f path + (v, importedEnv) <- fromMaybe (unit, emptyEnv) <$> f path bindAll importedEnv pure (Rval v) diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 9a1de3925..398fb82b4 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -116,7 +116,7 @@ instance Evaluatable Import where -- Last module path is the one we want to import let path = NonEmpty.last modulePaths - importedEnv <- maybe emptyEnv fst <$> require path + importedEnv <- maybe emptyEnv snd <$> require path bindAll (select importedEnv) pure (Rval unit) where @@ -136,7 +136,7 @@ evalQualifiedImport :: ( AbstractValue address value effects ) => Name -> ModulePath -> Evaluator address value effects value evalQualifiedImport name path = letrec' name $ \addr -> do - importedEnv <- maybe emptyEnv fst <$> require path + importedEnv <- maybe emptyEnv snd <$> require path bindAll importedEnv unit <$ makeNamespace name addr Nothing @@ -185,7 +185,7 @@ instance Evaluatable QualifiedAliasedImport where alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm) Rval <$> letrec' alias (\addr -> do let path = NonEmpty.last modulePaths - importedEnv <- maybe emptyEnv fst <$> require path + importedEnv <- maybe emptyEnv snd <$> require path bindAll importedEnv unit <$ makeNamespace alias addr Nothing) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 1eb89f5cd..89b81f8f6 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -73,7 +73,7 @@ instance Evaluatable Require where name <- subtermValue x >>= asString path <- resolveRubyName name traceResolve name path - (importedEnv, v) <- doRequire path + (v, importedEnv) <- doRequire path bindAll importedEnv pure (Rval v) -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require @@ -81,12 +81,12 @@ doRequire :: ( AbstractValue address value effects , Member (Modules address value) effects ) => M.ModulePath - -> Evaluator address value effects (Environment address, value) + -> Evaluator address value effects (value, Environment address) doRequire path = do result <- join <$> lookupModule path case result of - Nothing -> (,) . maybe emptyEnv fst <$> load path <*> pure (boolean True) - Just (env, _) -> pure (env, boolean False) + Nothing -> (,) (boolean True) . maybe emptyEnv snd <$> load path + Just (_, env) -> pure (boolean False, env) newtype Load a = Load { loadArgs :: [a] } @@ -120,7 +120,7 @@ doLoad :: ( AbstractValue address value effects doLoad path shouldWrap = do path' <- resolveRubyPath path traceResolve path path' - importedEnv <- maybe emptyEnv fst <$> load path' + importedEnv <- maybe emptyEnv snd <$> load path' unless shouldWrap $ bindAll importedEnv pure (boolean Prelude.True) -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 9cd3fe0cc..195fb7f33 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -144,7 +144,7 @@ evalRequire :: ( AbstractValue address value effects -> Name -> Evaluator address value effects value evalRequire modulePath alias = letrec' alias $ \addr -> do - importedEnv <- maybe emptyEnv fst <$> require modulePath + importedEnv <- maybe emptyEnv snd <$> require modulePath bindAll importedEnv unit <$ makeNamespace alias addr Nothing @@ -161,7 +161,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Import where eval (Import symbols importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - importedEnv <- maybe emptyEnv fst <$> require modulePath + importedEnv <- maybe emptyEnv snd <$> require modulePath bindAll (renamed importedEnv) $> Rval unit where renamed importedEnv @@ -246,7 +246,7 @@ instance ToJSONFields1 QualifiedExportFrom instance Evaluatable QualifiedExportFrom where eval (QualifiedExportFrom importPath exportSymbols) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - importedEnv <- maybe emptyEnv fst <$> require modulePath + importedEnv <- maybe emptyEnv snd <$> require modulePath -- Look up addresses in importedEnv and insert the aliases with addresses into the exports. for_ exportSymbols $ \(name, alias) -> do let address = Env.lookup name importedEnv From c7e8419e296e70b875f0da74b017fe5ffb8fb3c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 18:56:50 -0400 Subject: [PATCH 133/159] Placate hlint. --- src/Diffing/Algorithm.hs | 2 +- src/Semantic/IO.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Diffing/Algorithm.hs b/src/Diffing/Algorithm.hs index b6b0b300a..be17fd252 100644 --- a/src/Diffing/Algorithm.hs +++ b/src/Diffing/Algorithm.hs @@ -221,7 +221,7 @@ instance Diffable [] where -- | Diff two non-empty lists using RWS. instance Diffable NonEmpty where - algorithmFor (a1:|as1) (a2:|as2) = nonEmpty <$> byRWS (a1:as1) (a2:as2) >>= maybe empty pure + algorithmFor (a1:|as1) (a2:|as2) = nonEmpty <$> byRWS (a1:as1) (a2:as2) >>= maybeM empty tryAlignWith f (a1:|as1) (a2:|as2) = (:|) <$> f (These a1 a2) <*> tryAlignWith f as1 as2 diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 60e1dd162..9a594e557 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -96,7 +96,7 @@ readBlobsFromHandle = fmap toBlobs . readFromHandle readBlobFromPath :: MonadIO m => File -> m Blob.Blob readBlobFromPath file = do maybeFile <- readFile file - maybe (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) pure maybeFile + maybeM (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project readProjectFromPaths maybeRoot path lang excludeDirs = do From aef9fd94c809315122b8723ae70878c28f1036f9 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 30 May 2018 16:06:04 -0700 Subject: [PATCH 134/159] :fire: GAlign from new syntax constructors --- src/Data/Syntax/Literal.hs | 2 +- src/Language/Haskell/Syntax.hs | 12 ++++++------ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index dc1dd5805..a8c24925d 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -119,7 +119,7 @@ instance Evaluatable Data.Syntax.Literal.String instance ToJSONFields1 Data.Syntax.Literal.String newtype Character a = Character { characterContent :: ByteString } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 Data.Syntax.Literal.Character where liftEq = genericLiftEq instance Ord1 Data.Syntax.Literal.Character where liftCompare = genericLiftCompare diff --git a/src/Language/Haskell/Syntax.hs b/src/Language/Haskell/Syntax.hs index a10cfc5da..0bc06a65c 100644 --- a/src/Language/Haskell/Syntax.hs +++ b/src/Language/Haskell/Syntax.hs @@ -22,7 +22,7 @@ instance ToJSONFields1 Module instance Evaluatable Module data Type a = Type { typeIdentifier :: !a, typeParameters :: !a } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 Type where liftEq = genericLiftEq instance Ord1 Type where liftCompare = genericLiftCompare @@ -33,7 +33,7 @@ instance ToJSONFields1 Type instance Evaluatable Type data TypeSynonym a = TypeSynonym { typeSynonymLeft :: !a, typeSynonymRight :: !a } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 TypeSynonym where liftEq = genericLiftEq instance Ord1 TypeSynonym where liftCompare = genericLiftCompare @@ -43,7 +43,7 @@ instance ToJSONFields1 TypeSynonym instance Evaluatable TypeSynonym -newtype UnitConstructor a = UnitConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +newtype UnitConstructor a = UnitConstructor a deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 UnitConstructor where liftEq = genericLiftEq instance Ord1 UnitConstructor where liftCompare = genericLiftCompare @@ -53,7 +53,7 @@ instance ToJSONFields1 UnitConstructor instance Evaluatable UnitConstructor -newtype TupleConstructor a = TupleConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +newtype TupleConstructor a = TupleConstructor a deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 TupleConstructor where liftEq = genericLiftEq instance Ord1 TupleConstructor where liftCompare = genericLiftCompare @@ -63,7 +63,7 @@ instance ToJSONFields1 TupleConstructor instance Evaluatable TupleConstructor -newtype ListConstructor a = ListConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +newtype ListConstructor a = ListConstructor a deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 ListConstructor where liftEq = genericLiftEq instance Ord1 ListConstructor where liftCompare = genericLiftCompare @@ -73,7 +73,7 @@ instance ToJSONFields1 ListConstructor instance Evaluatable ListConstructor -newtype FunctionConstructor a = FunctionConstructor a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +newtype FunctionConstructor a = FunctionConstructor a deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 FunctionConstructor where liftEq = genericLiftEq instance Ord1 FunctionConstructor where liftCompare = genericLiftCompare From cc3a21583366936c452fd313a86f6f6e7e333cdf Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 30 May 2018 17:17:05 -0700 Subject: [PATCH 135/159] Update specialized constructors (`[]`, `(,)`, `(->)`, `()`) Also updates the `TuplingConstructor` to store its arity as Int --- src/Language/Haskell/Assignment.hs | 15 ++++++++----- src/Language/Haskell/Syntax.hs | 8 +++---- .../haskell/corpus/type-synonyms.diffA-B.txt | 21 +++++++------------ .../haskell/corpus/type-synonyms.diffB-A.txt | 21 +++++++------------ .../haskell/corpus/type-synonyms.parseA.txt | 15 +++++-------- .../haskell/corpus/type-synonyms.parseB.txt | 15 +++++-------- 6 files changed, 38 insertions(+), 57 deletions(-) diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index b771e5720..42012bbbf 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -6,7 +6,8 @@ module Language.Haskell.Assignment , Term ) where -import Assigning.Assignment hiding (Assignment, Error) +import Assigning.Assignment hiding (Assignment, Error, count) +import Data.ByteString.Char8 (count) import Data.Record import Data.Sum import Data.Syntax (emptyTerm, handleError, parseError, makeTerm, makeTerm'', contextualize, postContextualize) @@ -116,7 +117,7 @@ functionBody :: Assignment functionBody = makeTerm <$> symbol FunctionBody <*> children (many expression) functionConstructor :: Assignment -functionConstructor = makeTerm <$> token FunctionConstructor <*> (Syntax.FunctionConstructor <$> emptyTerm) +functionConstructor = makeTerm <$> token FunctionConstructor <*> pure Syntax.FunctionConstructor functionDeclaration :: Assignment functionDeclaration = makeTerm @@ -131,10 +132,10 @@ integer :: Assignment integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source) listConstructor :: Assignment -listConstructor = makeTerm <$> token ListConstructor <*> (Syntax.ListConstructor <$> emptyTerm) +listConstructor = makeTerm <$> token ListConstructor <*> pure Syntax.ListConstructor unitConstructor :: Assignment -unitConstructor = makeTerm <$> token UnitConstructor <*> (Syntax.UnitConstructor <$> emptyTerm) +unitConstructor = makeTerm <$> token UnitConstructor <*> pure Syntax.UnitConstructor listExpression :: Assignment listExpression = makeTerm <$> symbol ListExpression <*> children (Literal.Array <$> many listElement) @@ -144,7 +145,11 @@ listType :: Assignment listType = makeTerm <$> symbol ListType <*> children (Literal.Array <$> many type') tuplingConstructor :: Assignment -tuplingConstructor = makeTerm <$> symbol TuplingConstructor <*> children (Syntax.TupleConstructor <$> emptyTerm) +tuplingConstructor = makeTerm + <$> symbol TuplingConstructor + <*> (source >>= tupleWithArity) + -- a tuple (,) has arity two, but only one comma, so apply the successor to the count of commas for the correct arity. + where tupleWithArity = pure . Syntax.TupleConstructor . succ . count ',' type' :: Assignment type' = (makeTerm <$> symbol Type <*> children (Syntax.Type <$> typeConstructor <*> typeParameters)) diff --git a/src/Language/Haskell/Syntax.hs b/src/Language/Haskell/Syntax.hs index 0bc06a65c..5d60c29e0 100644 --- a/src/Language/Haskell/Syntax.hs +++ b/src/Language/Haskell/Syntax.hs @@ -43,7 +43,7 @@ instance ToJSONFields1 TypeSynonym instance Evaluatable TypeSynonym -newtype UnitConstructor a = UnitConstructor a deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +data UnitConstructor a = UnitConstructor deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 UnitConstructor where liftEq = genericLiftEq instance Ord1 UnitConstructor where liftCompare = genericLiftCompare @@ -53,7 +53,7 @@ instance ToJSONFields1 UnitConstructor instance Evaluatable UnitConstructor -newtype TupleConstructor a = TupleConstructor a deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +newtype TupleConstructor a = TupleConstructor { tupleConstructorArity :: Int } deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 TupleConstructor where liftEq = genericLiftEq instance Ord1 TupleConstructor where liftCompare = genericLiftCompare @@ -63,7 +63,7 @@ instance ToJSONFields1 TupleConstructor instance Evaluatable TupleConstructor -newtype ListConstructor a = ListConstructor a deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +data ListConstructor a = ListConstructor deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 ListConstructor where liftEq = genericLiftEq instance Ord1 ListConstructor where liftCompare = genericLiftCompare @@ -73,7 +73,7 @@ instance ToJSONFields1 ListConstructor instance Evaluatable ListConstructor -newtype FunctionConstructor a = FunctionConstructor a deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) +data FunctionConstructor a = FunctionConstructor deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) instance Eq1 FunctionConstructor where liftEq = genericLiftEq instance Ord1 FunctionConstructor where liftCompare = genericLiftCompare diff --git a/test/fixtures/haskell/corpus/type-synonyms.diffA-B.txt b/test/fixtures/haskell/corpus/type-synonyms.diffA-B.txt index 9543534a8..13562dea3 100644 --- a/test/fixtures/haskell/corpus/type-synonyms.diffA-B.txt +++ b/test/fixtures/haskell/corpus/type-synonyms.diffA-B.txt @@ -16,8 +16,7 @@ ->(Identifier) } (TypeParameters)) (Type - (ListConstructor - (Empty)) + (ListConstructor) (TypeParameters))) (TypeSynonym (Type @@ -49,40 +48,34 @@ ->(Identifier) } (TypeParameters)) (Type - (UnitConstructor - (Empty)) + (UnitConstructor) (TypeParameters))) {-(TypeSynonym {-(Type {-(Identifier)-} {-(TypeParameters)-})-} {-(Type - {-(TupleConstructor - {-(Empty)-})-} + {-(TupleConstructor)-} {-(TypeParameters)-})-})-} (TypeSynonym (Type (Identifier) (TypeParameters)) (Type - (TupleConstructor - (Empty)) + (TupleConstructor) (TypeParameters))) (TypeSynonym (Type (Identifier) (TypeParameters)) (Type - { (FunctionConstructor - {-(Empty)-}) - ->(TupleConstructor - {+(Empty)+}) } + { (FunctionConstructor) + ->(TupleConstructor) } (TypeParameters))) {+(TypeSynonym {+(Type {+(Identifier)+} {+(TypeParameters)+})+} {+(Type - {+(FunctionConstructor - {+(Empty)+})+} + {+(FunctionConstructor)+} {+(TypeParameters)+})+})+})) diff --git a/test/fixtures/haskell/corpus/type-synonyms.diffB-A.txt b/test/fixtures/haskell/corpus/type-synonyms.diffB-A.txt index 3db8a0ea3..26867ce22 100644 --- a/test/fixtures/haskell/corpus/type-synonyms.diffB-A.txt +++ b/test/fixtures/haskell/corpus/type-synonyms.diffB-A.txt @@ -16,8 +16,7 @@ ->(Identifier) } (TypeParameters)) (Type - (ListConstructor - (Empty)) + (ListConstructor) (TypeParameters))) (TypeSynonym (Type @@ -49,40 +48,34 @@ ->(Identifier) } (TypeParameters)) (Type - (UnitConstructor - (Empty)) + (UnitConstructor) (TypeParameters))) {+(TypeSynonym {+(Type {+(Identifier)+} {+(TypeParameters)+})+} {+(Type - {+(TupleConstructor - {+(Empty)+})+} + {+(TupleConstructor)+} {+(TypeParameters)+})+})+} (TypeSynonym (Type (Identifier) (TypeParameters)) (Type - (TupleConstructor - (Empty)) + (TupleConstructor) (TypeParameters))) (TypeSynonym (Type (Identifier) (TypeParameters)) (Type - { (TupleConstructor - {-(Empty)-}) - ->(FunctionConstructor - {+(Empty)+}) } + { (TupleConstructor) + ->(FunctionConstructor) } (TypeParameters))) {-(TypeSynonym {-(Type {-(Identifier)-} {-(TypeParameters)-})-} {-(Type - {-(FunctionConstructor - {-(Empty)-})-} + {-(FunctionConstructor)-} {-(TypeParameters)-})-})-})) diff --git a/test/fixtures/haskell/corpus/type-synonyms.parseA.txt b/test/fixtures/haskell/corpus/type-synonyms.parseA.txt index 86eca5b2b..ab91692b0 100644 --- a/test/fixtures/haskell/corpus/type-synonyms.parseA.txt +++ b/test/fixtures/haskell/corpus/type-synonyms.parseA.txt @@ -13,8 +13,7 @@ (Identifier) (TypeParameters)) (Type - (ListConstructor - (Empty)) + (ListConstructor) (TypeParameters))) (TypeSynonym (Type @@ -42,30 +41,26 @@ (Identifier) (TypeParameters)) (Type - (UnitConstructor - (Empty)) + (UnitConstructor) (TypeParameters))) (TypeSynonym (Type (Identifier) (TypeParameters)) (Type - (TupleConstructor - (Empty)) + (TupleConstructor) (TypeParameters))) (TypeSynonym (Type (Identifier) (TypeParameters)) (Type - (TupleConstructor - (Empty)) + (TupleConstructor) (TypeParameters))) (TypeSynonym (Type (Identifier) (TypeParameters)) (Type - (FunctionConstructor - (Empty)) + (FunctionConstructor) (TypeParameters))))) diff --git a/test/fixtures/haskell/corpus/type-synonyms.parseB.txt b/test/fixtures/haskell/corpus/type-synonyms.parseB.txt index 9153c086a..bc5168708 100644 --- a/test/fixtures/haskell/corpus/type-synonyms.parseB.txt +++ b/test/fixtures/haskell/corpus/type-synonyms.parseB.txt @@ -13,8 +13,7 @@ (Identifier) (TypeParameters)) (Type - (ListConstructor - (Empty)) + (ListConstructor) (TypeParameters))) (TypeSynonym (Type @@ -44,30 +43,26 @@ (Identifier) (TypeParameters)) (Type - (UnitConstructor - (Empty)) + (UnitConstructor) (TypeParameters))) (TypeSynonym (Type (Identifier) (TypeParameters)) (Type - (TupleConstructor - (Empty)) + (TupleConstructor) (TypeParameters))) (TypeSynonym (Type (Identifier) (TypeParameters)) (Type - (TupleConstructor - (Empty)) + (TupleConstructor) (TypeParameters))) (TypeSynonym (Type (Identifier) (TypeParameters)) (Type - (FunctionConstructor - (Empty)) + (FunctionConstructor) (TypeParameters))))) From 9f1e73cd0785c999f2b3d318acaf063181fce816 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 08:42:41 -0400 Subject: [PATCH 136/159] Align the Allocator constructors. --- src/Control/Abstract/Heap.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 6650abb55..063b93f9b 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -110,7 +110,7 @@ variable name = lookupEnv name >>= maybeM (freeVariableError name) >>= deref -- Effects data Allocator address value return where - Alloc :: Name -> Allocator address value address + Alloc :: Name -> Allocator address value address Deref :: address -> Allocator address value value runAllocator :: (Addressable address effects, Effectful (m address value), Member (Resumable (AddressError address value)) effects, Member (State (Heap address (Cell address) value)) effects) => m address value (Allocator address value ': effects) a -> m address value effects a From 42540a1e2086a840e8467fb33363c81fa17ad1f1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 08:47:16 -0400 Subject: [PATCH 137/159] Rename Allocator to Store. --- src/Analysis/Abstract/Caching.hs | 2 +- src/Control/Abstract/Heap.hs | 26 ++++++++++++------------- src/Control/Abstract/Primitive.hs | 4 ++-- src/Control/Abstract/Value.hs | 4 ++-- src/Data/Abstract/Evaluatable.hs | 6 +++--- src/Data/Abstract/Type.hs | 4 ++-- src/Data/Abstract/Value.hs | 4 ++-- src/Language/PHP/Syntax.hs | 2 +- src/Language/Python/Syntax.hs | 2 +- src/Language/TypeScript/Syntax.hs | 2 +- test/Control/Abstract/Evaluator/Spec.hs | 2 +- 11 files changed, 29 insertions(+), 29 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index f9056858a..df8b258f2 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -78,7 +78,7 @@ cachingTerms recur term = do convergingModules :: ( AbstractValue address value effects , Cacheable term address (Cell address) value - , Member (Allocator address value) effects + , Member (Store address value) effects , Member Fresh effects , Member NonDet effects , Member (Reader (Cache term address (Cell address) value)) effects diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 063b93f9b..514bc3c8b 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -12,8 +12,8 @@ module Control.Abstract.Heap , letrec' , variable -- * Effects -, Allocator(..) -, runAllocator +, Store(..) +, runStore , AddressError(..) , runAddressError , runAddressErrorWith @@ -41,11 +41,11 @@ modifyHeap :: Member (State (Heap address (Cell address) value)) effects => (Hea modifyHeap = modify' -alloc :: forall address value effects . Member (Allocator address value) effects => Name -> Evaluator address value effects address +alloc :: forall address value effects . Member (Store address value) effects => Name -> Evaluator address value effects address alloc = send . Alloc @address @value -- | Dereference the given address in the heap, or fail if the address is uninitialized. -deref :: Member (Allocator address value) effects => address -> Evaluator address value effects value +deref :: Member (Store address value) effects => address -> Evaluator address value effects value deref = send . Deref @@ -61,7 +61,7 @@ assign address = modifyHeap . heapInsert address -- | Look up or allocate an address for a 'Name'. -lookupOrAlloc :: ( Member (Allocator address value) effects +lookupOrAlloc :: ( Member (Store address value) effects , Member (Env address) effects ) => Name @@ -69,7 +69,7 @@ lookupOrAlloc :: ( Member (Allocator address value) effects lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name) -letrec :: ( Member (Allocator address value) effects +letrec :: ( Member (Store address value) effects , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects , Ord address @@ -85,7 +85,7 @@ letrec name body = do pure (v, addr) -- Lookup/alloc a name passing the address to a body evaluated in a new local environment. -letrec' :: ( Member (Allocator address value) effects +letrec' :: ( Member (Store address value) effects , Member (Env address) effects ) => Name @@ -98,7 +98,7 @@ letrec' name body = do -- | Look up and dereference the given 'Name', throwing an exception for free variables. -variable :: ( Member (Allocator address value) effects +variable :: ( Member (Store address value) effects , Member (Env address) effects , Member (Resumable (EnvironmentError address)) effects ) @@ -109,12 +109,12 @@ variable name = lookupEnv name >>= maybeM (freeVariableError name) >>= deref -- Effects -data Allocator address value return where - Alloc :: Name -> Allocator address value address - Deref :: address -> Allocator address value value +data Store address value return where + Alloc :: Name -> Store address value address + Deref :: address -> Store address value value -runAllocator :: (Addressable address effects, Effectful (m address value), Member (Resumable (AddressError address value)) effects, Member (State (Heap address (Cell address) value)) effects) => m address value (Allocator address value ': effects) a -> m address value effects a -runAllocator = raiseHandler (interpret (\ eff -> case eff of +runStore :: (Addressable address effects, Effectful (m address value), Member (Resumable (AddressError address value)) effects, Member (State (Heap address (Cell address) value)) effects) => m address value (Store address value ': effects) a -> m address value effects a +runStore = raiseHandler (interpret (\ eff -> case eff of Alloc name -> lowerEff $ allocCell name Deref addr -> lowerEff $ heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr)))) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 927b45b91..bec3ad1fa 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -13,7 +13,7 @@ import Data.Semilattice.Lower import Prologue builtin :: ( HasCallStack - , Member (Allocator address value) effects + , Member (Store address value) effects , Member (Env address) effects , Member (Reader ModuleInfo) effects , Member (Reader Span) effects @@ -39,7 +39,7 @@ lambda body = do defineBuiltins :: ( AbstractValue address value effects , HasCallStack - , Member (Allocator address value) effects + , Member (Store address value) effects , Member (Env address) effects , Member Fresh effects , Member (Reader ModuleInfo) effects diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index b4aa39867..5a2a9c976 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -218,7 +218,7 @@ evaluateInScopedEnv scopedEnvTerm term = do -- | Evaluates a 'Value' returning the referenced value value :: ( AbstractValue address value effects - , Member (Allocator address value) effects + , Member (Store address value) effects , Member (Env address) effects , Member (Resumable (EnvironmentError address)) effects ) @@ -230,7 +230,7 @@ value (Rval val) = pure val -- | Evaluates a 'Subterm' to its rval subtermValue :: ( AbstractValue address value effects - , Member (Allocator address value) effects + , Member (Store address value) effects , Member (Env address) effects , Member (Resumable (EnvironmentError address)) effects ) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 3229fade5..654ea8207 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -52,7 +52,7 @@ type EvaluatableConstraints address term value effects = ( AbstractValue address value effects , Declarations term , FreeVariables term - , Member (Allocator address value) effects + , Member (Store address value) effects , Member (Env address) effects , Member (LoopControl value) effects , Member (Modules address value) effects @@ -85,7 +85,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer , Member (State (ModuleTable (Maybe (value, Environment address)))) outer , Member Trace outer , Recursive term - , inner ~ (LoopControl value ': Return value ': Env address ': Allocator address value ': inner') + , inner ~ (LoopControl value ': Return value ': Env address ': Store address value ': inner') , inner' ~ (Reader ModuleInfo ': inner'') , inner'' ~ (Modules address value ': Reader Span ': Reader PackageInfo ': outer) ) @@ -111,7 +111,7 @@ evaluatePackageWith analyzeModule analyzeTerm package runInModule preludeEnv info = runReader info - . raiseHandler runAllocator + . raiseHandler runStore . raiseHandler (runEnv preludeEnv) . raiseHandler runReturn . raiseHandler runLoopControl diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index e112ce257..3f77164de 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -116,7 +116,7 @@ instance AbstractIntro Type where null = Null -instance ( Member (Allocator address Type) effects +instance ( Member (Store address Type) effects , Member (Env address) effects , Member Fresh effects , Member (Resumable TypeError) effects @@ -145,7 +145,7 @@ instance ( Member (Allocator address Type) effects -- | Discard the value arguments (if any), constructing a 'Type' instead. -instance ( Member (Allocator address Type) effects +instance ( Member (Store address Type) effects , Member (Env address) effects , Member Fresh effects , Member NonDet effects diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index f81646456..1fbee1e45 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -55,7 +55,7 @@ instance AbstractHole (Value address body) where hole = Hole instance ( Coercible body (Eff effects) - , Member (Allocator address (Value address body)) effects + , Member (Store address (Value address body)) effects , Member (Env address) effects , Member Fresh effects , Member (Reader ModuleInfo) effects @@ -108,7 +108,7 @@ instance Show address => AbstractIntro (Value address body) where -- | Construct a 'Value' wrapping the value arguments (if any). instance ( Coercible body (Eff effects) - , Member (Allocator address (Value address body)) effects + , Member (Store address (Value address body)) effects , Member (Env address) effects , Member Fresh effects , Member (LoopControl (Value address body)) effects diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 2fc416904..b4b77dd30 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -53,7 +53,7 @@ resolvePHPName n = do toName = BC.unpack . dropRelativePrefix . stripQuotes include :: ( AbstractValue address value effects - , Member (Allocator address value) effects + , Member (Store address value) effects , Member (Env address) effects , Member (Modules address value) effects , Member (Resumable ResolutionError) effects diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 4a97fcd22..84beb15ce 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -128,7 +128,7 @@ instance Evaluatable Import where -- Evaluate a qualified import evalQualifiedImport :: ( AbstractValue address value effects - , Member (Allocator address value) effects + , Member (Store address value) effects , Member (Env address) effects , Member (Modules address value) effects , Member (State (Heap address (Cell address) value)) effects diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index f7bd96060..7dc91837d 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -134,7 +134,7 @@ javascriptExtensions :: [String] javascriptExtensions = ["js"] evalRequire :: ( AbstractValue address value effects - , Member (Allocator address value) effects + , Member (Store address value) effects , Member (Env address) effects , Member (Modules address value) effects , Member (State (Heap address (Cell address) value)) effects diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index 28100f6b1..569307adb 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -37,7 +37,7 @@ evaluate . runValueError . runEnvironmentError . runAddressError - . runAllocator + . runStore . runEnv lowerBound . runReturn . runLoopControl From b491750f94b73fa2190d82d6a71d28865df08830 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 08:50:57 -0400 Subject: [PATCH 138/159] Specialize runStore. --- src/Control/Abstract/Heap.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 514bc3c8b..6258a6869 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -22,7 +22,6 @@ module Control.Abstract.Heap import Control.Abstract.Addressable import Control.Abstract.Environment import Control.Abstract.Evaluator -import Control.Monad.Effect.Internal import Data.Abstract.Heap import Data.Abstract.Name import Data.Semigroup.Reducer @@ -113,10 +112,10 @@ data Store address value return where Alloc :: Name -> Store address value address Deref :: address -> Store address value value -runStore :: (Addressable address effects, Effectful (m address value), Member (Resumable (AddressError address value)) effects, Member (State (Heap address (Cell address) value)) effects) => m address value (Store address value ': effects) a -> m address value effects a -runStore = raiseHandler (interpret (\ eff -> case eff of - Alloc name -> lowerEff $ allocCell name - Deref addr -> lowerEff $ heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr)))) +runStore :: (Addressable address effects, Member (Resumable (AddressError address value)) effects, Member (State (Heap address (Cell address) value)) effects) => Evaluator address value (Store address value ': effects) a -> Evaluator address value effects a +runStore = interpret (\ eff -> case eff of + Alloc name -> allocCell name + Deref addr -> heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr))) data AddressError address value resume where From ffd1e3e3f8905e66a1edc9ab01ea1e0635ff754a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 08:51:17 -0400 Subject: [PATCH 139/159] :lipstick:: $ for effect handler. --- src/Control/Abstract/Heap.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 6258a6869..87f310b4b 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -113,9 +113,9 @@ data Store address value return where Deref :: address -> Store address value value runStore :: (Addressable address effects, Member (Resumable (AddressError address value)) effects, Member (State (Heap address (Cell address) value)) effects) => Evaluator address value (Store address value ': effects) a -> Evaluator address value effects a -runStore = interpret (\ eff -> case eff of +runStore = interpret $ \ eff -> case eff of Alloc name -> allocCell name - Deref addr -> heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr))) + Deref addr -> heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr)) data AddressError address value resume where From eb40de097e2e2f0530961689106fb36d5dfc92fa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 08:52:42 -0400 Subject: [PATCH 140/159] Reformat the runStore signature. --- src/Control/Abstract/Heap.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 87f310b4b..93c0a7b6c 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -112,7 +112,12 @@ data Store address value return where Alloc :: Name -> Store address value address Deref :: address -> Store address value value -runStore :: (Addressable address effects, Member (Resumable (AddressError address value)) effects, Member (State (Heap address (Cell address) value)) effects) => Evaluator address value (Store address value ': effects) a -> Evaluator address value effects a +runStore :: ( Addressable address effects + , Member (Resumable (AddressError address value)) effects + , Member (State (Heap address (Cell address) value)) effects + ) + => Evaluator address value (Store address value ': effects) a + -> Evaluator address value effects a runStore = interpret $ \ eff -> case eff of Alloc name -> allocCell name Deref addr -> heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr)) From 21f43cdf4d7cdc3fe204039eff33375c6e303778 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 08:58:32 -0400 Subject: [PATCH 141/159] Assign values using the Store effect. --- src/Control/Abstract/Heap.hs | 17 +++++++---------- src/Control/Abstract/Primitive.hs | 8 -------- src/Control/Abstract/Value.hs | 6 +----- src/Data/Abstract/Type.hs | 7 ------- src/Data/Abstract/Value.hs | 7 ------- src/Language/Python/Syntax.hs | 4 ---- src/Language/TypeScript/Syntax.hs | 4 ---- 7 files changed, 8 insertions(+), 45 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 93c0a7b6c..d5d3fbdbb 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -49,14 +49,11 @@ deref = send . Deref -- | Write a value to the given address in the 'Store'. -assign :: ( Member (State (Heap address (Cell address) value)) effects - , Ord address - , Reducer value (Cell address value) - ) +assign :: Member (Store address value) effects => address -> value -> Evaluator address value effects () -assign address = modifyHeap . heapInsert address +assign address = send . Assign address -- | Look up or allocate an address for a 'Name'. @@ -70,9 +67,6 @@ lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name) letrec :: ( Member (Store address value) effects , Member (Env address) effects - , Member (State (Heap address (Cell address) value)) effects - , Ord address - , Reducer value (Cell address value) ) => Name -> Evaluator address value effects value @@ -109,18 +103,21 @@ variable name = lookupEnv name >>= maybeM (freeVariableError name) >>= deref -- Effects data Store address value return where - Alloc :: Name -> Store address value address - Deref :: address -> Store address value value + Alloc :: Name -> Store address value address + Deref :: address -> Store address value value + Assign :: address -> value -> Store address value () runStore :: ( Addressable address effects , Member (Resumable (AddressError address value)) effects , Member (State (Heap address (Cell address) value)) effects + , Reducer value (Cell address value) ) => Evaluator address value (Store address value ': effects) a -> Evaluator address value effects a runStore = interpret $ \ eff -> case eff of Alloc name -> allocCell name Deref addr -> heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr)) + Assign addr value -> modifyHeap (heapInsert addr value) data AddressError address value resume where diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index bec3ad1fa..d5d2bcda8 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -1,6 +1,5 @@ module Control.Abstract.Primitive where -import Control.Abstract.Addressable import Control.Abstract.Context import Control.Abstract.Environment import Control.Abstract.Evaluator @@ -8,7 +7,6 @@ import Control.Abstract.Heap import Control.Abstract.Value import Data.Abstract.Name import Data.ByteString.Char8 (pack, unpack) -import Data.Semigroup.Reducer hiding (unit) import Data.Semilattice.Lower import Prologue @@ -17,9 +15,6 @@ builtin :: ( HasCallStack , Member (Env address) effects , Member (Reader ModuleInfo) effects , Member (Reader Span) effects - , Member (State (Heap address (Cell address) value)) effects - , Ord address - , Reducer value (Cell address value) ) => String -> Evaluator address value effects value @@ -45,10 +40,7 @@ defineBuiltins :: ( AbstractValue address value effects , Member (Reader ModuleInfo) effects , Member (Reader Span) effects , Member (Resumable (EnvironmentError address)) effects - , Member (State (Heap address (Cell address) value)) effects , Member Trace effects - , Ord address - , Reducer value (Cell address value) ) => Evaluator address value effects () defineBuiltins = diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 5a2a9c976..8af79a65a 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -15,7 +15,6 @@ module Control.Abstract.Value , ValueRoots(..) ) where -import Control.Abstract.Addressable import Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Abstract.Heap @@ -25,7 +24,6 @@ import Data.Abstract.Name import Data.Abstract.Number as Number import Data.Abstract.Ref import Data.Scientific (Scientific) -import Data.Semigroup.Reducer hiding (unit) import Data.Semilattice.Lower import Prelude import Prologue hiding (TypeError) @@ -188,9 +186,7 @@ doWhile body cond = loop $ \ continue -> body *> do makeNamespace :: ( AbstractValue address value effects , Member (Env address) effects - , Member (State (Heap address (Cell address) value)) effects - , Ord address - , Reducer value (Cell address value) + , Member (Store address value) effects ) => Name -> address diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 3f77164de..48de6af7e 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -10,7 +10,6 @@ module Data.Abstract.Type import Control.Abstract import Data.Abstract.Environment as Env import Data.Semigroup.Foldable (foldMap1) -import Data.Semigroup.Reducer (Reducer) import Prologue hiding (TypeError) type TName = Int @@ -121,9 +120,6 @@ instance ( Member (Store address Type) effects , Member Fresh effects , Member (Resumable TypeError) effects , Member (Return Type) effects - , Member (State (Heap address (Cell address) Type)) effects - , Ord address - , Reducer Type (Cell address Type) ) => AbstractFunction address Type effects where closure names _ body = do @@ -151,9 +147,6 @@ instance ( Member (Store address Type) effects , Member NonDet effects , Member (Resumable TypeError) effects , Member (Return Type) effects - , Member (State (Heap address (Cell address) Type)) effects - , Ord address - , Reducer Type (Cell address Type) ) => AbstractValue address Type effects where array fields = do diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 1fbee1e45..759cdcfda 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -10,7 +10,6 @@ import Data.Coerce import Data.List (genericIndex, genericLength) import Data.Scientific (Scientific) import Data.Scientific.Exts -import Data.Semigroup.Reducer import qualified Data.Set as Set import Prologue @@ -62,9 +61,6 @@ instance ( Coercible body (Eff effects) , Member (Reader PackageInfo) effects , Member (Resumable (ValueError address body)) effects , Member (Return (Value address body)) effects - , Member (State (Heap address (Cell address) (Value address body))) effects - , Ord address - , Reducer (Value address body) (Cell address (Value address body)) , Show address ) => AbstractFunction address (Value address body) effects where @@ -116,9 +112,6 @@ instance ( Coercible body (Eff effects) , Member (Reader PackageInfo) effects , Member (Resumable (ValueError address body)) effects , Member (Return (Value address body)) effects - , Member (State (Heap address (Cell address) (Value address body))) effects - , Ord address - , Reducer (Value address body) (Cell address (Value address body)) , Show address ) => AbstractValue address (Value address body) effects where diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 84beb15ce..8ff59c351 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -16,7 +16,6 @@ import System.FilePath.Posix import qualified Data.ByteString.Char8 as BC import qualified Data.Language as Language import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Semigroup.Reducer as Reducer data QualifiedName = QualifiedName (NonEmpty FilePath) @@ -131,9 +130,6 @@ evalQualifiedImport :: ( AbstractValue address value effects , Member (Store address value) effects , Member (Env address) effects , Member (Modules address value) effects - , Member (State (Heap address (Cell address) value)) effects - , Ord address - , Reducer.Reducer value (Cell address value) ) => Name -> ModulePath -> Evaluator address value effects value evalQualifiedImport name path = letrec' name $ \addr -> do diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 7dc91837d..eb234dbae 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -12,7 +12,6 @@ import qualified Data.ByteString.Char8 as BC import Data.JSON.Fields import qualified Data.Language as Language import qualified Data.Map as Map -import Data.Semigroup.Reducer (Reducer) import Diffing.Algorithm import Prelude import Prologue @@ -137,9 +136,6 @@ evalRequire :: ( AbstractValue address value effects , Member (Store address value) effects , Member (Env address) effects , Member (Modules address value) effects - , Member (State (Heap address (Cell address) value)) effects - , Ord address - , Reducer value (Cell address value) ) => M.ModulePath -> Name From 8b9f49b5ea28df28b1903bbfe16f5abe7a8e16d6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 09:05:00 -0400 Subject: [PATCH 142/159] =?UTF-8?q?Evaluatable=20instances=20don=E2=80=99t?= =?UTF-8?q?=20need=20to=20know=20about=20the=20state.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Abstract/Evaluatable.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 654ea8207..b343f5e56 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -64,10 +64,7 @@ type EvaluatableConstraints address term value effects = , Member (Resumable ResolutionError) effects , Member (Resumable (Unspecialized value)) effects , Member (Return value) effects - , Member (State (Heap address (Cell address) value)) effects , Member Trace effects - , Ord address - , Reducer value (Cell address value) ) @@ -85,6 +82,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer , Member (State (ModuleTable (Maybe (value, Environment address)))) outer , Member Trace outer , Recursive term + , Reducer value (Cell address value) , inner ~ (LoopControl value ': Return value ': Env address ': Store address value ': inner') , inner' ~ (Reader ModuleInfo ': inner'') , inner'' ~ (Modules address value ': Reader Span ': Reader PackageInfo ': outer) From 252b904520794b09c0aa9ab557d9dac92f7b451c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 09:05:30 -0400 Subject: [PATCH 143/159] Swap the type parameters. --- src/Data/Abstract/Evaluatable.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index b343f5e56..69565bec7 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -41,14 +41,14 @@ import Prologue -- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics. class Evaluatable constr where - eval :: ( EvaluatableConstraints address term value effects + eval :: ( EvaluatableConstraints term address value effects , Member Fail effects ) => SubtermAlgebra constr term (Evaluator address value effects (ValueRef value)) default eval :: (Member (Resumable (Unspecialized value)) effects, Show1 constr) => SubtermAlgebra constr term (Evaluator address value effects (ValueRef value)) eval expr = throwResumable (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr "")) -type EvaluatableConstraints address term value effects = +type EvaluatableConstraints term address value effects = ( AbstractValue address value effects , Declarations term , FreeVariables term @@ -73,7 +73,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer -- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' locations require knowledge of 'currentModule' to run. Can we fix that? . ( Addressable address inner' , Evaluatable (Base term) - , EvaluatableConstraints address term value inner + , EvaluatableConstraints term address value inner , Member Fail outer , Member Fresh outer , Member (Resumable (AddressError address value)) outer From 58b1de14fca285c2c0a6d1e0c6a968649b89fe87 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 09:18:37 -0400 Subject: [PATCH 144/159] :lipstick: --- src/Analysis/Abstract/Collecting.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 33f48ca6d..a30069d09 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -45,9 +45,9 @@ reachable :: ( Ord address reachable roots heap = go mempty roots where go seen set = case liveSplit set of Nothing -> seen - Just (a, as) -> go (liveInsert a seen) (case heapLookupAll a heap of + Just (a, as) -> go (liveInsert a seen) $ case heapLookupAll a heap of Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen - _ -> seen) + _ -> seen providingLiveSet :: Effectful (m address value) => m address value (Reader (Live address) ': effects) a -> m address value effects a From 91122566dfc827d83bf35dd32c5989c03203f630 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 09:31:36 -0400 Subject: [PATCH 145/159] Move ValueRoots into Control.Abstract.Roots. --- src/Control/Abstract/Roots.hs | 10 +++++++++- src/Control/Abstract/Value.hs | 8 -------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Control/Abstract/Roots.hs b/src/Control/Abstract/Roots.hs index ccc07e3ca..bed08282d 100644 --- a/src/Control/Abstract/Roots.hs +++ b/src/Control/Abstract/Roots.hs @@ -1,5 +1,6 @@ module Control.Abstract.Roots -( Live +( ValueRoots(..) +, Live , askRoots , extraRoots ) where @@ -8,6 +9,13 @@ import Control.Abstract.Evaluator import Data.Abstract.Live import Prologue + +-- | Value types, e.g. closures, which can root a set of addresses. +class ValueRoots address value where + -- | Compute the set of addresses rooted by a given value. + valueRoots :: value -> Live address + + -- | Retrieve the local 'Live' set. askRoots :: Member (Reader (Live address)) effects => Evaluator address value effects (Live address) askRoots = ask diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 8af79a65a..546f761c1 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -12,14 +12,12 @@ module Control.Abstract.Value , evaluateInScopedEnv , value , subtermValue -, ValueRoots(..) ) where import Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Abstract.Heap import Data.Abstract.Environment as Env -import Data.Abstract.Live (Live) import Data.Abstract.Name import Data.Abstract.Number as Number import Data.Abstract.Ref @@ -233,9 +231,3 @@ subtermValue :: ( AbstractValue address value effects => Subterm term (Evaluator address value effects (ValueRef value)) -> Evaluator address value effects value subtermValue = value <=< subtermRef - - --- | Value types, e.g. closures, which can root a set of addresses. -class ValueRoots address value where - -- | Compute the set of addresses rooted by a given value. - valueRoots :: value -> Live address From a72515b8585480e28aa2f52bcd12e11db550e575 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 09:33:04 -0400 Subject: [PATCH 146/159] Move gc/reachable into Control.Abstract.Heap. --- src/Analysis/Abstract/Collecting.hs | 27 ----------------------- src/Control/Abstract/Heap.hs | 33 +++++++++++++++++++++++++++++ 2 files changed, 33 insertions(+), 27 deletions(-) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index a30069d09..70afb4fb8 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -5,8 +5,6 @@ module Analysis.Abstract.Collecting ) where import Control.Abstract -import Data.Abstract.Heap -import Data.Abstract.Live import Data.Semilattice.Lower import Prologue @@ -24,31 +22,6 @@ collectingTerms recur term = do v <- recur term v <$ TermEvaluator (modifyHeap (gc (roots <> valueRoots v))) --- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set. -gc :: ( Ord address - , Foldable (Cell address) - , ValueRoots address value - ) - => Live address -- ^ The set of addresses to consider rooted. - -> Heap address (Cell address) value -- ^ A heap to collect unreachable addresses within. - -> Heap address (Cell address) value -- ^ A garbage-collected heap. -gc roots heap = heapRestrict heap (reachable roots heap) - --- | Compute the set of addresses reachable from a given root set in a given heap. -reachable :: ( Ord address - , Foldable (Cell address) - , ValueRoots address value - ) - => Live address -- ^ The set of root addresses. - -> Heap address (Cell address) value -- ^ The heap to trace addresses through. - -> Live address -- ^ The set of addresses reachable from the root set. -reachable roots heap = go mempty roots - where go seen set = case liveSplit set of - Nothing -> seen - Just (a, as) -> go (liveInsert a seen) $ case heapLookupAll a heap of - Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen - _ -> seen - providingLiveSet :: Effectful (m address value) => m address value (Reader (Live address) ': effects) a -> m address value effects a providingLiveSet = runReader lowerBound diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index d5d3fbdbb..2c2cc9580 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -11,6 +11,9 @@ module Control.Abstract.Heap , letrec , letrec' , variable +-- * Garbage collection +, gc +, reachable -- * Effects , Store(..) , runStore @@ -22,7 +25,9 @@ module Control.Abstract.Heap import Control.Abstract.Addressable import Control.Abstract.Environment import Control.Abstract.Evaluator +import Control.Abstract.Roots import Data.Abstract.Heap +import Data.Abstract.Live import Data.Abstract.Name import Data.Semigroup.Reducer import Prologue @@ -100,6 +105,34 @@ variable :: ( Member (Store address value) effects variable name = lookupEnv name >>= maybeM (freeVariableError name) >>= deref +-- Garbage collection + +-- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set. +gc :: ( Ord address + , Foldable (Cell address) + , ValueRoots address value + ) + => Live address -- ^ The set of addresses to consider rooted. + -> Heap address (Cell address) value -- ^ A heap to collect unreachable addresses within. + -> Heap address (Cell address) value -- ^ A garbage-collected heap. +gc roots heap = heapRestrict heap (reachable roots heap) + +-- | Compute the set of addresses reachable from a given root set in a given heap. +reachable :: ( Ord address + , Foldable (Cell address) + , ValueRoots address value + ) + => Live address -- ^ The set of root addresses. + -> Heap address (Cell address) value -- ^ The heap to trace addresses through. + -> Live address -- ^ The set of addresses reachable from the root set. +reachable roots heap = go mempty roots + where go seen set = case liveSplit set of + Nothing -> seen + Just (a, as) -> go (liveInsert a seen) $ case heapLookupAll a heap of + Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen + _ -> seen + + -- Effects data Store address value return where From b13dc4660ac13168f3cf7eacc2dd870b938d9978 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 09:33:38 -0400 Subject: [PATCH 147/159] =?UTF-8?q?Don=E2=80=99t=20export=20reachable.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Heap.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 2c2cc9580..35acae7a9 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -13,7 +13,6 @@ module Control.Abstract.Heap , variable -- * Garbage collection , gc -, reachable -- * Effects , Store(..) , runStore From 798b65d82cd04d42fc998153ed78f222136f93ba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 09:40:06 -0400 Subject: [PATCH 148/159] gc is an action in Store. --- src/Analysis/Abstract/Collecting.hs | 7 +++---- src/Control/Abstract/Heap.hs | 19 +++++++++++-------- src/Data/Abstract/Evaluatable.hs | 2 ++ 3 files changed, 16 insertions(+), 12 deletions(-) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 70afb4fb8..a259506bd 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -9,9 +9,8 @@ import Data.Semilattice.Lower import Prologue -- | An analysis performing GC after every instruction. -collectingTerms :: ( Foldable (Cell address) - , Member (Reader (Live address)) effects - , Member (State (Heap address (Cell address) value)) effects +collectingTerms :: ( Member (Reader (Live address)) effects + , Member (Store address value) effects , Ord address , ValueRoots address value ) @@ -20,7 +19,7 @@ collectingTerms :: ( Foldable (Cell address) collectingTerms recur term = do roots <- TermEvaluator askRoots v <- recur term - v <$ TermEvaluator (modifyHeap (gc (roots <> valueRoots v))) + v <$ TermEvaluator (gc (roots <> valueRoots v)) providingLiveSet :: Effectful (m address value) => m address value (Reader (Live address) ': effects) a -> m address value effects a diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 35acae7a9..da2ad670a 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -107,14 +107,10 @@ variable name = lookupEnv name >>= maybeM (freeVariableError name) >>= deref -- Garbage collection -- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set. -gc :: ( Ord address - , Foldable (Cell address) - , ValueRoots address value - ) - => Live address -- ^ The set of addresses to consider rooted. - -> Heap address (Cell address) value -- ^ A heap to collect unreachable addresses within. - -> Heap address (Cell address) value -- ^ A garbage-collected heap. -gc roots heap = heapRestrict heap (reachable roots heap) +gc :: Member (Store address value) effects + => Live address -- ^ The set of addresses to consider rooted. + -> Evaluator address value effects () +gc roots = sendStore (GC roots) -- | Compute the set of addresses reachable from a given root set in a given heap. reachable :: ( Ord address @@ -134,15 +130,21 @@ reachable roots heap = go mempty roots -- Effects +sendStore :: Member (Store address value) effects => Store address value return -> Evaluator address value effects return +sendStore = send + data Store address value return where Alloc :: Name -> Store address value address Deref :: address -> Store address value value Assign :: address -> value -> Store address value () + GC :: Live address -> Store address value () runStore :: ( Addressable address effects + , Foldable (Cell address) , Member (Resumable (AddressError address value)) effects , Member (State (Heap address (Cell address) value)) effects , Reducer value (Cell address value) + , ValueRoots address value ) => Evaluator address value (Store address value ': effects) a -> Evaluator address value effects a @@ -150,6 +152,7 @@ runStore = interpret $ \ eff -> case eff of Alloc name -> allocCell name Deref addr -> heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr)) Assign addr value -> modifyHeap (heapInsert addr value) + GC roots -> modifyHeap (heapRestrict <*> reachable roots) data AddressError address value resume where diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 69565bec7..dca758ad8 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -74,6 +74,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer . ( Addressable address inner' , Evaluatable (Base term) , EvaluatableConstraints term address value inner + , Foldable (Cell address) , Member Fail outer , Member Fresh outer , Member (Resumable (AddressError address value)) outer @@ -83,6 +84,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer , Member Trace outer , Recursive term , Reducer value (Cell address value) + , ValueRoots address value , inner ~ (LoopControl value ': Return value ': Env address ': Store address value ': inner') , inner' ~ (Reader ModuleInfo ': inner'') , inner'' ~ (Modules address value ': Reader Span ': Reader PackageInfo ': outer) From f2d51d3802808173e5a6e0e288d7f81fb3333b9a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 09:40:38 -0400 Subject: [PATCH 149/159] =?UTF-8?q?Don=E2=80=99t=20export=20modifyHeap.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Heap.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index da2ad670a..6ff318706 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -3,7 +3,6 @@ module Control.Abstract.Heap ( Heap , getHeap , putHeap -, modifyHeap , alloc , deref , assign From a994c66f0b6eb7e57d562498d06d4385e2c2a0ab Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 10:09:57 -0400 Subject: [PATCH 150/159] Add a heading for the effects. --- src/Control/Abstract/Environment.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index c91254b53..597610fb7 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -9,6 +9,7 @@ module Control.Abstract.Environment , bindAll , locally , close +-- * Effects , Env(..) , runEnv , EnvironmentError(..) @@ -56,6 +57,9 @@ locally a = do close :: Member (Env address) effects => Set Name -> Evaluator address value effects (Environment address) close = send . Close + +-- Effects + data Env address return where Lookup :: Name -> Env address (Maybe address) Bind :: Name -> address -> Env address () From 0bf97c03950c0e9100f957111a85e30076bc83fd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 10:11:53 -0400 Subject: [PATCH 151/159] Use sendStore to obviate the need for ScopedTypeVariables. --- src/Control/Abstract/Heap.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 6ff318706..1cf840728 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-} module Control.Abstract.Heap ( Heap , getHeap @@ -43,8 +43,8 @@ modifyHeap :: Member (State (Heap address (Cell address) value)) effects => (Hea modifyHeap = modify' -alloc :: forall address value effects . Member (Store address value) effects => Name -> Evaluator address value effects address -alloc = send . Alloc @address @value +alloc :: Member (Store address value) effects => Name -> Evaluator address value effects address +alloc = sendStore . Alloc -- | Dereference the given address in the heap, or fail if the address is uninitialized. deref :: Member (Store address value) effects => address -> Evaluator address value effects value From 6e482be698583858ed00e402e71358e1267b3a6d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 10:21:57 -0400 Subject: [PATCH 152/159] Rename Store back to Allocator for now. --- src/Analysis/Abstract/Caching.hs | 2 +- src/Analysis/Abstract/Collecting.hs | 2 +- src/Control/Abstract/Heap.hs | 60 ++++++++++++------------- src/Control/Abstract/Primitive.hs | 4 +- src/Control/Abstract/Value.hs | 6 +-- src/Data/Abstract/Evaluatable.hs | 6 +-- src/Data/Abstract/Type.hs | 4 +- src/Data/Abstract/Value.hs | 4 +- src/Language/PHP/Syntax.hs | 2 +- src/Language/Python/Syntax.hs | 2 +- src/Language/TypeScript/Syntax.hs | 2 +- test/Control/Abstract/Evaluator/Spec.hs | 2 +- 12 files changed, 48 insertions(+), 48 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index df8b258f2..f9056858a 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -78,7 +78,7 @@ cachingTerms recur term = do convergingModules :: ( AbstractValue address value effects , Cacheable term address (Cell address) value - , Member (Store address value) effects + , Member (Allocator address value) effects , Member Fresh effects , Member NonDet effects , Member (Reader (Cache term address (Cell address) value)) effects diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index a259506bd..2d8202cdc 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -10,7 +10,7 @@ import Prologue -- | An analysis performing GC after every instruction. collectingTerms :: ( Member (Reader (Live address)) effects - , Member (Store address value) effects + , Member (Allocator address value) effects , Ord address , ValueRoots address value ) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 1cf840728..6732f55f8 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -13,8 +13,8 @@ module Control.Abstract.Heap -- * Garbage collection , gc -- * Effects -, Store(..) -, runStore +, Allocator(..) +, runAllocator , AddressError(..) , runAddressError , runAddressErrorWith @@ -43,16 +43,16 @@ modifyHeap :: Member (State (Heap address (Cell address) value)) effects => (Hea modifyHeap = modify' -alloc :: Member (Store address value) effects => Name -> Evaluator address value effects address -alloc = sendStore . Alloc +alloc :: Member (Allocator address value) effects => Name -> Evaluator address value effects address +alloc = sendAllocator . Alloc -- | Dereference the given address in the heap, or fail if the address is uninitialized. -deref :: Member (Store address value) effects => address -> Evaluator address value effects value +deref :: Member (Allocator address value) effects => address -> Evaluator address value effects value deref = send . Deref --- | Write a value to the given address in the 'Store'. -assign :: Member (Store address value) effects +-- | Write a value to the given address in the 'Allocator'. +assign :: Member (Allocator address value) effects => address -> value -> Evaluator address value effects () @@ -60,7 +60,7 @@ assign address = send . Assign address -- | Look up or allocate an address for a 'Name'. -lookupOrAlloc :: ( Member (Store address value) effects +lookupOrAlloc :: ( Member (Allocator address value) effects , Member (Env address) effects ) => Name @@ -68,7 +68,7 @@ lookupOrAlloc :: ( Member (Store address value) effects lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name) -letrec :: ( Member (Store address value) effects +letrec :: ( Member (Allocator address value) effects , Member (Env address) effects ) => Name @@ -81,7 +81,7 @@ letrec name body = do pure (v, addr) -- Lookup/alloc a name passing the address to a body evaluated in a new local environment. -letrec' :: ( Member (Store address value) effects +letrec' :: ( Member (Allocator address value) effects , Member (Env address) effects ) => Name @@ -94,7 +94,7 @@ letrec' name body = do -- | Look up and dereference the given 'Name', throwing an exception for free variables. -variable :: ( Member (Store address value) effects +variable :: ( Member (Allocator address value) effects , Member (Env address) effects , Member (Resumable (EnvironmentError address)) effects ) @@ -106,10 +106,10 @@ variable name = lookupEnv name >>= maybeM (freeVariableError name) >>= deref -- Garbage collection -- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set. -gc :: Member (Store address value) effects +gc :: Member (Allocator address value) effects => Live address -- ^ The set of addresses to consider rooted. -> Evaluator address value effects () -gc roots = sendStore (GC roots) +gc roots = sendAllocator (GC roots) -- | Compute the set of addresses reachable from a given root set in a given heap. reachable :: ( Ord address @@ -129,25 +129,25 @@ reachable roots heap = go mempty roots -- Effects -sendStore :: Member (Store address value) effects => Store address value return -> Evaluator address value effects return -sendStore = send +sendAllocator :: Member (Allocator address value) effects => Allocator address value return -> Evaluator address value effects return +sendAllocator = send -data Store address value return where - Alloc :: Name -> Store address value address - Deref :: address -> Store address value value - Assign :: address -> value -> Store address value () - GC :: Live address -> Store address value () +data Allocator address value return where + Alloc :: Name -> Allocator address value address + Deref :: address -> Allocator address value value + Assign :: address -> value -> Allocator address value () + GC :: Live address -> Allocator address value () -runStore :: ( Addressable address effects - , Foldable (Cell address) - , Member (Resumable (AddressError address value)) effects - , Member (State (Heap address (Cell address) value)) effects - , Reducer value (Cell address value) - , ValueRoots address value - ) - => Evaluator address value (Store address value ': effects) a - -> Evaluator address value effects a -runStore = interpret $ \ eff -> case eff of +runAllocator :: ( Addressable address effects + , Foldable (Cell address) + , Member (Resumable (AddressError address value)) effects + , Member (State (Heap address (Cell address) value)) effects + , Reducer value (Cell address value) + , ValueRoots address value + ) + => Evaluator address value (Allocator address value ': effects) a + -> Evaluator address value effects a +runAllocator = interpret $ \ eff -> case eff of Alloc name -> allocCell name Deref addr -> heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr)) Assign addr value -> modifyHeap (heapInsert addr value) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index d5d2bcda8..46b9743bc 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -11,7 +11,7 @@ import Data.Semilattice.Lower import Prologue builtin :: ( HasCallStack - , Member (Store address value) effects + , Member (Allocator address value) effects , Member (Env address) effects , Member (Reader ModuleInfo) effects , Member (Reader Span) effects @@ -34,7 +34,7 @@ lambda body = do defineBuiltins :: ( AbstractValue address value effects , HasCallStack - , Member (Store address value) effects + , Member (Allocator address value) effects , Member (Env address) effects , Member Fresh effects , Member (Reader ModuleInfo) effects diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 546f761c1..293d0fefd 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -184,7 +184,7 @@ doWhile body cond = loop $ \ continue -> body *> do makeNamespace :: ( AbstractValue address value effects , Member (Env address) effects - , Member (Store address value) effects + , Member (Allocator address value) effects ) => Name -> address @@ -212,7 +212,7 @@ evaluateInScopedEnv scopedEnvTerm term = do -- | Evaluates a 'Value' returning the referenced value value :: ( AbstractValue address value effects - , Member (Store address value) effects + , Member (Allocator address value) effects , Member (Env address) effects , Member (Resumable (EnvironmentError address)) effects ) @@ -224,7 +224,7 @@ value (Rval val) = pure val -- | Evaluates a 'Subterm' to its rval subtermValue :: ( AbstractValue address value effects - , Member (Store address value) effects + , Member (Allocator address value) effects , Member (Env address) effects , Member (Resumable (EnvironmentError address)) effects ) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index dca758ad8..44900700f 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -52,7 +52,7 @@ type EvaluatableConstraints term address value effects = ( AbstractValue address value effects , Declarations term , FreeVariables term - , Member (Store address value) effects + , Member (Allocator address value) effects , Member (Env address) effects , Member (LoopControl value) effects , Member (Modules address value) effects @@ -85,7 +85,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer , Recursive term , Reducer value (Cell address value) , ValueRoots address value - , inner ~ (LoopControl value ': Return value ': Env address ': Store address value ': inner') + , inner ~ (LoopControl value ': Return value ': Env address ': Allocator address value ': inner') , inner' ~ (Reader ModuleInfo ': inner'') , inner'' ~ (Modules address value ': Reader Span ': Reader PackageInfo ': outer) ) @@ -111,7 +111,7 @@ evaluatePackageWith analyzeModule analyzeTerm package runInModule preludeEnv info = runReader info - . raiseHandler runStore + . raiseHandler runAllocator . raiseHandler (runEnv preludeEnv) . raiseHandler runReturn . raiseHandler runLoopControl diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 48de6af7e..c517fcb18 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -115,7 +115,7 @@ instance AbstractIntro Type where null = Null -instance ( Member (Store address Type) effects +instance ( Member (Allocator address Type) effects , Member (Env address) effects , Member Fresh effects , Member (Resumable TypeError) effects @@ -141,7 +141,7 @@ instance ( Member (Store address Type) effects -- | Discard the value arguments (if any), constructing a 'Type' instead. -instance ( Member (Store address Type) effects +instance ( Member (Allocator address Type) effects , Member (Env address) effects , Member Fresh effects , Member NonDet effects diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 759cdcfda..e364c6572 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -54,7 +54,7 @@ instance AbstractHole (Value address body) where hole = Hole instance ( Coercible body (Eff effects) - , Member (Store address (Value address body)) effects + , Member (Allocator address (Value address body)) effects , Member (Env address) effects , Member Fresh effects , Member (Reader ModuleInfo) effects @@ -104,7 +104,7 @@ instance Show address => AbstractIntro (Value address body) where -- | Construct a 'Value' wrapping the value arguments (if any). instance ( Coercible body (Eff effects) - , Member (Store address (Value address body)) effects + , Member (Allocator address (Value address body)) effects , Member (Env address) effects , Member Fresh effects , Member (LoopControl (Value address body)) effects diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index b4b77dd30..2fc416904 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -53,7 +53,7 @@ resolvePHPName n = do toName = BC.unpack . dropRelativePrefix . stripQuotes include :: ( AbstractValue address value effects - , Member (Store address value) effects + , Member (Allocator address value) effects , Member (Env address) effects , Member (Modules address value) effects , Member (Resumable ResolutionError) effects diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 8ff59c351..2c1eeb9aa 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -127,7 +127,7 @@ instance Evaluatable Import where -- Evaluate a qualified import evalQualifiedImport :: ( AbstractValue address value effects - , Member (Store address value) effects + , Member (Allocator address value) effects , Member (Env address) effects , Member (Modules address value) effects ) diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index eb234dbae..7c0350b6f 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -133,7 +133,7 @@ javascriptExtensions :: [String] javascriptExtensions = ["js"] evalRequire :: ( AbstractValue address value effects - , Member (Store address value) effects + , Member (Allocator address value) effects , Member (Env address) effects , Member (Modules address value) effects ) diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index 569307adb..28100f6b1 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -37,7 +37,7 @@ evaluate . runValueError . runEnvironmentError . runAddressError - . runStore + . runAllocator . runEnv lowerBound . runReturn . runLoopControl From 00e0843a31784856a1569f19d9593798fed0723f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 May 2018 10:58:16 -0400 Subject: [PATCH 153/159] Define a liveMap function. --- src/Data/Abstract/Live.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Abstract/Live.hs b/src/Data/Abstract/Live.hs index f75dedf1e..e521e9caf 100644 --- a/src/Data/Abstract/Live.hs +++ b/src/Data/Abstract/Live.hs @@ -36,6 +36,10 @@ liveMember addr = Set.member addr . unLive liveSplit :: Live address -> Maybe (address, Live address) liveSplit = fmap (fmap Live) . Set.minView . unLive +-- | Map a function over the addresses in a 'Live' set. +liveMap :: Ord b => (a -> b) -> Live a -> Live b +liveMap f = Live . Set.map f . unLive + instance Show address => Show (Live address) where showsPrec d = showsUnaryWith showsPrec "Live" d . Set.toList . unLive From bde3400f28dcc47f2c0245e98022431c83745159 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 31 May 2018 11:23:02 -0400 Subject: [PATCH 154/159] ++proto3-suite --- vendor/proto3-suite | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/proto3-suite b/vendor/proto3-suite index 4828d77ef..4f3d4062b 160000 --- a/vendor/proto3-suite +++ b/vendor/proto3-suite @@ -1 +1 @@ -Subproject commit 4828d77ef5218cf309a8a78e2d97c488c4fe857a +Subproject commit 4f3d4062b29f26988e67fca14ff6b306032779d1 From 330908a7efd6e3b8e90a15f143d0975b4f525598 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 31 May 2018 11:26:01 -0400 Subject: [PATCH 155/159] Remove dupe Span and Pos --- semantic.proto | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/semantic.proto b/semantic.proto index 80d5e3758..68bad2620 100644 --- a/semantic.proto +++ b/semantic.proto @@ -56,13 +56,3 @@ message Error { Span span = 2; string language = 3; } - -message Span { - Pos start = 1; - Pos end = 2; -} - -message Pos { - int32 line = 1; - int32 column = 2; -} From 1c5d8d816e7b51e280b76bfed689054686ffd2c5 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 31 May 2018 11:38:45 -0400 Subject: [PATCH 156/159] lints --- src/Data/Span.hs | 2 +- src/Data/Syntax.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Span.hs b/src/Data/Span.hs index 37749d2c8..1f805060d 100644 --- a/src/Data/Span.hs +++ b/src/Data/Span.hs @@ -28,7 +28,7 @@ data Pos = Pos deriving (Show, Read, Eq, Ord, Generic, Hashable, Named, Message) instance MessageField Pos where - encodeMessageField num = (Encode.embedded num . encodeMessage (fieldNumber 1)) + encodeMessageField num = Encode.embedded num . encodeMessage (fieldNumber 1) decodeMessageField = fromMaybe def <$> Decode.embedded (decodeMessage (fieldNumber 1)) protoType pr = messageField (Prim $ Named (Single (nameOf pr))) Nothing diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index d933c0188..9930653bd 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -104,7 +104,7 @@ infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack, infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right instance (Apply Message1 fs, Generate Message1 fs fs, Generate Named1 fs fs) => Message1 (Sum fs) where - liftEncodeMessage encodeMessage num fs = apply @Message1 (liftEncodeMessage encodeMessage num) fs + liftEncodeMessage encodeMessage num = apply @Message1 (liftEncodeMessage encodeMessage num) liftDecodeMessage decodeMessage _ = oneof undefined listOfParsers where listOfParsers = @@ -127,7 +127,7 @@ instance Generate c all '[] where generate _ = mempty instance (Element f all, c f, Generate c all fs) => Generate c all (f ': fs) where - generate each = (each (Proxy @f) (natVal (Proxy @(ElemIndex f all)))) `mappend` generate @c @all @fs each + generate each = each (Proxy @f) (natVal (Proxy @(ElemIndex f all))) `mappend` generate @c @all @fs each -- Common From b8d22f215f6cf2ceac76e13b8ed08f463722564c Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 31 May 2018 09:19:21 -0700 Subject: [PATCH 157/159] :fire: >>= --- src/Language/Haskell/Assignment.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index 42012bbbf..46d846010 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -145,11 +145,9 @@ listType :: Assignment listType = makeTerm <$> symbol ListType <*> children (Literal.Array <$> many type') tuplingConstructor :: Assignment -tuplingConstructor = makeTerm - <$> symbol TuplingConstructor - <*> (source >>= tupleWithArity) +tuplingConstructor = makeTerm <$> symbol TuplingConstructor <*> (tupleWithArity <$> source) -- a tuple (,) has arity two, but only one comma, so apply the successor to the count of commas for the correct arity. - where tupleWithArity = pure . Syntax.TupleConstructor . succ . count ',' + where tupleWithArity = Syntax.TupleConstructor . succ . count ',' type' :: Assignment type' = (makeTerm <$> symbol Type <*> children (Syntax.Type <$> typeConstructor <*> typeParameters)) From 497c812d7f9d9e41d790bb1fb8669dd67cde5311 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 31 May 2018 12:30:39 -0400 Subject: [PATCH 158/159] ++proto3-suite --- vendor/proto3-suite | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/proto3-suite b/vendor/proto3-suite index 4f3d4062b..c2d14b67e 160000 --- a/vendor/proto3-suite +++ b/vendor/proto3-suite @@ -1 +1 @@ -Subproject commit 4f3d4062b29f26988e67fca14ff6b306032779d1 +Subproject commit c2d14b67e3d5b50dacb33f4a383197b3ef93d282 From 885768a89c085a26b5c7f67d06a6405845048e57 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 31 May 2018 16:23:27 -0400 Subject: [PATCH 159/159] ++proto3-suite --- vendor/proto3-suite | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/proto3-suite b/vendor/proto3-suite index c2d14b67e..c75b250e8 160000 --- a/vendor/proto3-suite +++ b/vendor/proto3-suite @@ -1 +1 @@ -Subproject commit c2d14b67e3d5b50dacb33f4a383197b3ef93d282 +Subproject commit c75b250e82481e23d2ff586b3e841834b5d93ff9