From eaf678c8e991e5357ef6f81eaa78bab41bbc9977 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 May 2018 19:34:51 -0400 Subject: [PATCH 001/174] Move isHole into AbstractHole. --- src/Control/Abstract/Value.hs | 4 +--- src/Data/Abstract/Type.hs | 3 +-- src/Data/Abstract/Value.hs | 6 ++---- 3 files changed, 4 insertions(+), 9 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 6ac24820f..9cf00ddb9 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -36,6 +36,7 @@ data Comparator class AbstractHole value where hole :: value + isHole :: value -> Bool -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- @@ -118,9 +119,6 @@ class Show value => AbstractValue location value effects where -- | @index x i@ computes @x[i]@, with zero-indexing. index :: value -> value -> Evaluator location value effects value - -- | Determine whether the given datum is a 'Hole'. - isHole :: value -> Evaluator location value effects Bool - -- | Build a class value from a name and environment. klass :: Name -- ^ The new class's identifier -> [value] -- ^ A list of superclasses diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index e4b3e64e8..2fcc13d49 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -101,6 +101,7 @@ instance Ord location => ValueRoots location Type where instance AbstractHole Type where hole = Hole + isHole = (== Hole) -- | Discard the value arguments (if any), constructing a 'Type' instead. instance ( Addressable location effects @@ -153,8 +154,6 @@ instance ( Addressable location effects unify t (Var t1 :* Var t2) $> (Var t1, Var t2) asBool t = unify t Bool *> (pure True <|> pure False) - isHole ty = pure (ty == Hole) - index arr sub = do _ <- unify sub Int field <- fresh diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 1f6aaf8ee..47b11adbe 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -203,6 +203,7 @@ instance Ord location => ValueRoots location (Value location) where instance AbstractHole (Value location) where hole = injValue Hole + isHole = (== Just Hole) . prjValue -- | Construct a 'Value' wrapping the value arguments (if any). instance ( Addressable location (Goto effects (Value location) ': effects) @@ -265,8 +266,7 @@ instance ( Addressable location (Goto effects (Value location) ': effects) | otherwise = throwValueError $ StringError v ifthenelse cond if' else' = do - isHole <- isHole cond - if isHole then + if isHole cond then pure hole else do bool <- asBool cond @@ -276,8 +276,6 @@ instance ( Addressable location (Goto effects (Value location) ': effects) | Just (Boolean b) <- prjValue val = pure b | otherwise = throwValueError $ BoolError val - isHole val = pure (prjValue val == Just Hole) - index = go where tryIdx list ii | ii > genericLength list = throwValueError (BoundsError list ii) From 52aaa31e73213695fe3bb5d0864bd45225e0babb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 May 2018 16:57:01 -0400 Subject: [PATCH 002/174] Extract the definition of builtins into a separate action. --- src/Data/Abstract/Evaluatable.hs | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 78902a60b..e13ecd734 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -218,6 +218,24 @@ builtin n def = withCurrentCallStack callStack $ do modifyEnv (X.insert name addr) def >>= assign addr +defineBuiltins :: ( AbstractValue location value effects + , HasCallStack + , Members '[ Allocator location value + , Reader (Environment location value) + , Reader ModuleInfo + , Reader Span + , Resumable (EnvironmentError value) + , State (Environment location value) + , State (Heap location (Cell location) value) + , Trace + ] effects + , Ord location + , Reducer value (Cell location value) + ) + => Evaluator location value effects () +defineBuiltins = do + builtin "print" (closure ["s"] lowerBound (variable "s" >>= asString >>= trace . unpack >> unit)) + -- | Evaluate a given package. evaluatePackageWith :: forall location term value 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? If not, can we factor this effect list out? @@ -273,9 +291,7 @@ evaluatePackageWith analyzeModule analyzeTerm package maybe v ((`call` []) <=< variable) sym evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule)) $ do - _ <- runInModule moduleInfoFromCallStack . TermEvaluator $ do - builtin "print" (closure ["s"] lowerBound (variable "s" >>= asString >>= trace . unpack >> unit)) - unit + _ <- runInModule moduleInfoFromCallStack (TermEvaluator (defineBuiltins *> unit)) fst <$> evalModule prelude withPrelude Nothing a = a From 077335784aa50f6730744d5a794ae04bd546e20b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 10:11:19 -0400 Subject: [PATCH 003/174] Stub in a module for primitives. --- semantic.cabal | 1 + src/Control/Abstract/Primitive.hs | 1 + 2 files changed, 2 insertions(+) create mode 100644 src/Control/Abstract/Primitive.hs diff --git a/semantic.cabal b/semantic.cabal index b7e4d7cc2..ecfcb0492 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -42,6 +42,7 @@ library , Control.Abstract.Heap , Control.Abstract.Matching , Control.Abstract.Modules + , Control.Abstract.Primitive , Control.Abstract.Roots , Control.Abstract.TermEvaluator , Control.Abstract.Value diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs new file mode 100644 index 000000000..af4402dc5 --- /dev/null +++ b/src/Control/Abstract/Primitive.hs @@ -0,0 +1 @@ +module Control.Abstract.Primitive where From f1844636b54aaa7e17f80de01e4b8a3f9c1b645a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 10:17:26 -0400 Subject: [PATCH 004/174] Re-export the Primitive module. --- src/Control/Abstract.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Abstract.hs b/src/Control/Abstract.hs index 08f83b900..a8b00273d 100644 --- a/src/Control/Abstract.hs +++ b/src/Control/Abstract.hs @@ -11,6 +11,7 @@ import Control.Abstract.Exports as X import Control.Abstract.Heap as X import Control.Abstract.Goto as X import Control.Abstract.Modules as X +import Control.Abstract.Primitive as X import Control.Abstract.Roots as X import Control.Abstract.TermEvaluator as X import Control.Abstract.Value as X From b9a807f5044638b1255e737ea8df31eef45ef531 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 10:18:22 -0400 Subject: [PATCH 005/174] Move builtin & defineBuiltin into the Primitive module. --- src/Control/Abstract/Primitive.hs | 51 +++++++++++++++++++++++++++++++ src/Data/Abstract/Evaluatable.hs | 42 ++----------------------- 2 files changed, 53 insertions(+), 40 deletions(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index af4402dc5..5a4178b44 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -1 +1,52 @@ module Control.Abstract.Primitive where + +import Control.Abstract.Addressable +import Control.Abstract.Context +import Control.Abstract.Environment +import Control.Abstract.Evaluator +import Control.Abstract.Heap +import Control.Abstract.Value +import Data.Abstract.Environment +import Data.Abstract.FreeVariables +import Data.ByteString.Char8 (pack, unpack) +import Data.Semigroup.Reducer hiding (unit) +import Data.Semilattice.Lower +import Prologue + +builtin :: ( HasCallStack + , Members '[ Allocator location value + , Reader (Environment location value) + , Reader ModuleInfo + , Reader Span + , State (Environment location value) + , State (Heap location (Cell location) value) + ] effects + , Ord location + , Reducer value (Cell location value) + ) + => String + -> Evaluator location value effects value + -> Evaluator location value effects () +builtin n def = withCurrentCallStack callStack $ do + let name' = name ("__semantic_" <> pack n) + addr <- alloc name' + modifyEnv (insert name' addr) + def >>= assign addr + +defineBuiltins :: ( AbstractValue location value effects + , HasCallStack + , Members '[ Allocator location value + , Reader (Environment location value) + , Reader ModuleInfo + , Reader Span + , Resumable (EnvironmentError value) + , State (Environment location value) + , State (Heap location (Cell location) value) + , Trace + ] effects + , Ord location + , Reducer value (Cell location value) + ) + => Evaluator location value effects () +defineBuiltins = do + builtin "print" (closure ["s"] lowerBound (variable "s" >>= asString >>= trace . unpack >> unit)) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index e13ecd734..87442a83f 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -19,10 +19,11 @@ module Data.Abstract.Evaluatable , Modules ) where -import Control.Abstract as X hiding (Goto(..), LoopControl(..), Modules(..), Return(..), TermEvaluator(..)) +import Control.Abstract as X hiding (Goto(..), LoopControl(..), Modules(..), Return(..), TermEvaluator(..), builtin, defineBuiltins) import Control.Abstract.Evaluator (LoopControl, Return(..)) import Control.Abstract.Goto (Goto(..)) import Control.Abstract.Modules (Modules(..)) +import Control.Abstract.Primitive (builtin, defineBuiltins) import Control.Abstract.TermEvaluator (TermEvaluator(..)) import Data.Abstract.Declarations as X import Data.Abstract.Environment as X @@ -31,7 +32,6 @@ import Data.Abstract.FreeVariables as X import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package as Package -import Data.ByteString.Char8 (pack, unpack) import Data.Scientific (Scientific) import Data.Semigroup.App import Data.Semigroup.Foldable @@ -198,44 +198,6 @@ traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator lo traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) -builtin :: ( HasCallStack - , Members '[ Allocator location value - , Reader (Environment location value) - , Reader ModuleInfo - , Reader Span - , State (Environment location value) - , State (Heap location (Cell location) value) - ] effects - , Ord location - , Reducer value (Cell location value) - ) - => String - -> Evaluator location value effects value - -> Evaluator location value effects () -builtin n def = withCurrentCallStack callStack $ do - let name = X.name ("__semantic_" <> pack n) - addr <- alloc name - modifyEnv (X.insert name addr) - def >>= assign addr - -defineBuiltins :: ( AbstractValue location value effects - , HasCallStack - , Members '[ Allocator location value - , Reader (Environment location value) - , Reader ModuleInfo - , Reader Span - , Resumable (EnvironmentError value) - , State (Environment location value) - , State (Heap location (Cell location) value) - , Trace - ] effects - , Ord location - , Reducer value (Cell location value) - ) - => Evaluator location value effects () -defineBuiltins = do - builtin "print" (closure ["s"] lowerBound (variable "s" >>= asString >>= trace . unpack >> unit)) - -- | Evaluate a given package. evaluatePackageWith :: forall location term value 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? If not, can we factor this effect list out? From f33df9946d9a91a719ad7776e0377494c2fcf25b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 10:31:28 -0400 Subject: [PATCH 006/174] =?UTF-8?q?Don=E2=80=99t=20throw=20EnvironmentLook?= =?UTF-8?q?upError=20in=20evaluateinScopedEnv.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Abstract/Evaluatable.hs | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 87442a83f..e5841af1c 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -94,19 +94,15 @@ runEvalErrorWith :: Effectful (m value) => (forall resume . EvalError value resu runEvalErrorWith = runResumableWith -- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'. --- Throws an 'EnvironmentLookupError' if @scopedEnvTerm@ does not have an environment. evaluateInScopedEnv :: ( AbstractValue location value effects - , Members '[ Resumable (EvalError value) - , State (Environment location value) - ] effects + , Member (State (Environment location value)) effects ) => Evaluator location value effects value -> Evaluator location value effects value -> Evaluator location value effects value evaluateInScopedEnv scopedEnvTerm term = do - value <- scopedEnvTerm - scopedEnv <- scopedEnvironment value - maybe (throwEvalError (EnvironmentLookupError value)) (flip localEnv term . mergeEnvs) scopedEnv + scopedEnv <- scopedEnvTerm >>= scopedEnvironment + maybe term (flip localEnv term . mergeEnvs) scopedEnv deriving instance Eq a => Eq (EvalError a b) deriving instance Show a => Show (EvalError a b) @@ -143,7 +139,6 @@ value :: ( AbstractValue location value effects , Members '[ Allocator location value , Reader (Environment location value) , Resumable (EnvironmentError value) - , Resumable (EvalError value) , State (Environment location value) , State (Heap location (Cell location) value) ] effects From 625dfb6fea12c147c88ad0f0fda93c95d69ccebd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 10:32:05 -0400 Subject: [PATCH 007/174] Move evaluateInScopedEnv into Control.Abstract.Value. --- src/Control/Abstract/Value.hs | 13 +++++++++++++ src/Data/Abstract/Evaluatable.hs | 12 ------------ 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 713e6b2e3..e4d4bf646 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -7,6 +7,7 @@ module Control.Abstract.Value , doWhile , forLoop , makeNamespace +, evaluateInScopedEnv , ValueRoots(..) ) where @@ -198,6 +199,18 @@ makeNamespace name addr super = do v <$ assign addr v +-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'. +evaluateInScopedEnv :: ( AbstractValue location value effects + , Member (State (Environment location value)) 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 + + -- | 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. diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index e5841af1c..e7182b91a 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -10,7 +10,6 @@ module Data.Abstract.Evaluatable , runEvalErrorWith , value , subtermValue -, evaluateInScopedEnv , evaluatePackageWith , throwEvalError , traceResolve @@ -93,17 +92,6 @@ runEvalError = runResumable runEvalErrorWith :: Effectful (m value) => (forall resume . EvalError value resume -> m value effects resume) -> m value (Resumable (EvalError value) ': effects) a -> m value effects a runEvalErrorWith = runResumableWith --- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'. -evaluateInScopedEnv :: ( AbstractValue location value effects - , Member (State (Environment location value)) 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 - deriving instance Eq a => Eq (EvalError a b) deriving instance Show a => Show (EvalError a b) instance Show value => Show1 (EvalError value) where From 5a43ed60f4ce840ce461df4e2f1fbf6651e14116 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 10:36:23 -0400 Subject: [PATCH 008/174] Stub in a module for ValueRef. --- semantic.cabal | 1 + src/Data/Abstract/Ref.hs | 1 + 2 files changed, 2 insertions(+) create mode 100644 src/Data/Abstract/Ref.hs diff --git a/semantic.cabal b/semantic.cabal index ecfcb0492..0bdcf8a09 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -62,6 +62,7 @@ library , Data.Abstract.Number , Data.Abstract.Package , Data.Abstract.Path + , Data.Abstract.Ref , Data.Abstract.Type , Data.Abstract.Value -- General datatype definitions & generic algorithms diff --git a/src/Data/Abstract/Ref.hs b/src/Data/Abstract/Ref.hs new file mode 100644 index 000000000..a622a56bb --- /dev/null +++ b/src/Data/Abstract/Ref.hs @@ -0,0 +1 @@ +module Data.Abstract.Ref where From c54efa2751da68e3fbbf6d3c6ca1518336a2b1ff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 10:37:12 -0400 Subject: [PATCH 009/174] Move ValueRef into Data.Abstract.Ref. --- src/Control/Abstract/Evaluator.hs | 12 ------------ src/Data/Abstract/Cache.hs | 2 +- src/Data/Abstract/Evaluatable.hs | 1 + src/Data/Abstract/Ref.hs | 13 +++++++++++++ src/Data/Syntax/Statement.hs | 1 - 5 files changed, 15 insertions(+), 14 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index f0a2eb287..b2360ef20 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,7 +1,6 @@ {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-} module Control.Abstract.Evaluator ( Evaluator(..) - , ValueRef(..) -- * Effects , Return(..) , earlyReturn @@ -30,7 +29,6 @@ import Control.Monad.Effect.Reader import Control.Monad.Effect.Resumable import Control.Monad.Effect.State import Control.Monad.Effect.Trace -import Data.Abstract.FreeVariables import Prologue -- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the location, term, and value types. @@ -43,16 +41,6 @@ newtype Evaluator location value effects a = Evaluator { runEvaluator :: Eff eff deriving instance Member NonDet effects => Alternative (Evaluator location value effects) --- | 'ValueRef' is the type subterms evaluate to and can represent either values directly ('Rval'), or references to values (lvals - such as local variables or object members) -data ValueRef value where - -- Represents a value: - Rval :: value -> ValueRef value - -- Represents a local variable. No environment is attached - it's assumed that LvalLocal will be evaluated in the same scope it was constructed: - LvalLocal :: Name -> ValueRef value - -- Represents an object member: - LvalMember :: value -> Name -> ValueRef value - - deriving (Eq, Ord, Show) -- Effects diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index 07b50f285..07487b216 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -1,9 +1,9 @@ {-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, TypeFamilies #-} module Data.Abstract.Cache where -import Control.Abstract.Evaluator import Data.Abstract.Configuration import Data.Abstract.Heap +import Data.Abstract.Ref import Data.Map.Monoidal as Monoidal import Data.Semilattice.Lower import Prologue diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index e7182b91a..473231416 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -31,6 +31,7 @@ import Data.Abstract.FreeVariables as X import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package as Package +import Data.Abstract.Ref as X import Data.Scientific (Scientific) import Data.Semigroup.App import Data.Semigroup.Foldable diff --git a/src/Data/Abstract/Ref.hs b/src/Data/Abstract/Ref.hs index a622a56bb..b618f9fc1 100644 --- a/src/Data/Abstract/Ref.hs +++ b/src/Data/Abstract/Ref.hs @@ -1 +1,14 @@ +{-# LANGUAGE GADTs #-} module Data.Abstract.Ref where + +import Data.Abstract.FreeVariables + +-- | 'ValueRef' is the type subterms evaluate to and can represent either values directly ('Rval'), or references to values (lvals - such as local variables or object members) +data ValueRef value where + -- Represents a value: + Rval :: value -> ValueRef value + -- Represents a local variable. No environment is attached - it's assumed that LvalLocal will be evaluated in the same scope it was constructed: + LvalLocal :: Name -> ValueRef value + -- Represents an object member: + LvalMember :: value -> Name -> ValueRef value + deriving (Eq, Ord, Show) diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 4d8bc20b9..2e748adb6 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, ViewPatterns #-} module Data.Syntax.Statement where -import Control.Abstract.Evaluator (ValueRef(..)) import qualified Data.Abstract.Environment as Env import Data.Abstract.Evaluatable import Data.ByteString.Char8 (unpack) From 796400e94cb064c734f83ea9bc79b4eba41ee268 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 10:38:45 -0400 Subject: [PATCH 010/174] Align the constructors, tweak the docs. --- src/Data/Abstract/Ref.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Data/Abstract/Ref.hs b/src/Data/Abstract/Ref.hs index b618f9fc1..596bec5e4 100644 --- a/src/Data/Abstract/Ref.hs +++ b/src/Data/Abstract/Ref.hs @@ -5,10 +5,10 @@ import Data.Abstract.FreeVariables -- | 'ValueRef' is the type subterms evaluate to and can represent either values directly ('Rval'), or references to values (lvals - such as local variables or object members) data ValueRef value where - -- Represents a value: - Rval :: value -> ValueRef value - -- Represents a local variable. No environment is attached - it's assumed that LvalLocal will be evaluated in the same scope it was constructed: - LvalLocal :: Name -> ValueRef value - -- Represents an object member: + -- | A value. + Rval :: value -> ValueRef value + -- | A local variable. No environment is attached—it’s assumed that 'LvalLocal' will be evaluated in the same scope it was constructed in. + LvalLocal :: Name -> ValueRef value + -- | An object member. LvalMember :: value -> Name -> ValueRef value deriving (Eq, Ord, Show) From 297cb9b448e2e038823d288ccfd7da27e1bb19eb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 10:40:47 -0400 Subject: [PATCH 011/174] :fire: EnvironmentLookupError. --- src/Data/Abstract/Evaluatable.hs | 4 +--- src/Semantic/Graph.hs | 3 +-- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 473231416..01d37e281 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -85,7 +85,6 @@ data EvalError value resume where RationalFormatError :: ByteString -> EvalError value Rational DefaultExportError :: EvalError value () ExportError :: ModulePath -> Name -> EvalError value () - EnvironmentLookupError :: value -> EvalError value value runEvalError :: Effectful (m value) => m value (Resumable (EvalError value) ': effects) a -> m value effects (Either (SomeExc (EvalError value)) a) runEvalError = runResumable @@ -97,14 +96,13 @@ deriving instance Eq a => Eq (EvalError a b) deriving instance Show a => Show (EvalError a b) instance Show value => Show1 (EvalError value) where liftShowsPrec _ _ = showsPrec -instance Eq term => Eq1 (EvalError term) where +instance Eq1 (EvalError value) where liftEq _ (FreeVariablesError a) (FreeVariablesError b) = a == b liftEq _ DefaultExportError DefaultExportError = True liftEq _ (ExportError a b) (ExportError c d) = (a == c) && (b == d) liftEq _ (IntegerFormatError a) (IntegerFormatError b) = a == b liftEq _ (FloatFormatError a) (FloatFormatError b) = a == b liftEq _ (RationalFormatError a) (RationalFormatError b) = a == b - liftEq _ (EnvironmentLookupError a) (EnvironmentLookupError b) = a == b liftEq _ _ _ = False diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index c74bdee6e..18f6b88d4 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -110,9 +110,8 @@ resumingResolutionError = runResolutionErrorWith (\ err -> trace ("ResolutionErr resumingLoadError :: Member Trace effects => Evaluator location value (Resumable (LoadError location value) ': effects) a -> Evaluator location value effects a resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> Nothing) -resumingEvalError :: (AbstractHole value, Member Trace effects, Show value) => Evaluator location value (Resumable (EvalError value) ': effects) a -> Evaluator location value effects a +resumingEvalError :: (Member Trace effects, Show value) => Evaluator location value (Resumable (EvalError value) ': effects) a -> Evaluator location value effects a resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *> case err of - EnvironmentLookupError{} -> pure hole DefaultExportError{} -> pure () ExportError{} -> pure () IntegerFormatError{} -> pure 0 From edde9765a86fabcb901495b76f10d48a34d26316 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 10:45:31 -0400 Subject: [PATCH 012/174] =?UTF-8?q?EvalError=20doesn=E2=80=99t=20need=20th?= =?UTF-8?q?e=20value=20parameter=20any=20more.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/Caching.hs | 1 - src/Data/Abstract/Evaluatable.hs | 31 +++++++++++++++---------------- src/Data/Abstract/Type.hs | 2 -- src/Language/PHP/Syntax.hs | 1 - src/Semantic/Graph.hs | 2 +- 5 files changed, 16 insertions(+), 21 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 8b7f18eae..f3a6a1ec3 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -88,7 +88,6 @@ convergingModules :: ( AbstractValue location value effects , Reader (Live location value) , Resumable (AddressError location value) , Resumable (EnvironmentError value) - , Resumable (EvalError value) , State (Cache term location (Cell location) value) , State (Environment location value) , State (Heap location (Cell location) value) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 01d37e281..151167226 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -62,7 +62,7 @@ type EvaluatableConstraints location term value effects = , Reader PackageInfo , Reader Span , Resumable (EnvironmentError value) - , Resumable (EvalError value) + , Resumable EvalError , Resumable ResolutionError , Resumable (Unspecialized value) , Return value @@ -77,26 +77,26 @@ type EvaluatableConstraints location term value effects = -- | The type of error thrown when failing to evaluate a term. -data EvalError value resume where - FreeVariablesError :: [Name] -> EvalError value Name +data EvalError return where + FreeVariablesError :: [Name] -> EvalError Name -- Indicates that our evaluator wasn't able to make sense of these literals. - IntegerFormatError :: ByteString -> EvalError value Integer - FloatFormatError :: ByteString -> EvalError value Scientific - RationalFormatError :: ByteString -> EvalError value Rational - DefaultExportError :: EvalError value () - ExportError :: ModulePath -> Name -> EvalError value () + IntegerFormatError :: ByteString -> EvalError Integer + FloatFormatError :: ByteString -> EvalError Scientific + RationalFormatError :: ByteString -> EvalError Rational + DefaultExportError :: EvalError () + ExportError :: ModulePath -> Name -> EvalError () -runEvalError :: Effectful (m value) => m value (Resumable (EvalError value) ': effects) a -> m value effects (Either (SomeExc (EvalError value)) a) +runEvalError :: Effectful m => m (Resumable EvalError ': effects) a -> m effects (Either (SomeExc EvalError) a) runEvalError = runResumable -runEvalErrorWith :: Effectful (m value) => (forall resume . EvalError value resume -> m value effects resume) -> m value (Resumable (EvalError value) ': effects) a -> m value effects a +runEvalErrorWith :: Effectful m => (forall resume . EvalError resume -> m effects resume) -> m (Resumable EvalError ': effects) a -> m effects a runEvalErrorWith = runResumableWith -deriving instance Eq a => Eq (EvalError a b) -deriving instance Show a => Show (EvalError a b) -instance Show value => Show1 (EvalError value) where +deriving instance Eq (EvalError return) +deriving instance Show (EvalError return) +instance Show1 EvalError where liftShowsPrec _ _ = showsPrec -instance Eq1 (EvalError value) where +instance Eq1 EvalError where liftEq _ (FreeVariablesError a) (FreeVariablesError b) = a == b liftEq _ DefaultExportError DefaultExportError = True liftEq _ (ExportError a b) (ExportError c d) = (a == c) && (b == d) @@ -106,7 +106,7 @@ instance Eq1 (EvalError value) where liftEq _ _ _ = False -throwEvalError :: Member (Resumable (EvalError value)) effects => EvalError value resume -> Evaluator location value effects resume +throwEvalError :: (Effectful m, Member (Resumable EvalError) effects) => EvalError resume -> m effects resume throwEvalError = throwResumable @@ -141,7 +141,6 @@ subtermValue :: ( AbstractValue location value effects , Members '[ Allocator location value , Reader (Environment location value) , Resumable (EnvironmentError value) - , Resumable (EvalError value) , State (Environment location value) , State (Heap location (Cell location) value) ] effects diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 14e0a13aa..e8100d7bc 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -9,7 +9,6 @@ module Data.Abstract.Type import Control.Abstract import Data.Abstract.Environment as Env -import Data.Abstract.Evaluatable import Data.Semigroup.Foldable (foldMap1) import Data.Semigroup.Reducer (Reducer) import Prologue hiding (TypeError) @@ -109,7 +108,6 @@ instance ( Members '[ Allocator location Type , NonDet , Reader (Environment location Type) , Resumable (AddressError location Type) - , Resumable (EvalError Type) , Resumable TypeError , Return Type , State (Environment location Type) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 47cb043b8..5c68c1d00 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -58,7 +58,6 @@ include :: ( AbstractValue location value effects , Reader (Environment location value) , Resumable ResolutionError , Resumable (EnvironmentError value) - , Resumable (EvalError value) , State (Environment location value) , State (Exports location value) , State (Heap location (Cell location) value) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 18f6b88d4..43b456026 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -110,7 +110,7 @@ resumingResolutionError = runResolutionErrorWith (\ err -> trace ("ResolutionErr resumingLoadError :: Member Trace effects => Evaluator location value (Resumable (LoadError location value) ': effects) a -> Evaluator location value effects a resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> Nothing) -resumingEvalError :: (Member Trace effects, Show value) => Evaluator location value (Resumable (EvalError value) ': effects) a -> Evaluator location value effects a +resumingEvalError :: Member Trace effects => Evaluator location value (Resumable EvalError ': effects) a -> Evaluator location value effects a resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *> case err of DefaultExportError{} -> pure () ExportError{} -> pure () From 1d883f49692a74fb890f4b9dd05e2d593152f0cf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 10:47:33 -0400 Subject: [PATCH 013/174] Move value & subtermValue into Control.Abstract.Value. --- src/Analysis/Abstract/Caching.hs | 2 +- src/Control/Abstract/Value.hs | 32 ++++++++++++++++++++++++++++++++ src/Data/Abstract/Evaluatable.hs | 30 ------------------------------ 3 files changed, 33 insertions(+), 31 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index f3a6a1ec3..a99cd1320 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -7,8 +7,8 @@ module Analysis.Abstract.Caching import Control.Abstract import Data.Abstract.Cache -import Data.Abstract.Evaluatable import Data.Abstract.Module +import Data.Abstract.Ref import Data.Semilattice.Lower import Prologue diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index e4d4bf646..4248157a1 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -8,6 +8,8 @@ module Control.Abstract.Value , forLoop , makeNamespace , evaluateInScopedEnv +, value +, subtermValue , ValueRoots(..) ) where @@ -20,6 +22,7 @@ import Data.Abstract.Environment as Env import Data.Abstract.FreeVariables import Data.Abstract.Live (Live) import Data.Abstract.Number as Number +import Data.Abstract.Ref import Data.Scientific (Scientific) import Data.Semigroup.Reducer hiding (unit) import Data.Semilattice.Lower @@ -211,6 +214,35 @@ evaluateInScopedEnv scopedEnvTerm term = do maybe term (flip localEnv term . mergeEnvs) scopedEnv +-- | Evaluates a 'Value' returning the referenced value +value :: ( AbstractValue location value effects + , Members '[ Allocator location value + , Reader (Environment location value) + , Resumable (EnvironmentError value) + , State (Environment location value) + , State (Heap location (Cell location) value) + ] effects + ) + => ValueRef value + -> Evaluator location value effects value +value (LvalLocal var) = variable var +value (LvalMember obj prop) = evaluateInScopedEnv (pure obj) (variable prop) +value (Rval val) = pure val + +-- | Evaluates a 'Subterm' to its rval +subtermValue :: ( AbstractValue location value effects + , Members '[ Allocator location value + , Reader (Environment location value) + , Resumable (EnvironmentError value) + , State (Environment location value) + , State (Heap location (Cell location) value) + ] effects + ) + => Subterm term (Evaluator location value effects (ValueRef value)) + -> Evaluator location value effects value +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. diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 151167226..b2964a5dd 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -8,8 +8,6 @@ module Data.Abstract.Evaluatable , EvalError(..) , runEvalError , runEvalErrorWith -, value -, subtermValue , evaluatePackageWith , throwEvalError , traceResolve @@ -121,34 +119,6 @@ deriving instance Show (Unspecialized a b) instance Show1 (Unspecialized a) where liftShowsPrec _ _ = showsPrec --- | Evaluates a 'Value' returning the referenced value -value :: ( AbstractValue location value effects - , Members '[ Allocator location value - , Reader (Environment location value) - , Resumable (EnvironmentError value) - , State (Environment location value) - , State (Heap location (Cell location) value) - ] effects - ) - => ValueRef value - -> Evaluator location value effects value -value (LvalLocal var) = variable var -value (LvalMember obj prop) = evaluateInScopedEnv (pure obj) (variable prop) -value (Rval val) = pure val - --- | Evaluates a 'Subterm' to its rval -subtermValue :: ( AbstractValue location value effects - , Members '[ Allocator location value - , Reader (Environment location value) - , Resumable (EnvironmentError value) - , State (Environment location value) - , State (Heap location (Cell location) value) - ] effects - ) - => Subterm term (Evaluator location value effects (ValueRef value)) - -> Evaluator location value effects value -subtermValue = value <=< subtermRef - runUnspecialized :: Effectful (m value) => m value (Resumable (Unspecialized value) ': effects) a -> m value effects (Either (SomeExc (Unspecialized value)) a) runUnspecialized = runResumable From d7a69613c47fb6d9e9c4ef48a8c08e57a9fd1d62 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 10:48:21 -0400 Subject: [PATCH 014/174] =?UTF-8?q?We=20don=E2=80=99t=20need=20to=20qualif?= =?UTF-8?q?y=20that.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Abstract/Evaluatable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index b2964a5dd..2371d269a 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -109,7 +109,7 @@ throwEvalError = throwResumable data Unspecialized a b where - Unspecialized :: Prelude.String -> Unspecialized value (ValueRef value) + Unspecialized :: String -> Unspecialized value (ValueRef value) instance Eq1 (Unspecialized a) where liftEq _ (Unspecialized a) (Unspecialized b) = a == b From 31b1cee6b333066ce1a2201e7b210a9dfbd6dd4d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 10:49:20 -0400 Subject: [PATCH 015/174] :fire: some unnecessary qualified names. --- src/Control/Abstract/Value.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 4248157a1..ebb755697 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -52,7 +52,7 @@ class Show value => AbstractValue location value effects where unit :: Evaluator location value effects value -- | Construct an abstract integral value. - integer :: Prelude.Integer -> Evaluator location value effects value + integer :: Integer -> Evaluator location value effects value -- | Lift a unary operator over a 'Num' to a function on 'value's. liftNumeric :: (forall a . Num a => a -> a) @@ -92,7 +92,7 @@ class Show value => AbstractValue location value effects where float :: Scientific -> Evaluator location value effects value -- | Construct a rational value. - rational :: Prelude.Rational -> Evaluator location value effects value + rational :: Rational -> Evaluator location value effects value -- | Construct an N-ary tuple of multiple (possibly-disjoint) values multiple :: [value] -> Evaluator location value effects value @@ -154,7 +154,7 @@ class Show value => AbstractValue location value effects where loop :: (Evaluator location value effects value -> Evaluator location value effects value) -> Evaluator location value effects value --- | Attempt to extract a 'Prelude.Bool' from a given value. +-- | C-style for loops. forLoop :: ( AbstractValue location value effects , Member (State (Environment location value)) effects ) @@ -166,7 +166,7 @@ forLoop :: ( AbstractValue location value effects forLoop initial cond step body = localize (initial *> while cond (body *> step)) --- | The fundamental looping primitive, built on top of ifthenelse. +-- | The fundamental looping primitive, built on top of 'ifthenelse'. while :: AbstractValue location value effects => Evaluator location value effects value -> Evaluator location value effects value From ff22cec5ad1c87529b19336d3cf7ec647dd84d1b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 10:51:23 -0400 Subject: [PATCH 016/174] Rearrange stuff related to the errors. --- src/Data/Abstract/Evaluatable.hs | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 2371d269a..ee0fa0532 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -84,16 +84,9 @@ data EvalError return where DefaultExportError :: EvalError () ExportError :: ModulePath -> Name -> EvalError () -runEvalError :: Effectful m => m (Resumable EvalError ': effects) a -> m effects (Either (SomeExc EvalError) a) -runEvalError = runResumable - -runEvalErrorWith :: Effectful m => (forall resume . EvalError resume -> m effects resume) -> m (Resumable EvalError ': effects) a -> m effects a -runEvalErrorWith = runResumableWith - deriving instance Eq (EvalError return) deriving instance Show (EvalError return) -instance Show1 EvalError where - liftShowsPrec _ _ = showsPrec + instance Eq1 EvalError where liftEq _ (FreeVariablesError a) (FreeVariablesError b) = a == b liftEq _ DefaultExportError DefaultExportError = True @@ -103,19 +96,28 @@ instance Eq1 EvalError where liftEq _ (RationalFormatError a) (RationalFormatError b) = a == b liftEq _ _ _ = False +instance Show1 EvalError where + liftShowsPrec _ _ = showsPrec throwEvalError :: (Effectful m, Member (Resumable EvalError) effects) => EvalError resume -> m effects resume throwEvalError = throwResumable +runEvalError :: Effectful m => m (Resumable EvalError ': effects) a -> m effects (Either (SomeExc EvalError) a) +runEvalError = runResumable + +runEvalErrorWith :: Effectful m => (forall resume . EvalError resume -> m effects resume) -> m (Resumable EvalError ': effects) a -> m effects a +runEvalErrorWith = runResumableWith + data Unspecialized a b where Unspecialized :: String -> Unspecialized value (ValueRef value) +deriving instance Eq (Unspecialized a b) +deriving instance Show (Unspecialized a b) + instance Eq1 (Unspecialized a) where liftEq _ (Unspecialized a) (Unspecialized b) = a == b -deriving instance Eq (Unspecialized a b) -deriving instance Show (Unspecialized a b) instance Show1 (Unspecialized a) where liftShowsPrec _ _ = showsPrec @@ -125,6 +127,7 @@ runUnspecialized = runResumable runUnspecializedWith :: Effectful (m value) => (forall resume . Unspecialized value resume -> m value effects resume) -> m value (Resumable (Unspecialized value) ': effects) a -> m value effects a runUnspecializedWith = runResumableWith + -- Instances -- | If we can evaluate any syntax which can occur in a 'Sum', we can evaluate the 'Sum'. From daf83fba768d8278cab179909cc75a5b76c776e1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 11:06:42 -0400 Subject: [PATCH 017/174] Move the errors to the bottom. --- src/Data/Abstract/Evaluatable.hs | 125 ++++++++++++++++--------------- 1 file changed, 64 insertions(+), 61 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index ee0fa0532..f7c92c513 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -2,18 +2,19 @@ module Data.Abstract.Evaluatable ( module X , Evaluatable(..) -, Unspecialized(..) -, runUnspecialized -, runUnspecializedWith -, EvalError(..) -, runEvalError -, runEvalErrorWith , evaluatePackageWith -, throwEvalError , traceResolve , builtin , isolate , Modules +-- | Effects +, EvalError(..) +, throwEvalError +, runEvalError +, runEvalErrorWith +, Unspecialized(..) +, runUnspecialized +, runUnspecializedWith ) where import Control.Abstract as X hiding (Goto(..), LoopControl(..), Modules(..), Return(..), TermEvaluator(..), builtin, defineBuiltins) @@ -74,60 +75,6 @@ type EvaluatableConstraints location term value effects = ) --- | The type of error thrown when failing to evaluate a term. -data EvalError return where - FreeVariablesError :: [Name] -> EvalError Name - -- Indicates that our evaluator wasn't able to make sense of these literals. - IntegerFormatError :: ByteString -> EvalError Integer - FloatFormatError :: ByteString -> EvalError Scientific - RationalFormatError :: ByteString -> EvalError Rational - DefaultExportError :: EvalError () - ExportError :: ModulePath -> Name -> EvalError () - -deriving instance Eq (EvalError return) -deriving instance Show (EvalError return) - -instance Eq1 EvalError where - liftEq _ (FreeVariablesError a) (FreeVariablesError b) = a == b - liftEq _ DefaultExportError DefaultExportError = True - liftEq _ (ExportError a b) (ExportError c d) = (a == c) && (b == d) - liftEq _ (IntegerFormatError a) (IntegerFormatError b) = a == b - liftEq _ (FloatFormatError a) (FloatFormatError b) = a == b - liftEq _ (RationalFormatError a) (RationalFormatError b) = a == b - liftEq _ _ _ = False - -instance Show1 EvalError where - liftShowsPrec _ _ = showsPrec - -throwEvalError :: (Effectful m, Member (Resumable EvalError) effects) => EvalError resume -> m effects resume -throwEvalError = throwResumable - -runEvalError :: Effectful m => m (Resumable EvalError ': effects) a -> m effects (Either (SomeExc EvalError) a) -runEvalError = runResumable - -runEvalErrorWith :: Effectful m => (forall resume . EvalError resume -> m effects resume) -> m (Resumable EvalError ': effects) a -> m effects a -runEvalErrorWith = runResumableWith - - -data Unspecialized a b where - Unspecialized :: String -> Unspecialized value (ValueRef value) - -deriving instance Eq (Unspecialized a b) -deriving instance Show (Unspecialized a b) - -instance Eq1 (Unspecialized a) where - liftEq _ (Unspecialized a) (Unspecialized b) = a == b - -instance Show1 (Unspecialized a) where - liftShowsPrec _ _ = showsPrec - -runUnspecialized :: Effectful (m value) => m value (Resumable (Unspecialized value) ': effects) a -> m value effects (Either (SomeExc (Unspecialized value)) a) -runUnspecialized = runResumable - -runUnspecializedWith :: Effectful (m value) => (forall resume . Unspecialized value resume -> m value effects resume) -> m value (Resumable (Unspecialized value) ': effects) a -> m value effects a -runUnspecializedWith = runResumableWith - - -- Instances -- | If we can evaluate any syntax which can occur in a 'Sum', we can evaluate the 'Sum'. @@ -230,3 +177,59 @@ newtype Gotos location value outer = Gotos { getGotos :: GotoTable (LoopControl -- | Isolate the given action with an empty global environment and exports. isolate :: Members '[State (Environment location value), State (Exports location value)] effects => Evaluator location value effects a -> Evaluator location value effects a isolate = withEnv lowerBound . withExports lowerBound + + +-- Effects + +-- | The type of error thrown when failing to evaluate a term. +data EvalError return where + FreeVariablesError :: [Name] -> EvalError Name + -- Indicates that our evaluator wasn't able to make sense of these literals. + IntegerFormatError :: ByteString -> EvalError Integer + FloatFormatError :: ByteString -> EvalError Scientific + RationalFormatError :: ByteString -> EvalError Rational + DefaultExportError :: EvalError () + ExportError :: ModulePath -> Name -> EvalError () + +deriving instance Eq (EvalError return) +deriving instance Show (EvalError return) + +instance Eq1 EvalError where + liftEq _ (FreeVariablesError a) (FreeVariablesError b) = a == b + liftEq _ DefaultExportError DefaultExportError = True + liftEq _ (ExportError a b) (ExportError c d) = (a == c) && (b == d) + liftEq _ (IntegerFormatError a) (IntegerFormatError b) = a == b + liftEq _ (FloatFormatError a) (FloatFormatError b) = a == b + liftEq _ (RationalFormatError a) (RationalFormatError b) = a == b + liftEq _ _ _ = False + +instance Show1 EvalError where + liftShowsPrec _ _ = showsPrec + +throwEvalError :: (Effectful m, Member (Resumable EvalError) effects) => EvalError resume -> m effects resume +throwEvalError = throwResumable + +runEvalError :: Effectful m => m (Resumable EvalError ': effects) a -> m effects (Either (SomeExc EvalError) a) +runEvalError = runResumable + +runEvalErrorWith :: Effectful m => (forall resume . EvalError resume -> m effects resume) -> m (Resumable EvalError ': effects) a -> m effects a +runEvalErrorWith = runResumableWith + + +data Unspecialized a b where + Unspecialized :: String -> Unspecialized value (ValueRef value) + +deriving instance Eq (Unspecialized a b) +deriving instance Show (Unspecialized a b) + +instance Eq1 (Unspecialized a) where + liftEq _ (Unspecialized a) (Unspecialized b) = a == b + +instance Show1 (Unspecialized a) where + liftShowsPrec _ _ = showsPrec + +runUnspecialized :: Effectful (m value) => m value (Resumable (Unspecialized value) ': effects) a -> m value effects (Either (SomeExc (Unspecialized value)) a) +runUnspecialized = runResumable + +runUnspecializedWith :: Effectful (m value) => (forall resume . Unspecialized value resume -> m value effects resume) -> m value (Resumable (Unspecialized value) ': effects) a -> m value effects a +runUnspecializedWith = runResumableWith From 008f628b585e381483f85c82ad600a7a3ccdd96c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 11:07:03 -0400 Subject: [PATCH 018/174] Tweak the Evaluatable re-exports. --- src/Analysis/Abstract/Graph.hs | 1 - src/Data/Abstract/Evaluatable.hs | 16 +++++++++------- src/Language/Go/Syntax.hs | 3 +-- src/Semantic/Util.hs | 5 ++--- 4 files changed, 12 insertions(+), 13 deletions(-) diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 1d695a89c..dc99d21ae 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -17,7 +17,6 @@ module Analysis.Abstract.Graph import Algebra.Graph.Export.Dot hiding (vertexName) import Control.Abstract import Data.Abstract.Address -import Data.Abstract.Evaluatable (LoadError (..)) import Data.Abstract.FreeVariables import Data.Abstract.Module (Module(moduleInfo), ModuleInfo(..)) import Data.Abstract.Package (PackageInfo(..)) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index f7c92c513..5a93d27fe 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -6,7 +6,6 @@ module Data.Abstract.Evaluatable , traceResolve , builtin , isolate -, Modules -- | Effects , EvalError(..) , throwEvalError @@ -15,14 +14,17 @@ module Data.Abstract.Evaluatable , Unspecialized(..) , runUnspecialized , runUnspecializedWith +, Cell ) where -import Control.Abstract as X hiding (Goto(..), LoopControl(..), Modules(..), Return(..), TermEvaluator(..), builtin, defineBuiltins) -import Control.Abstract.Evaluator (LoopControl, Return(..)) -import Control.Abstract.Goto (Goto(..)) -import Control.Abstract.Modules (Modules(..)) -import Control.Abstract.Primitive (builtin, defineBuiltins) -import Control.Abstract.TermEvaluator (TermEvaluator(..)) +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(..)) +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 import Data.Abstract.Declarations as X import Data.Abstract.Environment as X import Data.Abstract.Exports as Exports diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index 0329ecad3..4d4c9d11f 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -1,8 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} module Language.Go.Syntax where -import Data.Abstract.Evaluatable hiding (Label) -import Data.Abstract.FreeVariables (Name (..), name) +import Data.Abstract.Evaluatable import Data.Abstract.Module import qualified Data.Abstract.Package as Package import Data.Abstract.Path diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index abee369d4..2ab77b985 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -4,9 +4,8 @@ module Semantic.Util where import Analysis.Abstract.Caching import Analysis.Abstract.Collecting -import Analysis.Abstract.Evaluating as X -import Control.Abstract.Evaluator -import Control.Abstract.TermEvaluator +import Analysis.Abstract.Evaluating +import Control.Abstract import Control.Monad.Effect.Trace (runPrintingTrace) import Data.Abstract.Address import Data.Abstract.Evaluatable From 324a0232ae6e98b113116dbc94a1428bd62c3f69 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 11:07:48 -0400 Subject: [PATCH 019/174] Move the Evaluatable instances to the bottom. --- src/Data/Abstract/Evaluatable.hs | 40 ++++++++++++++++---------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 5a93d27fe..2ceb99445 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -77,26 +77,6 @@ type EvaluatableConstraints location term value effects = ) --- Instances - --- | If we can evaluate any syntax which can occur in a 'Sum', we can evaluate the 'Sum'. -instance Apply Evaluatable fs => Evaluatable (Sum fs) where - eval = apply @Evaluatable eval - --- | Evaluating a 'TermF' ignores its annotation, evaluating the underlying syntax. -instance Evaluatable s => Evaluatable (TermF s a) where - eval = eval . termFOut - ---- | '[]' is treated as an imperative sequence of statements/declarations s.t.: ---- ---- 1. Each statement’s effects on the store are accumulated; ---- 2. Each statement can affect the environment of later statements (e.g. by 'modify'-ing the environment); and ---- 3. Only the last statement’s return value is returned. -instance Evaluatable [] where - -- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists. - eval = maybe (Rval <$> unit) (runApp . foldMap1 (App . subtermRef)) . nonEmpty - - traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator location value effects () traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) @@ -235,3 +215,23 @@ runUnspecialized = runResumable runUnspecializedWith :: Effectful (m value) => (forall resume . Unspecialized value resume -> m value effects resume) -> m value (Resumable (Unspecialized value) ': effects) a -> m value effects a runUnspecializedWith = runResumableWith + + +-- Instances + +-- | If we can evaluate any syntax which can occur in a 'Sum', we can evaluate the 'Sum'. +instance Apply Evaluatable fs => Evaluatable (Sum fs) where + eval = apply @Evaluatable eval + +-- | Evaluating a 'TermF' ignores its annotation, evaluating the underlying syntax. +instance Evaluatable s => Evaluatable (TermF s a) where + eval = eval . termFOut + +--- | '[]' is treated as an imperative sequence of statements/declarations s.t.: +--- +--- 1. Each statement’s effects on the store are accumulated; +--- 2. Each statement can affect the environment of later statements (e.g. by 'modify'-ing the environment); and +--- 3. Only the last statement’s return value is returned. +instance Evaluatable [] where + -- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists. + eval = maybe (Rval <$> unit) (runApp . foldMap1 (App . subtermRef)) . nonEmpty From f9b3b8292d3e12dba26e9f9a181ebae515dca0e1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 11:08:15 -0400 Subject: [PATCH 020/174] Put traceResolve next to isolate. --- src/Data/Abstract/Evaluatable.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 2ceb99445..2195291dd 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -3,9 +3,9 @@ module Data.Abstract.Evaluatable ( module X , Evaluatable(..) , evaluatePackageWith -, traceResolve , builtin , isolate +, traceResolve -- | Effects , EvalError(..) , throwEvalError @@ -77,10 +77,6 @@ type EvaluatableConstraints location term value effects = ) -traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator location value effects () -traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) - - -- | Evaluate a given package. evaluatePackageWith :: forall location term value 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? If not, can we factor this effect list out? @@ -160,6 +156,9 @@ newtype Gotos location value outer = Gotos { getGotos :: GotoTable (LoopControl isolate :: Members '[State (Environment location value), State (Exports location value)] effects => Evaluator location value effects a -> Evaluator location value effects a isolate = withEnv lowerBound . withExports lowerBound +traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator location value effects () +traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) + -- Effects From d2b7af489f953999c4358594949ee7290e16cfa7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 11:08:23 -0400 Subject: [PATCH 021/174] =?UTF-8?q?Don=E2=80=99t=20re-export=20builtin.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- 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 2195291dd..a4dbf9912 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 -, builtin , isolate , traceResolve -- | Effects From edded16e4416c32479e3b728efdf9931372f936a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 11:17:36 -0400 Subject: [PATCH 022/174] Combine the Evaluator re-exports. --- src/Control/Abstract/Evaluator.hs | 25 +++++++++---------------- 1 file changed, 9 insertions(+), 16 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index b2360ef20..238ec21fe 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -11,24 +11,17 @@ module Control.Abstract.Evaluator , throwContinue , catchLoopControl , runLoopControl - , module Control.Monad.Effect - , module Control.Monad.Effect.Fail - , module Control.Monad.Effect.Fresh - , module Control.Monad.Effect.NonDet - , module Control.Monad.Effect.Reader - , module Control.Monad.Effect.Resumable - , module Control.Monad.Effect.State - , module Control.Monad.Effect.Trace + , module X ) where -import Control.Monad.Effect -import Control.Monad.Effect.Fail -import Control.Monad.Effect.Fresh -import Control.Monad.Effect.NonDet -import Control.Monad.Effect.Reader -import Control.Monad.Effect.Resumable -import Control.Monad.Effect.State -import Control.Monad.Effect.Trace +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 +import Control.Monad.Effect.Resumable as X +import Control.Monad.Effect.State as X +import Control.Monad.Effect.Trace as X import Prologue -- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the location, term, and value types. From ac73ebf840d09be35cf6b46f8638dfb24e3ce84d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 11:18:37 -0400 Subject: [PATCH 023/174] =?UTF-8?q?Don=E2=80=99t=20re-export=20catchReturn?= =?UTF-8?q?/catchLoopControl.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Abstract/Evaluatable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index a4dbf9912..e69b6c959 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -19,7 +19,7 @@ module Data.Abstract.Evaluatable 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(..)) +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) From a11a071b88cc769d7791cedc85c99dab1d1817e9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 11:44:02 -0400 Subject: [PATCH 024/174] :fire: a redundant do. --- src/Control/Abstract/Primitive.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 5a4178b44..49b938199 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -48,5 +48,5 @@ defineBuiltins :: ( AbstractValue location value effects , Reducer value (Cell location value) ) => Evaluator location value effects () -defineBuiltins = do +defineBuiltins = builtin "print" (closure ["s"] lowerBound (variable "s" >>= asString >>= trace . unpack >> unit)) From db5bd5cbaa5a8788f5daaa07e2741b677df8a904 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 12:18:35 -0400 Subject: [PATCH 025/174] Throw an error in ifthenelse directly. --- src/Data/Abstract/Value.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 192905d1b..4b718f4c1 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -80,7 +80,7 @@ instance Ord1 Hole where liftCompare = genericLiftCompare instance Show1 Hole where liftShowsPrec = genericLiftShowsPrec -- | Boolean values. -newtype Boolean value = Boolean Prelude.Bool +newtype Boolean value = Boolean { getBoolean :: Bool } deriving (Eq, Generic1, Ord, Show) instance Eq1 Boolean where liftEq = genericLiftEq @@ -265,11 +265,10 @@ instance ( Members '[ Allocator location (Value location) | Just (String n) <- prjValue v = pure n | otherwise = throwValueError $ StringError v - ifthenelse cond if' else' = do - if isHole cond then - pure hole - else do - bool <- asBool cond + ifthenelse cond if' else' + | isHole cond = pure hole + | otherwise = do + bool <- maybe (throwValueError (BoolError cond)) (pure . getBoolean) (prjValue cond) if bool then if' else else' asBool val From bb97d7d8c4a5559ec5e90ad23291f74fd029a85a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 12:24:14 -0400 Subject: [PATCH 026/174] asBool is not primitive. --- src/Control/Abstract/Value.hs | 10 ++++++---- src/Data/Abstract/Type.hs | 1 - src/Data/Abstract/Value.hs | 12 +++--------- 3 files changed, 9 insertions(+), 14 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index ebb755697..954b63644 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -3,6 +3,7 @@ module Control.Abstract.Value ( AbstractValue(..) , AbstractHole(..) , Comparator(..) +, asBool , while , doWhile , forLoop @@ -113,10 +114,7 @@ class Show value => AbstractValue location value effects where asString :: value -> Evaluator location value effects ByteString -- | Eliminate boolean values. TODO: s/boolean/truthy - ifthenelse :: value -> Evaluator location value effects value -> Evaluator location value effects value -> Evaluator location value effects value - - -- | Extract a 'Bool' from a given value. - asBool :: value -> Evaluator location value effects Bool + ifthenelse :: value -> Evaluator location value effects a -> Evaluator location value effects a -> Evaluator location value effects a -- | Construct the nil/null datatype. null :: Evaluator location value effects value @@ -154,6 +152,10 @@ class Show value => AbstractValue location value effects where loop :: (Evaluator location value effects value -> Evaluator location value effects value) -> Evaluator location value effects value +-- | Extract a 'Bool' from a given value. +asBool :: AbstractValue location value effects => value -> Evaluator location value effects Bool +asBool value = ifthenelse value (pure True) (pure False) + -- | C-style for loops. forLoop :: ( AbstractValue location value effects , Member (State (Environment location value)) effects diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index e8100d7bc..fc9d8ece9 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -151,7 +151,6 @@ instance ( Members '[ Allocator location Type t1 <- fresh t2 <- fresh unify t (Var t1 :* Var t2) $> (Var t1, Var t2) - asBool t = unify t Bool *> (pure True <|> pure False) index arr sub = do _ <- unify sub Int diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 4b718f4c1..b41a3810c 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -265,15 +265,9 @@ instance ( Members '[ Allocator location (Value location) | Just (String n) <- prjValue v = pure n | otherwise = throwValueError $ StringError v - ifthenelse cond if' else' - | isHole cond = pure hole - | otherwise = do - bool <- maybe (throwValueError (BoolError cond)) (pure . getBoolean) (prjValue cond) - if bool then if' else else' - - asBool val - | Just (Boolean b) <- prjValue val = pure b - | otherwise = throwValueError $ BoolError val + ifthenelse cond if' else' = do + bool <- maybe (throwValueError (BoolError cond)) (pure . getBoolean) (prjValue cond) + if bool then if' else else' index = go where tryIdx list ii From ba0e53079f964872361677b6a3b67773a8c33c49 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 12:26:04 -0400 Subject: [PATCH 027/174] :fire: isHole. Holes are going to be composed onto values like Located is composed onto locations. --- src/Control/Abstract/Value.hs | 1 - src/Data/Abstract/Type.hs | 1 - src/Data/Abstract/Value.hs | 1 - 3 files changed, 3 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 954b63644..3d34ba743 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -42,7 +42,6 @@ data Comparator class AbstractHole value where hole :: value - isHole :: value -> Bool -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index fc9d8ece9..03b99c219 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -100,7 +100,6 @@ instance Ord location => ValueRoots location Type where instance AbstractHole Type where hole = Hole - isHole = (== Hole) -- | Discard the value arguments (if any), constructing a 'Type' instead. instance ( Members '[ Allocator location Type diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index b41a3810c..19a1d804e 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -203,7 +203,6 @@ instance Ord location => ValueRoots location (Value location) where instance AbstractHole (Value location) where hole = injValue Hole - isHole = (== Just Hole) . prjValue -- | Construct a 'Value' wrapping the value arguments (if any). instance ( Members '[ Allocator location (Value location) From 66d1f8286b78841c89c6bc11a1f03da82a6eddf3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 12:43:28 -0400 Subject: [PATCH 028/174] Stub in a module for names. --- semantic.cabal | 1 + src/Data/Abstract/Name.hs | 1 + 2 files changed, 2 insertions(+) create mode 100644 src/Data/Abstract/Name.hs diff --git a/semantic.cabal b/semantic.cabal index 0bdcf8a09..d819401c5 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -59,6 +59,7 @@ library , Data.Abstract.Live , Data.Abstract.Module , Data.Abstract.ModuleTable + , Data.Abstract.Name , Data.Abstract.Number , Data.Abstract.Package , Data.Abstract.Path diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs new file mode 100644 index 000000000..d474d4e9d --- /dev/null +++ b/src/Data/Abstract/Name.hs @@ -0,0 +1 @@ +module Data.Abstract.Name where From 2c6f26694549f00c411cd34605058ff94040bf84 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 12:53:01 -0400 Subject: [PATCH 029/174] Move Name into its own module. --- src/Analysis/Abstract/Graph.hs | 2 +- src/Analysis/Declaration.hs | 2 +- src/Analysis/IdentifierName.hs | 2 +- src/Control/Abstract/Addressable.hs | 2 +- src/Control/Abstract/Environment.hs | 2 +- src/Control/Abstract/Exports.hs | 2 +- src/Control/Abstract/Heap.hs | 2 +- src/Control/Abstract/Primitive.hs | 2 +- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Address.hs | 2 +- src/Data/Abstract/Declarations.hs | 1 + src/Data/Abstract/Environment.hs | 2 +- src/Data/Abstract/Evaluatable.hs | 1 + src/Data/Abstract/Exports.hs | 2 +- src/Data/Abstract/FreeVariables.hs | 16 +--------------- src/Data/Abstract/Name.hs | 17 +++++++++++++++++ src/Data/Abstract/Package.hs | 2 +- src/Data/Abstract/Ref.hs | 2 +- src/Data/Abstract/Value.hs | 2 +- src/Language/Go/Assignment.hs | 2 +- src/Language/PHP/Assignment.hs | 10 +++++----- src/Language/Python/Assignment.hs | 2 +- src/Language/Python/Syntax.hs | 7 +++---- src/Language/Ruby/Assignment.hs | 2 +- src/Language/TypeScript/Assignment.hs | 2 +- src/Language/TypeScript/Syntax.hs | 3 +-- 26 files changed, 48 insertions(+), 45 deletions(-) diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index dc99d21ae..ed015f841 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -17,8 +17,8 @@ module Analysis.Abstract.Graph import Algebra.Graph.Export.Dot hiding (vertexName) import Control.Abstract import Data.Abstract.Address -import Data.Abstract.FreeVariables import Data.Abstract.Module (Module(moduleInfo), ModuleInfo(..)) +import Data.Abstract.Name import Data.Abstract.Package (PackageInfo(..)) import Data.Aeson hiding (Result) import Data.ByteString.Builder diff --git a/src/Analysis/Declaration.hs b/src/Analysis/Declaration.hs index c745aa11a..46de47c33 100644 --- a/src/Analysis/Declaration.hs +++ b/src/Analysis/Declaration.hs @@ -5,7 +5,7 @@ module Analysis.Declaration , declarationAlgebra ) where -import Data.Abstract.FreeVariables (Name(..)) +import Data.Abstract.Name (Name(..)) import Data.Blob import Data.Error (Error(..), showExpectation) import Data.Language as Language diff --git a/src/Analysis/IdentifierName.hs b/src/Analysis/IdentifierName.hs index 700e989f6..29ac62195 100644 --- a/src/Analysis/IdentifierName.hs +++ b/src/Analysis/IdentifierName.hs @@ -5,7 +5,7 @@ module Analysis.IdentifierName , identifierLabel ) where -import Data.Abstract.FreeVariables (Name (..)) +import Data.Abstract.Name (Name (..)) import Data.Aeson import Data.JSON.Fields import Data.Sum diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index a37035776..ccadd1736 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -6,7 +6,7 @@ module Control.Abstract.Addressable import Control.Abstract.Context import Control.Abstract.Evaluator import Data.Abstract.Address -import Data.Abstract.FreeVariables +import Data.Abstract.Name import Prologue -- | Defines allocation and dereferencing of 'Address'es in a 'Heap'. diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 4f4ee0f40..f330b0e44 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -20,7 +20,7 @@ module Control.Abstract.Environment import Control.Abstract.Evaluator import Data.Abstract.Address import Data.Abstract.Environment as Env -import Data.Abstract.FreeVariables +import Data.Abstract.Name import Prologue -- | Retrieve the environment. diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs index ac935d4fb..46a362444 100644 --- a/src/Control/Abstract/Exports.hs +++ b/src/Control/Abstract/Exports.hs @@ -10,7 +10,7 @@ module Control.Abstract.Exports import Control.Abstract.Evaluator import Data.Abstract.Address import Data.Abstract.Exports -import Data.Abstract.FreeVariables +import Data.Abstract.Name -- | Get the global export state. getExports :: Member (State (Exports location value)) effects => Evaluator location value effects (Exports location value) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 49fa70fcb..6e1905ccb 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -24,8 +24,8 @@ import Control.Abstract.Environment import Control.Abstract.Evaluator import Data.Abstract.Address import Data.Abstract.Environment -import Data.Abstract.FreeVariables import Data.Abstract.Heap +import Data.Abstract.Name import Data.Semigroup.Reducer import Prologue diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 49b938199..1b98b17ec 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -7,7 +7,7 @@ import Control.Abstract.Evaluator import Control.Abstract.Heap import Control.Abstract.Value import Data.Abstract.Environment -import Data.Abstract.FreeVariables +import Data.Abstract.Name import Data.ByteString.Char8 (pack, unpack) import Data.Semigroup.Reducer hiding (unit) import Data.Semilattice.Lower diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 3d34ba743..71f562e3a 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -20,8 +20,8 @@ import Control.Abstract.Evaluator import Control.Abstract.Heap import Data.Abstract.Address (Address) import Data.Abstract.Environment as Env -import Data.Abstract.FreeVariables import Data.Abstract.Live (Live) +import Data.Abstract.Name import Data.Abstract.Number as Number import Data.Abstract.Ref import Data.Scientific (Scientific) diff --git a/src/Data/Abstract/Address.hs b/src/Data/Abstract/Address.hs index c61f712bf..1b90c8206 100644 --- a/src/Data/Abstract/Address.hs +++ b/src/Data/Abstract/Address.hs @@ -1,8 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} module Data.Abstract.Address where -import Data.Abstract.FreeVariables import Data.Abstract.Module (ModuleInfo) +import Data.Abstract.Name import Data.Abstract.Package (PackageInfo) import Data.Monoid (Last(..)) import Data.Semigroup.Reducer diff --git a/src/Data/Abstract/Declarations.hs b/src/Data/Abstract/Declarations.hs index 00a46aaf3..a15c74f04 100644 --- a/src/Data/Abstract/Declarations.hs +++ b/src/Data/Abstract/Declarations.hs @@ -2,6 +2,7 @@ module Data.Abstract.Declarations where import Data.Abstract.FreeVariables +import Data.Abstract.Name import Data.Sum import Data.Term import Prologue diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index eb74a724e..746a2523a 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -19,8 +19,8 @@ module Data.Abstract.Environment ) where import Data.Abstract.Address -import Data.Abstract.FreeVariables import Data.Abstract.Live +import Data.Abstract.Name import Data.Align import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index e69b6c959..b3293d539 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -30,6 +30,7 @@ import Data.Abstract.Exports as Exports import Data.Abstract.FreeVariables as X import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable +import Data.Abstract.Name as X import Data.Abstract.Package as Package import Data.Abstract.Ref as X import Data.Scientific (Scientific) diff --git a/src/Data/Abstract/Exports.hs b/src/Data/Abstract/Exports.hs index 09dea7aaf..b9db75887 100644 --- a/src/Data/Abstract/Exports.hs +++ b/src/Data/Abstract/Exports.hs @@ -11,7 +11,7 @@ import Prelude hiding (null) import Prologue hiding (null) import Data.Abstract.Address import Data.Abstract.Environment (Environment, unpairs) -import Data.Abstract.FreeVariables +import Data.Abstract.Name import qualified Data.Map as Map import Data.Semilattice.Lower diff --git a/src/Data/Abstract/FreeVariables.hs b/src/Data/Abstract/FreeVariables.hs index a8dbfafb3..ddf54b02e 100644 --- a/src/Data/Abstract/FreeVariables.hs +++ b/src/Data/Abstract/FreeVariables.hs @@ -1,25 +1,11 @@ {-# LANGUAGE DefaultSignatures, GeneralizedNewtypeDeriving, UndecidableInstances #-} module Data.Abstract.FreeVariables where -import qualified Data.ByteString.Char8 as BC -import Data.String +import Data.Abstract.Name import Data.Sum import Data.Term import Prologue --- | The type of variable names. -newtype Name = Name { unName :: ByteString } - deriving (Eq, Hashable, Ord) - -name :: ByteString -> Name -name = Name - -instance IsString Name where - fromString = Name . BC.pack - -instance Show Name where showsPrec d (Name str) = showsPrec d str - - -- | Types which can contain unbound variables. class FreeVariables term where -- | The set of free variables in the given value. diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index d474d4e9d..0622f5d78 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -1 +1,18 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Abstract.Name where + +import qualified Data.ByteString.Char8 as BC +import Data.String +import Prologue + +-- | The type of variable names. +newtype Name = Name { unName :: ByteString } + deriving (Eq, Hashable, Ord) + +name :: ByteString -> Name +name = Name + +instance IsString Name where + fromString = Name . BC.pack + +instance Show Name where showsPrec d (Name str) = showsPrec d str diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 6fddde453..c95ec8d57 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -1,10 +1,10 @@ {-# LANGUAGE TupleSections #-} module Data.Abstract.Package where -import Data.Abstract.FreeVariables import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import qualified Data.Map as Map +import Data.Abstract.Name type PackageName = Name diff --git a/src/Data/Abstract/Ref.hs b/src/Data/Abstract/Ref.hs index 596bec5e4..c7412cde4 100644 --- a/src/Data/Abstract/Ref.hs +++ b/src/Data/Abstract/Ref.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-} module Data.Abstract.Ref where -import Data.Abstract.FreeVariables +import Data.Abstract.Name -- | 'ValueRef' is the type subterms evaluate to and can represent either values directly ('Rval'), or references to values (lvals - such as local variables or object members) data ValueRef value where diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 19a1d804e..6f8c5353e 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -4,7 +4,7 @@ module Data.Abstract.Value where import Control.Abstract import Data.Abstract.Environment (Environment, emptyEnv, mergeEnvs) import qualified Data.Abstract.Environment as Env -import Data.Abstract.FreeVariables +import Data.Abstract.Name import qualified Data.Abstract.Number as Number import Data.List (genericIndex, genericLength) import Data.Scientific (Scientific) diff --git a/src/Language/Go/Assignment.hs b/src/Language/Go/Assignment.hs index 7ba2fb519..665bd7bd3 100644 --- a/src/Language/Go/Assignment.hs +++ b/src/Language/Go/Assignment.hs @@ -7,7 +7,7 @@ module Language.Go.Assignment ) where import Assigning.Assignment hiding (Assignment, Error) -import Data.Abstract.FreeVariables (name) +import Data.Abstract.Name (name) import Data.Record import Data.Syntax (contextualize, emptyTerm, parseError, handleError, infixContext, makeTerm, makeTerm', makeTerm'', makeTerm1) import Language.Go.Grammar as Grammar diff --git a/src/Language/PHP/Assignment.hs b/src/Language/PHP/Assignment.hs index 7317dc15a..7a66a2604 100644 --- a/src/Language/PHP/Assignment.hs +++ b/src/Language/PHP/Assignment.hs @@ -11,7 +11,7 @@ import Data.Record import Data.Syntax (emptyTerm, handleError, parseError, infixContext, makeTerm, makeTerm', makeTerm1, contextualize, postContextualize) import Language.PHP.Grammar as Grammar import qualified Assigning.Assignment as Assignment -import qualified Data.Abstract.FreeVariables as FV +import qualified Data.Abstract.Name as Name import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Syntax as Syntax import qualified Data.Syntax.Comment as Comment @@ -442,7 +442,7 @@ classConstDeclaration :: Assignment classConstDeclaration = makeTerm <$> symbol ClassConstDeclaration <*> children (Syntax.ClassConstDeclaration <$> (term visibilityModifier <|> emptyTerm) <*> manyTerm constElement) visibilityModifier :: Assignment -visibilityModifier = makeTerm <$> symbol VisibilityModifier <*> (Syntax.Identifier . FV.name <$> source) +visibilityModifier = makeTerm <$> symbol VisibilityModifier <*> (Syntax.Identifier . Name.name <$> source) constElement :: Assignment constElement = makeTerm <$> symbol ConstElement <*> children (Statement.Assignment [] <$> term name <*> term expression) @@ -648,7 +648,7 @@ propertyDeclaration :: Assignment propertyDeclaration = makeTerm <$> symbol PropertyDeclaration <*> children (Syntax.PropertyDeclaration <$> term propertyModifier <*> someTerm propertyElement) propertyModifier :: Assignment -propertyModifier = (makeTerm <$> symbol PropertyModifier <*> children (Syntax.PropertyModifier <$> (term visibilityModifier <|> emptyTerm) <*> (term staticModifier <|> emptyTerm))) <|> term (makeTerm <$> symbol PropertyModifier <*> (Syntax.Identifier . FV.name <$> source)) +propertyModifier = (makeTerm <$> symbol PropertyModifier <*> children (Syntax.PropertyModifier <$> (term visibilityModifier <|> emptyTerm) <*> (term staticModifier <|> emptyTerm))) <|> term (makeTerm <$> symbol PropertyModifier <*> (Syntax.Identifier . Name.name <$> source)) propertyElement :: Assignment propertyElement = makeTerm <$> symbol PropertyElement <*> children (Statement.Assignment [] <$> term variableName <*> term propertyInitializer) <|> (symbol PropertyElement *> children (term variableName)) @@ -709,7 +709,7 @@ namespaceAliasingClause = makeTerm <$> symbol NamespaceAliasingClause <*> childr -- | TODO Do something better than Identifier namespaceFunctionOrConst :: Assignment -namespaceFunctionOrConst = makeTerm <$> symbol NamespaceFunctionOrConst <*> (Syntax.Identifier . FV.name <$> source) +namespaceFunctionOrConst = makeTerm <$> symbol NamespaceFunctionOrConst <*> (Syntax.Identifier . Name.name <$> source) globalDeclaration :: Assignment globalDeclaration = makeTerm <$> symbol GlobalDeclaration <*> children (Syntax.GlobalDeclaration <$> manyTerm simpleVariable') @@ -745,7 +745,7 @@ variableName :: Assignment variableName = makeTerm <$> symbol VariableName <*> children (Syntax.VariableName <$> term name) name :: Assignment -name = makeTerm <$> (symbol Name <|> symbol Name') <*> (Syntax.Identifier . FV.name <$> source) +name = makeTerm <$> (symbol Name <|> symbol Name') <*> (Syntax.Identifier . Name.name <$> source) functionStaticDeclaration :: Assignment functionStaticDeclaration = makeTerm <$> symbol FunctionStaticDeclaration <*> children (Declaration.VariableDeclaration <$> manyTerm staticVariableDeclaration) diff --git a/src/Language/Python/Assignment.hs b/src/Language/Python/Assignment.hs index f2080cbb1..74b2bdb1d 100644 --- a/src/Language/Python/Assignment.hs +++ b/src/Language/Python/Assignment.hs @@ -8,7 +8,7 @@ module Language.Python.Assignment ) where import Assigning.Assignment hiding (Assignment, Error) -import Data.Abstract.FreeVariables (name) +import Data.Abstract.Name (name) import Data.Record import Data.Syntax (contextualize, emptyTerm, handleError, infixContext, makeTerm, makeTerm', makeTerm'', makeTerm1, parseError, postContextualize) import GHC.Stack diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 6a1506f8b..a36cec28d 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -3,7 +3,6 @@ module Language.Python.Syntax where import Data.Abstract.Environment as Env import Data.Abstract.Evaluatable -import qualified Data.Abstract.FreeVariables as FV import Data.Abstract.Module import Data.Align.Generic import qualified Data.ByteString.Char8 as BC @@ -158,9 +157,9 @@ instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec -- import a.b.c instance Evaluatable QualifiedImport where eval (QualifiedImport (RelativeQualifiedName _ _)) = raiseEff (fail "technically this is not allowed in python") - eval (QualifiedImport name@(QualifiedName qualifiedName)) = do - modulePaths <- resolvePythonModules name - Rval <$> go (NonEmpty.zip (FV.name . BC.pack <$> qualifiedName) modulePaths) + eval (QualifiedImport qname@(QualifiedName qualifiedName)) = do + modulePaths <- resolvePythonModules qname + Rval <$> go (NonEmpty.zip (name . BC.pack <$> qualifiedName) modulePaths) where -- Evaluate and import the last module, updating the environment go ((name, path) :| []) = evalQualifiedImport name path diff --git a/src/Language/Ruby/Assignment.hs b/src/Language/Ruby/Assignment.hs index 2fbfdca2b..f16c6ca06 100644 --- a/src/Language/Ruby/Assignment.hs +++ b/src/Language/Ruby/Assignment.hs @@ -7,11 +7,11 @@ module Language.Ruby.Assignment ) where import Assigning.Assignment hiding (Assignment, Error) +import Data.Abstract.Name (name) import Data.List (elem) import Data.Record import Data.Syntax (contextualize, postContextualize, emptyTerm, parseError, handleError, infixContext, makeTerm, makeTerm', makeTerm'', makeTerm1) import Language.Ruby.Grammar as Grammar -import Data.Abstract.FreeVariables (name) import qualified Assigning.Assignment as Assignment import Data.Sum import qualified Data.Syntax as Syntax diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs index 1c47ec893..432dd3eea 100644 --- a/src/Language/TypeScript/Assignment.hs +++ b/src/Language/TypeScript/Assignment.hs @@ -7,7 +7,7 @@ module Language.TypeScript.Assignment ) where import Assigning.Assignment hiding (Assignment, Error) -import Data.Abstract.FreeVariables (name) +import Data.Abstract.Name (name) import qualified Assigning.Assignment as Assignment import Data.Record import Data.Sum diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 1f3a403ba..687d92327 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -3,7 +3,6 @@ module Language.TypeScript.Syntax where import qualified Data.Abstract.Environment as Env import Data.Abstract.Evaluatable -import qualified Data.Abstract.FreeVariables as FV import qualified Data.Abstract.Module as M import Data.Abstract.Package import Data.Abstract.Path @@ -32,7 +31,7 @@ importPath str = let path = stripQuotes str in ImportPath (BC.unpack path) (path | otherwise = NonRelative toName :: ImportPath -> Name -toName = FV.name . BC.pack . unPath +toName = name . BC.pack . unPath -- Node.js resolution algorithm: https://nodejs.org/api/modules.html#modules_all_together -- From 138b4c7a9334f80a72482a85ef6ab585c2840942 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 12:58:03 -0400 Subject: [PATCH 030/174] Simplify the Show instances for Monovariant and Environment since Name is no longer verbose. --- src/Data/Abstract/Address.hs | 2 +- src/Data/Abstract/Environment.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Address.hs b/src/Data/Abstract/Address.hs index 1b90c8206..16deab806 100644 --- a/src/Data/Abstract/Address.hs +++ b/src/Data/Abstract/Address.hs @@ -35,7 +35,7 @@ newtype Monovariant = Monovariant { unMonovariant :: Name } deriving (Eq, Ord) instance Show Monovariant where - showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unName . unMonovariant + showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unMonovariant data Located location = Located diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 746a2523a..4b14cfa70 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -132,4 +132,4 @@ addresses = fromAddresses . map snd . pairs instance Lower (Environment location value) where lowerBound = emptyEnv instance Show location => Show (Environment location value) where - showsPrec d = showsUnaryWith showsPrec "Environment" d . map (first unName) . pairs + showsPrec d = showsUnaryWith showsPrec "Environment" d . pairs From dc2bffa288b9c5bdb585a801337493e10e39c339 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 12:59:23 -0400 Subject: [PATCH 031/174] Define unName as a function. --- src/Data/Abstract/Name.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index 0622f5d78..d92a181e9 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -6,12 +6,15 @@ import Data.String import Prologue -- | The type of variable names. -newtype Name = Name { unName :: ByteString } +newtype Name = Name ByteString deriving (Eq, Hashable, Ord) name :: ByteString -> Name name = Name +unName :: Name -> ByteString +unName (Name name) = name + instance IsString Name where fromString = Name . BC.pack From 0cd428286dbb8018a5cab21363e7260bedec2c8e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:01:31 -0400 Subject: [PATCH 032/174] Use unName exclusively. --- src/Analysis/Declaration.hs | 4 ++-- src/Analysis/IdentifierName.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Declaration.hs b/src/Analysis/Declaration.hs index 46de47c33..ac77e1be6 100644 --- a/src/Analysis/Declaration.hs +++ b/src/Analysis/Declaration.hs @@ -5,7 +5,7 @@ module Analysis.Declaration , declarationAlgebra ) where -import Data.Abstract.Name (Name(..)) +import Data.Abstract.Name (unName) import Data.Blob import Data.Error (Error(..), showExpectation) import Data.Language as Language @@ -130,7 +130,7 @@ getSource blobSource = toText . flip Source.slice blobSource . getField instance (Syntax.Identifier :< fs, Expression.MemberAccess :< fs) => CustomHasDeclaration (Sum fs) Expression.Call where customToDeclaration Blob{..} _ (Expression.Call _ (Term (In fromAnn fromF), _) _ _) | Just (Expression.MemberAccess (Term (In leftAnn leftF)) (Term (In idenAnn _))) <- projectSum fromF = Just $ CallReference (getSource idenAnn) mempty blobLanguage (memberAccess leftAnn leftF) - | Just (Syntax.Identifier (Name name)) <- projectSum fromF = Just $ CallReference (T.decodeUtf8 name) mempty blobLanguage [] + | Just (Syntax.Identifier name) <- projectSum fromF = Just $ CallReference (T.decodeUtf8 (unName name)) mempty blobLanguage [] | otherwise = Just $ CallReference (getSource fromAnn) mempty blobLanguage [] where memberAccess modAnn termFOut diff --git a/src/Analysis/IdentifierName.hs b/src/Analysis/IdentifierName.hs index 29ac62195..f98d13fef 100644 --- a/src/Analysis/IdentifierName.hs +++ b/src/Analysis/IdentifierName.hs @@ -5,7 +5,7 @@ module Analysis.IdentifierName , identifierLabel ) where -import Data.Abstract.Name (Name (..)) +import Data.Abstract.Name (unName) import Data.Aeson import Data.JSON.Fields import Data.Sum @@ -41,7 +41,7 @@ instance Apply IdentifierName fs => CustomIdentifierName (Sum fs) where customIdentifierName = apply @IdentifierName identifierName instance CustomIdentifierName Data.Syntax.Identifier where - customIdentifierName (Data.Syntax.Identifier (Name name)) = Just name + customIdentifierName (Data.Syntax.Identifier name) = Just (unName name) data Strategy = Default | Custom From 8fe77fbdd3c65b8e8a7c4f9f398d687fe1b4e413 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:01:49 -0400 Subject: [PATCH 033/174] =?UTF-8?q?Don=E2=80=99t=20export=20the=20Name=20c?= =?UTF-8?q?onstructor.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Abstract/Name.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index d92a181e9..c15252a98 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -1,5 +1,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Data.Abstract.Name where +module Data.Abstract.Name +( Name +, name +, unName +) where import qualified Data.ByteString.Char8 as BC import Data.String From 2a0483d662b37dcc6e9bc20d45bce1e36a10d780 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:01:55 -0400 Subject: [PATCH 034/174] Show Name via unName. --- src/Data/Abstract/Name.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index c15252a98..cc87884d3 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -22,4 +22,5 @@ unName (Name name) = name instance IsString Name where fromString = Name . BC.pack -instance Show Name where showsPrec d (Name str) = showsPrec d str +instance Show Name where + showsPrec d = showsPrec d . unName From 81951d7bcc839ca09b4201c51e66c0bd980a9f90 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:05:46 -0400 Subject: [PATCH 035/174] Fix the Listable instance for Name. --- test/Data/Functor/Listable.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs index 3d9064e89..e6e653fa0 100644 --- a/test/Data/Functor/Listable.hs +++ b/test/Data/Functor/Listable.hs @@ -47,7 +47,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.Statement as Statement -import qualified Data.Abstract.FreeVariables as FV +import qualified Data.Abstract.Name as Name import Data.Term import Data.Text as T (Text, pack) import qualified Data.Text.Encoding as T @@ -257,8 +257,8 @@ type ListableSyntax = Sum , [] ] -instance Listable FV.Name where - tiers = cons1 FV.name +instance Listable Name.Name where + tiers = cons1 Name.name instance Listable1 Gram where liftTiers tiers = liftCons2 (liftTiers (liftTiers tiers)) (liftTiers (liftTiers tiers)) Gram From 75d83155ec2471c70fed5f5051e1c55a5a8ad744 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:06:35 -0400 Subject: [PATCH 036/174] Re-export the Name module. --- test/SpecHelpers.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 5894ca97b..498a5c25c 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -23,6 +23,7 @@ import Data.Abstract.Evaluatable import Data.Abstract.FreeVariables as X hiding (dropExtension) import Data.Abstract.Heap as X import Data.Abstract.ModuleTable as X hiding (lookup) +import Data.Abstract.Name as X import Data.Abstract.Value (Namespace(..), Value, ValueError, injValue, prjValue, runValueError) import Data.Bifunctor (first) import Data.Blob as X From 2ba726cb28db8986f386769c513c5e2712b636e8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:06:49 -0400 Subject: [PATCH 037/174] Fix a dodgy import. --- test/SpecHelpers.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 498a5c25c..7cbe629de 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -20,7 +20,7 @@ import Control.Monad ((>=>)) import Data.Abstract.Address as X import Data.Abstract.Environment as Env import Data.Abstract.Evaluatable -import Data.Abstract.FreeVariables as X hiding (dropExtension) +import Data.Abstract.FreeVariables as X import Data.Abstract.Heap as X import Data.Abstract.ModuleTable as X hiding (lookup) import Data.Abstract.Name as X From 109dbd3b442019aa75d5ddde03615718b4e755b8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:07:37 -0400 Subject: [PATCH 038/174] Fix the typescript spec. --- test/Analysis/TypeScript/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 73a0afd71..13d26e47b 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -32,7 +32,7 @@ spec = parallel $ do it "fails exporting symbols not defined in the module" $ do ((res, _), _) <- evaluate "bad-export.ts" - res `shouldBe` Left (SomeExc (injectSum @(EvalError (Value Precise)) (ExportError "foo.ts" (Name "pip")))) + res `shouldBe` Left (SomeExc (injectSum @EvalError (ExportError "foo.ts" (name "pip")))) it "evaluates early return statements" $ do ((res, _), _) <- evaluate "early-return.ts" From 0baa19de2d8715a0360653d63db4d23492d50326 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:10:04 -0400 Subject: [PATCH 039/174] Add integer names. --- src/Data/Abstract/Name.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index cc87884d3..44001b34b 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Abstract.Name ( Name , name @@ -10,17 +9,23 @@ import Data.String import Prologue -- | The type of variable names. -newtype Name = Name ByteString - deriving (Eq, Hashable, Ord) +data Name + = Name ByteString + | I Int + deriving (Eq, Ord) name :: ByteString -> Name name = Name unName :: Name -> ByteString unName (Name name) = name +unName (I i) = BC.pack (show i) instance IsString Name where fromString = Name . BC.pack instance Show Name where showsPrec d = showsPrec d . unName + +instance Hashable Name where + hashWithSalt = hashUsing unName From 11fa7e318b8809364ed08630808729413bf27aa1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:11:31 -0400 Subject: [PATCH 040/174] Better distribution of hashes for integer names. --- src/Data/Abstract/Name.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index 44001b34b..deba9a476 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -28,4 +28,5 @@ instance Show Name where showsPrec d = showsPrec d . unName instance Hashable Name where - hashWithSalt = hashUsing unName + hashWithSalt salt (Name name) = hashWithSalt salt name + hashWithSalt salt (I i) = salt `hashWithSalt` (1 :: Int) `hashWithSalt` i From f9c21b9448dd8b5096abb019ae5741eb1be5b700 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:13:59 -0400 Subject: [PATCH 041/174] Add a constructor for integral names. --- src/Data/Abstract/Name.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index deba9a476..a83739e25 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -1,6 +1,7 @@ module Data.Abstract.Name ( Name , name +, nameI , unName ) where @@ -17,6 +18,9 @@ data Name name :: ByteString -> Name name = Name +nameI :: Int -> Name +nameI = I + unName :: Name -> ByteString unName (Name name) = name unName (I i) = BC.pack (show i) From bd564a92ceb1fa04d20ce23cb6a209de954741a1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:15:45 -0400 Subject: [PATCH 042/174] :memo: name. --- src/Data/Abstract/Name.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index a83739e25..21c48e35c 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -15,6 +15,7 @@ data Name | I Int deriving (Eq, Ord) +-- | Construct a 'Name' from a 'ByteString'. name :: ByteString -> Name name = Name From 2e0ee8b935c24d4074d37e79b3c61142ee04d0af Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:15:50 -0400 Subject: [PATCH 043/174] :memo: nameI. --- src/Data/Abstract/Name.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index 21c48e35c..41a0fd1bf 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -19,6 +19,7 @@ data Name name :: ByteString -> Name name = Name +-- | Construct a 'Name' from an 'Int'. This is suitable for automatic generation, e.g. using a Fresh effect, but should not be used for human-generated names. nameI :: Int -> Name nameI = I From f49ba195cf1cb5d8f4f06f2d7f9debe60d674ca1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:16:16 -0400 Subject: [PATCH 044/174] :memo: unName. --- src/Data/Abstract/Name.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index 41a0fd1bf..352284bf9 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -23,6 +23,7 @@ name = Name nameI :: Int -> Name nameI = I +-- | Extract a human-readable 'ByteString' from a 'Name'. unName :: Name -> ByteString unName (Name name) = name unName (I i) = BC.pack (show i) From 40b1d2030b7162edc91db06e13510d0898f5f9fb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:19:24 -0400 Subject: [PATCH 045/174] Prettier output for machine-generated names. --- src/Data/Abstract/Name.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index 352284bf9..9fb330301 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -26,7 +26,9 @@ nameI = I -- | Extract a human-readable 'ByteString' from a 'Name'. unName :: Name -> ByteString unName (Name name) = name -unName (I i) = BC.pack (show i) +unName (I i) = BC.pack $ '_' : (alphabet !! a) : replicate n 'ʹ' + where alphabet = ['a'..'z'] + (n, a) = i `divMod` length alphabet instance IsString Name where fromString = Name . BC.pack From c45802a809dda561dc9a9930caf11c25cb9a137a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:20:56 -0400 Subject: [PATCH 046/174] Reformat defaultFiles. --- test/Doctests.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/test/Doctests.hs b/test/Doctests.hs index 9108b2ab0..27b6055db 100644 --- a/test/Doctests.hs +++ b/test/Doctests.hs @@ -5,7 +5,11 @@ module Main import System.Environment import Test.DocTest -defaultFiles = ["src/Data/Abstract/Environment.hs", "src/Data/Range.hs", "src/Data/Semigroup/App.hs"] +defaultFiles = + [ "src/Data/Abstract/Environment.hs" + , "src/Data/Range.hs" + , "src/Data/Semigroup/App.hs" + ] main :: IO () main = do From 6d77a7dc58d887e2815700bff8f89532eef96a65 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:56:07 -0400 Subject: [PATCH 047/174] Encode the name as utf8. --- src/Data/Abstract/Name.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index 9fb330301..7d50338b0 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -6,6 +6,8 @@ module Data.Abstract.Name ) where import qualified Data.ByteString.Char8 as BC +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Data.String import Prologue @@ -26,7 +28,7 @@ nameI = I -- | Extract a human-readable 'ByteString' from a 'Name'. unName :: Name -> ByteString unName (Name name) = name -unName (I i) = BC.pack $ '_' : (alphabet !! a) : replicate n 'ʹ' +unName (I i) = Text.encodeUtf8 . Text.pack $ '_' : (alphabet !! a) : replicate n 'ʹ' where alphabet = ['a'..'z'] (n, a) = i `divMod` length alphabet From 6bd5ab77bb87dd1e1ff730d87b4382e0a273b966 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 13:56:55 -0400 Subject: [PATCH 048/174] Show printable utf8 characters in names. --- src/Data/Abstract/Name.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index 7d50338b0..0eb6b926b 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -6,6 +6,7 @@ module Data.Abstract.Name ) where import qualified Data.ByteString.Char8 as BC +import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.String @@ -36,7 +37,11 @@ instance IsString Name where fromString = Name . BC.pack instance Show Name where - showsPrec d = showsPrec d . unName + showsPrec _ = prettyShowString . Text.unpack . Text.decodeUtf8 . unName + where prettyShowString str = showChar '"' . foldr ((.) . prettyChar) id str . showChar '"' + prettyChar c + | Char.isPrint c = showChar c + | otherwise = Char.showLitChar c instance Hashable Name where hashWithSalt salt (Name name) = hashWithSalt salt name From 5504b0b673c818afe70b493fa5cdb7ae8472a478 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 14:03:42 -0400 Subject: [PATCH 049/174] Add doctests for the Show output. --- src/Data/Abstract/Name.hs | 6 ++++++ test/Doctests.hs | 1 + 2 files changed, 7 insertions(+) diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index 0eb6b926b..399211268 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -1,5 +1,6 @@ module Data.Abstract.Name ( Name +-- * Constructors , name , nameI , unName @@ -36,6 +37,11 @@ unName (I i) = Text.encodeUtf8 . Text.pack $ '_' : (alphabet !! a) : repli instance IsString Name where fromString = Name . BC.pack +-- $ +-- >>> I 0 +-- "_a" +-- >>> I 26 +-- "_aʹ" instance Show Name where showsPrec _ = prettyShowString . Text.unpack . Text.decodeUtf8 . unName where prettyShowString str = showChar '"' . foldr ((.) . prettyChar) id str . showChar '"' diff --git a/test/Doctests.hs b/test/Doctests.hs index 27b6055db..965f0bbe9 100644 --- a/test/Doctests.hs +++ b/test/Doctests.hs @@ -7,6 +7,7 @@ import Test.DocTest defaultFiles = [ "src/Data/Abstract/Environment.hs" + , "src/Data/Abstract/Name.hs" , "src/Data/Range.hs" , "src/Data/Semigroup/App.hs" ] From 49fe7b5c1b6f14a5fd796bbba339c8cc79faab75 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 14:04:50 -0400 Subject: [PATCH 050/174] Escape quotes and backslashes. --- src/Data/Abstract/Name.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index 399211268..46bf635ee 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -46,8 +46,9 @@ instance Show Name where showsPrec _ = prettyShowString . Text.unpack . Text.decodeUtf8 . unName where prettyShowString str = showChar '"' . foldr ((.) . prettyChar) id str . showChar '"' prettyChar c - | Char.isPrint c = showChar c - | otherwise = Char.showLitChar c + | c `elem` ['\\', '\"'] = Char.showLitChar c + | Char.isPrint c = showChar c + | otherwise = Char.showLitChar c instance Hashable Name where hashWithSalt salt (Name name) = hashWithSalt salt name From 9d20a0a0710b3012210b4417bd95cd319cfbeac8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 14:07:02 -0400 Subject: [PATCH 051/174] Define a helper to build lambdas. --- src/Control/Abstract/Primitive.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 1b98b17ec..d39198764 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -33,6 +33,14 @@ builtin n def = withCurrentCallStack callStack $ do modifyEnv (insert name' addr) def >>= assign addr +lambda :: (AbstractValue location value effects, Member Fresh effects) + => Set Name + -> (Name -> Evaluator location value effects value) + -> Evaluator location value effects value +lambda fvs body = do + var <- nameI <$> fresh + closure [var] fvs (body var) + defineBuiltins :: ( AbstractValue location value effects , HasCallStack , Members '[ Allocator location value From c21326dfc1455684baaf1f86e9b79649cd27a4c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 14:08:41 -0400 Subject: [PATCH 052/174] Use the lambda helper to construct the print builtin. --- src/Control/Abstract/Primitive.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index d39198764..1b7a483f7 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -44,6 +44,7 @@ lambda fvs body = do defineBuiltins :: ( AbstractValue location value effects , HasCallStack , Members '[ Allocator location value + , Fresh , Reader (Environment location value) , Reader ModuleInfo , Reader Span @@ -57,4 +58,4 @@ defineBuiltins :: ( AbstractValue location value effects ) => Evaluator location value effects () defineBuiltins = - builtin "print" (closure ["s"] lowerBound (variable "s" >>= asString >>= trace . unpack >> unit)) + builtin "print" (lambda lowerBound (\ v -> variable v >>= asString >>= trace . unpack >> unit)) From 88c205e261d0a15dfb9e0a245a0fd1d5b37d42e6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 14:59:24 -0400 Subject: [PATCH 053/174] Move closure/call into an AbstractFunction class. --- src/Control/Abstract/Primitive.hs | 2 +- src/Control/Abstract/Value.hs | 21 ++++++----- src/Data/Abstract/Type.hs | 49 ++++++++++++++++--------- src/Data/Abstract/Value.hs | 59 ++++++++++++++++++++----------- 4 files changed, 83 insertions(+), 48 deletions(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 1b7a483f7..0d0909f22 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -33,7 +33,7 @@ builtin n def = withCurrentCallStack callStack $ do modifyEnv (insert name' addr) def >>= assign addr -lambda :: (AbstractValue location value effects, Member Fresh effects) +lambda :: (AbstractFunction location value effects, Member Fresh effects) => Set Name -> (Name -> Evaluator location value effects value) -> Evaluator location value effects value diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 71f562e3a..b4bfa9aeb 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,6 +1,7 @@ {-# LANGUAGE Rank2Types #-} module Control.Abstract.Value ( AbstractValue(..) +, AbstractFunction(..) , AbstractHole(..) , Comparator(..) , asBool @@ -43,10 +44,20 @@ data Comparator class AbstractHole value where hole :: value +class Show value => AbstractFunction location value effects where + -- | Build a closure (a binder like a lambda or method definition). + closure :: [Name] -- ^ The parameter names. + -> Set Name -- ^ The set of free variables to close over. + -> Evaluator location value effects value -- ^ The evaluator for the body of the closure. + -> Evaluator location value effects value + -- | Evaluate an application (like a function call). + call :: value -> [Evaluator location value effects value] -> Evaluator location value effects value + + -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class Show value => AbstractValue location value effects where +class AbstractFunction location value effects => AbstractValue location value effects where -- | Construct an abstract unit value. -- TODO: This might be the same as the empty tuple for some value types unit :: Evaluator location value effects value @@ -137,14 +148,6 @@ class Show value => AbstractValue location value effects where -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc). scopedEnvironment :: value -> Evaluator location value effects (Maybe (Environment location value)) - -- | Build a closure (a binder like a lambda or method definition). - closure :: [Name] -- ^ The parameter names. - -> Set Name -- ^ The set of free variables to close over. - -> Evaluator location value effects value -- ^ The evaluator for the body of the closure. - -> Evaluator location value effects value - -- | Evaluate an application (like a function call). - call :: value -> [Evaluator location value effects value] -> Evaluator location value effects value - -- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion. -- -- The function argument takes an action which recurs through the loop. diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 03b99c219..7a8ad72a5 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -101,6 +101,38 @@ instance Ord location => ValueRoots location Type where instance AbstractHole Type where hole = Hole +instance ( Members '[ Allocator location Type + , Fresh + , NonDet + , Reader (Environment location Type) + , Resumable (AddressError location Type) + , Resumable TypeError + , Return Type + , State (Environment location Type) + , State (Heap location (Cell location) Type) + ] effects + , Ord location + , Reducer Type (Cell location Type) + ) + => AbstractFunction location Type effects where + closure names _ body = do + (env, tvars) <- foldr (\ name rest -> do + a <- 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) + + call op params = do + tvar <- fresh + paramTypes <- sequenceA params + let needed = zeroOrMoreProduct paramTypes :-> Var tvar + unified <- op `unify` needed + case unified of + _ :-> ret -> pure ret + gotten -> throwResumable (UnificationError needed gotten) + + -- | Discard the value arguments (if any), constructing a 'Type' instead. instance ( Members '[ Allocator location Type , Fresh @@ -116,14 +148,6 @@ instance ( Members '[ Allocator location Type , Reducer Type (Cell location Type) ) => AbstractValue location Type effects where - closure names _ body = do - (env, tvars) <- foldr (\ name rest -> do - a <- 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) - unit = pure Unit integer _ = pure Int boolean _ = pure Bool @@ -176,13 +200,4 @@ instance ( Members '[ Allocator location Type (Int, Float) -> pure Int _ -> unify left right $> Bool - call op params = do - tvar <- fresh - paramTypes <- sequenceA params - let needed = zeroOrMoreProduct paramTypes :-> Var tvar - unified <- op `unify` needed - case unified of - _ :-> ret -> pure ret - gotten -> throwResumable (UnificationError needed gotten) - loop f = f empty diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 194050edc..e51f6b39a 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -204,6 +204,44 @@ instance Ord location => ValueRoots location (Value location) where instance AbstractHole (Value location) where hole = injValue Hole +instance ( Members '[ Allocator location (Value location) + , Fail + , LoopControl (Value location) + , Reader (Environment location (Value location)) + , Reader ModuleInfo + , Reader PackageInfo + , Resumable (ValueError location) + , Return (Value location) + , State (Environment location (Value location)) + , State (Heap location (Cell location) (Value location)) + ] effects + , Ord location + , Reducer (Value location) (Cell location (Value location)) + , Show location + ) + => AbstractFunction location (Value location) (Goto effects (Value location) ': effects) where + closure parameters freeVariables body = do + packageInfo <- currentPackage + moduleInfo <- currentModule + l <- label body + injValue . Closure packageInfo moduleInfo parameters l . Env.bind (foldr Set.delete freeVariables parameters) <$> getEnv + + call op params = do + case prjValue op of + Just (Closure packageInfo moduleInfo names label env) -> do + body <- goto label + -- Evaluate the bindings and body with the closure’s package/module info in scope in order to + -- 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) (body `catchReturn` \ (Return value) -> pure value) + Nothing -> throwValueError (CallError op) + + -- | Construct a 'Value' wrapping the value arguments (if any). instance ( Members '[ Allocator location (Value location) , Fail @@ -338,27 +376,6 @@ instance ( Members '[ Allocator location (Value location) | otherwise = throwValueError (Bitwise2Error left right) where pair = (left, right) - closure parameters freeVariables body = do - packageInfo <- currentPackage - moduleInfo <- currentModule - l <- label body - injValue . Closure packageInfo moduleInfo parameters l . Env.bind (foldr Set.delete freeVariables parameters) <$> getEnv - - call op params = do - case prjValue op of - Just (Closure packageInfo moduleInfo names label env) -> do - body <- goto label - -- Evaluate the bindings and body with the closure’s package/module info in scope in order to - -- 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) (body `catchReturn` \ (Return value) -> pure value) - Nothing -> throwValueError (CallError op) - loop x = catchLoopControl (fix x) (\ control -> case control of Break value -> pure value -- FIXME: Figure out how to deal with this. Ruby treats this as the result of the current block iteration, while PHP specifies a breakout level and TypeScript appears to take a label. From 29aef25e44137b5d71b616a25989d2c014ebc326 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 15:00:14 -0400 Subject: [PATCH 054/174] :fire: obsolete dependencies on AddressError. --- src/Data/Abstract/Type.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 7a8ad72a5..f4ad9cb1e 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -105,7 +105,6 @@ instance ( Members '[ Allocator location Type , Fresh , NonDet , Reader (Environment location Type) - , Resumable (AddressError location Type) , Resumable TypeError , Return Type , State (Environment location Type) @@ -138,7 +137,6 @@ instance ( Members '[ Allocator location Type , Fresh , NonDet , Reader (Environment location Type) - , Resumable (AddressError location Type) , Resumable TypeError , Return Type , State (Environment location Type) From 7986c22415e21957b098d8dec96bb1bd0a6617d1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 15:01:13 -0400 Subject: [PATCH 055/174] :fire: obsolete dependencies on Fail. --- src/Data/Abstract/Value.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index e51f6b39a..6302aa178 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -205,7 +205,6 @@ instance AbstractHole (Value location) where hole = injValue Hole instance ( Members '[ Allocator location (Value location) - , Fail , LoopControl (Value location) , Reader (Environment location (Value location)) , Reader ModuleInfo @@ -244,7 +243,6 @@ instance ( Members '[ Allocator location (Value location) -- | Construct a 'Value' wrapping the value arguments (if any). instance ( Members '[ Allocator location (Value location) - , Fail , LoopControl (Value location) , Reader (Environment location (Value location)) , Reader ModuleInfo From d9b7dbb6a0829eca498496638e4c59691a506824 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 18 May 2018 15:01:49 -0400 Subject: [PATCH 056/174] =?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/Control/Abstract/Evaluator.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 238ec21fe..f8c623573 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -15,7 +15,6 @@ module Control.Abstract.Evaluator ) where 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 2485e8bcd56e58934ace89d9df3778a318cb8da3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 22 May 2018 08:45:50 -0400 Subject: [PATCH 057/174] :fire: a redundant constraint. --- src/Data/Abstract/Value.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 6302aa178..bd73a21b9 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -205,7 +205,6 @@ instance AbstractHole (Value location) where hole = injValue Hole instance ( Members '[ Allocator location (Value location) - , LoopControl (Value location) , Reader (Environment location (Value location)) , Reader ModuleInfo , Reader PackageInfo From 340904d3a9afb688710c78bbfc34cf2181e207a0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 22 May 2018 17:21:11 -0400 Subject: [PATCH 058/174] Experimental encoding of functions/calls as an effect. --- src/Control/Abstract/Value.hs | 78 ++++++++++++++++++++++++++++++++++- 1 file changed, 77 insertions(+), 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index b4bfa9aeb..e9c1642be 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs, Rank2Types, TypeOperators #-} module Control.Abstract.Value ( AbstractValue(..) , AbstractFunction(..) @@ -16,6 +16,7 @@ module Control.Abstract.Value ) where import Control.Abstract.Addressable +import Control.Abstract.Context import Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Abstract.Heap @@ -25,9 +26,11 @@ import Data.Abstract.Live (Live) import Data.Abstract.Name import Data.Abstract.Number as Number import Data.Abstract.Ref +import qualified Data.Map as Map import Data.Scientific (Scientific) import Data.Semigroup.Reducer hiding (unit) import Data.Semilattice.Lower +import qualified Data.Set as Set import Prelude import Prologue hiding (TypeError) @@ -44,6 +47,79 @@ data Comparator class AbstractHole value where hole :: value + +data Function m value return where + Lambda :: [Name] -> Set Name -> m value -> Function m value value + Call :: value -> [m value] -> Function m value value + + +data Value m location + = Closure [Name] (m (Value m location)) (Map Name location) + +runFunctionValue :: ( Effectful (m location) + , Members '[ Reader (Map Name location) + , Reader ModuleInfo + , Reader PackageInfo + ] effects + , Monad (m location effects) + ) + => (Name -> m location effects location) + -> (location -> Value (m location effects) location -> m location effects ()) + -> m location (Function (m location effects) (Value (m location effects) location) ': effects) a + -> m location effects a +runFunctionValue alloc assign = relay pure $ \ eff yield -> case eff of + Lambda params fvs body -> do + packageInfo <- currentPackage + moduleInfo <- currentModule + env <- Map.filterWithKey (fmap (`Set.member` fvs) . const) <$> ask + let body' = withCurrentPackage packageInfo (withCurrentModule moduleInfo body) + yield (Closure params body' env) + Call (Closure paramNames body env) params -> do + bindings <- foldr (\ (name, param) rest -> do + v <- param + a <- alloc name + assign a v + Map.insert name a <$> rest) (pure env) (zip paramNames params) + local (Map.unionWith const bindings) body >>= yield + + +data Type + = Type :-> Type + | Product [Type] + | Var Int + deriving (Eq, Ord, Show) + +runFunctionType :: ( Alternative (m location effects) + , Effectful (m location) + , Members '[ Fresh + , Reader (Map Name location) + , Reader ModuleInfo + , Reader PackageInfo + ] effects + , Monad (m location effects) + ) + => (Name -> m location effects location) + -> (location -> Type -> m location effects ()) + -> m location (Function (m location effects) Type ': effects) a + -> m location effects a +runFunctionType alloc assign = relay pure $ \ eff yield -> case eff of + Lambda params _ body -> do + (bindings, tvars) <- foldr (\ name rest -> do + a <- alloc name + tvar <- Var <$> fresh + assign a tvar + bimap (Map.insert name a) (tvar :) <$> rest) (pure (Map.empty, [])) params + ret <- local (Map.unionWith const bindings) body + yield (Product tvars :-> ret) + Call fn params -> do + paramTypes <- sequenceA params + case fn of + Product argTypes :-> ret -> do + guard (and (zipWith (==) paramTypes argTypes)) + yield ret + _ -> empty + + class Show value => AbstractFunction location value effects where -- | Build a closure (a binder like a lambda or method definition). closure :: [Name] -- ^ The parameter names. From 47f08b3254254139201c5fb26a0b1759fde4c286 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 22 May 2018 17:25:06 -0400 Subject: [PATCH 059/174] Revert "Environment holds Addresses." This reverts commit a30ebe8c38263e66ea4968c20c6f5eef7884590d. --- src/Data/Abstract/Environment.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 4b14cfa70..3ed222b50 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -35,11 +35,11 @@ import Prologue -- | A LIFO stack of maps of names to addresses, representing a lexically-scoped evaluation environment. -- All behaviors can be assumed to be frontmost-biased: looking up "a" will check the most specific -- scope for "a", then the next, and so on. -newtype Environment location value = Environment { unEnvironment :: NonEmpty (Map.Map Name (Address location value)) } +newtype Environment location value = Environment { unEnvironment :: NonEmpty (Map.Map Name location) } deriving (Eq, Ord) -instance Eq location => Eq1 (Environment location) where liftEq eq (Environment a) (Environment b) = liftEq (liftEq (liftEq eq)) a b -instance Ord location => Ord1 (Environment location) where liftCompare compare (Environment a) (Environment b) = liftCompare (liftCompare (liftCompare compare)) a b +instance Eq location => Eq1 (Environment location) where liftEq _ (Environment a) (Environment b) = a == b +instance Ord location => Ord1 (Environment location) where liftCompare _ (Environment a) (Environment b) = a `compare` b instance Show location => Show1 (Environment location) where liftShowsPrec _ _ = showsPrec mergeEnvs :: Environment location value -> Environment location value -> Environment location value @@ -77,21 +77,21 @@ mergeNewer (Environment a) (Environment b) = -- >>> pairs shadowed -- [("foo",Precise 1)] pairs :: Environment location value -> [(Name, Address location value)] -pairs = Map.toList . fold . unEnvironment +pairs = map (second Address) . Map.toList . fold . unEnvironment unpairs :: [(Name, Address location value)] -> Environment location value -unpairs = Environment . pure . Map.fromList +unpairs = Environment . pure . Map.fromList . map (second unAddress) -- | Lookup a 'Name' in the environment. -- -- >>> lookup (name "foo") shadowed -- Just (Precise 1) lookup :: Name -> Environment location value -> Maybe (Address location value) -lookup k = foldMapA (Map.lookup k) . unEnvironment +lookup k = fmap Address . foldMapA (Map.lookup k) . unEnvironment -- | Insert a 'Name' in the environment. insert :: Name -> Address location value -> Environment location value -> Environment location value -insert name address (Environment (a :| as)) = Environment (Map.insert name address a :| as) +insert name (Address value) (Environment (a :| as)) = Environment (Map.insert name value a :| as) -- | Remove a 'Name' from the environment. -- From ad8876cd773d000dccb90bb6265f2c63522b29ba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 22 May 2018 17:28:10 -0400 Subject: [PATCH 060/174] Simplify toEnvironment. --- src/Data/Abstract/Exports.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/Data/Abstract/Exports.hs b/src/Data/Abstract/Exports.hs index b9db75887..801f420ac 100644 --- a/src/Data/Abstract/Exports.hs +++ b/src/Data/Abstract/Exports.hs @@ -23,10 +23,7 @@ null :: Exports location value -> Bool null = Map.null . unExports toEnvironment :: Exports location value -> Environment location value -toEnvironment exports = unpairs (mapMaybe collectExport (toList (unExports exports))) - where - collectExport (_, Nothing) = Nothing - collectExport (n, Just value) = Just (n, value) +toEnvironment exports = unpairs (mapMaybe sequenceA (toList (unExports exports))) insert :: Name -> Name -> Maybe (Address location value) -> Exports location value -> Exports location value insert name alias address = Exports . Map.insert name (alias, address) . unExports From 2e0a9fb55339c78b26f32e4d690f6fa479d58235 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 22 May 2018 17:29:37 -0400 Subject: [PATCH 061/174] Exports holds locations. --- src/Data/Abstract/Exports.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Exports.hs b/src/Data/Abstract/Exports.hs index 801f420ac..d6dd974a9 100644 --- a/src/Data/Abstract/Exports.hs +++ b/src/Data/Abstract/Exports.hs @@ -16,17 +16,17 @@ import qualified Data.Map as Map import Data.Semilattice.Lower -- | A map of export names to an alias & address tuple. -newtype Exports location value = Exports { unExports :: Map.Map Name (Name, Maybe (Address location value)) } +newtype Exports location value = Exports { unExports :: Map.Map Name (Name, Maybe location) } deriving (Eq, Lower, Monoid, Ord, Semigroup) null :: Exports location value -> Bool null = Map.null . unExports toEnvironment :: Exports location value -> Environment location value -toEnvironment exports = unpairs (mapMaybe sequenceA (toList (unExports exports))) +toEnvironment exports = unpairs (mapMaybe sequenceA (map (second (fmap Address)) (toList (unExports exports)))) insert :: Name -> Name -> Maybe (Address location value) -> Exports location value -> Exports location value -insert name alias address = Exports . Map.insert name (alias, address) . unExports +insert name alias address = Exports . Map.insert name (alias, unAddress <$> address) . unExports -- TODO: Should we filter for duplicates here? aliases :: Exports location value -> [(Name, Name)] From 2a46f5ea6fbcb32651b7b0d77eab8164e146225e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 22 May 2018 17:31:41 -0400 Subject: [PATCH 062/174] =?UTF-8?q?Remove=20Exports=E2=80=99=20value=20par?= =?UTF-8?q?ameter.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/Evaluating.hs | 6 +++--- src/Control/Abstract/Exports.hs | 10 +++++----- src/Data/Abstract/Evaluatable.hs | 6 +++--- src/Data/Abstract/Exports.hs | 12 ++++++------ src/Language/PHP/Syntax.hs | 2 +- src/Language/Python/Syntax.hs | 2 +- src/Language/Ruby/Syntax.hs | 2 +- src/Language/TypeScript/Syntax.hs | 2 +- 8 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index df9b0c101..401dd774d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -12,7 +12,7 @@ data EvaluatingState location value = EvaluatingState { environment :: Environment location value , heap :: Heap location (Cell location) value , modules :: ModuleTable (Maybe (Environment location value, value)) - , exports :: Exports location value + , exports :: Exports location } deriving instance (Eq (Cell location value), Eq location, Eq value) => Eq (EvaluatingState location value) @@ -27,12 +27,12 @@ evaluating :: Evaluator location value ': State (Environment location value) ': State (Heap location (Cell location) value) ': State (ModuleTable (Maybe (Environment location value, value))) - ': State (Exports location value) + ': State (Exports location) ': effects) result -> Evaluator location value effects (Either String result, EvaluatingState location value) evaluating = fmap (\ ((((result, env), heap), modules), exports) -> (result, EvaluatingState env heap modules exports)) - . runState lowerBound -- State (Exports location value) + . runState lowerBound -- State (Exports location) . runState lowerBound -- State (ModuleTable (Maybe (Environment location value, value))) . runState lowerBound -- State (Heap location (Cell location) value) . runState lowerBound -- State (Environment location value) diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs index 46a362444..e31e8d376 100644 --- a/src/Control/Abstract/Exports.hs +++ b/src/Control/Abstract/Exports.hs @@ -13,21 +13,21 @@ import Data.Abstract.Exports import Data.Abstract.Name -- | Get the global export state. -getExports :: Member (State (Exports location value)) effects => Evaluator location value effects (Exports location value) +getExports :: Member (State (Exports location)) effects => Evaluator location value effects (Exports location) getExports = get -- | Set the global export state. -putExports :: Member (State (Exports location value)) effects => Exports location value -> Evaluator location value effects () +putExports :: Member (State (Exports location)) effects => Exports location -> Evaluator location value effects () putExports = put -- | Update the global export state. -modifyExports :: Member (State (Exports location value)) effects => (Exports location value -> Exports location value) -> Evaluator location value effects () +modifyExports :: Member (State (Exports location)) effects => (Exports location -> Exports location) -> Evaluator location value effects () modifyExports = modify' -- | Add an export to the global export state. -addExport :: Member (State (Exports location value)) effects => Name -> Name -> Maybe (Address location value) -> Evaluator location value effects () +addExport :: Member (State (Exports location)) effects => Name -> Name -> Maybe (Address location value) -> Evaluator location 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 location value)) effects => Exports location value -> Evaluator location value effects a -> Evaluator location value effects a +withExports :: Member (State (Exports location)) effects => Exports location -> Evaluator location value effects a -> Evaluator location value effects a withExports = localState . const diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index b3293d539..77c9f42f8 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -68,7 +68,7 @@ type EvaluatableConstraints location term value effects = , Resumable (Unspecialized value) , Return value , State (Environment location value) - , State (Exports location value) + , State (Exports location) , State (Heap location (Cell location) value) , Trace ] effects @@ -89,7 +89,7 @@ evaluatePackageWith :: forall location term value inner inner' outer , Resumable (AddressError location value) , Resumable (LoadError location value) , State (Environment location value) - , State (Exports location value) + , State (Exports location) , State (Heap location (Cell location) value) , State (ModuleTable (Maybe (Environment location value, value))) , Trace @@ -153,7 +153,7 @@ newtype Gotos location value outer = Gotos { getGotos :: GotoTable (LoopControl -- | Isolate the given action with an empty global environment and exports. -isolate :: Members '[State (Environment location value), State (Exports location value)] effects => Evaluator location value effects a -> Evaluator location value effects a +isolate :: Members '[State (Environment location value), State (Exports location)] effects => Evaluator location value effects a -> Evaluator location value effects a isolate = withEnv lowerBound . withExports lowerBound traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator location value effects () diff --git a/src/Data/Abstract/Exports.hs b/src/Data/Abstract/Exports.hs index d6dd974a9..a228eb539 100644 --- a/src/Data/Abstract/Exports.hs +++ b/src/Data/Abstract/Exports.hs @@ -16,22 +16,22 @@ import qualified Data.Map as Map import Data.Semilattice.Lower -- | A map of export names to an alias & address tuple. -newtype Exports location value = Exports { unExports :: Map.Map Name (Name, Maybe location) } +newtype Exports location = Exports { unExports :: Map.Map Name (Name, Maybe location) } deriving (Eq, Lower, Monoid, Ord, Semigroup) -null :: Exports location value -> Bool +null :: Exports location -> Bool null = Map.null . unExports -toEnvironment :: Exports location value -> Environment location value +toEnvironment :: Exports location -> Environment location value toEnvironment exports = unpairs (mapMaybe sequenceA (map (second (fmap Address)) (toList (unExports exports)))) -insert :: Name -> Name -> Maybe (Address location value) -> Exports location value -> Exports location value +insert :: Name -> Name -> Maybe (Address location value) -> Exports location -> Exports location insert name alias address = Exports . Map.insert name (alias, unAddress <$> address) . unExports -- TODO: Should we filter for duplicates here? -aliases :: Exports location value -> [(Name, Name)] +aliases :: Exports location -> [(Name, Name)] aliases = Map.toList . fmap fst . unExports -instance Show location => Show (Exports location value) where +instance Show location => Show (Exports location) where showsPrec d = showsUnaryWith showsPrec "Exports" d . Map.toList . unExports diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 5c68c1d00..9cc923425 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -59,7 +59,7 @@ include :: ( AbstractValue location value effects , Resumable ResolutionError , Resumable (EnvironmentError value) , State (Environment location value) - , State (Exports location value) + , State (Exports location) , State (Heap location (Cell location) value) , Trace ] effects diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index a36cec28d..3be7a397c 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -132,7 +132,7 @@ evalQualifiedImport :: ( AbstractValue location value effects , Modules location value , Reader (Environment location value) , State (Environment location value) - , State (Exports location value) + , State (Exports location) , State (Heap location (Cell location) value) ] effects , Ord location diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 4a5a65aaf..33a72f83a 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -112,7 +112,7 @@ doLoad :: ( AbstractValue location value effects , Members '[ Modules location value , Resumable ResolutionError , State (Environment location value) - , State (Exports location value) + , State (Exports location) , Trace ] effects ) diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 687d92327..21f5acd6b 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -137,7 +137,7 @@ evalRequire :: ( AbstractValue location value effects , Modules location value , Reader (Environment location value) , State (Environment location value) - , State (Exports location value) + , State (Exports location) , State (Heap location (Cell location) value) , Trace ] effects From 12cec06dfe3fb8df8c4b6ff98ab75e191eb58009 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 22 May 2018 17:37:35 -0400 Subject: [PATCH 063/174] =?UTF-8?q?Remove=20Environment=E2=80=99s=20value?= =?UTF-8?q?=20parameter.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/Caching.hs | 6 ++-- src/Analysis/Abstract/Evaluating.hs | 16 +++++----- src/Analysis/Abstract/Graph.hs | 8 ++--- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Configuration.hs | 2 +- src/Control/Abstract/Environment.hs | 20 ++++++------ src/Control/Abstract/Heap.hs | 16 +++++----- src/Control/Abstract/Modules.hs | 24 +++++++-------- src/Control/Abstract/Primitive.hs | 8 ++--- src/Control/Abstract/Value.hs | 26 ++++++++-------- src/Data/Abstract/Configuration.hs | 8 ++--- src/Data/Abstract/Environment.hs | 44 ++++++++++++--------------- src/Data/Abstract/Evaluatable.hs | 12 ++++---- src/Data/Abstract/Exports.hs | 2 +- src/Data/Abstract/Type.hs | 8 ++--- src/Data/Abstract/Value.hs | 16 +++++----- src/Language/PHP/Syntax.hs | 6 ++-- src/Language/Python/Syntax.hs | 4 +-- src/Language/Ruby/Syntax.hs | 4 +-- src/Language/TypeScript/Syntax.hs | 4 +-- src/Semantic/Graph.hs | 2 +- 21 files changed, 117 insertions(+), 121 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index a99cd1320..8001ec6e1 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -63,7 +63,7 @@ cachingTerms :: ( Cacheable term location (Cell location) value , Reader (Cache term location (Cell location) value) , Reader (Live location value) , State (Cache term location (Cell location) value) - , State (Environment location value) + , State (Environment location) , State (Heap location (Cell location) value) ] effects ) @@ -84,12 +84,12 @@ convergingModules :: ( AbstractValue location value effects , Fresh , NonDet , Reader (Cache term location (Cell location) value) - , Reader (Environment location value) + , Reader (Environment location) , Reader (Live location value) , Resumable (AddressError location value) , Resumable (EnvironmentError value) , State (Cache term location (Cell location) value) - , State (Environment location value) + , State (Environment location) , State (Heap location (Cell location) value) ] effects ) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 401dd774d..3cc429c3d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -9,9 +9,9 @@ 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 location value = EvaluatingState - { environment :: Environment location value + { environment :: Environment location , heap :: Heap location (Cell location) value - , modules :: ModuleTable (Maybe (Environment location value, value)) + , modules :: ModuleTable (Maybe (Environment location, value)) , exports :: Exports location } @@ -23,19 +23,19 @@ deriving instance (Show (Cell location value), Show location, Show value) => Sho evaluating :: Evaluator location value ( Fail ': Fresh - ': Reader (Environment location value) - ': State (Environment location value) + ': Reader (Environment location) + ': State (Environment location) ': State (Heap location (Cell location) value) - ': State (ModuleTable (Maybe (Environment location value, value))) + ': State (ModuleTable (Maybe (Environment location, value))) ': State (Exports location) ': effects) result -> Evaluator location value effects (Either String result, EvaluatingState location value) evaluating = fmap (\ ((((result, env), heap), modules), exports) -> (result, EvaluatingState env heap modules exports)) . runState lowerBound -- State (Exports location) - . runState lowerBound -- State (ModuleTable (Maybe (Environment location value, value))) + . runState lowerBound -- State (ModuleTable (Maybe (Environment location, value))) . runState lowerBound -- State (Heap location (Cell location) value) - . runState lowerBound -- State (Environment location value) - . runReader lowerBound -- Reader (Environment location value) + . runState lowerBound -- State (Environment location) + . runReader lowerBound -- Reader (Environment location) . runFresh 0 . runFail diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index c60d82c03..b5b4218c3 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -53,10 +53,10 @@ style = (defaultStyle (byteString . vertexName)) -- | Add vertices to the graph for evaluated identifiers. graphingTerms :: ( Element Syntax.Identifier syntax - , Members '[ Reader (Environment (Located location) value) + , Members '[ Reader (Environment (Located location)) , Reader ModuleInfo , Reader PackageInfo - , State (Environment (Located location) value) + , State (Environment (Located location)) , State (Graph Vertex) ] effects , term ~ Term (Sum syntax) ann @@ -127,8 +127,8 @@ moduleInclusion v = do appendGraph (moduleGraph m `connect` vertex v) -- | Add an edge from the passed variable name to the module it originated within. -variableDefinition :: ( Member (Reader (Environment (Located location) value)) effects - , Member (State (Environment (Located location) value)) effects +variableDefinition :: ( Member (Reader (Environment (Located location))) effects + , Member (State (Environment (Located location))) effects , Member (State (Graph Vertex)) effects ) => Name diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 93c07af27..79a878819 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 , Members '[ Reader (Live location value) - , State (Environment location value) + , State (Environment location) , State (Heap location (Cell location) value) , Writer (trace (Configuration term location (Cell location) value)) ] effects diff --git a/src/Control/Abstract/Configuration.hs b/src/Control/Abstract/Configuration.hs index 68cd128af..37a97033a 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 :: Members '[Reader (Live location value), State (Environment location value), State (Heap location (Cell location) value)] effects => term -> TermEvaluator term location value effects (Configuration term location (Cell location) value) +getConfiguration :: Members '[Reader (Live location value), State (Environment location), 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/Environment.hs b/src/Control/Abstract/Environment.hs index f330b0e44..08cb9b4db 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -24,49 +24,49 @@ import Data.Abstract.Name import Prologue -- | Retrieve the environment. -getEnv :: Member (State (Environment location value)) effects => Evaluator location value effects (Environment location value) +getEnv :: Member (State (Environment location)) effects => Evaluator location value effects (Environment location) getEnv = get -- | Set the environment. -putEnv :: Member (State (Environment location value)) effects => Environment location value -> Evaluator location value effects () +putEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value effects () putEnv = put -- | Update the global environment. -modifyEnv :: Member (State (Environment location value)) effects => (Environment location value -> Environment location value) -> Evaluator location value effects () +modifyEnv :: Member (State (Environment location)) effects => (Environment location -> Environment location) -> Evaluator location value effects () modifyEnv = modify' -- | Sets the environment for the lifetime of the given action. -withEnv :: Member (State (Environment location value)) effects => Environment location value -> Evaluator location value effects a -> Evaluator location value effects a +withEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value effects a -> Evaluator location value effects a withEnv = localState . const -- | Retrieve the default environment. -defaultEnvironment :: Member (Reader (Environment location value)) effects => Evaluator location value effects (Environment location value) +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 value)) effects => Environment location value -> Evaluator location value effects a -> Evaluator location value effects a +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 :: Members '[Reader (Environment location value), State (Environment location value)] effects => Evaluator location value effects (Environment location value) +fullEnvironment :: Members '[Reader (Environment location), 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 value)) effects => (Environment location value -> Environment location value) -> Evaluator location value effects a -> Evaluator location value effects a +localEnv :: Member (State (Environment location)) effects => (Environment location -> Environment location) -> Evaluator location value effects a -> Evaluator location value effects a localEnv f a = do modifyEnv (f . Env.push) result <- a result <$ modifyEnv Env.pop -- | Run a computation in a new local environment. -localize :: Member (State (Environment location value)) effects => Evaluator location value effects a -> Evaluator location value effects a +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 :: Members '[Reader (Environment location value), State (Environment location value)] effects => Name -> Evaluator location value effects (Maybe (Address location value)) +lookupEnv :: Members '[Reader (Environment location), State (Environment location)] effects => Name -> Evaluator location value effects (Maybe (Address location value)) lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 6e1905ccb..846b533c1 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -63,8 +63,8 @@ assign address = modifyHeap . heapInsert address -- | Look up or allocate an address for a 'Name'. lookupOrAlloc :: Members '[ Allocator location value - , Reader (Environment location value) - , State (Environment location value) + , Reader (Environment location) + , State (Environment location) ] effects => Name -> Evaluator location value effects (Address location value) @@ -72,8 +72,8 @@ lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure letrec :: ( Members '[ Allocator location value - , Reader (Environment location value) - , State (Environment location value) + , Reader (Environment location) + , State (Environment location) , State (Heap location (Cell location) value) ] effects , Ord location @@ -90,8 +90,8 @@ letrec name body = do -- Lookup/alloc a name passing the address to a body evaluated in a new local environment. letrec' :: Members '[ Allocator location value - , Reader (Environment location value) - , State (Environment location value) + , Reader (Environment location) + , State (Environment location) ] effects => Name -> (Address location value -> Evaluator location value effects value) @@ -104,9 +104,9 @@ letrec' name body = do -- | Look up and dereference the given 'Name', throwing an exception for free variables. variable :: Members '[ Allocator location value - , Reader (Environment location value) + , Reader (Environment location) , Resumable (EnvironmentError value) - , State (Environment location value) + , State (Environment location) , State (Heap location (Cell location) value) ] effects => Name diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index 7f83e05ba..89a9c9e88 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -26,7 +26,7 @@ import Data.Language 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 location value) effects => ModulePath -> Evaluator location value effects (Maybe (Maybe (Environment location value, value))) +lookupModule :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Maybe (Environment location, value))) lookupModule = send . Lookup -- | Resolve a list of module paths to a possible module table entry. @@ -40,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 location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location value, value)) +require :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, value)) require path = lookupModule path >>= maybeM (load path) -- | Load another module by name and return its environment and value. -- -- Always loads/evaluates. -load :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location value, value)) +load :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, value)) load = send . Load data Modules location value return where - Load :: ModulePath -> Modules location value (Maybe (Environment location value, value)) - Lookup :: ModulePath -> Modules location value (Maybe (Maybe (Environment location value, value))) + Load :: ModulePath -> Modules location value (Maybe (Environment location, value)) + Lookup :: ModulePath -> Modules location value (Maybe (Maybe (Environment location, value))) Resolve :: [FilePath] -> Modules location value (Maybe ModulePath) List :: FilePath -> Modules location value [ModulePath] @@ -61,10 +61,10 @@ sendModules = send runModules :: forall term location value effects a . Members '[ Resumable (LoadError location value) - , State (ModuleTable (Maybe (Environment location value, value))) + , State (ModuleTable (Maybe (Environment location, value))) , Trace ] effects - => (Module term -> Evaluator location value (Modules location value ': effects) (Environment location value, value)) + => (Module term -> Evaluator location value (Modules location value ': effects) (Environment location, value)) -> Evaluator location value (Modules location value ': effects) a -> Evaluator location value (Reader (ModuleTable [Module term]) ': effects) a runModules evaluateModule = go @@ -89,17 +89,17 @@ runModules evaluateModule = go pure (find isMember names) List dir -> modulePathsInDir dir <$> askModuleTable @term) -getModuleTable :: Member (State (ModuleTable (Maybe (Environment location value, value)))) effects => Evaluator location value effects (ModuleTable (Maybe (Environment location value, value))) +getModuleTable :: Member (State (ModuleTable (Maybe (Environment location, value)))) effects => Evaluator location value effects (ModuleTable (Maybe (Environment location, value))) getModuleTable = get -cacheModule :: Member (State (ModuleTable (Maybe (Environment location value, value)))) effects => ModulePath -> Maybe (Environment location value, value) -> Evaluator location value effects (Maybe (Environment location value, value)) +cacheModule :: Member (State (ModuleTable (Maybe (Environment location, value)))) effects => ModulePath -> Maybe (Environment location, value) -> Evaluator location value effects (Maybe (Environment location, value)) cacheModule path result = modify' (ModuleTable.insert path result) $> result askModuleTable :: Member (Reader (ModuleTable [Module term])) effects => Evaluator location value effects (ModuleTable [Module term]) askModuleTable = ask -newtype Merging m location value = Merging { runMerging :: m (Maybe (Environment location value, value)) } +newtype Merging m location value = Merging { runMerging :: m (Maybe (Environment location, value)) } instance Applicative m => Semigroup (Merging m location value) where Merging a <> Merging b = Merging (merge <$> a <*> b) @@ -113,7 +113,7 @@ instance Applicative m => Monoid (Merging m location 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 location value resume where - ModuleNotFound :: ModulePath -> LoadError location value (Maybe (Environment location value, value)) + ModuleNotFound :: ModulePath -> LoadError location value (Maybe (Environment location, value)) deriving instance Eq (LoadError location value resume) deriving instance Show (LoadError location value resume) @@ -122,7 +122,7 @@ instance Show1 (LoadError location value) where instance Eq1 (LoadError location value) where liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b -moduleNotFound :: Member (Resumable (LoadError location value)) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location value, value)) +moduleNotFound :: Member (Resumable (LoadError location value)) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, value)) moduleNotFound = throwResumable . ModuleNotFound resumeLoadError :: Member (Resumable (LoadError location value)) effects => Evaluator location value effects a -> (forall resume . LoadError location value resume -> Evaluator location value effects resume) -> Evaluator location value effects a diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 0d0909f22..a557018b7 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -15,10 +15,10 @@ import Prologue builtin :: ( HasCallStack , Members '[ Allocator location value - , Reader (Environment location value) + , Reader (Environment location) , Reader ModuleInfo , Reader Span - , State (Environment location value) + , State (Environment location) , State (Heap location (Cell location) value) ] effects , Ord location @@ -45,11 +45,11 @@ defineBuiltins :: ( AbstractValue location value effects , HasCallStack , Members '[ Allocator location value , Fresh - , Reader (Environment location value) + , Reader (Environment location) , Reader ModuleInfo , Reader Span , Resumable (EnvironmentError value) - , State (Environment location value) + , State (Environment location) , State (Heap location (Cell location) value) , Trace ] effects diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index e9c1642be..1b184052e 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -209,20 +209,20 @@ class AbstractFunction location value effects => AbstractValue location value ef index :: value -> value -> Evaluator location value effects value -- | Build a class value from a name and environment. - klass :: Name -- ^ The new class's identifier - -> [value] -- ^ A list of superclasses - -> Environment location value -- ^ The environment to capture + klass :: Name -- ^ The new class's identifier + -> [value] -- ^ A list of superclasses + -> Environment location -- ^ The environment to capture -> Evaluator location value effects value -- | Build a namespace value from a name and environment stack -- -- Namespaces model closures with monoidal environments. - namespace :: Name -- ^ The namespace's identifier - -> Environment location value -- ^ The environment to mappend + namespace :: Name -- ^ The namespace's identifier + -> Environment location -- ^ The environment to mappend -> Evaluator location value effects value -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc). - scopedEnvironment :: value -> Evaluator location value effects (Maybe (Environment location value)) + scopedEnvironment :: value -> Evaluator location value effects (Maybe (Environment location)) -- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion. -- @@ -236,7 +236,7 @@ asBool value = ifthenelse value (pure True) (pure False) -- | C-style for loops. forLoop :: ( AbstractValue location value effects - , Member (State (Environment location value)) effects + , Member (State (Environment location)) effects ) => Evaluator location value effects value -- ^ Initial statement -> Evaluator location value effects value -- ^ Condition @@ -265,7 +265,7 @@ doWhile body cond = loop $ \ continue -> body *> do ifthenelse this continue unit makeNamespace :: ( AbstractValue location value effects - , Member (State (Environment location value)) effects + , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) value)) effects , Ord location , Reducer value (Cell location value) @@ -284,7 +284,7 @@ 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 value)) effects + , Member (State (Environment location)) effects ) => Evaluator location value effects value -> Evaluator location value effects value @@ -297,9 +297,9 @@ evaluateInScopedEnv scopedEnvTerm term = do -- | Evaluates a 'Value' returning the referenced value value :: ( AbstractValue location value effects , Members '[ Allocator location value - , Reader (Environment location value) + , Reader (Environment location) , Resumable (EnvironmentError value) - , State (Environment location value) + , State (Environment location) , State (Heap location (Cell location) value) ] effects ) @@ -312,9 +312,9 @@ value (Rval val) = pure val -- | Evaluates a 'Subterm' to its rval subtermValue :: ( AbstractValue location value effects , Members '[ Allocator location value - , Reader (Environment location value) + , Reader (Environment location) , Resumable (EnvironmentError value) - , State (Environment location value) + , State (Environment location) , State (Heap location (Cell location) value) ] effects ) diff --git a/src/Data/Abstract/Configuration.hs b/src/Data/Abstract/Configuration.hs index 38cfa8632..72913421b 100644 --- a/src/Data/Abstract/Configuration.hs +++ b/src/Data/Abstract/Configuration.hs @@ -6,9 +6,9 @@ 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. - , configurationEnvironment :: Environment location value -- ^ The environment binding any free variables in 'configurationTerm'. - , configurationHeap :: Heap location cell value -- ^ The heap of values. + { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. + , configurationRoots :: Live location value -- ^ 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. } deriving (Eq, Ord, Show) diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 3ed222b50..924df9d4a 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -35,36 +35,32 @@ import Prologue -- | A LIFO stack of maps of names to addresses, representing a lexically-scoped evaluation environment. -- All behaviors can be assumed to be frontmost-biased: looking up "a" will check the most specific -- scope for "a", then the next, and so on. -newtype Environment location value = Environment { unEnvironment :: NonEmpty (Map.Map Name location) } +newtype Environment location = Environment { unEnvironment :: NonEmpty (Map.Map Name location) } deriving (Eq, Ord) -instance Eq location => Eq1 (Environment location) where liftEq _ (Environment a) (Environment b) = a == b -instance Ord location => Ord1 (Environment location) where liftCompare _ (Environment a) (Environment b) = a `compare` b -instance Show location => Show1 (Environment location) where liftShowsPrec _ _ = showsPrec - -mergeEnvs :: Environment location value -> Environment location value -> Environment location value +mergeEnvs :: Environment location -> Environment location -> Environment location mergeEnvs (Environment (a :| as)) (Environment (b :| bs)) = Environment ((<>) a b :| alignWith (mergeThese (<>)) as bs) -emptyEnv :: Environment location value +emptyEnv :: Environment location emptyEnv = Environment (lowerBound :| []) -- | Make and enter a new empty scope in the given environment. -push :: Environment location value -> Environment location value +push :: Environment location -> Environment location push (Environment (a :| as)) = Environment (mempty :| a : as) -- | Remove the frontmost scope. -pop :: Environment location value -> Environment location value +pop :: Environment location -> Environment location pop (Environment (_ :| [])) = emptyEnv pop (Environment (_ :| a : as)) = Environment (a :| as) -- | Drop all scopes save for the frontmost one. -head :: Environment location value -> Environment location value +head :: Environment location -> Environment location head (Environment (a :| _)) = Environment (a :| []) -- | Take the union of two environments. When duplicate keys are found in the -- name to address map, the second definition wins. -mergeNewer :: Environment location value -> Environment location value -> Environment location value +mergeNewer :: Environment location -> Environment location -> Environment location mergeNewer (Environment a) (Environment b) = Environment (NonEmpty.fromList . reverse $ alignWith (mergeThese combine) (reverse as) (reverse bs)) where @@ -76,45 +72,45 @@ mergeNewer (Environment a) (Environment b) = -- -- >>> pairs shadowed -- [("foo",Precise 1)] -pairs :: Environment location value -> [(Name, Address location value)] +pairs :: Environment location -> [(Name, Address location value)] pairs = map (second Address) . Map.toList . fold . unEnvironment -unpairs :: [(Name, Address location value)] -> Environment location value +unpairs :: [(Name, Address location value)] -> Environment location unpairs = Environment . pure . Map.fromList . map (second unAddress) -- | Lookup a 'Name' in the environment. -- -- >>> lookup (name "foo") shadowed -- Just (Precise 1) -lookup :: Name -> Environment location value -> Maybe (Address location value) +lookup :: Name -> Environment location -> Maybe (Address location value) lookup k = fmap Address . foldMapA (Map.lookup k) . unEnvironment -- | Insert a 'Name' in the environment. -insert :: Name -> Address location value -> Environment location value -> Environment location value +insert :: Name -> Address location value -> Environment location -> Environment location insert name (Address value) (Environment (a :| as)) = Environment (Map.insert name value a :| as) -- | Remove a 'Name' from the environment. -- -- >>> delete (name "foo") shadowed -- Environment [] -delete :: Name -> Environment location value -> Environment location value +delete :: Name -> Environment location -> Environment location delete name = trim . Environment . fmap (Map.delete name) . unEnvironment -trim :: Environment location value -> Environment location value +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 value -> Environment location value +bind :: Foldable t => t Name -> Environment location -> Environment location bind names env = unpairs (mapMaybe lookupName (toList names)) where lookupName name = (,) name <$> lookup name env -- | Get all bound 'Name's in an environment. -names :: Environment location value -> [Name] +names :: Environment location -> [Name] names = fmap fst . pairs -- | Lookup and alias name-value bindings from an environment. -overwrite :: [(Name, Name)] -> Environment location value -> Environment location value +overwrite :: [(Name, Name)] -> Environment location -> Environment location overwrite pairs env = unpairs $ mapMaybe lookupAndAlias pairs where lookupAndAlias (oldName, newName) = (,) newName <$> lookup oldName env @@ -122,14 +118,14 @@ 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 value -> t Name -> Live location value +roots :: (Ord location, Foldable t) => Environment location -> t Name -> Live location value roots env = foldMap (maybe mempty liveSingleton . flip lookup env) -addresses :: Ord location => Environment location value -> Live location value +addresses :: Ord location => Environment location -> Live location value addresses = fromAddresses . map snd . pairs -instance Lower (Environment location value) where lowerBound = emptyEnv +instance Lower (Environment location) where lowerBound = emptyEnv -instance Show location => Show (Environment location value) where +instance Show location => Show (Environment location) where showsPrec d = showsUnaryWith showsPrec "Environment" d . pairs diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 77c9f42f8..c24ba25ce 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -58,7 +58,7 @@ type EvaluatableConstraints location term value effects = , Members '[ Allocator location value , LoopControl value , Modules location value - , Reader (Environment location value) + , Reader (Environment location) , Reader ModuleInfo , Reader PackageInfo , Reader Span @@ -67,7 +67,7 @@ type EvaluatableConstraints location term value effects = , Resumable ResolutionError , Resumable (Unspecialized value) , Return value - , State (Environment location value) + , State (Environment location) , State (Exports location) , State (Heap location (Cell location) value) , Trace @@ -85,13 +85,13 @@ evaluatePackageWith :: forall location term value inner inner' outer , EvaluatableConstraints location term value inner , Members '[ Fail , Fresh - , Reader (Environment location value) + , Reader (Environment location) , Resumable (AddressError location value) , Resumable (LoadError location value) - , State (Environment location value) + , State (Environment location) , State (Exports location) , State (Heap location (Cell location) value) - , State (ModuleTable (Maybe (Environment location value, value))) + , State (ModuleTable (Maybe (Environment location, value))) , Trace ] outer , Recursive term @@ -153,7 +153,7 @@ newtype Gotos location value outer = Gotos { getGotos :: GotoTable (LoopControl -- | Isolate the given action with an empty global environment and exports. -isolate :: Members '[State (Environment location value), State (Exports location)] effects => Evaluator location value effects a -> Evaluator location value effects a +isolate :: Members '[State (Environment location), State (Exports location)] effects => Evaluator location value effects a -> Evaluator location value effects a isolate = withEnv lowerBound . withExports lowerBound traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator location value effects () diff --git a/src/Data/Abstract/Exports.hs b/src/Data/Abstract/Exports.hs index a228eb539..12cea0c74 100644 --- a/src/Data/Abstract/Exports.hs +++ b/src/Data/Abstract/Exports.hs @@ -22,7 +22,7 @@ newtype Exports location = Exports { unExports :: Map.Map Name (Name, Maybe loca null :: Exports location -> Bool null = Map.null . unExports -toEnvironment :: Exports location -> Environment location value +toEnvironment :: Exports location -> Environment location toEnvironment exports = unpairs (mapMaybe sequenceA (map (second (fmap Address)) (toList (unExports exports)))) insert :: Name -> Name -> Maybe (Address location value) -> Exports location -> Exports location diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index f4ad9cb1e..5f381f3eb 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -104,10 +104,10 @@ instance AbstractHole Type where instance ( Members '[ Allocator location Type , Fresh , NonDet - , Reader (Environment location Type) + , Reader (Environment location) , Resumable TypeError , Return Type - , State (Environment location Type) + , State (Environment location) , State (Heap location (Cell location) Type) ] effects , Ord location @@ -136,10 +136,10 @@ instance ( Members '[ Allocator location Type instance ( Members '[ Allocator location Type , Fresh , NonDet - , Reader (Environment location Type) + , Reader (Environment location) , Resumable TypeError , Return Type - , State (Environment location Type) + , State (Environment location) , State (Heap location (Cell location) Type) ] effects , Ord location diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index bd73a21b9..43e8c72cc 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -57,7 +57,7 @@ prjPair = bitraverse prjValue prjValue -- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union. -- | A function value consisting of a package & module info, a list of parameter 'Name's, a 'Label' to jump to the body of the function, and an 'Environment' of bindings captured by the body. -data Closure location value = Closure PackageInfo ModuleInfo [Name] Label (Environment location value) +data Closure location value = Closure PackageInfo ModuleInfo [Name] Label (Environment location) deriving (Eq, Generic1, Ord, Show) instance Eq location => Eq1 (Closure location) where liftEq = genericLiftEq @@ -151,7 +151,7 @@ instance Show1 Array where liftShowsPrec = genericLiftShowsPrec -- but for the time being we're pretending all languages have prototypical inheritance. data Class location value = Class { _className :: Name - , _classScope :: Environment location value + , _classScope :: Environment location } deriving (Eq, Generic1, Ord, Show) instance Eq location => Eq1 (Class location) where liftEq = genericLiftEq @@ -160,7 +160,7 @@ instance Show location => Show1 (Class location) where liftShowsPrec = genericLi data Namespace location value = Namespace { namespaceName :: Name - , namespaceScope :: Environment location value + , namespaceScope :: Environment location } deriving (Eq, Generic1, Ord, Show) instance Eq location => Eq1 (Namespace location) where liftEq = genericLiftEq @@ -205,12 +205,12 @@ instance AbstractHole (Value location) where hole = injValue Hole instance ( Members '[ Allocator location (Value location) - , Reader (Environment location (Value location)) + , Reader (Environment location) , Reader ModuleInfo , Reader PackageInfo , Resumable (ValueError location) , Return (Value location) - , State (Environment location (Value location)) + , State (Environment location) , State (Heap location (Cell location) (Value location)) ] effects , Ord location @@ -243,12 +243,12 @@ instance ( Members '[ Allocator location (Value location) -- | Construct a 'Value' wrapping the value arguments (if any). instance ( Members '[ Allocator location (Value location) , LoopControl (Value location) - , Reader (Environment location (Value location)) + , Reader (Environment location) , Reader ModuleInfo , Reader PackageInfo , Resumable (ValueError location) , Return (Value location) - , State (Environment location (Value location)) + , State (Environment location) , State (Heap location (Cell location) (Value location)) ] effects , Ord location @@ -384,7 +384,7 @@ data ValueError location resume where StringError :: Value location -> ValueError location ByteString BoolError :: Value location -> ValueError location Bool IndexError :: Value location -> Value location -> ValueError location (Value location) - NamespaceError :: Prelude.String -> ValueError location (Environment location (Value location)) + NamespaceError :: Prelude.String -> ValueError location (Environment location) CallError :: Value location -> ValueError location (Value location) NumericError :: Value location -> ValueError location (Value location) Numeric2Error :: Value location -> Value location -> ValueError location (Value location) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 9cc923425..29abe803a 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -55,17 +55,17 @@ resolvePHPName n = do include :: ( AbstractValue location value effects , Members '[ Allocator location value , Modules location value - , Reader (Environment location value) + , Reader (Environment location) , Resumable ResolutionError , Resumable (EnvironmentError value) - , State (Environment location value) + , State (Environment location) , State (Exports location) , State (Heap location (Cell location) value) , Trace ] effects ) => Subterm term (Evaluator location value effects (ValueRef value)) - -> (ModulePath -> Evaluator location value effects (Maybe (Environment location value, value))) + -> (ModulePath -> Evaluator location value effects (Maybe (Environment location, value))) -> Evaluator location value effects (ValueRef value) include pathTerm f = do name <- subtermValue pathTerm >>= asString diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 3be7a397c..5358af741 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -130,8 +130,8 @@ instance Evaluatable Import where evalQualifiedImport :: ( AbstractValue location value effects , Members '[ Allocator location value , Modules location value - , Reader (Environment location value) - , State (Environment location value) + , Reader (Environment location) + , State (Environment location) , State (Exports location) , State (Heap location (Cell location) value) ] effects diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 33a72f83a..56e8532ef 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -81,7 +81,7 @@ doRequire :: ( AbstractValue location value effects , Member (Modules location value) effects ) => M.ModulePath - -> Evaluator location value effects (Environment location value, value) + -> Evaluator location value effects (Environment location, value) doRequire path = do result <- join <$> lookupModule path case result of @@ -111,7 +111,7 @@ instance Evaluatable Load where doLoad :: ( AbstractValue location value effects , Members '[ Modules location value , Resumable ResolutionError - , State (Environment location value) + , State (Environment location) , State (Exports location) , Trace ] effects diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 21f5acd6b..a2657e029 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -135,8 +135,8 @@ javascriptExtensions = ["js"] evalRequire :: ( AbstractValue location value effects , Members '[ Allocator location value , Modules location value - , Reader (Environment location value) - , State (Environment location value) + , Reader (Environment location) + , State (Environment location) , State (Exports location) , State (Heap location (Cell location) value) , Trace diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 43b456026..2dae1cfe2 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -127,7 +127,7 @@ resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> s UnallocatedAddress _ -> pure lowerBound UninitializedAddress _ -> pure hole) -resumingValueError :: (Members '[State (Environment location (Value location)), Trace] effects, Show location) => Evaluator location (Value location) (Resumable (ValueError location) ': effects) a -> Evaluator location (Value location) effects a +resumingValueError :: (Members '[State (Environment location), Trace] effects, Show location) => Evaluator location (Value location) (Resumable (ValueError location) ': effects) a -> Evaluator location (Value location) effects a resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of CallError val -> pure val StringError val -> pure (pack (show val)) From a3d4ea114052ef4ea8d73f62adf5b6847978b8ec Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 10:46:31 -0400 Subject: [PATCH 064/174] Bump effects for https://github.com/joshvera/effects/pull/48 --- vendor/effects | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/effects b/vendor/effects index 4b4f2956d..e14257722 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit 4b4f2956d8a4d5542990431a1d0a5735f48f917e +Subproject commit e142577226ae12d286893ae3801644e266c951f1 From 531e9892ba112f4111f877a660af2d1040544749 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 10:47:31 -0400 Subject: [PATCH 065/174] Hide the Delete typeclass. --- src/Data/Syntax/Expression.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 0e668810e..38da1f135 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -6,7 +6,7 @@ import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedF import Data.Fixed import Data.JSON.Fields import Diffing.Algorithm -import Prologue hiding (index) +import Prologue hiding (index, Delete) -- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell. data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a } From c8a64a56936b95787619c46180123ff2847f328a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:04:22 -0400 Subject: [PATCH 066/174] Add a smart constructor for Lambda. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 1b184052e..930126663 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -48,6 +48,9 @@ class AbstractHole value where hole :: value +lambda :: (Effectful m, Member (Function action value) effects) => [Name] -> Set Name -> action value -> m effects value +lambda paramNames fvs body = send (Lambda paramNames fvs body) + data Function m value return where Lambda :: [Name] -> Set Name -> m value -> Function m value value Call :: value -> [m value] -> Function m value value From fa6af66a6577a01b9deb201b14bf1c1e70a3dbfe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:04:49 -0400 Subject: [PATCH 067/174] Handle self-referential effects lists. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 930126663..d9f3a2f36 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, Rank2Types, TypeOperators #-} +{-# LANGUAGE GADTs, Rank2Types, ScopedTypeVariables, TypeOperators #-} module Control.Abstract.Value ( AbstractValue(..) , AbstractFunction(..) @@ -59,31 +59,39 @@ data Function m value return where data Value m location = Closure [Name] (m (Value m location)) (Map Name location) -runFunctionValue :: ( Effectful (m location) - , Members '[ Reader (Map Name location) +runFunctionValue :: forall m location effects a function + . ( Effectful (m location) + , Members '[ function + , Reader (Map Name location) , Reader ModuleInfo , Reader PackageInfo ] effects + , Members '[ Reader (Map Name location) + , Reader ModuleInfo + , Reader PackageInfo + ] (Delete function effects) , Monad (m location effects) + , Monad (m location (Delete function effects)) + , function ~ Function (m location effects) (Value (m location effects) location) ) => (Name -> m location effects location) -> (location -> Value (m location effects) location -> m location effects ()) - -> m location (Function (m location effects) (Value (m location effects) location) ': effects) a -> m location effects a -runFunctionValue alloc assign = relay pure $ \ eff yield -> case eff of + -> m location (Delete function effects) a +runFunctionValue alloc assign = relayAny @function pure $ \ eff yield -> case eff of Lambda params fvs body -> do packageInfo <- currentPackage moduleInfo <- currentModule env <- Map.filterWithKey (fmap (`Set.member` fvs) . const) <$> ask let body' = withCurrentPackage packageInfo (withCurrentModule moduleInfo body) yield (Closure params body' env) - Call (Closure paramNames body env) params -> do + Call (Closure paramNames body env) params -> runFunctionValue alloc assign (do bindings <- foldr (\ (name, param) rest -> do v <- param a <- alloc name assign a v Map.insert name a <$> rest) (pure env) (zip paramNames params) - local (Map.unionWith const bindings) body >>= yield + local (Map.unionWith const bindings) body) >>= yield data Type From 20a4ccf7f552ebc4bf1889b9c3776ef014ccc21a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:14:40 -0400 Subject: [PATCH 068/174] Handle self-referential effects lists for Types. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d9f3a2f36..b0e54f226 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -100,35 +100,39 @@ data Type | Var Int deriving (Eq, Ord, Show) -runFunctionType :: ( Alternative (m location effects) +runFunctionType :: forall m location effects a function + . ( Alternative (m location effects) + , Alternative (m location (Delete function effects)) , Effectful (m location) , Members '[ Fresh + , function , Reader (Map Name location) , Reader ModuleInfo , Reader PackageInfo ] effects , Monad (m location effects) + , Monad (m location (Delete function effects)) + , function ~ Function (m location effects) Type ) => (Name -> m location effects location) -> (location -> Type -> m location effects ()) - -> m location (Function (m location effects) Type ': effects) a -> m location effects a -runFunctionType alloc assign = relay pure $ \ eff yield -> case eff of - Lambda params _ body -> do + -> m location (Delete function effects) a +runFunctionType alloc assign = relayAny @function pure $ \ eff yield -> case eff of + Lambda params _ body -> runFunctionType alloc assign (do (bindings, tvars) <- foldr (\ name rest -> do a <- alloc name tvar <- Var <$> fresh assign a tvar bimap (Map.insert name a) (tvar :) <$> rest) (pure (Map.empty, [])) params - ret <- local (Map.unionWith const bindings) body - yield (Product tvars :-> ret) - Call fn params -> do + (Product tvars :->) <$> local (Map.unionWith const bindings) body) >>= yield + Call fn params -> runFunctionType alloc assign (do paramTypes <- sequenceA params case fn of Product argTypes :-> ret -> do guard (and (zipWith (==) paramTypes argTypes)) - yield ret - _ -> empty + pure ret + _ -> empty) >>= yield class Show value => AbstractFunction location value effects where From 8d2b48aa59fa157a651e97c6381c39eb81f0f3b2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:22:05 -0400 Subject: [PATCH 069/174] Lift handlers into Value. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index b0e54f226..68ff8a10a 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -59,6 +59,9 @@ data Function m value return where data Value m location = Closure [Name] (m (Value m location)) (Map Name location) +liftHandler :: Functor m => (forall a . m a -> m' a) -> Value m location -> Value m' location +liftHandler handler = go where go (Closure names body env) = Closure names (handler (go <$> body)) env + runFunctionValue :: forall m location effects a function . ( Effectful (m location) , Members '[ function From 53e9daad79b43be6762cc066b4375723740bea6c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:24:33 -0400 Subject: [PATCH 070/174] Close over alloc/assign. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 62 +++++++++++++++++++---------------- 1 file changed, 33 insertions(+), 29 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 68ff8a10a..967c29735 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -81,20 +81,22 @@ runFunctionValue :: forall m location effects a function -> (location -> Value (m location effects) location -> m location effects ()) -> m location effects a -> m location (Delete function effects) a -runFunctionValue alloc assign = relayAny @function pure $ \ eff yield -> case eff of - Lambda params fvs body -> do - packageInfo <- currentPackage - moduleInfo <- currentModule - env <- Map.filterWithKey (fmap (`Set.member` fvs) . const) <$> ask - let body' = withCurrentPackage packageInfo (withCurrentModule moduleInfo body) - yield (Closure params body' env) - Call (Closure paramNames body env) params -> runFunctionValue alloc assign (do - bindings <- foldr (\ (name, param) rest -> do - v <- param - a <- alloc name - assign a v - Map.insert name a <$> rest) (pure env) (zip paramNames params) - local (Map.unionWith const bindings) body) >>= yield +runFunctionValue alloc assign = go + where go :: forall a . m location effects a -> m location (Delete function effects) a + go = relayAny @function pure $ \ eff yield -> case eff of + Lambda params fvs body -> do + packageInfo <- currentPackage + moduleInfo <- currentModule + env <- Map.filterWithKey (fmap (`Set.member` fvs) . const) <$> ask + let body' = withCurrentPackage packageInfo (withCurrentModule moduleInfo body) + yield (Closure params body' env) + Call (Closure paramNames body env) params -> go (do + bindings <- foldr (\ (name, param) rest -> do + v <- param + a <- alloc name + assign a v + Map.insert name a <$> rest) (pure env) (zip paramNames params) + local (Map.unionWith const bindings) body) >>= yield data Type @@ -121,21 +123,23 @@ runFunctionType :: forall m location effects a function -> (location -> Type -> m location effects ()) -> m location effects a -> m location (Delete function effects) a -runFunctionType alloc assign = relayAny @function pure $ \ eff yield -> case eff of - Lambda params _ body -> runFunctionType alloc assign (do - (bindings, tvars) <- foldr (\ name rest -> do - a <- alloc name - tvar <- Var <$> fresh - assign a tvar - bimap (Map.insert name a) (tvar :) <$> rest) (pure (Map.empty, [])) params - (Product tvars :->) <$> local (Map.unionWith const bindings) body) >>= yield - Call fn params -> runFunctionType alloc assign (do - paramTypes <- sequenceA params - case fn of - Product argTypes :-> ret -> do - guard (and (zipWith (==) paramTypes argTypes)) - pure ret - _ -> empty) >>= yield +runFunctionType alloc assign = go + where go :: forall a . m location effects a -> m location (Delete function effects) a + go = relayAny @function pure $ \ eff yield -> case eff of + Lambda params _ body -> go (do + (bindings, tvars) <- foldr (\ name rest -> do + a <- alloc name + tvar <- Var <$> fresh + assign a tvar + bimap (Map.insert name a) (tvar :) <$> rest) (pure (Map.empty, [])) params + (Product tvars :->) <$> local (Map.unionWith const bindings) body) >>= yield + Call fn params -> go (do + paramTypes <- sequenceA params + case fn of + Product argTypes :-> ret -> do + guard (and (zipWith (==) paramTypes argTypes)) + pure ret + _ -> empty) >>= yield class Show value => AbstractFunction location value effects where From c9d8a82f12f3b569c934fd196a81f6a13ce7a73c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:26:36 -0400 Subject: [PATCH 071/174] Define a smart constructor for Call. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 967c29735..37497f2ee 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -51,6 +51,9 @@ class AbstractHole value where lambda :: (Effectful m, Member (Function action value) effects) => [Name] -> Set Name -> action value -> m effects value lambda paramNames fvs body = send (Lambda paramNames fvs body) +call' :: (Effectful m, Member (Function action value) effects) => value -> [action value] -> m effects value +call' fn params = send (Call fn params) + data Function m value return where Lambda :: [Name] -> Set Name -> m value -> Function m value value Call :: value -> [m value] -> Function m value value From 10cf048dfc3605e44910d6794d37d1e85b6027ff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:27:34 -0400 Subject: [PATCH 072/174] Specialize to m effects. Co-Authored-By: Patrick Thomson --- 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 37497f2ee..ea54a03f9 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -48,10 +48,10 @@ class AbstractHole value where hole :: value -lambda :: (Effectful m, Member (Function action value) effects) => [Name] -> Set Name -> action value -> m effects value +lambda :: (Effectful m, Member (Function (m effects) value) effects) => [Name] -> Set Name -> m effects value -> m effects value lambda paramNames fvs body = send (Lambda paramNames fvs body) -call' :: (Effectful m, Member (Function action value) effects) => value -> [action value] -> m effects value +call' :: (Effectful m, Member (Function (m effects) value) effects) => value -> [m effects value] -> m effects value call' fn params = send (Call fn params) data Function m value return where From 3200ce88a799d341a893b7757c43121b5fc995ea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:47:57 -0400 Subject: [PATCH 073/174] Rename type variables to TVar. Co-Authored-By: Patrick Thomson --- 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 ea54a03f9..2795146da 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -105,7 +105,7 @@ runFunctionValue alloc assign = go data Type = Type :-> Type | Product [Type] - | Var Int + | TVar Int deriving (Eq, Ord, Show) runFunctionType :: forall m location effects a function @@ -132,7 +132,7 @@ runFunctionType alloc assign = go Lambda params _ body -> go (do (bindings, tvars) <- foldr (\ name rest -> do a <- alloc name - tvar <- Var <$> fresh + tvar <- TVar <$> fresh assign a tvar bimap (Map.insert name a) (tvar :) <$> rest) (pure (Map.empty, [])) params (Product tvars :->) <$> local (Map.unionWith const bindings) body) >>= yield From 41854f6bbc403ba7a4282dba71cfcff41183f4e3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:48:11 -0400 Subject: [PATCH 074/174] Define a Unit effect type. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 2795146da..53d20397e 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -59,6 +59,10 @@ data Function m value return where Call :: value -> [m value] -> Function m value value +data Unit value return where + Unit :: Unit value value + + data Value m location = Closure [Name] (m (Value m location)) (Map Name location) From 49fe2199080f7860a1832edbc71a3ee98ec69fc3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:48:21 -0400 Subject: [PATCH 075/174] Define a unit' request. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 53d20397e..55ceaa05b 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -58,6 +58,9 @@ data Function m value return where Lambda :: [Name] -> Set Name -> m value -> Function m value value Call :: value -> [m value] -> Function m value value +unit' :: (Effectful m, Member (Unit value) effects) => m effects value +unit' = send Unit + data Unit value return where Unit :: Unit value value From 433aa96cd7ef9cb37733ae7d207fb6c7fe93c889 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:48:31 -0400 Subject: [PATCH 076/174] Define a Variable effect. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 55ceaa05b..02d4ecc81 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -58,6 +58,10 @@ data Function m value return where Lambda :: [Name] -> Set Name -> m value -> Function m value value Call :: value -> [m value] -> Function m value value +data Variable value return where + Variable :: Name -> Variable value value + + unit' :: (Effectful m, Member (Unit value) effects) => m effects value unit' = send Unit From a368e8d9f459f23e85c7caf7f6e95f121763fc5b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:48:39 -0400 Subject: [PATCH 077/174] Define variable' requests. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 02d4ecc81..dcccf6684 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -58,6 +58,9 @@ data Function m value return where Lambda :: [Name] -> Set Name -> m value -> Function m value value Call :: value -> [m value] -> Function m value value +variable' :: (Effectful m, Member (Variable value) effects) => Name -> m effects value +variable' = send . Variable + data Variable value return where Variable :: Name -> Variable value value From a8c68e40b1e4a5177c0688dc8d3564a2d7a60fd4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:49:00 -0400 Subject: [PATCH 078/174] =?UTF-8?q?Define=20a=20helper=20to=20build=20lamb?= =?UTF-8?q?das=20with=20gensym=E2=80=99d=20names.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index dcccf6684..1fc2aad98 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -54,6 +54,15 @@ lambda paramNames fvs body = send (Lambda paramNames fvs body) call' :: (Effectful m, Member (Function (m effects) value) effects) => value -> [m effects value] -> m effects value call' fn params = send (Call fn params) + +lambda' :: (Effectful m, Members '[Fresh, Function (m effects) value] effects, Monad (m effects)) + => Set Name + -> (Name -> m effects value) + -> m effects value +lambda' fvs body = do + var <- nameI <$> fresh + lambda [var] fvs (body var) + data Function m value return where Lambda :: [Name] -> Set Name -> m value -> Function m value value Call :: value -> [m value] -> Function m value value From 09b5dd8f3349f5ffe8f096422902c0956764460c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:49:28 -0400 Subject: [PATCH 079/174] Define the identity function. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 1fc2aad98..0527dfe92 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -63,6 +63,12 @@ lambda' fvs body = do var <- nameI <$> fresh lambda [var] fvs (body var) + +builtinId :: (Effectful m, Members '[Fresh, Function (m effects) value, Variable value] effects, Monad (m effects)) + => m effects value +builtinId = lambda' lowerBound (\ name -> variable' name) + + data Function m value return where Lambda :: [Name] -> Set Name -> m value -> Function m value value Call :: value -> [m value] -> Function m value value From b11ad895f400f52e00f9b214ad21551480da24a4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:51:32 -0400 Subject: [PATCH 080/174] Expect closed values. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 0527dfe92..823f3e6fb 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -56,17 +56,16 @@ call' fn params = send (Call fn params) lambda' :: (Effectful m, Members '[Fresh, Function (m effects) value] effects, Monad (m effects)) - => Set Name - -> (Name -> m effects value) + => (Name -> m effects value) -> m effects value -lambda' fvs body = do +lambda' body = do var <- nameI <$> fresh - lambda [var] fvs (body var) + lambda [var] lowerBound (body var) builtinId :: (Effectful m, Members '[Fresh, Function (m effects) value, Variable value] effects, Monad (m effects)) => m effects value -builtinId = lambda' lowerBound (\ name -> variable' name) +builtinId = lambda' (\ name -> variable' name) data Function m value return where From bb79415ec0800795f36fd9577a93c241b91fc80b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 12:52:42 -0400 Subject: [PATCH 081/174] Define the (curried) const function. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 823f3e6fb..579bd38bf 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -67,6 +67,10 @@ builtinId :: (Effectful m, Members '[Fresh, Function (m effects) value, Variable => m effects value builtinId = lambda' (\ name -> variable' name) +builtinConst :: (Effectful m, Members '[Fresh, Function (m effects) value, Variable value] effects, Monad (m effects)) + => m effects value +builtinConst = lambda' (\ name -> lambda' (const (variable' name))) + data Function m value return where Lambda :: [Name] -> Set Name -> m value -> Function m value value From 9e02243e5876b22fe0ed4f5e1095e6600b197ea6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 13:13:40 -0400 Subject: [PATCH 082/174] Define a handler for Unit effects. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 579bd38bf..0a7019b94 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -90,9 +90,20 @@ unit' = send Unit data Unit value return where Unit :: Unit value value +runUnitValue :: forall m location effects a unit + . ( Applicative (m location (Delete unit effects)) + , Effectful (m location) + , Member unit effects + , unit ~ (Unit (Value (m location effects) location)) + ) + => m location effects a + -> m location (Delete unit effects) a +runUnitValue = relayAny @unit pure (\ Unit yield -> yield Unit') + data Value m location = Closure [Name] (m (Value m location)) (Map Name location) + | Unit' liftHandler :: Functor m => (forall a . m a -> m' a) -> Value m location -> Value m' location liftHandler handler = go where go (Closure names body env) = Closure names (handler (go <$> body)) env From 2d63f5cdfd3e95a745d7c8b11182deb9c540bec0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 13:28:38 -0400 Subject: [PATCH 083/174] Revert "Hide the Delete typeclass." This reverts commit 41546b367250750616ad5eaab3a8e5b7370a8000. --- src/Data/Syntax/Expression.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 38da1f135..0e668810e 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -6,7 +6,7 @@ import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedF import Data.Fixed import Data.JSON.Fields import Diffing.Algorithm -import Prologue hiding (index, Delete) +import Prologue hiding (index) -- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell. data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a } From fb65fa24c39d157952fd49491987ce3914555826 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 13:28:46 -0400 Subject: [PATCH 084/174] Bump effects. --- vendor/effects | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/effects b/vendor/effects index e14257722..f1b8c91af 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit e142577226ae12d286893ae3801644e266c951f1 +Subproject commit f1b8c91afbe848061da3611edce502bf07f7212e From e8629b80f9697c369bfce4c2173cdb57cb7a4ab8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 13:31:31 -0400 Subject: [PATCH 085/174] Use the \\ class. --- src/Control/Abstract/Value.hs | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 0a7019b94..0ce387086 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -90,14 +90,14 @@ unit' = send Unit data Unit value return where Unit :: Unit value value -runUnitValue :: forall m location effects a unit - . ( Applicative (m location (Delete unit effects)) +runUnitValue :: forall m location effects effects' a unit + . ( Applicative (m location effects') , Effectful (m location) - , Member unit effects , unit ~ (Unit (Value (m location effects) location)) + , (unit \\ effects) effects' ) => m location effects a - -> m location (Delete unit effects) a + -> m location effects' a runUnitValue = relayAny @unit pure (\ Unit yield -> yield Unit') @@ -108,7 +108,7 @@ data Value m location liftHandler :: Functor m => (forall a . m a -> m' a) -> Value m location -> Value m' location liftHandler handler = go where go (Closure names body env) = Closure names (handler (go <$> body)) env -runFunctionValue :: forall m location effects a function +runFunctionValue :: forall m location effects effects' a function . ( Effectful (m location) , Members '[ function , Reader (Map Name location) @@ -118,17 +118,18 @@ runFunctionValue :: forall m location effects a function , Members '[ Reader (Map Name location) , Reader ModuleInfo , Reader PackageInfo - ] (Delete function effects) + ] effects' , Monad (m location effects) - , Monad (m location (Delete function effects)) + , Monad (m location effects') , function ~ Function (m location effects) (Value (m location effects) location) + , (function \\ effects) effects' ) => (Name -> m location effects location) -> (location -> Value (m location effects) location -> m location effects ()) -> m location effects a - -> m location (Delete function effects) a + -> m location effects' a runFunctionValue alloc assign = go - where go :: forall a . m location effects a -> m location (Delete function effects) a + where go :: forall a . m location effects a -> m location effects' a go = relayAny @function pure $ \ eff yield -> case eff of Lambda params fvs body -> do packageInfo <- currentPackage @@ -151,9 +152,9 @@ data Type | TVar Int deriving (Eq, Ord, Show) -runFunctionType :: forall m location effects a function +runFunctionType :: forall m location effects effects' a function . ( Alternative (m location effects) - , Alternative (m location (Delete function effects)) + , Alternative (m location effects') , Effectful (m location) , Members '[ Fresh , function @@ -162,15 +163,16 @@ runFunctionType :: forall m location effects a function , Reader PackageInfo ] effects , Monad (m location effects) - , Monad (m location (Delete function effects)) + , Monad (m location effects') , function ~ Function (m location effects) Type + , (function \\ effects) effects' ) => (Name -> m location effects location) -> (location -> Type -> m location effects ()) -> m location effects a - -> m location (Delete function effects) a + -> m location effects' a runFunctionType alloc assign = go - where go :: forall a . m location effects a -> m location (Delete function effects) a + where go :: forall a . m location effects a -> m location effects' a go = relayAny @function pure $ \ eff yield -> case eff of Lambda params _ body -> go (do (bindings, tvars) <- foldr (\ name rest -> do From 1f8ab5bbfea248726a0def2701f8768d276d9626 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 13:36:37 -0400 Subject: [PATCH 086/174] :fire: some scoped type variables. --- src/Control/Abstract/Value.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 0ce387086..c7432a10a 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -90,15 +90,14 @@ unit' = send Unit data Unit value return where Unit :: Unit value value -runUnitValue :: forall m location effects effects' a unit - . ( Applicative (m location effects') +runUnitValue :: ( Applicative (m location effects') , Effectful (m location) , unit ~ (Unit (Value (m location effects) location)) , (unit \\ effects) effects' ) => m location effects a -> m location effects' a -runUnitValue = relayAny @unit pure (\ Unit yield -> yield Unit') +runUnitValue = relayAny pure (\ Unit yield -> yield Unit') data Value m location From e6fe0798851a2875be084a9704ef2e44335f01a4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 13:37:27 -0400 Subject: [PATCH 087/174] =?UTF-8?q?We=20don=E2=80=99t=20need=20to=20apply?= =?UTF-8?q?=20the=20function=20type=20any=20more.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- 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 c7432a10a..32b827001 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -129,7 +129,7 @@ runFunctionValue :: forall m location effects effects' a function -> m location effects' a runFunctionValue alloc assign = go where go :: forall a . m location effects a -> m location effects' a - go = relayAny @function pure $ \ eff yield -> case eff of + go = relayAny pure $ \ eff yield -> case eff of Lambda params fvs body -> do packageInfo <- currentPackage moduleInfo <- currentModule @@ -172,7 +172,7 @@ runFunctionType :: forall m location effects effects' a function -> m location effects' a runFunctionType alloc assign = go where go :: forall a . m location effects a -> m location effects' a - go = relayAny @function pure $ \ eff yield -> case eff of + go = relayAny pure $ \ eff yield -> case eff of Lambda params _ body -> go (do (bindings, tvars) <- foldr (\ name rest -> do a <- alloc name From 07624e0ae32d011ee9de5461db6b95d256eaed3c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 13:39:03 -0400 Subject: [PATCH 088/174] =?UTF-8?q?We=20don=E2=80=99t=20need=20to=20use=20?= =?UTF-8?q?equality=20constraints=20to=20bind=20the=20effect=20types.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Value.hs | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 32b827001..d5614c5c1 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -92,8 +92,7 @@ data Unit value return where runUnitValue :: ( Applicative (m location effects') , Effectful (m location) - , unit ~ (Unit (Value (m location effects) location)) - , (unit \\ effects) effects' + , (Unit (Value (m location effects) location) \\ effects) effects' ) => m location effects a -> m location effects' a @@ -107,10 +106,9 @@ data Value m location liftHandler :: Functor m => (forall a . m a -> m' a) -> Value m location -> Value m' location liftHandler handler = go where go (Closure names body env) = Closure names (handler (go <$> body)) env -runFunctionValue :: forall m location effects effects' a function +runFunctionValue :: forall m location effects effects' a . ( Effectful (m location) - , Members '[ function - , Reader (Map Name location) + , Members '[ Reader (Map Name location) , Reader ModuleInfo , Reader PackageInfo ] effects @@ -120,8 +118,7 @@ runFunctionValue :: forall m location effects effects' a function ] effects' , Monad (m location effects) , Monad (m location effects') - , function ~ Function (m location effects) (Value (m location effects) location) - , (function \\ effects) effects' + , (Function (m location effects) (Value (m location effects) location) \\ effects) effects' ) => (Name -> m location effects location) -> (location -> Value (m location effects) location -> m location effects ()) @@ -151,20 +148,18 @@ data Type | TVar Int deriving (Eq, Ord, Show) -runFunctionType :: forall m location effects effects' a function +runFunctionType :: forall m location effects effects' a . ( Alternative (m location effects) , Alternative (m location effects') , Effectful (m location) , Members '[ Fresh - , function , Reader (Map Name location) , Reader ModuleInfo , Reader PackageInfo ] effects , Monad (m location effects) , Monad (m location effects') - , function ~ Function (m location effects) Type - , (function \\ effects) effects' + , (Function (m location effects) Type \\ effects) effects' ) => (Name -> m location effects location) -> (location -> Type -> m location effects ()) From 7289acfb291ba5acfb60afc2fb99408dbfe94e6a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 13:40:18 -0400 Subject: [PATCH 089/174] Define a handler for the unit type. --- src/Control/Abstract/Value.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d5614c5c1..1ae626e48 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -183,6 +183,14 @@ runFunctionType alloc assign = go pure ret _ -> empty) >>= yield +runUnitType :: ( Applicative (m location effects') + , Effectful (m location) + , (Unit Type \\ effects) effects' + ) + => m location effects a + -> m location effects' a +runUnitType = relayAny pure (\ Unit yield -> yield (Product [])) + class Show value => AbstractFunction location value effects where -- | Build a closure (a binder like a lambda or method definition). From e75872bdb90db85a9302de09423f83432609d46f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 13:41:44 -0400 Subject: [PATCH 090/174] Move runUnitValue down. --- src/Control/Abstract/Value.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 1ae626e48..fc5149c73 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -90,14 +90,6 @@ unit' = send Unit data Unit value return where Unit :: Unit value value -runUnitValue :: ( Applicative (m location effects') - , Effectful (m location) - , (Unit (Value (m location effects) location) \\ effects) effects' - ) - => m location effects a - -> m location effects' a -runUnitValue = relayAny pure (\ Unit yield -> yield Unit') - data Value m location = Closure [Name] (m (Value m location)) (Map Name location) @@ -141,6 +133,14 @@ runFunctionValue alloc assign = go Map.insert name a <$> rest) (pure env) (zip paramNames params) local (Map.unionWith const bindings) body) >>= yield +runUnitValue :: ( Applicative (m location effects') + , Effectful (m location) + , (Unit (Value (m location effects) location) \\ effects) effects' + ) + => m location effects a + -> m location effects' a +runUnitValue = relayAny pure (\ Unit yield -> yield Unit') + data Type = Type :-> Type From b37073aea12c589c11384106cae756445173469c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 13:46:34 -0400 Subject: [PATCH 091/174] Bump effects for interpretAny. --- vendor/effects | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/effects b/vendor/effects index f1b8c91af..ca179cd6c 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit f1b8c91afbe848061da3611edce502bf07f7212e +Subproject commit ca179cd6ca0c4ca266a2c827cd2490e949e318c3 From f856674f6e2bb7bc07f595e3b5bdce1298751efd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 13:47:59 -0400 Subject: [PATCH 092/174] Simplify the handlers with interpretAny. --- src/Control/Abstract/Value.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index fc5149c73..e87bff602 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -118,20 +118,20 @@ runFunctionValue :: forall m location effects effects' a -> m location effects' a runFunctionValue alloc assign = go where go :: forall a . m location effects a -> m location effects' a - go = relayAny pure $ \ eff yield -> case eff of + go = interpretAny $ \ eff -> case eff of Lambda params fvs body -> do packageInfo <- currentPackage moduleInfo <- currentModule env <- Map.filterWithKey (fmap (`Set.member` fvs) . const) <$> ask let body' = withCurrentPackage packageInfo (withCurrentModule moduleInfo body) - yield (Closure params body' env) - Call (Closure paramNames body env) params -> go (do + pure (Closure params body' env) + Call (Closure paramNames body env) params -> go $ do bindings <- foldr (\ (name, param) rest -> do v <- param a <- alloc name assign a v Map.insert name a <$> rest) (pure env) (zip paramNames params) - local (Map.unionWith const bindings) body) >>= yield + local (Map.unionWith const bindings) body runUnitValue :: ( Applicative (m location effects') , Effectful (m location) @@ -139,7 +139,7 @@ runUnitValue :: ( Applicative (m location effects') ) => m location effects a -> m location effects' a -runUnitValue = relayAny pure (\ Unit yield -> yield Unit') +runUnitValue = interpretAny (\ Unit -> pure Unit') data Type @@ -167,21 +167,21 @@ runFunctionType :: forall m location effects effects' a -> m location effects' a runFunctionType alloc assign = go where go :: forall a . m location effects a -> m location effects' a - go = relayAny pure $ \ eff yield -> case eff of - Lambda params _ body -> go (do + go = interpretAny $ \ eff -> case eff of + Lambda params _ body -> go $ do (bindings, tvars) <- foldr (\ name rest -> do a <- alloc name tvar <- TVar <$> fresh assign a tvar bimap (Map.insert name a) (tvar :) <$> rest) (pure (Map.empty, [])) params - (Product tvars :->) <$> local (Map.unionWith const bindings) body) >>= yield - Call fn params -> go (do + (Product tvars :->) <$> local (Map.unionWith const bindings) body + Call fn params -> go $ do paramTypes <- sequenceA params case fn of Product argTypes :-> ret -> do guard (and (zipWith (==) paramTypes argTypes)) pure ret - _ -> empty) >>= yield + _ -> empty runUnitType :: ( Applicative (m location effects') , Effectful (m location) @@ -189,7 +189,7 @@ runUnitType :: ( Applicative (m location effects') ) => m location effects a -> m location effects' a -runUnitType = relayAny pure (\ Unit yield -> yield (Product [])) +runUnitType = interpretAny (\ Unit -> pure (Product [])) class Show value => AbstractFunction location value effects where From 9d8c91f32f779bb73a004cdbcd4a0e5c1cbc52a9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 14:10:32 -0400 Subject: [PATCH 093/174] Define a handler for Variable effects. --- src/Control/Abstract/Value.hs | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index e87bff602..3fd2723e6 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -31,7 +31,7 @@ import Data.Scientific (Scientific) import Data.Semigroup.Reducer hiding (unit) import Data.Semilattice.Lower import qualified Data.Set as Set -import Prelude +import Prelude hiding (fail) import Prologue hiding (TypeError) -- | This datum is passed into liftComparison to handle the fact that Ruby and PHP @@ -82,6 +82,26 @@ variable' = send . Variable data Variable value return where Variable :: Name -> Variable value value +runVariable :: forall m location effects effects' value a + . ( Effectful (m location) + , (Variable value \\ effects) effects' + , Members '[ Fail + , Reader (Map Name location) + , State (Map location value) + ] effects' + , Monad (m location effects') + , Show location + ) + => (Name -> m location effects' (Maybe location)) + -> (location -> m location effects' (Maybe value)) + -> m location effects a + -> m location effects' a +runVariable lookup deref = go + where go :: forall a . m location effects a -> m location effects' a + go = interpretAny (\ (Variable name) -> do + addr <- lookup name >>= maybeM (raiseEff (fail ("free variable: " <> show name))) + deref addr >>= maybeM (raiseEff (fail ("uninitialized address: " <> show addr)))) + unit' :: (Effectful m, Member (Unit value) effects) => m effects value unit' = send Unit From 477e34aca27233912c0066b1ae0014d297f9ae99 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 14:17:35 -0400 Subject: [PATCH 094/174] Eta-reduce. --- 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 3fd2723e6..3dc6be489 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -65,7 +65,7 @@ lambda' body = do builtinId :: (Effectful m, Members '[Fresh, Function (m effects) value, Variable value] effects, Monad (m effects)) => m effects value -builtinId = lambda' (\ name -> variable' name) +builtinId = lambda' variable' builtinConst :: (Effectful m, Members '[Fresh, Function (m effects) value, Variable value] effects, Monad (m effects)) => m effects value From 30c0090ebd2e2e55a46d08ec7393bf526f8c2d71 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 14:31:01 -0400 Subject: [PATCH 095/174] Define a Boolean effect. --- src/Control/Abstract/Value.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 3dc6be489..4bbc40361 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -111,6 +111,11 @@ data Unit value return where Unit :: Unit value value +data Boolean value return where + Bool :: Bool -> Boolean value value + AsBool :: value -> Boolean value Bool + + data Value m location = Closure [Name] (m (Value m location)) (Map Name location) | Unit' From 7d4ac1f492c01374b38f32cc2cf408550354b186 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 14:31:19 -0400 Subject: [PATCH 096/174] Define a bool smart constructor. --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 4bbc40361..f6b2ebeaf 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -111,6 +111,9 @@ data Unit value return where Unit :: Unit value value +bool :: (Effectful m, Member (Boolean value) effects) => Bool -> m effects value +bool = send . Bool + data Boolean value return where Bool :: Bool -> Boolean value value AsBool :: value -> Boolean value Bool From 655c4a12ad33489521e646e6c20d724b8be5e23d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 14:32:10 -0400 Subject: [PATCH 097/174] Define an asBool' smart constructor. --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index f6b2ebeaf..287ad6da2 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -114,6 +114,9 @@ data Unit value return where bool :: (Effectful m, Member (Boolean value) effects) => Bool -> m effects value bool = send . Bool +asBool' :: (Effectful m, Member (Boolean value) effects) => value -> m effects Bool +asBool' = send . AsBool + data Boolean value return where Bool :: Bool -> Boolean value value AsBool :: value -> Boolean value Bool From 03a60b3c7546b604e65efb915b218e04feecad2a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 14:34:25 -0400 Subject: [PATCH 098/174] Define a handler for booleans in Value. --- src/Control/Abstract/Value.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 287ad6da2..69d6baddb 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -125,6 +125,7 @@ data Boolean value return where data Value m location = Closure [Name] (m (Value m location)) (Map Name location) | Unit' + | Bool' Bool liftHandler :: Functor m => (forall a . m a -> m' a) -> Value m location -> Value m' location liftHandler handler = go where go (Closure names body env) = Closure names (handler (go <$> body)) env @@ -172,6 +173,16 @@ runUnitValue :: ( Applicative (m location effects') -> m location effects' a runUnitValue = interpretAny (\ Unit -> pure Unit') +runBooleanValue :: ( Applicative (m location effects') + , Effectful (m location) + , (Boolean (Value (m location effects) location) \\ effects) effects' + ) + => m location effects a + -> m location effects' a +runBooleanValue = interpretAny (\ eff -> case eff of + Bool b -> pure (Bool' b) + AsBool (Bool' b) -> pure b) + data Type = Type :-> Type From 7e057b3f14c41b12fc441ee6675eae2f251e65f1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 14:37:19 -0400 Subject: [PATCH 099/174] Define a handler for booleans in Type. --- src/Control/Abstract/Value.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 69d6baddb..71de813cc 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -188,6 +188,7 @@ data Type = Type :-> Type | Product [Type] | TVar Int + | BoolT deriving (Eq, Ord, Show) runFunctionType :: forall m location effects effects' a @@ -233,6 +234,17 @@ runUnitType :: ( Applicative (m location effects') -> m location effects' a runUnitType = interpretAny (\ Unit -> pure (Product [])) +runBooleanType :: ( Alternative (m location effects') + , Effectful (m location) + , Member NonDet effects + , (Boolean Type \\ effects) effects' + ) + => m location effects a + -> m location effects' a +runBooleanType = interpretAny (\ eff -> case eff of + Bool _ -> pure BoolT + AsBool BoolT -> pure True <|> pure False) + class Show value => AbstractFunction location value effects where -- | Build a closure (a binder like a lambda or method definition). From 2056dd4e14694c119dd57bb0de81548d014d589d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 14:39:26 -0400 Subject: [PATCH 100/174] Define an iff convenience for Boolean. --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 71de813cc..a65cfba78 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -117,6 +117,9 @@ bool = send . Bool asBool' :: (Effectful m, Member (Boolean value) effects) => value -> m effects Bool asBool' = send . AsBool +iff :: (Effectful m, Member (Boolean value) effects, Monad (m effects)) => value -> m effects a -> m effects a -> m effects a +iff c t e = asBool' c >>= \ c' -> if c' then t else e + data Boolean value return where Bool :: Bool -> Boolean value value AsBool :: value -> Boolean value Bool From 5ef77253732fddbf24dc2fec1198b3e205f9737e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 14:52:56 -0400 Subject: [PATCH 101/174] Add a little program against the DSL. --- src/Control/Abstract/Value.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index a65cfba78..b158889d4 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -63,6 +63,21 @@ lambda' body = do lambda [var] lowerBound (body var) +prog :: ( Effectful m + , Members '[ Boolean value + , Fresh + , Function (m effects) value + , Unit value + , Variable value + ] effects + , Monad (m effects) + ) + => value -> m effects value +prog b = do + identity <- lambda' variable' + iff b unit' (call' identity [unit']) + + builtinId :: (Effectful m, Members '[Fresh, Function (m effects) value, Variable value] effects, Monad (m effects)) => m effects value builtinId = lambda' variable' From 2d18b9d7fc99e0ca6a87ba5071b26f5ede2d04a4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 15:00:13 -0400 Subject: [PATCH 102/174] Define a lookup function. --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index b158889d4..773c69467 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -62,6 +62,9 @@ lambda' body = do var <- nameI <$> fresh lambda [var] lowerBound (body var) +lookup' :: (Effectful (m location), Functor (m location effects), Member (Reader (Map Name location)) effects) => Name -> m location effects (Maybe location) +lookup' name = Map.lookup name <$> ask + prog :: ( Effectful m , Members '[ Boolean value From 108068f7f880a971c89b517ae09924609f0a2d74 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 15:00:38 -0400 Subject: [PATCH 103/174] Define variable' using lookup'. --- src/Control/Abstract/Value.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 773c69467..f8a76b7b4 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -110,14 +110,13 @@ runVariable :: forall m location effects effects' value a , Monad (m location effects') , Show location ) - => (Name -> m location effects' (Maybe location)) - -> (location -> m location effects' (Maybe value)) + => (location -> m location effects' (Maybe value)) -> m location effects a -> m location effects' a -runVariable lookup deref = go +runVariable deref = go where go :: forall a . m location effects a -> m location effects' a go = interpretAny (\ (Variable name) -> do - addr <- lookup name >>= maybeM (raiseEff (fail ("free variable: " <> show name))) + addr <- lookup' name >>= maybeM (raiseEff (fail ("free variable: " <> show name))) deref addr >>= maybeM (raiseEff (fail ("uninitialized address: " <> show addr)))) From 47dd98970ac7539abb2ec224076dcd36143f1947 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 15:01:58 -0400 Subject: [PATCH 104/174] Define an Eval newtype. --- src/Control/Abstract/Value.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index f8a76b7b4..d9d6e2bab 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, Rank2Types, ScopedTypeVariables, TypeOperators #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, Rank2Types, ScopedTypeVariables, TypeOperators #-} module Control.Abstract.Value ( AbstractValue(..) , AbstractFunction(..) @@ -80,6 +80,10 @@ prog b = do identity <- lambda' variable' iff b unit' (call' identity [unit']) +newtype Eval location effects a = Eval { runEval :: Eff effects a } + deriving (Applicative, Effectful, Functor, Monad) + + builtinId :: (Effectful m, Members '[Fresh, Function (m effects) value, Variable value] effects, Monad (m effects)) => m effects value From 2cec1468c0752416ef9a6a7685e937ac6ba883cc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 15:11:49 -0400 Subject: [PATCH 105/174] Add a function to dereference types. --- src/Control/Abstract/Value.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d9d6e2bab..ec17cb42d 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -65,6 +65,14 @@ lambda' body = do lookup' :: (Effectful (m location), Functor (m location effects), Member (Reader (Map Name location)) effects) => Name -> m location effects (Maybe location) lookup' name = Map.lookup name <$> ask +derefType :: (Alternative (m location effects), Effectful (m location), Members '[Fail, NonDet, State (Map location (Set Type))] effects, Monad (m location effects), Ord location, Show location) => location -> m location effects (Maybe Type) +derefType loc = do + cell <- gets (Map.lookup loc) >>= maybeM (raiseEff (fail ("unallocated address: " <> show loc))) + if Set.null cell then + pure Nothing + else + Set.foldr ((<|>) . pure . Just) empty cell + prog :: ( Effectful m , Members '[ Boolean value From b861543d06d620c582608b8f8e67cb5f03b5d906 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 15:13:04 -0400 Subject: [PATCH 106/174] Define alloc for types. --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index ec17cb42d..5d1dcf750 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -65,6 +65,9 @@ lambda' body = do lookup' :: (Effectful (m location), Functor (m location effects), Member (Reader (Map Name location)) effects) => Name -> m location effects (Maybe location) lookup' name = Map.lookup name <$> ask +allocType :: Applicative (m Name effects) => Name -> m Name effects Name +allocType = pure + derefType :: (Alternative (m location effects), Effectful (m location), Members '[Fail, NonDet, State (Map location (Set Type))] effects, Monad (m location effects), Ord location, Show location) => location -> m location effects (Maybe Type) derefType loc = do cell <- gets (Map.lookup loc) >>= maybeM (raiseEff (fail ("unallocated address: " <> show loc))) From 5dbba8a92de589f51d86bdc718986e276e224594 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 15:16:56 -0400 Subject: [PATCH 107/174] Define assign for types. --- src/Control/Abstract/Value.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 5d1dcf750..82b575cdd 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -68,6 +68,11 @@ lookup' name = Map.lookup name <$> ask allocType :: Applicative (m Name effects) => Name -> m Name effects Name allocType = pure +assignType :: (Effectful (m location), Member (State (Map location (Set Type))) effects, Monad (m location effects), Ord location, Show location) => location -> Type -> m location effects () +assignType addr value = do + cell <- gets (Map.lookup addr) >>= maybeM (pure (Set.empty)) + modify' (Map.insert addr (Set.insert value cell)) + derefType :: (Alternative (m location effects), Effectful (m location), Members '[Fail, NonDet, State (Map location (Set Type))] effects, Monad (m location effects), Ord location, Show location) => location -> m location effects (Maybe Type) derefType loc = do cell <- gets (Map.lookup loc) >>= maybeM (raiseEff (fail ("unallocated address: " <> show loc))) From aa1141ad584ecf391e3032fb23344ca4f5684abb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 15:17:03 -0400 Subject: [PATCH 108/174] Rename the loc parameter to addr. --- 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 82b575cdd..0af61271c 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -74,8 +74,8 @@ assignType addr value = do modify' (Map.insert addr (Set.insert value cell)) derefType :: (Alternative (m location effects), Effectful (m location), Members '[Fail, NonDet, State (Map location (Set Type))] effects, Monad (m location effects), Ord location, Show location) => location -> m location effects (Maybe Type) -derefType loc = do - cell <- gets (Map.lookup loc) >>= maybeM (raiseEff (fail ("unallocated address: " <> show loc))) +derefType addr = do + cell <- gets (Map.lookup addr) >>= maybeM (raiseEff (fail ("unallocated address: " <> show addr))) if Set.null cell then pure Nothing else From b8eae43542d1fdc1e7b9ef90ab279748098ea299 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 15:44:31 -0400 Subject: [PATCH 109/174] Correct the kind of allocType. --- 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 0af61271c..8c70b22f7 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -65,7 +65,7 @@ lambda' body = do lookup' :: (Effectful (m location), Functor (m location effects), Member (Reader (Map Name location)) effects) => Name -> m location effects (Maybe location) lookup' name = Map.lookup name <$> ask -allocType :: Applicative (m Name effects) => Name -> m Name effects Name +allocType :: (Applicative (m Name effects), Effectful (m Name)) => Name -> m Name effects Name allocType = pure assignType :: (Effectful (m location), Member (State (Map location (Set Type))) effects, Monad (m location effects), Ord location, Show location) => location -> Type -> m location effects () From 0321976831bc5c28798bddceba8a217c320e2d53 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 15:44:38 -0400 Subject: [PATCH 110/174] :fire: a redundant constraint. --- src/Control/Abstract/Value.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 8c70b22f7..09b9e6288 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -276,7 +276,6 @@ runUnitType = interpretAny (\ Unit -> pure (Product [])) runBooleanType :: ( Alternative (m location effects') , Effectful (m location) - , Member NonDet effects , (Boolean Type \\ effects) effects' ) => m location effects a From 66caefcd5855b0a356956c7443ac22c75da08fb8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 15:44:54 -0400 Subject: [PATCH 111/174] Derive an Alternative instance for Eval. --- src/Control/Abstract/Value.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 09b9e6288..372c90fae 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -99,6 +99,7 @@ prog b = do newtype Eval location effects a = Eval { runEval :: Eff effects a } deriving (Applicative, Effectful, Functor, Monad) +deriving instance Member NonDet effects => Alternative (Eval location effects) builtinId :: (Effectful m, Members '[Fresh, Function (m effects) value, Variable value] effects, Monad (m effects)) From 6252a56e8e39d2493fea3721fdfc8c056794be10 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 15:45:10 -0400 Subject: [PATCH 112/174] Define a handler for the env. --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 372c90fae..fe631b65e 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -81,6 +81,9 @@ derefType addr = do else Set.foldr ((<|>) . pure . Just) empty cell +runEnv :: Effectful (m location) => m location (Reader (Map Name location) ': effects) a -> m location effects a +runEnv = runReader Map.empty + prog :: ( Effectful m , Members '[ Boolean value From ccf00d4239beb0cf9cf7af8391132329f11eeb4c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 15:45:18 -0400 Subject: [PATCH 113/174] Define a handler for the heap for types. --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index fe631b65e..c3eae0430 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -84,6 +84,9 @@ derefType addr = do runEnv :: Effectful (m location) => m location (Reader (Map Name location) ': effects) a -> m location effects a runEnv = runReader Map.empty +runHeapType :: Effectful (m Name) => m Name (State (Map Name (Set Type)) ': effects) a -> m Name effects (a, Map Name (Set Type)) +runHeapType = runState Map.empty + prog :: ( Effectful m , Members '[ Boolean value From d0a4b9d6960c5889e6ebbb078f51ce635bfce3ae Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 15:47:05 -0400 Subject: [PATCH 114/174] Define a handler for programs in Type. --- src/Control/Abstract/Value.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index c3eae0430..f13b3f11d 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -20,6 +20,8 @@ import Control.Abstract.Context import Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Abstract.Heap +import Control.Monad.Effect.Fail +import Control.Monad.Effect.NonDet import Data.Abstract.Address (Address) import Data.Abstract.Environment as Env import Data.Abstract.Live (Live) @@ -107,6 +109,20 @@ newtype Eval location effects a = Eval { runEval :: Eff effects a } deriving instance Member NonDet effects => Alternative (Eval location effects) +runType :: ( effects ~ (Function (Eval Name effects) Type ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) + , (Function (Eval Name effects) Type \\ effects) effects' + , effects' ~ (Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) + , (Unit Type \\ effects') effects'' + , effects'' ~ (Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) + , (Boolean Type \\ effects'') effects''' + , effects''' ~ (Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) + , (Variable Type \\ effects''') effects'''' + , effects'''' ~ (State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) + ) + => Eval Name effects a + -> Eval Name rest [Either String (a, Map Name (Set Type))] +runType = runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType allocType assignType + builtinId :: (Effectful m, Members '[Fresh, Function (m effects) value, Variable value] effects, Monad (m effects)) => m effects value From 7da70e5983eb8c9dc5a2bf95dda10fcad5f08c9d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 15:55:16 -0400 Subject: [PATCH 115/174] Define a helper to embed an effectful action. --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index f13b3f11d..dc052daec 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -109,6 +109,9 @@ newtype Eval location effects a = Eval { runEval :: Eff effects a } deriving instance Member NonDet effects => Alternative (Eval location effects) +data Embed effect effects return where + Embed :: (effect \\ effects') effects => Eff effects' a -> Embed effect effects a + runType :: ( effects ~ (Function (Eval Name effects) Type ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) , (Function (Eval Name effects) Type \\ effects) effects' , effects' ~ (Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) From 145ce59a5435af8c7a32c7782626688095003586 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 16:02:14 -0400 Subject: [PATCH 116/174] Parameterize Function by the effects list. --- src/Control/Abstract/Value.hs | 38 +++++++++++++++++------------------ 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index dc052daec..11eb87a2d 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -50,14 +50,14 @@ class AbstractHole value where hole :: value -lambda :: (Effectful m, Member (Function (m effects) value) effects) => [Name] -> Set Name -> m effects value -> m effects value -lambda paramNames fvs body = send (Lambda paramNames fvs body) +lambda :: (Effectful m, Member (Function effects value) effects) => [Name] -> Set Name -> m effects value -> m effects value +lambda paramNames fvs body = send (Lambda paramNames fvs (lowerEff body)) -call' :: (Effectful m, Member (Function (m effects) value) effects) => value -> [m effects value] -> m effects value -call' fn params = send (Call fn params) +call' :: (Effectful m, Member (Function effects value) effects) => value -> [m effects value] -> m effects value +call' fn params = send (Call fn (map lowerEff params)) -lambda' :: (Effectful m, Members '[Fresh, Function (m effects) value] effects, Monad (m effects)) +lambda' :: (Effectful m, Members '[Fresh, Function effects value] effects, Monad (m effects)) => (Name -> m effects value) -> m effects value lambda' body = do @@ -93,7 +93,7 @@ runHeapType = runState Map.empty prog :: ( Effectful m , Members '[ Boolean value , Fresh - , Function (m effects) value + , Function effects value , Unit value , Variable value ] effects @@ -112,8 +112,8 @@ deriving instance Member NonDet effects => Alternative (Eval location effects) data Embed effect effects return where Embed :: (effect \\ effects') effects => Eff effects' a -> Embed effect effects a -runType :: ( effects ~ (Function (Eval Name effects) Type ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) - , (Function (Eval Name effects) Type \\ effects) effects' +runType :: ( effects ~ (Function effects Type ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) + , (Function effects Type \\ effects) effects' , effects' ~ (Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) , (Unit Type \\ effects') effects'' , effects'' ~ (Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) @@ -127,18 +127,18 @@ runType :: ( effects ~ (Function (Eval Name effects) Type ': Unit Type ': Boolea runType = runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType allocType assignType -builtinId :: (Effectful m, Members '[Fresh, Function (m effects) value, Variable value] effects, Monad (m effects)) +builtinId :: (Effectful m, Members '[Fresh, Function effects value, Variable value] effects, Monad (m effects)) => m effects value builtinId = lambda' variable' -builtinConst :: (Effectful m, Members '[Fresh, Function (m effects) value, Variable value] effects, Monad (m effects)) +builtinConst :: (Effectful m, Members '[Fresh, Function effects value, Variable value] effects, Monad (m effects)) => m effects value builtinConst = lambda' (\ name -> lambda' (const (variable' name))) -data Function m value return where - Lambda :: [Name] -> Set Name -> m value -> Function m value value - Call :: value -> [m value] -> Function m value value +data Function effects value return where + Lambda :: [Name] -> Set Name -> Eff effects value -> Function effects value value + Call :: value -> [Eff effects value] -> Function effects value value variable' :: (Effectful m, Member (Variable value) effects) => Name -> m effects value variable' = send . Variable @@ -208,7 +208,7 @@ runFunctionValue :: forall m location effects effects' a ] effects' , Monad (m location effects) , Monad (m location effects') - , (Function (m location effects) (Value (m location effects) location) \\ effects) effects' + , (Function effects (Value (m location effects) location) \\ effects) effects' ) => (Name -> m location effects location) -> (location -> Value (m location effects) location -> m location effects ()) @@ -221,14 +221,14 @@ runFunctionValue alloc assign = go packageInfo <- currentPackage moduleInfo <- currentModule env <- Map.filterWithKey (fmap (`Set.member` fvs) . const) <$> ask - let body' = withCurrentPackage packageInfo (withCurrentModule moduleInfo body) + let body' = withCurrentPackage packageInfo (withCurrentModule moduleInfo (raiseEff body)) pure (Closure params body' env) Call (Closure paramNames body env) params -> go $ do bindings <- foldr (\ (name, param) rest -> do v <- param a <- alloc name assign a v - Map.insert name a <$> rest) (pure env) (zip paramNames params) + Map.insert name a <$> rest) (pure env) (zip paramNames (map raiseEff params)) local (Map.unionWith const bindings) body runUnitValue :: ( Applicative (m location effects') @@ -268,7 +268,7 @@ runFunctionType :: forall m location effects effects' a ] effects , Monad (m location effects) , Monad (m location effects') - , (Function (m location effects) Type \\ effects) effects' + , (Function effects Type \\ effects) effects' ) => (Name -> m location effects location) -> (location -> Type -> m location effects ()) @@ -283,9 +283,9 @@ runFunctionType alloc assign = go tvar <- TVar <$> fresh assign a tvar bimap (Map.insert name a) (tvar :) <$> rest) (pure (Map.empty, [])) params - (Product tvars :->) <$> local (Map.unionWith const bindings) body + (Product tvars :->) <$> local (Map.unionWith const bindings) (raiseEff body) Call fn params -> go $ do - paramTypes <- sequenceA params + paramTypes <- traverse raiseEff params case fn of Product argTypes :-> ret -> do guard (and (zipWith (==) paramTypes argTypes)) From 1de3eaf9dc0cc04cb8f207cf57860c636f6c4fe2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 16:24:56 -0400 Subject: [PATCH 117/174] Rename Embed to EmbedAny. --- 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 11eb87a2d..0b574a4eb 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -109,8 +109,8 @@ newtype Eval location effects a = Eval { runEval :: Eff effects a } deriving instance Member NonDet effects => Alternative (Eval location effects) -data Embed effect effects return where - Embed :: (effect \\ effects') effects => Eff effects' a -> Embed effect effects a +data EmbedAny effect effects return where + EmbedAny :: (effect \\ effects') effects => Eff effects' a -> EmbedAny effect effects a runType :: ( effects ~ (Function effects Type ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) , (Function effects Type \\ effects) effects' From 3726735dfc41a78382b4992024257382fc196bd1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 16:25:13 -0400 Subject: [PATCH 118/174] Define an Embed newtype. --- src/Control/Abstract/Value.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 0b574a4eb..b948a017e 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -112,6 +112,8 @@ deriving instance Member NonDet effects => Alternative (Eval location effects) data EmbedAny effect effects return where EmbedAny :: (effect \\ effects') effects => Eff effects' a -> EmbedAny effect effects a +newtype Embed effect effects a = Embed { unEmbed :: Eff (effect effects ': effects) a } + runType :: ( effects ~ (Function effects Type ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) , (Function effects Type \\ effects) effects' , effects' ~ (Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) From 204b6dd1f4d7076ee00690217355d2be393ae9a3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 16:25:40 -0400 Subject: [PATCH 119/174] :fire: a redundant constraint. --- 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 b948a017e..32a296b6e 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -70,7 +70,7 @@ lookup' name = Map.lookup name <$> ask allocType :: (Applicative (m Name effects), Effectful (m Name)) => Name -> m Name effects Name allocType = pure -assignType :: (Effectful (m location), Member (State (Map location (Set Type))) effects, Monad (m location effects), Ord location, Show location) => location -> Type -> m location effects () +assignType :: (Effectful (m location), Member (State (Map location (Set Type))) effects, Monad (m location effects), Ord location) => location -> Type -> m location effects () assignType addr value = do cell <- gets (Map.lookup addr) >>= maybeM (pure (Set.empty)) modify' (Map.insert addr (Set.insert value cell)) From f2000de54be8f38f4bc3138317b2b258e4c2197c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 16:28:39 -0400 Subject: [PATCH 120/174] :fire: some more redundancies. --- src/Control/Abstract/Value.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 32a296b6e..82222b310 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -21,7 +21,6 @@ import Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Abstract.Heap import Control.Monad.Effect.Fail -import Control.Monad.Effect.NonDet import Data.Abstract.Address (Address) import Data.Abstract.Environment as Env import Data.Abstract.Live (Live) @@ -261,7 +260,6 @@ data Type runFunctionType :: forall m location effects effects' a . ( Alternative (m location effects) - , Alternative (m location effects') , Effectful (m location) , Members '[ Fresh , Reader (Map Name location) @@ -269,7 +267,6 @@ runFunctionType :: forall m location effects effects' a , Reader PackageInfo ] effects , Monad (m location effects) - , Monad (m location effects') , (Function effects Type \\ effects) effects' ) => (Name -> m location effects location) From 2431d4267581cf2fd16f110de65085b204ec92c3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 16:31:32 -0400 Subject: [PATCH 121/174] Stub in a function to shuffle an effect to the head of the list. --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 82222b310..43dd1a7b9 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -48,6 +48,9 @@ data Comparator class AbstractHole value where hole :: value +shuffle :: (Effectful m, (effect \\ effects) effects') => m effects a -> m (effect ': effects') a +shuffle = undefined + lambda :: (Effectful m, Member (Function effects value) effects) => [Name] -> Set Name -> m effects value -> m effects value lambda paramNames fvs body = send (Lambda paramNames fvs (lowerEff body)) From e8406b6502782ea517ebae24694b7c979c1c40b1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 16:48:11 -0400 Subject: [PATCH 122/174] Bump effects for shuffle. --- src/Control/Abstract/Value.hs | 3 --- vendor/effects | 2 +- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 43dd1a7b9..82222b310 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -48,9 +48,6 @@ data Comparator class AbstractHole value where hole :: value -shuffle :: (Effectful m, (effect \\ effects) effects') => m effects a -> m (effect ': effects') a -shuffle = undefined - lambda :: (Effectful m, Member (Function effects value) effects) => [Name] -> Set Name -> m effects value -> m effects value lambda paramNames fvs body = send (Lambda paramNames fvs (lowerEff body)) diff --git a/vendor/effects b/vendor/effects index ca179cd6c..b45d9cacf 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit ca179cd6ca0c4ca266a2c827cd2490e949e318c3 +Subproject commit b45d9cacf9af0e9e9ae9244f1ad334741a9d4f6c From 41a1010aebdf1729a337cb5929c8612d47bcf7e2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 17:08:00 -0400 Subject: [PATCH 123/174] Redefine Embed as a type synonym. --- 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 82222b310..48c6f636c 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -111,7 +111,7 @@ deriving instance Member NonDet effects => Alternative (Eval location effects) data EmbedAny effect effects return where EmbedAny :: (effect \\ effects') effects => Eff effects' a -> EmbedAny effect effects a -newtype Embed effect effects a = Embed { unEmbed :: Eff (effect effects ': effects) a } +type Embed effect effects = Eff (effect effects ': effects) runType :: ( effects ~ (Function effects Type ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) , (Function effects Type \\ effects) effects' From 8f15f7155d278c49b08d2ba19a963dcb4867b330 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 17:29:49 -0400 Subject: [PATCH 124/174] :fire: builtinId/builtinConst. --- src/Control/Abstract/Value.hs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 48c6f636c..3711e5827 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -128,15 +128,6 @@ runType :: ( effects ~ (Function effects Type ': Unit Type ': Boolean Type ': Va runType = runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType allocType assignType -builtinId :: (Effectful m, Members '[Fresh, Function effects value, Variable value] effects, Monad (m effects)) - => m effects value -builtinId = lambda' variable' - -builtinConst :: (Effectful m, Members '[Fresh, Function effects value, Variable value] effects, Monad (m effects)) - => m effects value -builtinConst = lambda' (\ name -> lambda' (const (variable' name))) - - data Function effects value return where Lambda :: [Name] -> Set Name -> Eff effects value -> Function effects value value Call :: value -> [Eff effects value] -> Function effects value value From 56742b494a5c1673e400f8185925e02ae20ff4bb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 17:32:33 -0400 Subject: [PATCH 125/174] Parameterize Value by the list of effects. --- src/Control/Abstract/Value.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 3711e5827..0de83020a 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -180,12 +180,12 @@ data Boolean value return where AsBool :: value -> Boolean value Bool -data Value m location - = Closure [Name] (m (Value m location)) (Map Name location) +data Value effects location + = Closure [Name] (Eff effects (Value effects location)) (Map Name location) | Unit' | Bool' Bool -liftHandler :: Functor m => (forall a . m a -> m' a) -> Value m location -> Value m' location +liftHandler :: (forall a . Eff effects a -> Eff effects' a) -> Value effects location -> Value effects' location liftHandler handler = go where go (Closure names body env) = Closure names (handler (go <$> body)) env runFunctionValue :: forall m location effects effects' a @@ -200,10 +200,10 @@ runFunctionValue :: forall m location effects effects' a ] effects' , Monad (m location effects) , Monad (m location effects') - , (Function effects (Value (m location effects) location) \\ effects) effects' + , (Function effects (Value effects location) \\ effects) effects' ) => (Name -> m location effects location) - -> (location -> Value (m location effects) location -> m location effects ()) + -> (location -> Value effects location -> m location effects ()) -> m location effects a -> m location effects' a runFunctionValue alloc assign = go @@ -213,7 +213,7 @@ runFunctionValue alloc assign = go packageInfo <- currentPackage moduleInfo <- currentModule env <- Map.filterWithKey (fmap (`Set.member` fvs) . const) <$> ask - let body' = withCurrentPackage packageInfo (withCurrentModule moduleInfo (raiseEff body)) + let body' = withCurrentPackage packageInfo (withCurrentModule moduleInfo body) pure (Closure params body' env) Call (Closure paramNames body env) params -> go $ do bindings <- foldr (\ (name, param) rest -> do @@ -221,11 +221,11 @@ runFunctionValue alloc assign = go a <- alloc name assign a v Map.insert name a <$> rest) (pure env) (zip paramNames (map raiseEff params)) - local (Map.unionWith const bindings) body + local (Map.unionWith const bindings) (raiseEff body) runUnitValue :: ( Applicative (m location effects') , Effectful (m location) - , (Unit (Value (m location effects) location) \\ effects) effects' + , (Unit (Value effects location) \\ effects) effects' ) => m location effects a -> m location effects' a @@ -233,7 +233,7 @@ runUnitValue = interpretAny (\ Unit -> pure Unit') runBooleanValue :: ( Applicative (m location effects') , Effectful (m location) - , (Boolean (Value (m location effects) location) \\ effects) effects' + , (Boolean (Value effects location) \\ effects) effects' ) => m location effects a -> m location effects' a From e17be092ec6d5e710b37f48025acabd79eced8b5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 17:33:18 -0400 Subject: [PATCH 126/174] =?UTF-8?q?Swap=20Value=E2=80=99s=20parameters.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Value.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 0de83020a..aaa9dd831 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -180,12 +180,12 @@ data Boolean value return where AsBool :: value -> Boolean value Bool -data Value effects location - = Closure [Name] (Eff effects (Value effects location)) (Map Name location) +data Value location effects + = Closure [Name] (Eff effects (Value location effects)) (Map Name location) | Unit' | Bool' Bool -liftHandler :: (forall a . Eff effects a -> Eff effects' a) -> Value effects location -> Value effects' location +liftHandler :: (forall a . Eff effects a -> Eff effects' a) -> Value location effects -> Value location effects' liftHandler handler = go where go (Closure names body env) = Closure names (handler (go <$> body)) env runFunctionValue :: forall m location effects effects' a @@ -200,10 +200,10 @@ runFunctionValue :: forall m location effects effects' a ] effects' , Monad (m location effects) , Monad (m location effects') - , (Function effects (Value effects location) \\ effects) effects' + , (Function effects (Value location effects) \\ effects) effects' ) => (Name -> m location effects location) - -> (location -> Value effects location -> m location effects ()) + -> (location -> Value location effects -> m location effects ()) -> m location effects a -> m location effects' a runFunctionValue alloc assign = go @@ -225,7 +225,7 @@ runFunctionValue alloc assign = go runUnitValue :: ( Applicative (m location effects') , Effectful (m location) - , (Unit (Value effects location) \\ effects) effects' + , (Unit (Value location effects) \\ effects) effects' ) => m location effects a -> m location effects' a @@ -233,7 +233,7 @@ runUnitValue = interpretAny (\ Unit -> pure Unit') runBooleanValue :: ( Applicative (m location effects') , Effectful (m location) - , (Boolean (Value effects location) \\ effects) effects' + , (Boolean (Value location effects) \\ effects) effects' ) => m location effects a -> m location effects' a From 98523e4aac4646037554f1dc83a00cb87328c89f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 17:34:23 -0400 Subject: [PATCH 127/174] =?UTF-8?q?Swap=20Function=E2=80=99s=20parameters.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Value.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index aaa9dd831..19537b21c 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -49,14 +49,14 @@ class AbstractHole value where hole :: value -lambda :: (Effectful m, Member (Function effects value) effects) => [Name] -> Set Name -> m effects value -> m effects value +lambda :: (Effectful m, Member (Function value effects) effects) => [Name] -> Set Name -> m effects value -> m effects value lambda paramNames fvs body = send (Lambda paramNames fvs (lowerEff body)) -call' :: (Effectful m, Member (Function effects value) effects) => value -> [m effects value] -> m effects value +call' :: (Effectful m, Member (Function value effects) effects) => value -> [m effects value] -> m effects value call' fn params = send (Call fn (map lowerEff params)) -lambda' :: (Effectful m, Members '[Fresh, Function effects value] effects, Monad (m effects)) +lambda' :: (Effectful m, Members '[Fresh, Function value effects] effects, Monad (m effects)) => (Name -> m effects value) -> m effects value lambda' body = do @@ -92,7 +92,7 @@ runHeapType = runState Map.empty prog :: ( Effectful m , Members '[ Boolean value , Fresh - , Function effects value + , Function value effects , Unit value , Variable value ] effects @@ -113,8 +113,8 @@ data EmbedAny effect effects return where type Embed effect effects = Eff (effect effects ': effects) -runType :: ( effects ~ (Function effects Type ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) - , (Function effects Type \\ effects) effects' +runType :: ( effects ~ (Function Type effects ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) + , (Function Type effects \\ effects) effects' , effects' ~ (Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) , (Unit Type \\ effects') effects'' , effects'' ~ (Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) @@ -128,9 +128,9 @@ runType :: ( effects ~ (Function effects Type ': Unit Type ': Boolean Type ': Va runType = runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType allocType assignType -data Function effects value return where - Lambda :: [Name] -> Set Name -> Eff effects value -> Function effects value value - Call :: value -> [Eff effects value] -> Function effects value value +data Function value effects return where + Lambda :: [Name] -> Set Name -> Eff effects value -> Function value effects value + Call :: value -> [Eff effects value] -> Function value effects value variable' :: (Effectful m, Member (Variable value) effects) => Name -> m effects value variable' = send . Variable @@ -200,7 +200,7 @@ runFunctionValue :: forall m location effects effects' a ] effects' , Monad (m location effects) , Monad (m location effects') - , (Function effects (Value location effects) \\ effects) effects' + , (Function (Value location effects) effects \\ effects) effects' ) => (Name -> m location effects location) -> (location -> Value location effects -> m location effects ()) @@ -258,7 +258,7 @@ runFunctionType :: forall m location effects effects' a , Reader PackageInfo ] effects , Monad (m location effects) - , (Function effects Type \\ effects) effects' + , (Function Type effects \\ effects) effects' ) => (Name -> m location effects location) -> (location -> Type -> m location effects ()) From 4bffbb5c28e9045a5af0b5a1f14955856ac7ff34 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 May 2018 15:36:09 -0700 Subject: [PATCH 128/174] Assign Haskell files without a module declaration --- src/Language/Haskell/Assignment.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index 0276dd867..64cc05980 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -9,7 +9,7 @@ module Language.Haskell.Assignment import Assigning.Assignment hiding (Assignment, Error) import Data.Record import Data.Sum -import Data.Syntax (emptyTerm, handleError, parseError, makeTerm, contextualize, postContextualize) +import Data.Syntax (emptyTerm, handleError, parseError, makeTerm, makeTerm'', contextualize, postContextualize) import Language.Haskell.Grammar as Grammar import qualified Assigning.Assignment as Assignment import qualified Data.Abstract.FreeVariables as FV @@ -37,7 +37,13 @@ assignment :: Assignment assignment = handleError $ module' <|> parseError module' :: Assignment -module' = makeTerm <$> symbol Module <*> children (Syntax.Module <$> moduleIdentifier <*> pure [] <*> (where' <|> emptyTerm)) +module' = makeTerm + <$> symbol Module + <*> children (Syntax.Module <$> (moduleIdentifier <|> emptyTerm) <*> pure [] <*> (where' <|> expressions <|> emptyTerm)) + + +expressions :: Assignment +expressions = makeTerm'' <$> location <*> many expression expression :: Assignment expression = term (handleError (choice expressionChoices)) From e0bc3fd533ae40796ced9e5726c4490ee6d128cf Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 May 2018 15:37:15 -0700 Subject: [PATCH 129/174] Assign integer literals --- src/Language/Haskell/Assignment.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index 64cc05980..a98bca932 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -15,12 +15,14 @@ import qualified Assigning.Assignment as Assignment import qualified Data.Abstract.FreeVariables as FV import qualified Data.Syntax as Syntax import qualified Data.Syntax.Comment as Comment +import qualified Data.Syntax.Literal as Literal import qualified Data.Term as Term import qualified Language.Haskell.Syntax as Syntax import Prologue type Syntax = '[ Comment.Comment + , Literal.Integer , Syntax.Context , Syntax.Empty , Syntax.Error @@ -51,6 +53,7 @@ expression = term (handleError (choice expressionChoices)) expressionChoices :: [Assignment.Assignment [] Grammar Term] expressionChoices = [ constructorIdentifier + , integer , moduleIdentifier , comment , where' @@ -62,6 +65,8 @@ term term = contextualize comment (postContextualize comment term) comment :: Assignment comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) +variableIdentifier :: Assignment +variableIdentifier = makeTerm <$> symbol VariableIdentifier <*> (Syntax.Identifier . FV.name <$> source) constructorIdentifier :: Assignment constructorIdentifier = makeTerm <$> symbol ConstructorIdentifier <*> (Syntax.Identifier . FV.name <$> source) @@ -70,3 +75,6 @@ moduleIdentifier = makeTerm <$> symbol ModuleIdentifier <*> (Syntax.Identifier . where' :: Assignment where' = makeTerm <$> (symbol Where <|> symbol Where') <*> children (many expression) +integer :: Assignment +integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source) + From 5463ab4a2895fe55f4ef6bf67607c0539d66184d Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 May 2018 15:37:50 -0700 Subject: [PATCH 130/174] Assign function declarations --- src/Language/Haskell/Assignment.hs | 25 +++++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index a98bca932..3c2c7d218 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -15,6 +15,7 @@ import qualified Assigning.Assignment as Assignment import qualified Data.Abstract.FreeVariables as FV 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.Term as Term import qualified Language.Haskell.Syntax as Syntax @@ -22,6 +23,7 @@ import Prologue type Syntax = '[ Comment.Comment + , Declaration.Function , Literal.Integer , Syntax.Context , Syntax.Empty @@ -52,10 +54,12 @@ expression = term (handleError (choice expressionChoices)) expressionChoices :: [Assignment.Assignment [] Grammar Term] expressionChoices = [ - constructorIdentifier + comment + , constructorIdentifier + , functionDeclaration , integer , moduleIdentifier - , comment + , variableIdentifier , where' ] @@ -67,6 +71,7 @@ comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) variableIdentifier :: Assignment variableIdentifier = makeTerm <$> symbol VariableIdentifier <*> (Syntax.Identifier . FV.name <$> source) + constructorIdentifier :: Assignment constructorIdentifier = makeTerm <$> symbol ConstructorIdentifier <*> (Syntax.Identifier . FV.name <$> source) @@ -75,6 +80,22 @@ moduleIdentifier = makeTerm <$> symbol ModuleIdentifier <*> (Syntax.Identifier . where' :: Assignment where' = makeTerm <$> (symbol Where <|> symbol Where') <*> children (many expression) + +functionBody :: Assignment +functionBody = makeTerm <$> symbol FunctionBody <*> children (many expression) + +functionDeclaration :: Assignment +functionDeclaration = makeTerm + <$> symbol FunctionDeclaration + <*> children (Declaration.Function + <$> pure [] + <*> variableIdentifier + <*> ((manyTermsTill expression (symbol FunctionBody)) <|> pure []) + <*> functionBody) + integer :: Assignment integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> 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 end = manyTill (step <|> comment) end From fdbbac199880c2b49dcea07322b8cdaeba08bc6c Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 May 2018 15:55:14 -0700 Subject: [PATCH 131/174] Assign float literals --- src/Language/Haskell/Assignment.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index 3c2c7d218..2e6d7642e 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.Float , Literal.Integer , Syntax.Context , Syntax.Empty @@ -56,6 +57,7 @@ expressionChoices :: [Assignment.Assignment [] Grammar Term] expressionChoices = [ comment , constructorIdentifier + , float , functionDeclaration , integer , moduleIdentifier @@ -96,6 +98,9 @@ functionDeclaration = makeTerm integer :: Assignment integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source) +float :: Assignment +float = makeTerm <$> symbol Float <*> (Literal.Float <$> 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 end = manyTill (step <|> comment) end From 32619a812453b07fe66ce6acb21fe15a50168e63 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 May 2018 15:55:26 -0700 Subject: [PATCH 132/174] Add literal test fixtures --- test/fixtures/haskell/corpus/literals.A.hs | 37 +++ test/fixtures/haskell/corpus/literals.B.hs | 37 +++ .../haskell/corpus/literals.diffA-B.txt | 232 ++++++++++++++++++ .../haskell/corpus/literals.diffB-A.txt | 230 +++++++++++++++++ .../haskell/corpus/literals.parseA.txt | 119 +++++++++ .../haskell/corpus/literals.parseB.txt | 119 +++++++++ 6 files changed, 774 insertions(+) create mode 100644 test/fixtures/haskell/corpus/literals.A.hs create mode 100644 test/fixtures/haskell/corpus/literals.B.hs create mode 100644 test/fixtures/haskell/corpus/literals.diffA-B.txt create mode 100644 test/fixtures/haskell/corpus/literals.diffB-A.txt create mode 100644 test/fixtures/haskell/corpus/literals.parseA.txt create mode 100644 test/fixtures/haskell/corpus/literals.parseB.txt diff --git a/test/fixtures/haskell/corpus/literals.A.hs b/test/fixtures/haskell/corpus/literals.A.hs new file mode 100644 index 000000000..210598ae6 --- /dev/null +++ b/test/fixtures/haskell/corpus/literals.A.hs @@ -0,0 +1,37 @@ +module A where +a = 0 +a = 1 + +a = 0o00 +a = 0O77 + +a = 0x00 +a = 0XFF + +a = 0.00 +a = 0.99 + +a = 0.00e01 +a = 0.99E01 +a = 0.00e+01 +a = 0.99E-01 +a = 0.00e-01 +a = 0.99E+01 + +a = 00e01 +a = 99E01 +a = 00e+01 +a = 99E-01 +a = 00e-01 +a = 99E+01 + +a = undefined +_a0 = undefined +_A0 = undefined +a0 = undefined +a9 = undefined +aA = undefined +aZ' = undefined + +a = True +a = False diff --git a/test/fixtures/haskell/corpus/literals.B.hs b/test/fixtures/haskell/corpus/literals.B.hs new file mode 100644 index 000000000..d41b1b37a --- /dev/null +++ b/test/fixtures/haskell/corpus/literals.B.hs @@ -0,0 +1,37 @@ +module A where +b = 0 +b = 1 + +b = 0o00 +b = 0O77 + +b = 0x00 +b = 0XFF + +b = 0.00 +b = 0.99 + +b = 0.00e01 +b = 0.99E01 +b = 0.00e+01 +b = 0.99E-01 +b = 0.00e-01 +b = 0.99E+01 + +b = 00e01 +b = 99E01 +b = 00e+01 +b = 99E-01 +b = 00e-01 +b = 99E+01 + +b = undefined +ba0 = undefined +bA0 = undefined +b0 = undefined +b9 = undefined +bA = undefined +bZ' = undefined + +b = True +b = False diff --git a/test/fixtures/haskell/corpus/literals.diffA-B.txt b/test/fixtures/haskell/corpus/literals.diffA-B.txt new file mode 100644 index 000000000..a7e1f8237 --- /dev/null +++ b/test/fixtures/haskell/corpus/literals.diffA-B.txt @@ -0,0 +1,232 @@ +(Module + (Identifier) + ( + (Function + { (Identifier) + ->(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)+} + {+( + {+(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)-} + {-( + {-(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)-})-})-})) diff --git a/test/fixtures/haskell/corpus/literals.diffB-A.txt b/test/fixtures/haskell/corpus/literals.diffB-A.txt new file mode 100644 index 000000000..34000a913 --- /dev/null +++ b/test/fixtures/haskell/corpus/literals.diffB-A.txt @@ -0,0 +1,230 @@ +(Module + (Identifier) + ( + (Function + { (Identifier) + ->(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)+} + {+( + {+(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) } + ( + {+(Identifier)+} + {-(Integer)-})) + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {+(Function + {+(Identifier)+} + {+( + {+(Identifier)+})+})+} + {-(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)-})-})-})) diff --git a/test/fixtures/haskell/corpus/literals.parseA.txt b/test/fixtures/haskell/corpus/literals.parseA.txt new file mode 100644 index 000000000..40982fe4b --- /dev/null +++ b/test/fixtures/haskell/corpus/literals.parseA.txt @@ -0,0 +1,119 @@ +(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) + ( + (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))))) diff --git a/test/fixtures/haskell/corpus/literals.parseB.txt b/test/fixtures/haskell/corpus/literals.parseB.txt new file mode 100644 index 000000000..40982fe4b --- /dev/null +++ b/test/fixtures/haskell/corpus/literals.parseB.txt @@ -0,0 +1,119 @@ +(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) + ( + (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))))) From 3d70af57a451a074476863acf8a436ab20953892 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 May 2018 15:59:32 -0700 Subject: [PATCH 133/174] Add blank file test fixture --- test/fixtures/haskell/corpus/blank.A.hs | 0 test/fixtures/haskell/corpus/blank.parseA.txt | 3 +++ 2 files changed, 3 insertions(+) create mode 100644 test/fixtures/haskell/corpus/blank.A.hs create mode 100644 test/fixtures/haskell/corpus/blank.parseA.txt diff --git a/test/fixtures/haskell/corpus/blank.A.hs b/test/fixtures/haskell/corpus/blank.A.hs new file mode 100644 index 000000000..e69de29bb diff --git a/test/fixtures/haskell/corpus/blank.parseA.txt b/test/fixtures/haskell/corpus/blank.parseA.txt new file mode 100644 index 000000000..0fc8549c6 --- /dev/null +++ b/test/fixtures/haskell/corpus/blank.parseA.txt @@ -0,0 +1,3 @@ +(Module + (Empty) + ([])) From 3818e06ab608fd863b3221eb15659eeee022e56b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 19:09:08 -0400 Subject: [PATCH 134/174] Add an opaque parameter to Eval. --- src/Control/Abstract/Value.hs | 102 +++++++++++++++++----------------- 1 file changed, 51 insertions(+), 51 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 19537b21c..5a6db17ed 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -63,18 +63,18 @@ lambda' body = do var <- nameI <$> fresh lambda [var] lowerBound (body var) -lookup' :: (Effectful (m location), Functor (m location effects), Member (Reader (Map Name location)) effects) => Name -> m location effects (Maybe location) +lookup' :: (Effectful (m location opaque), Functor (m location opaque effects), Member (Reader (Map Name location)) effects) => Name -> m location opaque effects (Maybe location) lookup' name = Map.lookup name <$> ask -allocType :: (Applicative (m Name effects), Effectful (m Name)) => Name -> m Name effects Name +allocType :: (Applicative (m Name opaque effects), Effectful (m Name opaque)) => Name -> m Name opaque effects Name allocType = pure -assignType :: (Effectful (m location), Member (State (Map location (Set Type))) effects, Monad (m location effects), Ord location) => location -> Type -> m location effects () +assignType :: (Effectful (m location opaque), Member (State (Map location (Set Type))) effects, Monad (m location opaque effects), Ord location) => location -> Type -> m location opaque effects () assignType addr value = do cell <- gets (Map.lookup addr) >>= maybeM (pure (Set.empty)) modify' (Map.insert addr (Set.insert value cell)) -derefType :: (Alternative (m location effects), Effectful (m location), Members '[Fail, NonDet, State (Map location (Set Type))] effects, Monad (m location effects), Ord location, Show location) => location -> m location effects (Maybe Type) +derefType :: (Alternative (m location opaque effects), Effectful (m location opaque), Members '[Fail, NonDet, State (Map location (Set Type))] effects, Monad (m location opaque effects), Ord location, Show location) => location -> m location opaque effects (Maybe Type) derefType addr = do cell <- gets (Map.lookup addr) >>= maybeM (raiseEff (fail ("unallocated address: " <> show addr))) if Set.null cell then @@ -82,10 +82,10 @@ derefType addr = do else Set.foldr ((<|>) . pure . Just) empty cell -runEnv :: Effectful (m location) => m location (Reader (Map Name location) ': effects) a -> m location effects a +runEnv :: Effectful (m location opaque) => m location opaque (Reader (Map Name location) ': effects) a -> m location opaque effects a runEnv = runReader Map.empty -runHeapType :: Effectful (m Name) => m Name (State (Map Name (Set Type)) ': effects) a -> m Name effects (a, Map Name (Set Type)) +runHeapType :: Effectful (m Name opaque) => m Name opaque (State (Map Name (Set Type)) ': effects) a -> m Name opaque effects (a, Map Name (Set Type)) runHeapType = runState Map.empty @@ -103,10 +103,10 @@ prog b = do identity <- lambda' variable' iff b unit' (call' identity [unit']) -newtype Eval location effects a = Eval { runEval :: Eff effects a } +newtype Eval location opaque effects a = Eval { runEval :: Eff effects a } deriving (Applicative, Effectful, Functor, Monad) -deriving instance Member NonDet effects => Alternative (Eval location effects) +deriving instance Member NonDet effects => Alternative (Eval location opaque effects) data EmbedAny effect effects return where EmbedAny :: (effect \\ effects') effects => Eff effects' a -> EmbedAny effect effects a @@ -123,8 +123,8 @@ runType :: ( effects ~ (Function Type effects ': Unit Type ': Boolean Type ': Va , (Variable Type \\ effects''') effects'''' , effects'''' ~ (State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) ) - => Eval Name effects a - -> Eval Name rest [Either String (a, Map Name (Set Type))] + => Eval Name opaque effects a + -> Eval Name opaque rest [Either String (a, Map Name (Set Type))] runType = runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType allocType assignType @@ -138,21 +138,21 @@ variable' = send . Variable data Variable value return where Variable :: Name -> Variable value value -runVariable :: forall m location effects effects' value a - . ( Effectful (m location) +runVariable :: forall m location opaque effects effects' value a + . ( Effectful (m location opaque) , (Variable value \\ effects) effects' , Members '[ Fail , Reader (Map Name location) , State (Map location value) ] effects' - , Monad (m location effects') + , Monad (m location opaque effects') , Show location ) - => (location -> m location effects' (Maybe value)) - -> m location effects a - -> m location effects' a + => (location -> m location opaque effects' (Maybe value)) + -> m location opaque effects a + -> m location opaque effects' a runVariable deref = go - where go :: forall a . m location effects a -> m location effects' a + where go :: forall a . m location opaque effects a -> m location opaque effects' a go = interpretAny (\ (Variable name) -> do addr <- lookup' name >>= maybeM (raiseEff (fail ("free variable: " <> show name))) deref addr >>= maybeM (raiseEff (fail ("uninitialized address: " <> show addr)))) @@ -188,8 +188,8 @@ data Value location effects liftHandler :: (forall a . Eff effects a -> Eff effects' a) -> Value location effects -> Value location effects' liftHandler handler = go where go (Closure names body env) = Closure names (handler (go <$> body)) env -runFunctionValue :: forall m location effects effects' a - . ( Effectful (m location) +runFunctionValue :: forall m location opaque effects effects' a + . ( Effectful (m location opaque) , Members '[ Reader (Map Name location) , Reader ModuleInfo , Reader PackageInfo @@ -198,16 +198,16 @@ runFunctionValue :: forall m location effects effects' a , Reader ModuleInfo , Reader PackageInfo ] effects' - , Monad (m location effects) - , Monad (m location effects') + , Monad (m location opaque effects) + , Monad (m location opaque effects') , (Function (Value location effects) effects \\ effects) effects' ) - => (Name -> m location effects location) - -> (location -> Value location effects -> m location effects ()) - -> m location effects a - -> m location effects' a + => (Name -> m location opaque effects location) + -> (location -> Value location effects -> m location opaque effects ()) + -> m location opaque effects a + -> m location opaque effects' a runFunctionValue alloc assign = go - where go :: forall a . m location effects a -> m location effects' a + where go :: forall a . m location opaque effects a -> m location opaque effects' a go = interpretAny $ \ eff -> case eff of Lambda params fvs body -> do packageInfo <- currentPackage @@ -223,20 +223,20 @@ runFunctionValue alloc assign = go Map.insert name a <$> rest) (pure env) (zip paramNames (map raiseEff params)) local (Map.unionWith const bindings) (raiseEff body) -runUnitValue :: ( Applicative (m location effects') - , Effectful (m location) +runUnitValue :: ( Applicative (m location opaque effects') + , Effectful (m location opaque) , (Unit (Value location effects) \\ effects) effects' ) - => m location effects a - -> m location effects' a + => m location opaque effects a + -> m location opaque effects' a runUnitValue = interpretAny (\ Unit -> pure Unit') -runBooleanValue :: ( Applicative (m location effects') - , Effectful (m location) +runBooleanValue :: ( Applicative (m location opaque effects') + , Effectful (m location opaque) , (Boolean (Value location effects) \\ effects) effects' ) - => m location effects a - -> m location effects' a + => m location opaque effects a + -> m location opaque effects' a runBooleanValue = interpretAny (\ eff -> case eff of Bool b -> pure (Bool' b) AsBool (Bool' b) -> pure b) @@ -249,23 +249,23 @@ data Type | BoolT deriving (Eq, Ord, Show) -runFunctionType :: forall m location effects effects' a - . ( Alternative (m location effects) - , Effectful (m location) +runFunctionType :: forall m location opaque effects effects' a + . ( Alternative (m location opaque effects) + , Effectful (m location opaque) , Members '[ Fresh , Reader (Map Name location) , Reader ModuleInfo , Reader PackageInfo ] effects - , Monad (m location effects) + , Monad (m location opaque effects) , (Function Type effects \\ effects) effects' ) - => (Name -> m location effects location) - -> (location -> Type -> m location effects ()) - -> m location effects a - -> m location effects' a + => (Name -> m location opaque effects location) + -> (location -> Type -> m location opaque effects ()) + -> m location opaque effects a + -> m location opaque effects' a runFunctionType alloc assign = go - where go :: forall a . m location effects a -> m location effects' a + where go :: forall a . m location opaque effects a -> m location opaque effects' a go = interpretAny $ \ eff -> case eff of Lambda params _ body -> go $ do (bindings, tvars) <- foldr (\ name rest -> do @@ -282,20 +282,20 @@ runFunctionType alloc assign = go pure ret _ -> empty -runUnitType :: ( Applicative (m location effects') - , Effectful (m location) +runUnitType :: ( Applicative (m location opaque effects') + , Effectful (m location opaque) , (Unit Type \\ effects) effects' ) - => m location effects a - -> m location effects' a + => m location opaque effects a + -> m location opaque effects' a runUnitType = interpretAny (\ Unit -> pure (Product [])) -runBooleanType :: ( Alternative (m location effects') - , Effectful (m location) +runBooleanType :: ( Alternative (m location opaque effects') + , Effectful (m location opaque) , (Boolean Type \\ effects) effects' ) - => m location effects a - -> m location effects' a + => m location opaque effects a + -> m location opaque effects' a runBooleanType = interpretAny (\ eff -> case eff of Bool _ -> pure BoolT AsBool BoolT -> pure True <|> pure False) From 65ef9c2304cecdf7aa768495dd31a2524e4fabff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 09:23:25 -0400 Subject: [PATCH 135/174] Assign variables in a zip. --- 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 5a6db17ed..b142aa3d6 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -216,11 +216,11 @@ runFunctionValue alloc assign = go let body' = withCurrentPackage packageInfo (withCurrentModule moduleInfo body) pure (Closure params body' env) Call (Closure paramNames body env) params -> go $ do - bindings <- foldr (\ (name, param) rest -> do + bindings <- foldr (uncurry (Map.insert)) env <$> sequenceA (zipWith (\ name param -> do v <- param a <- alloc name assign a v - Map.insert name a <$> rest) (pure env) (zip paramNames (map raiseEff params)) + pure (name, a)) paramNames (map raiseEff params)) local (Map.unionWith const bindings) (raiseEff body) runUnitValue :: ( Applicative (m location opaque effects') From 15835e5b7c15ccfbceb88641b110b14896128f8d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 09:46:32 -0400 Subject: [PATCH 136/174] Add a value parameter to Eval. --- src/Control/Abstract/Value.hs | 98 +++++++++++++++++------------------ 1 file changed, 49 insertions(+), 49 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index b142aa3d6..bd31cba6d 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -63,18 +63,18 @@ lambda' body = do var <- nameI <$> fresh lambda [var] lowerBound (body var) -lookup' :: (Effectful (m location opaque), Functor (m location opaque effects), Member (Reader (Map Name location)) effects) => Name -> m location opaque effects (Maybe location) +lookup' :: (Effectful (m location value opaque), Functor (m location value opaque effects), Member (Reader (Map Name location)) effects) => Name -> m location value opaque effects (Maybe location) lookup' name = Map.lookup name <$> ask -allocType :: (Applicative (m Name opaque effects), Effectful (m Name opaque)) => Name -> m Name opaque effects Name +allocType :: (Applicative (m Name Type opaque effects), Effectful (m Name Type opaque)) => Name -> m Name Type opaque effects Name allocType = pure -assignType :: (Effectful (m location opaque), Member (State (Map location (Set Type))) effects, Monad (m location opaque effects), Ord location) => location -> Type -> m location opaque effects () +assignType :: (Effectful (m location Type opaque), Member (State (Map location (Set Type))) effects, Monad (m location Type opaque effects), Ord location) => location -> Type -> m location Type opaque effects () assignType addr value = do cell <- gets (Map.lookup addr) >>= maybeM (pure (Set.empty)) modify' (Map.insert addr (Set.insert value cell)) -derefType :: (Alternative (m location opaque effects), Effectful (m location opaque), Members '[Fail, NonDet, State (Map location (Set Type))] effects, Monad (m location opaque effects), Ord location, Show location) => location -> m location opaque effects (Maybe Type) +derefType :: (Alternative (m location Type opaque effects), Effectful (m location Type opaque), Members '[Fail, NonDet, State (Map location (Set Type))] effects, Monad (m location Type opaque effects), Ord location, Show location) => location -> m location Type opaque effects (Maybe Type) derefType addr = do cell <- gets (Map.lookup addr) >>= maybeM (raiseEff (fail ("unallocated address: " <> show addr))) if Set.null cell then @@ -82,10 +82,10 @@ derefType addr = do else Set.foldr ((<|>) . pure . Just) empty cell -runEnv :: Effectful (m location opaque) => m location opaque (Reader (Map Name location) ': effects) a -> m location opaque effects a +runEnv :: Effectful (m location value opaque) => m location value opaque (Reader (Map Name location) ': effects) a -> m location value opaque effects a runEnv = runReader Map.empty -runHeapType :: Effectful (m Name opaque) => m Name opaque (State (Map Name (Set Type)) ': effects) a -> m Name opaque effects (a, Map Name (Set Type)) +runHeapType :: Effectful (m Name Type opaque) => m Name Type opaque (State (Map Name (Set Type)) ': effects) a -> m Name Type opaque effects (a, Map Name (Set Type)) runHeapType = runState Map.empty @@ -103,10 +103,10 @@ prog b = do identity <- lambda' variable' iff b unit' (call' identity [unit']) -newtype Eval location opaque effects a = Eval { runEval :: Eff effects a } +newtype Eval location value opaque effects a = Eval { runEval :: Eff effects a } deriving (Applicative, Effectful, Functor, Monad) -deriving instance Member NonDet effects => Alternative (Eval location opaque effects) +deriving instance Member NonDet effects => Alternative (Eval location value opaque effects) data EmbedAny effect effects return where EmbedAny :: (effect \\ effects') effects => Eff effects' a -> EmbedAny effect effects a @@ -123,8 +123,8 @@ runType :: ( effects ~ (Function Type effects ': Unit Type ': Boolean Type ': Va , (Variable Type \\ effects''') effects'''' , effects'''' ~ (State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) ) - => Eval Name opaque effects a - -> Eval Name opaque rest [Either String (a, Map Name (Set Type))] + => Eval Name Type opaque effects a + -> Eval Name Type opaque rest [Either String (a, Map Name (Set Type))] runType = runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType allocType assignType @@ -138,21 +138,21 @@ variable' = send . Variable data Variable value return where Variable :: Name -> Variable value value -runVariable :: forall m location opaque effects effects' value a - . ( Effectful (m location opaque) +runVariable :: forall m location value opaque effects effects' a + . ( Effectful (m location value opaque) , (Variable value \\ effects) effects' , Members '[ Fail , Reader (Map Name location) , State (Map location value) ] effects' - , Monad (m location opaque effects') + , Monad (m location value opaque effects') , Show location ) - => (location -> m location opaque effects' (Maybe value)) - -> m location opaque effects a - -> m location opaque effects' a + => (location -> m location value opaque effects' (Maybe value)) + -> m location value opaque effects a + -> m location value opaque effects' a runVariable deref = go - where go :: forall a . m location opaque effects a -> m location opaque effects' a + where go :: forall a . m location value opaque effects a -> m location value opaque effects' a go = interpretAny (\ (Variable name) -> do addr <- lookup' name >>= maybeM (raiseEff (fail ("free variable: " <> show name))) deref addr >>= maybeM (raiseEff (fail ("uninitialized address: " <> show addr)))) @@ -189,7 +189,7 @@ liftHandler :: (forall a . Eff effects a -> Eff effects' a) -> Value location ef liftHandler handler = go where go (Closure names body env) = Closure names (handler (go <$> body)) env runFunctionValue :: forall m location opaque effects effects' a - . ( Effectful (m location opaque) + . ( Effectful (m location (Value location effects) opaque) , Members '[ Reader (Map Name location) , Reader ModuleInfo , Reader PackageInfo @@ -198,16 +198,16 @@ runFunctionValue :: forall m location opaque effects effects' a , Reader ModuleInfo , Reader PackageInfo ] effects' - , Monad (m location opaque effects) - , Monad (m location opaque effects') + , Monad (m location (Value location effects) opaque effects) + , Monad (m location (Value location effects) opaque effects') , (Function (Value location effects) effects \\ effects) effects' ) - => (Name -> m location opaque effects location) - -> (location -> Value location effects -> m location opaque effects ()) - -> m location opaque effects a - -> m location opaque effects' a + => (Name -> m location (Value location effects) opaque effects location) + -> (location -> Value location effects -> m location (Value location effects) opaque effects ()) + -> m location (Value location effects) opaque effects a + -> m location (Value location effects) opaque effects' a runFunctionValue alloc assign = go - where go :: forall a . m location opaque effects a -> m location opaque effects' a + where go :: forall a . m location (Value location effects) opaque effects a -> m location (Value location effects) opaque effects' a go = interpretAny $ \ eff -> case eff of Lambda params fvs body -> do packageInfo <- currentPackage @@ -223,20 +223,20 @@ runFunctionValue alloc assign = go pure (name, a)) paramNames (map raiseEff params)) local (Map.unionWith const bindings) (raiseEff body) -runUnitValue :: ( Applicative (m location opaque effects') - , Effectful (m location opaque) +runUnitValue :: ( Applicative (m location (Value location effects) opaque effects') + , Effectful (m location (Value location effects) opaque) , (Unit (Value location effects) \\ effects) effects' ) - => m location opaque effects a - -> m location opaque effects' a + => m location (Value location effects) opaque effects a + -> m location (Value location effects) opaque effects' a runUnitValue = interpretAny (\ Unit -> pure Unit') -runBooleanValue :: ( Applicative (m location opaque effects') - , Effectful (m location opaque) +runBooleanValue :: ( Applicative (m location (Value location effects) opaque effects') + , Effectful (m location (Value location effects) opaque) , (Boolean (Value location effects) \\ effects) effects' ) - => m location opaque effects a - -> m location opaque effects' a + => m location (Value location effects) opaque effects a + -> m location (Value location effects) opaque effects' a runBooleanValue = interpretAny (\ eff -> case eff of Bool b -> pure (Bool' b) AsBool (Bool' b) -> pure b) @@ -250,22 +250,22 @@ data Type deriving (Eq, Ord, Show) runFunctionType :: forall m location opaque effects effects' a - . ( Alternative (m location opaque effects) - , Effectful (m location opaque) + . ( Alternative (m location Type opaque effects) + , Effectful (m location Type opaque) , Members '[ Fresh , Reader (Map Name location) , Reader ModuleInfo , Reader PackageInfo ] effects - , Monad (m location opaque effects) + , Monad (m location Type opaque effects) , (Function Type effects \\ effects) effects' ) - => (Name -> m location opaque effects location) - -> (location -> Type -> m location opaque effects ()) - -> m location opaque effects a - -> m location opaque effects' a + => (Name -> m location Type opaque effects location) + -> (location -> Type -> m location Type opaque effects ()) + -> m location Type opaque effects a + -> m location Type opaque effects' a runFunctionType alloc assign = go - where go :: forall a . m location opaque effects a -> m location opaque effects' a + where go :: forall a . m location Type opaque effects a -> m location Type opaque effects' a go = interpretAny $ \ eff -> case eff of Lambda params _ body -> go $ do (bindings, tvars) <- foldr (\ name rest -> do @@ -282,20 +282,20 @@ runFunctionType alloc assign = go pure ret _ -> empty -runUnitType :: ( Applicative (m location opaque effects') - , Effectful (m location opaque) +runUnitType :: ( Applicative (m location Type opaque effects') + , Effectful (m location Type opaque) , (Unit Type \\ effects) effects' ) - => m location opaque effects a - -> m location opaque effects' a + => m location Type opaque effects a + -> m location Type opaque effects' a runUnitType = interpretAny (\ Unit -> pure (Product [])) -runBooleanType :: ( Alternative (m location opaque effects') - , Effectful (m location opaque) +runBooleanType :: ( Alternative (m location Type opaque effects') + , Effectful (m location Type opaque) , (Boolean Type \\ effects) effects' ) - => m location opaque effects a - -> m location opaque effects' a + => m location Type opaque effects a + -> m location Type opaque effects' a runBooleanType = interpretAny (\ eff -> case eff of Bool _ -> pure BoolT AsBool BoolT -> pure True <|> pure False) From 5609ea996d91a4518c4181f6a1a64ccb61d31f43 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 09:47:52 -0400 Subject: [PATCH 137/174] Specialize all the lambda stuff to Eval. --- src/Control/Abstract/Value.hs | 27 ++++++++++++--------------- 1 file changed, 12 insertions(+), 15 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index bd31cba6d..54d9d7f0d 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -49,16 +49,16 @@ class AbstractHole value where hole :: value -lambda :: (Effectful m, Member (Function value effects) effects) => [Name] -> Set Name -> m effects value -> m effects value +lambda :: Member (Function value effects) effects => [Name] -> Set Name -> Eval location value opaque effects value -> Eval location value opaque effects value lambda paramNames fvs body = send (Lambda paramNames fvs (lowerEff body)) -call' :: (Effectful m, Member (Function value effects) effects) => value -> [m effects value] -> m effects value +call' :: Member (Function value effects) effects => value -> [Eval location value opaque effects value] -> Eval location value opaque effects value call' fn params = send (Call fn (map lowerEff params)) -lambda' :: (Effectful m, Members '[Fresh, Function value effects] effects, Monad (m effects)) - => (Name -> m effects value) - -> m effects value +lambda' :: Members '[Fresh, Function value effects] effects + => (Name -> Eval location value opaque effects value) + -> Eval location value opaque effects value lambda' body = do var <- nameI <$> fresh lambda [var] lowerBound (body var) @@ -89,16 +89,13 @@ runHeapType :: Effectful (m Name Type opaque) => m Name Type opaque (State (Map runHeapType = runState Map.empty -prog :: ( Effectful m - , Members '[ Boolean value - , Fresh - , Function value effects - , Unit value - , Variable value - ] effects - , Monad (m effects) - ) - => value -> m effects value +prog :: Members '[ Boolean value + , Fresh + , Function value effects + , Unit value + , Variable value + ] effects + => value -> Eval location value opaque effects value prog b = do identity <- lambda' variable' iff b unit' (call' identity [unit']) From baa3e535ae7035e8f5aff86f170526573e6168a7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 09:48:55 -0400 Subject: [PATCH 138/174] Specialize lookup' to Eval. --- src/Control/Abstract/Value.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 54d9d7f0d..df15dfe04 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -63,7 +63,7 @@ lambda' body = do var <- nameI <$> fresh lambda [var] lowerBound (body var) -lookup' :: (Effectful (m location value opaque), Functor (m location value opaque effects), Member (Reader (Map Name location)) effects) => Name -> m location value opaque effects (Maybe location) +lookup' :: Member (Reader (Map Name location)) effects => Name -> Eval location value opaque effects (Maybe location) lookup' name = Map.lookup name <$> ask allocType :: (Applicative (m Name Type opaque effects), Effectful (m Name Type opaque)) => Name -> m Name Type opaque effects Name @@ -135,21 +135,19 @@ variable' = send . Variable data Variable value return where Variable :: Name -> Variable value value -runVariable :: forall m location value opaque effects effects' a - . ( Effectful (m location value opaque) - , (Variable value \\ effects) effects' +runVariable :: forall location value opaque effects effects' a + . ( (Variable value \\ effects) effects' , Members '[ Fail , Reader (Map Name location) , State (Map location value) ] effects' - , Monad (m location value opaque effects') , Show location ) - => (location -> m location value opaque effects' (Maybe value)) - -> m location value opaque effects a - -> m location value opaque effects' a + => (location -> Eval location value opaque effects' (Maybe value)) + -> Eval location value opaque effects a + -> Eval location value opaque effects' a runVariable deref = go - where go :: forall a . m location value opaque effects a -> m location value opaque effects' a + where go :: forall a . Eval location value opaque effects a -> Eval location value opaque effects' a go = interpretAny (\ (Variable name) -> do addr <- lookup' name >>= maybeM (raiseEff (fail ("free variable: " <> show name))) deref addr >>= maybeM (raiseEff (fail ("uninitialized address: " <> show addr)))) From 70cbab7860570e9e45dc4fed3306bdf36aa0906f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 09:49:50 -0400 Subject: [PATCH 139/174] Specialize the heap/env stuff to Eval. --- src/Control/Abstract/Value.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index df15dfe04..106a9d6bd 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -66,15 +66,15 @@ lambda' body = do lookup' :: Member (Reader (Map Name location)) effects => Name -> Eval location value opaque effects (Maybe location) lookup' name = Map.lookup name <$> ask -allocType :: (Applicative (m Name Type opaque effects), Effectful (m Name Type opaque)) => Name -> m Name Type opaque effects Name +allocType :: Name -> Eval Name Type opaque effects Name allocType = pure -assignType :: (Effectful (m location Type opaque), Member (State (Map location (Set Type))) effects, Monad (m location Type opaque effects), Ord location) => location -> Type -> m location Type opaque effects () +assignType :: (Member (State (Map location (Set Type))) effects, Ord location) => location -> Type -> Eval location Type opaque effects () assignType addr value = do cell <- gets (Map.lookup addr) >>= maybeM (pure (Set.empty)) modify' (Map.insert addr (Set.insert value cell)) -derefType :: (Alternative (m location Type opaque effects), Effectful (m location Type opaque), Members '[Fail, NonDet, State (Map location (Set Type))] effects, Monad (m location Type opaque effects), Ord location, Show location) => location -> m location Type opaque effects (Maybe Type) +derefType :: (Members '[Fail, NonDet, State (Map location (Set Type))] effects, Ord location, Show location) => location -> Eval location Type opaque effects (Maybe Type) derefType addr = do cell <- gets (Map.lookup addr) >>= maybeM (raiseEff (fail ("unallocated address: " <> show addr))) if Set.null cell then From e13dd0725d9ef92cf821b743b2fde67d165d0aba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 09:50:13 -0400 Subject: [PATCH 140/174] Specialize the env/heap handlers to Eval. --- 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 106a9d6bd..6b6adebf6 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -82,10 +82,10 @@ derefType addr = do else Set.foldr ((<|>) . pure . Just) empty cell -runEnv :: Effectful (m location value opaque) => m location value opaque (Reader (Map Name location) ': effects) a -> m location value opaque effects a +runEnv :: Eval location value opaque (Reader (Map Name location) ': effects) a -> Eval location value opaque effects a runEnv = runReader Map.empty -runHeapType :: Effectful (m Name Type opaque) => m Name Type opaque (State (Map Name (Set Type)) ': effects) a -> m Name Type opaque effects (a, Map Name (Set Type)) +runHeapType :: Eval Name Type opaque (State (Map Name (Set Type)) ': effects) a -> Eval Name Type opaque effects (a, Map Name (Set Type)) runHeapType = runState Map.empty From 6b874d19d77795ee867323c9d5e0e29f56356065 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 09:52:01 -0400 Subject: [PATCH 141/174] Specialize the smart constructors and handlers to Eval. --- src/Control/Abstract/Value.hs | 45 ++++++++++++++--------------------- 1 file changed, 18 insertions(+), 27 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 6b6adebf6..9a20204b8 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -129,7 +129,7 @@ data Function value effects return where Lambda :: [Name] -> Set Name -> Eff effects value -> Function value effects value Call :: value -> [Eff effects value] -> Function value effects value -variable' :: (Effectful m, Member (Variable value) effects) => Name -> m effects value +variable' :: Member (Variable value) effects => Name -> Eval location value opaque effects value variable' = send . Variable data Variable value return where @@ -153,7 +153,7 @@ runVariable deref = go deref addr >>= maybeM (raiseEff (fail ("uninitialized address: " <> show addr)))) -unit' :: (Effectful m, Member (Unit value) effects) => m effects value +unit' :: Member (Unit value) effects => Eval location value opaque effects value unit' = send Unit @@ -161,13 +161,13 @@ data Unit value return where Unit :: Unit value value -bool :: (Effectful m, Member (Boolean value) effects) => Bool -> m effects value +bool :: Member (Boolean value) effects => Bool -> Eval location value opaque effects value bool = send . Bool -asBool' :: (Effectful m, Member (Boolean value) effects) => value -> m effects Bool +asBool' :: Member (Boolean value) effects => value -> Eval location value opaque effects Bool asBool' = send . AsBool -iff :: (Effectful m, Member (Boolean value) effects, Monad (m effects)) => value -> m effects a -> m effects a -> m effects a +iff :: Member (Boolean value) effects => value -> Eval location value opaque effects a -> Eval location value opaque effects a -> Eval location value opaque effects a iff c t e = asBool' c >>= \ c' -> if c' then t else e data Boolean value return where @@ -183,9 +183,8 @@ data Value location effects liftHandler :: (forall a . Eff effects a -> Eff effects' a) -> Value location effects -> Value location effects' liftHandler handler = go where go (Closure names body env) = Closure names (handler (go <$> body)) env -runFunctionValue :: forall m location opaque effects effects' a - . ( Effectful (m location (Value location effects) opaque) - , Members '[ Reader (Map Name location) +runFunctionValue :: forall location opaque effects effects' a + . ( Members '[ Reader (Map Name location) , Reader ModuleInfo , Reader PackageInfo ] effects @@ -193,16 +192,14 @@ runFunctionValue :: forall m location opaque effects effects' a , Reader ModuleInfo , Reader PackageInfo ] effects' - , Monad (m location (Value location effects) opaque effects) - , Monad (m location (Value location effects) opaque effects') , (Function (Value location effects) effects \\ effects) effects' ) - => (Name -> m location (Value location effects) opaque effects location) - -> (location -> Value location effects -> m location (Value location effects) opaque effects ()) - -> m location (Value location effects) opaque effects a - -> m location (Value location effects) opaque effects' a + => (Name -> Eval location (Value location effects) opaque effects location) + -> (location -> Value location effects -> Eval location (Value location effects) opaque effects ()) + -> Eval location (Value location effects) opaque effects a + -> Eval location (Value location effects) opaque effects' a runFunctionValue alloc assign = go - where go :: forall a . m location (Value location effects) opaque effects a -> m location (Value location effects) opaque effects' a + where go :: forall a . Eval location (Value location effects) opaque effects a -> Eval location (Value location effects) opaque effects' a go = interpretAny $ \ eff -> case eff of Lambda params fvs body -> do packageInfo <- currentPackage @@ -218,20 +215,14 @@ runFunctionValue alloc assign = go pure (name, a)) paramNames (map raiseEff params)) local (Map.unionWith const bindings) (raiseEff body) -runUnitValue :: ( Applicative (m location (Value location effects) opaque effects') - , Effectful (m location (Value location effects) opaque) - , (Unit (Value location effects) \\ effects) effects' - ) - => m location (Value location effects) opaque effects a - -> m location (Value location effects) opaque effects' a +runUnitValue :: (Unit (Value location effects) \\ effects) effects' + => Eval location (Value location effects) opaque effects a + -> Eval location (Value location effects) opaque effects' a runUnitValue = interpretAny (\ Unit -> pure Unit') -runBooleanValue :: ( Applicative (m location (Value location effects) opaque effects') - , Effectful (m location (Value location effects) opaque) - , (Boolean (Value location effects) \\ effects) effects' - ) - => m location (Value location effects) opaque effects a - -> m location (Value location effects) opaque effects' a +runBooleanValue :: (Boolean (Value location effects) \\ effects) effects' + => Eval location (Value location effects) opaque effects a + -> Eval location (Value location effects) opaque effects' a runBooleanValue = interpretAny (\ eff -> case eff of Bool b -> pure (Bool' b) AsBool (Bool' b) -> pure b) From 8bc9178a317b8d4906e31bb6b93e7338d6df2ce9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 09:54:28 -0400 Subject: [PATCH 142/174] Specialize the Type handlers to Eval. --- src/Control/Abstract/Value.hs | 34 ++++++++++++++-------------------- 1 file changed, 14 insertions(+), 20 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 9a20204b8..70382ce97 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -235,23 +235,21 @@ data Type | BoolT deriving (Eq, Ord, Show) -runFunctionType :: forall m location opaque effects effects' a - . ( Alternative (m location Type opaque effects) - , Effectful (m location Type opaque) - , Members '[ Fresh +runFunctionType :: forall location opaque effects effects' a + . ( Members '[ Fresh + , NonDet , Reader (Map Name location) , Reader ModuleInfo , Reader PackageInfo ] effects - , Monad (m location Type opaque effects) , (Function Type effects \\ effects) effects' ) - => (Name -> m location Type opaque effects location) - -> (location -> Type -> m location Type opaque effects ()) - -> m location Type opaque effects a - -> m location Type opaque effects' a + => (Name -> Eval location Type opaque effects location) + -> (location -> Type -> Eval location Type opaque effects ()) + -> Eval location Type opaque effects a + -> Eval location Type opaque effects' a runFunctionType alloc assign = go - where go :: forall a . m location Type opaque effects a -> m location Type opaque effects' a + where go :: forall a . Eval location Type opaque effects a -> Eval location Type opaque effects' a go = interpretAny $ \ eff -> case eff of Lambda params _ body -> go $ do (bindings, tvars) <- foldr (\ name rest -> do @@ -268,20 +266,16 @@ runFunctionType alloc assign = go pure ret _ -> empty -runUnitType :: ( Applicative (m location Type opaque effects') - , Effectful (m location Type opaque) - , (Unit Type \\ effects) effects' - ) - => m location Type opaque effects a - -> m location Type opaque effects' a +runUnitType :: (Unit Type \\ effects) effects' + => Eval location Type opaque effects a + -> Eval location Type opaque effects' a runUnitType = interpretAny (\ Unit -> pure (Product [])) -runBooleanType :: ( Alternative (m location Type opaque effects') - , Effectful (m location Type opaque) +runBooleanType :: ( Member NonDet effects' , (Boolean Type \\ effects) effects' ) - => m location Type opaque effects a - -> m location Type opaque effects' a + => Eval location Type opaque effects a + -> Eval location Type opaque effects' a runBooleanType = interpretAny (\ eff -> case eff of Bool _ -> pure BoolT AsBool BoolT -> pure True <|> pure False) From 0a841bafea0fbba0a2af2ef8190b66d3cb1e54ed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 09:54:51 -0400 Subject: [PATCH 143/174] opaque is * -> *. --- 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 70382ce97..d91e37276 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, Rank2Types, ScopedTypeVariables, TypeOperators #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, Rank2Types, ScopedTypeVariables, TypeOperators #-} module Control.Abstract.Value ( AbstractValue(..) , AbstractFunction(..) @@ -100,7 +100,7 @@ prog b = do identity <- lambda' variable' iff b unit' (call' identity [unit']) -newtype Eval location value opaque effects a = Eval { runEval :: Eff effects a } +newtype Eval location value (opaque :: * -> *) effects a = Eval { runEval :: Eff effects a } deriving (Applicative, Effectful, Functor, Monad) deriving instance Member NonDet effects => Alternative (Eval location value opaque effects) From 228e686781297c5fd866d5f0d2b0f2bfb83f7d4b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 09:57:13 -0400 Subject: [PATCH 144/174] Specialize runFunctionType to use allocType/assignType. --- src/Control/Abstract/Value.hs | 46 ++++++++++++++++------------------- 1 file changed, 21 insertions(+), 25 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d91e37276..d2365689d 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -122,7 +122,7 @@ runType :: ( effects ~ (Function Type effects ': Unit Type ': Boolean Type ': Va ) => Eval Name Type opaque effects a -> Eval Name Type opaque rest [Either String (a, Map Name (Set Type))] -runType = runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType allocType assignType +runType = runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType data Function value effects return where @@ -235,36 +235,32 @@ data Type | BoolT deriving (Eq, Ord, Show) -runFunctionType :: forall location opaque effects effects' a - . ( Members '[ Fresh +runFunctionType :: ( Members '[ Fresh , NonDet - , Reader (Map Name location) + , Reader (Map Name Name) , Reader ModuleInfo , Reader PackageInfo + , State (Map Name (Set Type)) ] effects , (Function Type effects \\ effects) effects' ) - => (Name -> Eval location Type opaque effects location) - -> (location -> Type -> Eval location Type opaque effects ()) - -> Eval location Type opaque effects a - -> Eval location Type opaque effects' a -runFunctionType alloc assign = go - where go :: forall a . Eval location Type opaque effects a -> Eval location Type opaque effects' a - go = interpretAny $ \ eff -> case eff of - Lambda params _ body -> go $ do - (bindings, tvars) <- foldr (\ name rest -> do - a <- alloc name - tvar <- TVar <$> fresh - assign a tvar - bimap (Map.insert name a) (tvar :) <$> rest) (pure (Map.empty, [])) params - (Product tvars :->) <$> local (Map.unionWith const bindings) (raiseEff body) - Call fn params -> go $ do - paramTypes <- traverse raiseEff params - case fn of - Product argTypes :-> ret -> do - guard (and (zipWith (==) paramTypes argTypes)) - pure ret - _ -> empty + => Eval Name Type opaque effects a + -> Eval Name Type opaque effects' a +runFunctionType = interpretAny $ \ eff -> case eff of + Lambda params _ body -> runFunctionType $ do + (bindings, tvars) <- foldr (\ name rest -> do + a <- allocType name + tvar <- TVar <$> fresh + assignType a tvar + bimap (Map.insert name a) (tvar :) <$> rest) (pure (Map.empty, [])) params + (Product tvars :->) <$> local (Map.unionWith const bindings) (raiseEff body) + Call fn params -> runFunctionType $ do + paramTypes <- traverse raiseEff params + case fn of + Product argTypes :-> ret -> do + guard (and (zipWith (==) paramTypes argTypes)) + pure ret + _ -> empty runUnitType :: (Unit Type \\ effects) effects' => Eval location Type opaque effects a From bf6aefc871707ee37cfd3404604bfd62950c0449 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 10:07:20 -0400 Subject: [PATCH 145/174] Stub in helpers to hide and reveal evaluators under the opaque parameter. --- src/Control/Abstract/Value.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d2365689d..7f9ea604a 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -129,6 +129,14 @@ data Function value effects return where Lambda :: [Name] -> Set Name -> Eff effects value -> Function value effects value Call :: value -> [Eff effects value] -> Function value effects value + +unembedEval :: opaque a -> Eval location value opaque effects a +unembedEval = undefined + +embedEval :: Eval location value opaque effects a -> opaque a +embedEval = undefined + + variable' :: Member (Variable value) effects => Name -> Eval location value opaque effects value variable' = send . Variable From 3dfc4ec336ad2a5ec4cdb935279cf5389d9770c8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 10:07:44 -0400 Subject: [PATCH 146/174] Use opaque in Function. --- src/Control/Abstract/Value.hs | 40 ++++++++++++++++++----------------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 7f9ea604a..7eab1a4c9 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -49,14 +49,14 @@ class AbstractHole value where hole :: value -lambda :: Member (Function value effects) effects => [Name] -> Set Name -> Eval location value opaque effects value -> Eval location value opaque effects value -lambda paramNames fvs body = send (Lambda paramNames fvs (lowerEff body)) +lambda :: Member (Function value opaque) effects => [Name] -> Set Name -> Eval location value opaque effects value -> Eval location value opaque effects value +lambda paramNames fvs body = send (Lambda paramNames fvs (embedEval body)) -call' :: Member (Function value effects) effects => value -> [Eval location value opaque effects value] -> Eval location value opaque effects value -call' fn params = send (Call fn (map lowerEff params)) +call' :: Member (Function value opaque) effects => value -> [Eval location value opaque effects value] -> Eval location value opaque effects value +call' fn params = send (Call fn (map embedEval params)) -lambda' :: Members '[Fresh, Function value effects] effects +lambda' :: Members '[Fresh, Function value opaque] effects => (Name -> Eval location value opaque effects value) -> Eval location value opaque effects value lambda' body = do @@ -91,11 +91,12 @@ runHeapType = runState Map.empty prog :: Members '[ Boolean value , Fresh - , Function value effects + , Function value opaque , Unit value , Variable value ] effects - => value -> Eval location value opaque effects value + => value + -> Eval location value opaque effects value prog b = do identity <- lambda' variable' iff b unit' (call' identity [unit']) @@ -110,8 +111,8 @@ data EmbedAny effect effects return where type Embed effect effects = Eff (effect effects ': effects) -runType :: ( effects ~ (Function Type effects ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) - , (Function Type effects \\ effects) effects' +runType :: ( effects ~ (Function Type opaque ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) + , (Function Type opaque \\ effects) effects' , effects' ~ (Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) , (Unit Type \\ effects') effects'' , effects'' ~ (Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) @@ -125,9 +126,9 @@ runType :: ( effects ~ (Function Type effects ': Unit Type ': Boolean Type ': Va runType = runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType -data Function value effects return where - Lambda :: [Name] -> Set Name -> Eff effects value -> Function value effects value - Call :: value -> [Eff effects value] -> Function value effects value +data Function value opaque return where + Lambda :: [Name] -> Set Name -> opaque value -> Function value opaque value + Call :: value -> [opaque value] -> Function value opaque value unembedEval :: opaque a -> Eval location value opaque effects a @@ -200,7 +201,7 @@ runFunctionValue :: forall location opaque effects effects' a , Reader ModuleInfo , Reader PackageInfo ] effects' - , (Function (Value location effects) effects \\ effects) effects' + , (Function (Value location effects) opaque \\ effects) effects' ) => (Name -> Eval location (Value location effects) opaque effects location) -> (location -> Value location effects -> Eval location (Value location effects) opaque effects ()) @@ -213,14 +214,14 @@ runFunctionValue alloc assign = go packageInfo <- currentPackage moduleInfo <- currentModule env <- Map.filterWithKey (fmap (`Set.member` fvs) . const) <$> ask - let body' = withCurrentPackage packageInfo (withCurrentModule moduleInfo body) + let body' = withCurrentPackage packageInfo (withCurrentModule moduleInfo (lowerEff (unembedEval body))) pure (Closure params body' env) Call (Closure paramNames body env) params -> go $ do bindings <- foldr (uncurry (Map.insert)) env <$> sequenceA (zipWith (\ name param -> do v <- param a <- alloc name assign a v - pure (name, a)) paramNames (map raiseEff params)) + pure (name, a)) paramNames (map unembedEval params)) local (Map.unionWith const bindings) (raiseEff body) runUnitValue :: (Unit (Value location effects) \\ effects) effects' @@ -243,14 +244,15 @@ data Type | BoolT deriving (Eq, Ord, Show) -runFunctionType :: ( Members '[ Fresh +runFunctionType :: forall opaque effects effects' a + . ( Members '[ Fresh , NonDet , Reader (Map Name Name) , Reader ModuleInfo , Reader PackageInfo , State (Map Name (Set Type)) ] effects - , (Function Type effects \\ effects) effects' + , (Function Type opaque \\ effects) effects' ) => Eval Name Type opaque effects a -> Eval Name Type opaque effects' a @@ -261,9 +263,9 @@ runFunctionType = interpretAny $ \ eff -> case eff of tvar <- TVar <$> fresh assignType a tvar bimap (Map.insert name a) (tvar :) <$> rest) (pure (Map.empty, [])) params - (Product tvars :->) <$> local (Map.unionWith const bindings) (raiseEff body) + (Product tvars :->) <$> local (Map.unionWith const bindings) (unembedEval @_ @_ @_ @_ @effects body) Call fn params -> runFunctionType $ do - paramTypes <- traverse raiseEff params + paramTypes <- traverse (unembedEval @_ @_ @_ @_ @effects) params case fn of Product argTypes :-> ret -> do guard (and (zipWith (==) paramTypes argTypes)) From dc5d3ecc76eac2c81e19262579416abb5736bc88 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 10:12:58 -0400 Subject: [PATCH 147/174] Run progs. --- src/Control/Abstract/Value.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 7eab1a4c9..e03143b70 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -125,6 +125,9 @@ runType :: ( effects ~ (Function Type opaque ': Unit Type ': Boolean Type ': Var -> Eval Name Type opaque rest [Either String (a, Map Name (Set Type))] runType = runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType +resultType :: [Either String (Type, Map Name (Set Type))] +resultType = run (runFresh 0 (runType (prog BoolT))) + data Function value opaque return where Lambda :: [Name] -> Set Name -> opaque value -> Function value opaque value From 32b39faad907387a2fadd101f0933321104acc66 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 10:19:22 -0400 Subject: [PATCH 148/174] :fire: the final type parameter. --- src/Control/Abstract/Value.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index e03143b70..4febafbae 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -118,8 +118,7 @@ runType :: ( effects ~ (Function Type opaque ': Unit Type ': Boolean Type ': Var , effects'' ~ (Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) , (Boolean Type \\ effects'') effects''' , effects''' ~ (Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) - , (Variable Type \\ effects''') effects'''' - , effects'''' ~ (State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) + , (Variable Type \\ effects''') (State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) ) => Eval Name Type opaque effects a -> Eval Name Type opaque rest [Either String (a, Map Name (Set Type))] From 589ef3534f2cb9ce75dbde5b61119ef3b524e958 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 10:20:34 -0400 Subject: [PATCH 149/174] Move the Fresh handler into runType. --- src/Control/Abstract/Value.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 4febafbae..e2947aa47 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -111,21 +111,21 @@ data EmbedAny effect effects return where type Embed effect effects = Eff (effect effects ': effects) -runType :: ( effects ~ (Function Type opaque ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) +runType :: ( effects ~ (Function Type opaque ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': Fresh ': rest) , (Function Type opaque \\ effects) effects' - , effects' ~ (Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) + , effects' ~ (Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': Fresh ': rest) , (Unit Type \\ effects') effects'' - , effects'' ~ (Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) + , effects'' ~ (Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': Fresh ': rest) , (Boolean Type \\ effects'') effects''' - , effects''' ~ (Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) - , (Variable Type \\ effects''') (State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) + , effects''' ~ (Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': Fresh ': rest) + , (Variable Type \\ effects''') (State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': Fresh ': rest) ) => Eval Name Type opaque effects a -> Eval Name Type opaque rest [Either String (a, Map Name (Set Type))] -runType = runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType +runType = runFresh 0 . runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType resultType :: [Either String (Type, Map Name (Set Type))] -resultType = run (runFresh 0 (runType (prog BoolT))) +resultType = run (runType (prog BoolT)) data Function value opaque return where From 218c283d1863de7ccf19ffb3485272690b6af405 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 10:22:25 -0400 Subject: [PATCH 150/174] Move the basic effect handlers out of runType. --- src/Control/Abstract/Value.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index e2947aa47..2fba7670d 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -111,21 +111,23 @@ data EmbedAny effect effects return where type Embed effect effects = Eff (effect effects ': effects) -runType :: ( effects ~ (Function Type opaque ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': Fresh ': rest) +runType :: ( effects ~ (Function Type opaque ': Unit Type ': Boolean Type ': Variable Type ': rest) , (Function Type opaque \\ effects) effects' - , effects' ~ (Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': Fresh ': rest) + , effects' ~ (Unit Type ': Boolean Type ': Variable Type ': rest) , (Unit Type \\ effects') effects'' - , effects'' ~ (Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': Fresh ': rest) + , effects'' ~ (Boolean Type ': Variable Type ': rest) , (Boolean Type \\ effects'') effects''' - , effects''' ~ (Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': Fresh ': rest) - , (Variable Type \\ effects''') (State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': Fresh ': rest) + , effects''' ~ (Variable Type ': rest) + , (Variable Type \\ effects''') (rest) ) => Eval Name Type opaque effects a - -> Eval Name Type opaque rest [Either String (a, Map Name (Set Type))] -runType = runFresh 0 . runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType + -> Eval Name Type opaque rest a +runType = runVariable derefType . runBooleanType . runUnitType . runFunctionType + +runRest = runFresh 0 . runNonDetA . runFail . runEnv . runHeapType resultType :: [Either String (Type, Map Name (Set Type))] -resultType = run (runType (prog BoolT)) +resultType = run (runRest (runType (prog BoolT))) data Function value opaque return where From a9041e000283989babfbd9101c71bfc68e13706d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 10:42:26 -0400 Subject: [PATCH 151/174] Interpret in runVariable. --- src/Control/Abstract/Value.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 2fba7670d..55ef8a8c3 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -148,20 +148,19 @@ variable' = send . Variable data Variable value return where Variable :: Name -> Variable value value -runVariable :: forall location value opaque effects effects' a - . ( (Variable value \\ effects) effects' - , Members '[ Fail +runVariable :: forall location value opaque effects a + . ( Members '[ Fail , Reader (Map Name location) , State (Map location value) - ] effects' + ] effects , Show location ) - => (location -> Eval location value opaque effects' (Maybe value)) + => (location -> Eval location value opaque effects (Maybe value)) + -> Eval location value opaque (Variable value ': effects) a -> Eval location value opaque effects a - -> Eval location value opaque effects' a runVariable deref = go - where go :: forall a . Eval location value opaque effects a -> Eval location value opaque effects' a - go = interpretAny (\ (Variable name) -> do + where go :: forall a . Eval location value opaque (Variable value ': effects) a -> Eval location value opaque effects a + go = interpret (\ (Variable name) -> do addr <- lookup' name >>= maybeM (raiseEff (fail ("free variable: " <> show name))) deref addr >>= maybeM (raiseEff (fail ("uninitialized address: " <> show addr)))) From 13366d65c0415efceb0e018b0dd1699653746a87 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 10:42:42 -0400 Subject: [PATCH 152/174] Interpret in runBooleanType. --- src/Control/Abstract/Value.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 55ef8a8c3..4a9a9310b 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -280,12 +280,10 @@ runUnitType :: (Unit Type \\ effects) effects' -> Eval location Type opaque effects' a runUnitType = interpretAny (\ Unit -> pure (Product [])) -runBooleanType :: ( Member NonDet effects' - , (Boolean Type \\ effects) effects' - ) - => Eval location Type opaque effects a - -> Eval location Type opaque effects' a -runBooleanType = interpretAny (\ eff -> case eff of +runBooleanType :: Member NonDet effects + => Eval location Type opaque (Boolean Type ': effects) a + -> Eval location Type opaque effects a +runBooleanType = interpret (\ eff -> case eff of Bool _ -> pure BoolT AsBool BoolT -> pure True <|> pure False) From f176cd2c14f58a71bb69f1e82e72c4fa8ef38a6a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 10:42:49 -0400 Subject: [PATCH 153/174] Interpret in runUnitType. --- src/Control/Abstract/Value.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 4a9a9310b..4541a741a 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -275,10 +275,9 @@ runFunctionType = interpretAny $ \ eff -> case eff of pure ret _ -> empty -runUnitType :: (Unit Type \\ effects) effects' - => Eval location Type opaque effects a - -> Eval location Type opaque effects' a -runUnitType = interpretAny (\ Unit -> pure (Product [])) +runUnitType :: Eval location Type opaque (Unit Type ': effects) a + -> Eval location Type opaque effects a +runUnitType = interpret (\ Unit -> pure (Product [])) runBooleanType :: Member NonDet effects => Eval location Type opaque (Boolean Type ': effects) a From e4c91a6d1fb4776afb89d48ebc58923124664265 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 10:43:45 -0400 Subject: [PATCH 154/174] Interpret in runFunctionType. --- src/Control/Abstract/Value.hs | 28 +++++++++++++--------------- 1 file changed, 13 insertions(+), 15 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 4541a741a..e040393c8 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -247,28 +247,26 @@ data Type | BoolT deriving (Eq, Ord, Show) -runFunctionType :: forall opaque effects effects' a - . ( Members '[ Fresh - , NonDet - , Reader (Map Name Name) - , Reader ModuleInfo - , Reader PackageInfo - , State (Map Name (Set Type)) - ] effects - , (Function Type opaque \\ effects) effects' - ) - => Eval Name Type opaque effects a - -> Eval Name Type opaque effects' a -runFunctionType = interpretAny $ \ eff -> case eff of +runFunctionType :: forall opaque effects a + . Members '[ Fresh + , NonDet + , Reader (Map Name Name) + , Reader ModuleInfo + , Reader PackageInfo + , State (Map Name (Set Type)) + ] effects + => Eval Name Type opaque (Function Type opaque ': effects) a + -> Eval Name Type opaque effects a +runFunctionType = interpret $ \ eff -> case eff of Lambda params _ body -> runFunctionType $ do (bindings, tvars) <- foldr (\ name rest -> do a <- allocType name tvar <- TVar <$> fresh assignType a tvar bimap (Map.insert name a) (tvar :) <$> rest) (pure (Map.empty, [])) params - (Product tvars :->) <$> local (Map.unionWith const bindings) (unembedEval @_ @_ @_ @_ @effects body) + (Product tvars :->) <$> local (Map.unionWith const bindings) (unembedEval @_ @_ @_ @_ @(Function Type opaque ': effects) body) Call fn params -> runFunctionType $ do - paramTypes <- traverse (unembedEval @_ @_ @_ @_ @effects) params + paramTypes <- traverse (unembedEval @_ @_ @_ @_ @(Function Type opaque ': effects)) params case fn of Product argTypes :-> ret -> do guard (and (zipWith (==) paramTypes argTypes)) From 6ec225948befb9cc237ecfdddf39c946d1ba6566 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 10:47:31 -0400 Subject: [PATCH 155/174] :fire: a redundant constraint. --- src/Control/Abstract/Value.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index e040393c8..63a69daab 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -151,7 +151,6 @@ data Variable value return where runVariable :: forall location value opaque effects a . ( Members '[ Fail , Reader (Map Name location) - , State (Map location value) ] effects , Show location ) From f7442219af6a23cf568d21f9d0909a6a7310c4ef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 10:48:20 -0400 Subject: [PATCH 156/174] :fire: more redundant constraints. --- src/Control/Abstract/Value.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 63a69daab..5c27dc0e7 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -250,8 +250,6 @@ runFunctionType :: forall opaque effects a . Members '[ Fresh , NonDet , Reader (Map Name Name) - , Reader ModuleInfo - , Reader PackageInfo , State (Map Name (Set Type)) ] effects => Eval Name Type opaque (Function Type opaque ': effects) a From 871d2e8dfb15cd5e73a3c6c435bcc76140df326c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 10:48:44 -0400 Subject: [PATCH 157/174] Use the normal effect handling flow for runType. --- src/Control/Abstract/Value.hs | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 5c27dc0e7..bfed92ac7 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -111,17 +111,14 @@ data EmbedAny effect effects return where type Embed effect effects = Eff (effect effects ': effects) -runType :: ( effects ~ (Function Type opaque ': Unit Type ': Boolean Type ': Variable Type ': rest) - , (Function Type opaque \\ effects) effects' - , effects' ~ (Unit Type ': Boolean Type ': Variable Type ': rest) - , (Unit Type \\ effects') effects'' - , effects'' ~ (Boolean Type ': Variable Type ': rest) - , (Boolean Type \\ effects'') effects''' - , effects''' ~ (Variable Type ': rest) - , (Variable Type \\ effects''') (rest) - ) - => Eval Name Type opaque effects a - -> Eval Name Type opaque rest a +runType :: Members '[ Fail + , Fresh + , NonDet + , Reader (Map Name Name) + , State (Map Name (Set Type)) + ] effects + => Eval Name Type opaque (Function Type opaque ': Unit Type ': Boolean Type ': Variable Type ': effects) a + -> Eval Name Type opaque effects a runType = runVariable derefType . runBooleanType . runUnitType . runFunctionType runRest = runFresh 0 . runNonDetA . runFail . runEnv . runHeapType From 3bf6074f6e63b50f2f77f45daa1f3247ea68f66a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 10:51:40 -0400 Subject: [PATCH 158/174] Define embedEval monadically. --- src/Control/Abstract/Value.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index bfed92ac7..dd206ffff 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -50,10 +50,10 @@ class AbstractHole value where lambda :: Member (Function value opaque) effects => [Name] -> Set Name -> Eval location value opaque effects value -> Eval location value opaque effects value -lambda paramNames fvs body = send (Lambda paramNames fvs (embedEval body)) +lambda paramNames fvs body = embedEval body >>= send . Lambda paramNames fvs call' :: Member (Function value opaque) effects => value -> [Eval location value opaque effects value] -> Eval location value opaque effects value -call' fn params = send (Call fn (map embedEval params)) +call' fn params = traverse embedEval params >>= send . Call fn lambda' :: Members '[Fresh, Function value opaque] effects @@ -135,7 +135,7 @@ data Function value opaque return where unembedEval :: opaque a -> Eval location value opaque effects a unembedEval = undefined -embedEval :: Eval location value opaque effects a -> opaque a +embedEval :: Eval location value opaque effects a -> Eval location value opaque effects (opaque a) embedEval = undefined From 37f7aa8ff8545aa2564a357d65c73c1de17a357d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 11:02:26 -0400 Subject: [PATCH 159/174] Spike out a candidate implementation of embedEval. --- semantic.cabal | 1 + src/Control/Abstract/Value.hs | 8 ++++++++ 2 files changed, 9 insertions(+) diff --git a/semantic.cabal b/semantic.cabal index 50b40a34a..52cf5f7ce 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -203,6 +203,7 @@ library , pretty-show , recursion-schemes , reducers + , reflection , scientific , semigroupoids , split diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index dd206ffff..8ac61149a 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -28,6 +28,7 @@ import Data.Abstract.Name import Data.Abstract.Number as Number import Data.Abstract.Ref import qualified Data.Map as Map +import Data.Reflection import Data.Scientific (Scientific) import Data.Semigroup.Reducer hiding (unit) import Data.Semilattice.Lower @@ -138,6 +139,13 @@ unembedEval = undefined embedEval :: Eval location value opaque effects a -> Eval location value opaque effects (opaque a) embedEval = undefined +newtype EmbedEval opaque effects = EmbedEval { runEmbedEval :: forall a . Eff effects a -> opaque a } + +embedEval' :: forall location value opaque effects a . (Member (Reader (Proxy opaque)) effects, Reifies opaque (EmbedEval opaque effects)) => Eval location value opaque effects a -> Eval location value opaque effects (opaque a) +embedEval' action = do + proxy <- ask @(Proxy opaque) + pure (runEmbedEval (reflect proxy) (lowerEff action)) + variable' :: Member (Variable value) effects => Name -> Eval location value opaque effects value variable' = send . Variable From f05de7ab1a747f6ee083abfd05d650240108e948 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 11:02:41 -0400 Subject: [PATCH 160/174] Rename runEmbedEval to unEmbedEval. --- 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 8ac61149a..3b95d4d92 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -139,12 +139,12 @@ unembedEval = undefined embedEval :: Eval location value opaque effects a -> Eval location value opaque effects (opaque a) embedEval = undefined -newtype EmbedEval opaque effects = EmbedEval { runEmbedEval :: forall a . Eff effects a -> opaque a } +newtype EmbedEval opaque effects = EmbedEval { unEmbedEval :: forall a . Eff effects a -> opaque a } embedEval' :: forall location value opaque effects a . (Member (Reader (Proxy opaque)) effects, Reifies opaque (EmbedEval opaque effects)) => Eval location value opaque effects a -> Eval location value opaque effects (opaque a) embedEval' action = do proxy <- ask @(Proxy opaque) - pure (runEmbedEval (reflect proxy) (lowerEff action)) + pure (unEmbedEval (reflect proxy) (lowerEff action)) variable' :: Member (Variable value) effects => Name -> Eval location value opaque effects value From a346886950099df2106a02363933e0ef93a2c8fb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 11:10:48 -0400 Subject: [PATCH 161/174] =?UTF-8?q?Swap=20Function=E2=80=99s=20parameters?= =?UTF-8?q?=20again.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Value.hs | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 3b95d4d92..6f7518674 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -50,14 +50,14 @@ class AbstractHole value where hole :: value -lambda :: Member (Function value opaque) effects => [Name] -> Set Name -> Eval location value opaque effects value -> Eval location value opaque effects value +lambda :: Member (Function opaque value) effects => [Name] -> Set Name -> Eval location value opaque effects value -> Eval location value opaque effects value lambda paramNames fvs body = embedEval body >>= send . Lambda paramNames fvs -call' :: Member (Function value opaque) effects => value -> [Eval location value opaque effects value] -> Eval location value opaque effects value +call' :: Member (Function opaque value) effects => value -> [Eval location value opaque effects value] -> Eval location value opaque effects value call' fn params = traverse embedEval params >>= send . Call fn -lambda' :: Members '[Fresh, Function value opaque] effects +lambda' :: Members '[Fresh, Function opaque value] effects => (Name -> Eval location value opaque effects value) -> Eval location value opaque effects value lambda' body = do @@ -92,7 +92,7 @@ runHeapType = runState Map.empty prog :: Members '[ Boolean value , Fresh - , Function value opaque + , Function opaque value , Unit value , Variable value ] effects @@ -118,7 +118,7 @@ runType :: Members '[ Fail , Reader (Map Name Name) , State (Map Name (Set Type)) ] effects - => Eval Name Type opaque (Function Type opaque ': Unit Type ': Boolean Type ': Variable Type ': effects) a + => Eval Name Type opaque (Function opaque Type ': Unit Type ': Boolean Type ': Variable Type ': effects) a -> Eval Name Type opaque effects a runType = runVariable derefType . runBooleanType . runUnitType . runFunctionType @@ -128,9 +128,9 @@ resultType :: [Either String (Type, Map Name (Set Type))] resultType = run (runRest (runType (prog BoolT))) -data Function value opaque return where - Lambda :: [Name] -> Set Name -> opaque value -> Function value opaque value - Call :: value -> [opaque value] -> Function value opaque value +data Function opaque value return where + Lambda :: [Name] -> Set Name -> opaque value -> Function opaque value value + Call :: value -> [opaque value] -> Function opaque value value unembedEval :: opaque a -> Eval location value opaque effects a @@ -208,7 +208,7 @@ runFunctionValue :: forall location opaque effects effects' a , Reader ModuleInfo , Reader PackageInfo ] effects' - , (Function (Value location effects) opaque \\ effects) effects' + , (Function opaque (Value location effects) \\ effects) effects' ) => (Name -> Eval location (Value location effects) opaque effects location) -> (location -> Value location effects -> Eval location (Value location effects) opaque effects ()) @@ -257,7 +257,7 @@ runFunctionType :: forall opaque effects a , Reader (Map Name Name) , State (Map Name (Set Type)) ] effects - => Eval Name Type opaque (Function Type opaque ': effects) a + => Eval Name Type opaque (Function opaque Type ': effects) a -> Eval Name Type opaque effects a runFunctionType = interpret $ \ eff -> case eff of Lambda params _ body -> runFunctionType $ do @@ -266,9 +266,9 @@ runFunctionType = interpret $ \ eff -> case eff of tvar <- TVar <$> fresh assignType a tvar bimap (Map.insert name a) (tvar :) <$> rest) (pure (Map.empty, [])) params - (Product tvars :->) <$> local (Map.unionWith const bindings) (unembedEval @_ @_ @_ @_ @(Function Type opaque ': effects) body) + (Product tvars :->) <$> local (Map.unionWith const bindings) (unembedEval @_ @_ @_ @_ @(Function opaque Type ': effects) body) Call fn params -> runFunctionType $ do - paramTypes <- traverse (unembedEval @_ @_ @_ @_ @(Function Type opaque ': effects)) params + paramTypes <- traverse (unembedEval @_ @_ @_ @_ @(Function opaque Type ': effects)) params case fn of Product argTypes :-> ret -> do guard (and (zipWith (==) paramTypes argTypes)) From be85a89c72f9c5ab8f84ebbce72017de10b5fb5f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 11:14:01 -0400 Subject: [PATCH 162/174] :fire: the ModuleInfo/PackageInfo stuff from the experiment. --- src/Control/Abstract/Value.hs | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 6f7518674..3173cb188 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -201,12 +201,8 @@ liftHandler handler = go where go (Closure names body env) = Closure names (hand runFunctionValue :: forall location opaque effects effects' a . ( Members '[ Reader (Map Name location) - , Reader ModuleInfo - , Reader PackageInfo ] effects , Members '[ Reader (Map Name location) - , Reader ModuleInfo - , Reader PackageInfo ] effects' , (Function opaque (Value location effects) \\ effects) effects' ) @@ -218,11 +214,8 @@ runFunctionValue alloc assign = go where go :: forall a . Eval location (Value location effects) opaque effects a -> Eval location (Value location effects) opaque effects' a go = interpretAny $ \ eff -> case eff of Lambda params fvs body -> do - packageInfo <- currentPackage - moduleInfo <- currentModule env <- Map.filterWithKey (fmap (`Set.member` fvs) . const) <$> ask - let body' = withCurrentPackage packageInfo (withCurrentModule moduleInfo (lowerEff (unembedEval body))) - pure (Closure params body' env) + pure (Closure params (lowerEff (unembedEval body)) env) Call (Closure paramNames body env) params -> go $ do bindings <- foldr (uncurry (Map.insert)) env <$> sequenceA (zipWith (\ name param -> do v <- param From 5144f41a6efe3b35c80f1d2b8b150b033868888b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 11:16:59 -0400 Subject: [PATCH 163/174] :fire: a redundant import. --- src/Control/Abstract/Value.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 3173cb188..ece58dfce 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -16,7 +16,6 @@ module Control.Abstract.Value ) where import Control.Abstract.Addressable -import Control.Abstract.Context import Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Abstract.Heap From 98bd85f6763d48ef3f793b7a2952a8bd609521fb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 11:17:08 -0400 Subject: [PATCH 164/174] Parameterize Value by opaque instead of effects. --- src/Control/Abstract/Value.hs | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index ece58dfce..efc87b09d 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -190,12 +190,12 @@ data Boolean value return where AsBool :: value -> Boolean value Bool -data Value location effects - = Closure [Name] (Eff effects (Value location effects)) (Map Name location) +data Value location opaque + = Closure [Name] (opaque (Value location opaque)) (Map Name location) | Unit' | Bool' Bool -liftHandler :: (forall a . Eff effects a -> Eff effects' a) -> Value location effects -> Value location effects' +liftHandler :: Functor opaque => (forall a . opaque a -> opaque' a) -> Value location opaque -> Value location opaque' liftHandler handler = go where go (Closure names body env) = Closure names (handler (go <$> body)) env runFunctionValue :: forall location opaque effects effects' a @@ -203,34 +203,34 @@ runFunctionValue :: forall location opaque effects effects' a ] effects , Members '[ Reader (Map Name location) ] effects' - , (Function opaque (Value location effects) \\ effects) effects' + , (Function opaque (Value location opaque) \\ effects) effects' ) - => (Name -> Eval location (Value location effects) opaque effects location) - -> (location -> Value location effects -> Eval location (Value location effects) opaque effects ()) - -> Eval location (Value location effects) opaque effects a - -> Eval location (Value location effects) opaque effects' a + => (Name -> Eval location (Value location opaque) opaque effects location) + -> (location -> Value location opaque -> Eval location (Value location opaque) opaque effects ()) + -> Eval location (Value location opaque) opaque effects a + -> Eval location (Value location opaque) opaque effects' a runFunctionValue alloc assign = go - where go :: forall a . Eval location (Value location effects) opaque effects a -> Eval location (Value location effects) opaque effects' a + where go :: forall a . Eval location (Value location opaque) opaque effects a -> Eval location (Value location opaque) opaque effects' a go = interpretAny $ \ eff -> case eff of Lambda params fvs body -> do env <- Map.filterWithKey (fmap (`Set.member` fvs) . const) <$> ask - pure (Closure params (lowerEff (unembedEval body)) env) + pure (Closure params body env) Call (Closure paramNames body env) params -> go $ do bindings <- foldr (uncurry (Map.insert)) env <$> sequenceA (zipWith (\ name param -> do v <- param a <- alloc name assign a v pure (name, a)) paramNames (map unembedEval params)) - local (Map.unionWith const bindings) (raiseEff body) + local (Map.unionWith const bindings) (unembedEval body) -runUnitValue :: (Unit (Value location effects) \\ effects) effects' - => Eval location (Value location effects) opaque effects a - -> Eval location (Value location effects) opaque effects' a +runUnitValue :: (Unit (Value location opaque) \\ effects) effects' + => Eval location (Value location opaque) opaque effects a + -> Eval location (Value location opaque) opaque effects' a runUnitValue = interpretAny (\ Unit -> pure Unit') -runBooleanValue :: (Boolean (Value location effects) \\ effects) effects' - => Eval location (Value location effects) opaque effects a - -> Eval location (Value location effects) opaque effects' a +runBooleanValue :: (Boolean (Value location opaque) \\ effects) effects' + => Eval location (Value location opaque) opaque effects a + -> Eval location (Value location opaque) opaque effects' a runBooleanValue = interpretAny (\ eff -> case eff of Bool b -> pure (Bool' b) AsBool (Bool' b) -> pure b) From 39851a602ef7af4c971f30e326ea11ca59d15731 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 11:17:50 -0400 Subject: [PATCH 165/174] :fire: EmbedAny/Embed. --- src/Control/Abstract/Value.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index efc87b09d..0680f3d7b 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -106,10 +106,6 @@ newtype Eval location value (opaque :: * -> *) effects a = Eval { runEval :: Eff deriving instance Member NonDet effects => Alternative (Eval location value opaque effects) -data EmbedAny effect effects return where - EmbedAny :: (effect \\ effects') effects => Eff effects' a -> EmbedAny effect effects a - -type Embed effect effects = Eff (effect effects ': effects) runType :: Members '[ Fail , Fresh From 02a595cc3642406fdd17a46a98587d98b39f2c63 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 11:18:26 -0400 Subject: [PATCH 166/174] Infer the type of runType. --- src/Control/Abstract/Value.hs | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 0680f3d7b..3ae3bf5a2 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -107,20 +107,10 @@ newtype Eval location value (opaque :: * -> *) effects a = Eval { runEval :: Eff deriving instance Member NonDet effects => Alternative (Eval location value opaque effects) -runType :: Members '[ Fail - , Fresh - , NonDet - , Reader (Map Name Name) - , State (Map Name (Set Type)) - ] effects - => Eval Name Type opaque (Function opaque Type ': Unit Type ': Boolean Type ': Variable Type ': effects) a - -> Eval Name Type opaque effects a -runType = runVariable derefType . runBooleanType . runUnitType . runFunctionType - -runRest = runFresh 0 . runNonDetA . runFail . runEnv . runHeapType +runType = runFresh 0 . runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType resultType :: [Either String (Type, Map Name (Set Type))] -resultType = run (runRest (runType (prog BoolT))) +resultType = run (runType (prog BoolT)) data Function opaque value return where From e141f0e6ac8ebfed48fda447f888b55a56c931ed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 11:20:04 -0400 Subject: [PATCH 167/174] =?UTF-8?q?Swap=20the=20order=20of=20Value?= =?UTF-8?q?=E2=80=99s=20parameters.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Value.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 3ae3bf5a2..d0418cad8 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -176,12 +176,12 @@ data Boolean value return where AsBool :: value -> Boolean value Bool -data Value location opaque - = Closure [Name] (opaque (Value location opaque)) (Map Name location) +data Value opaque location + = Closure [Name] (opaque (Value opaque location)) (Map Name location) | Unit' | Bool' Bool -liftHandler :: Functor opaque => (forall a . opaque a -> opaque' a) -> Value location opaque -> Value location opaque' +liftHandler :: Functor opaque => (forall a . opaque a -> opaque' a) -> Value opaque location -> Value opaque' location liftHandler handler = go where go (Closure names body env) = Closure names (handler (go <$> body)) env runFunctionValue :: forall location opaque effects effects' a @@ -189,14 +189,14 @@ runFunctionValue :: forall location opaque effects effects' a ] effects , Members '[ Reader (Map Name location) ] effects' - , (Function opaque (Value location opaque) \\ effects) effects' + , (Function opaque (Value opaque location) \\ effects) effects' ) - => (Name -> Eval location (Value location opaque) opaque effects location) - -> (location -> Value location opaque -> Eval location (Value location opaque) opaque effects ()) - -> Eval location (Value location opaque) opaque effects a - -> Eval location (Value location opaque) opaque effects' a + => (Name -> Eval location (Value opaque location) opaque effects location) + -> (location -> Value opaque location -> Eval location (Value opaque location) opaque effects ()) + -> Eval location (Value opaque location) opaque effects a + -> Eval location (Value opaque location) opaque effects' a runFunctionValue alloc assign = go - where go :: forall a . Eval location (Value location opaque) opaque effects a -> Eval location (Value location opaque) opaque effects' a + where go :: forall a . Eval location (Value opaque location) opaque effects a -> Eval location (Value opaque location) opaque effects' a go = interpretAny $ \ eff -> case eff of Lambda params fvs body -> do env <- Map.filterWithKey (fmap (`Set.member` fvs) . const) <$> ask @@ -209,14 +209,14 @@ runFunctionValue alloc assign = go pure (name, a)) paramNames (map unembedEval params)) local (Map.unionWith const bindings) (unembedEval body) -runUnitValue :: (Unit (Value location opaque) \\ effects) effects' - => Eval location (Value location opaque) opaque effects a - -> Eval location (Value location opaque) opaque effects' a +runUnitValue :: (Unit (Value opaque location) \\ effects) effects' + => Eval location (Value opaque location) opaque effects a + -> Eval location (Value opaque location) opaque effects' a runUnitValue = interpretAny (\ Unit -> pure Unit') -runBooleanValue :: (Boolean (Value location opaque) \\ effects) effects' - => Eval location (Value location opaque) opaque effects a - -> Eval location (Value location opaque) opaque effects' a +runBooleanValue :: (Boolean (Value opaque location) \\ effects) effects' + => Eval location (Value opaque location) opaque effects a + -> Eval location (Value opaque location) opaque effects' a runBooleanValue = interpretAny (\ eff -> case eff of Bool b -> pure (Bool' b) AsBool (Bool' b) -> pure b) From 3a8ee0dca2c23504ad6dd1a218e2ff7fe3753418 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 11:26:42 -0400 Subject: [PATCH 168/174] Back out all of the effect decomposition stuff. --- semantic.cabal | 1 - src/Control/Abstract/Value.hs | 222 +--------------------------------- vendor/effects | 2 +- 3 files changed, 2 insertions(+), 223 deletions(-) diff --git a/semantic.cabal b/semantic.cabal index 52cf5f7ce..50b40a34a 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -203,7 +203,6 @@ library , pretty-show , recursion-schemes , reducers - , reflection , scientific , semigroupoids , split diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d0418cad8..ef1fa79d9 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, Rank2Types, ScopedTypeVariables, TypeOperators #-} +{-# LANGUAGE GADTs, Rank2Types #-} module Control.Abstract.Value ( AbstractValue(..) , AbstractFunction(..) @@ -19,19 +19,15 @@ import Control.Abstract.Addressable import Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Abstract.Heap -import Control.Monad.Effect.Fail import Data.Abstract.Address (Address) 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 -import qualified Data.Map as Map -import Data.Reflection import Data.Scientific (Scientific) import Data.Semigroup.Reducer hiding (unit) import Data.Semilattice.Lower -import qualified Data.Set as Set import Prelude hiding (fail) import Prologue hiding (TypeError) @@ -49,222 +45,6 @@ class AbstractHole value where hole :: value -lambda :: Member (Function opaque value) effects => [Name] -> Set Name -> Eval location value opaque effects value -> Eval location value opaque effects value -lambda paramNames fvs body = embedEval body >>= send . Lambda paramNames fvs - -call' :: Member (Function opaque value) effects => value -> [Eval location value opaque effects value] -> Eval location value opaque effects value -call' fn params = traverse embedEval params >>= send . Call fn - - -lambda' :: Members '[Fresh, Function opaque value] effects - => (Name -> Eval location value opaque effects value) - -> Eval location value opaque effects value -lambda' body = do - var <- nameI <$> fresh - lambda [var] lowerBound (body var) - -lookup' :: Member (Reader (Map Name location)) effects => Name -> Eval location value opaque effects (Maybe location) -lookup' name = Map.lookup name <$> ask - -allocType :: Name -> Eval Name Type opaque effects Name -allocType = pure - -assignType :: (Member (State (Map location (Set Type))) effects, Ord location) => location -> Type -> Eval location Type opaque effects () -assignType addr value = do - cell <- gets (Map.lookup addr) >>= maybeM (pure (Set.empty)) - modify' (Map.insert addr (Set.insert value cell)) - -derefType :: (Members '[Fail, NonDet, State (Map location (Set Type))] effects, Ord location, Show location) => location -> Eval location Type opaque effects (Maybe Type) -derefType addr = do - cell <- gets (Map.lookup addr) >>= maybeM (raiseEff (fail ("unallocated address: " <> show addr))) - if Set.null cell then - pure Nothing - else - Set.foldr ((<|>) . pure . Just) empty cell - -runEnv :: Eval location value opaque (Reader (Map Name location) ': effects) a -> Eval location value opaque effects a -runEnv = runReader Map.empty - -runHeapType :: Eval Name Type opaque (State (Map Name (Set Type)) ': effects) a -> Eval Name Type opaque effects (a, Map Name (Set Type)) -runHeapType = runState Map.empty - - -prog :: Members '[ Boolean value - , Fresh - , Function opaque value - , Unit value - , Variable value - ] effects - => value - -> Eval location value opaque effects value -prog b = do - identity <- lambda' variable' - iff b unit' (call' identity [unit']) - -newtype Eval location value (opaque :: * -> *) effects a = Eval { runEval :: Eff effects a } - deriving (Applicative, Effectful, Functor, Monad) - -deriving instance Member NonDet effects => Alternative (Eval location value opaque effects) - - -runType = runFresh 0 . runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType - -resultType :: [Either String (Type, Map Name (Set Type))] -resultType = run (runType (prog BoolT)) - - -data Function opaque value return where - Lambda :: [Name] -> Set Name -> opaque value -> Function opaque value value - Call :: value -> [opaque value] -> Function opaque value value - - -unembedEval :: opaque a -> Eval location value opaque effects a -unembedEval = undefined - -embedEval :: Eval location value opaque effects a -> Eval location value opaque effects (opaque a) -embedEval = undefined - -newtype EmbedEval opaque effects = EmbedEval { unEmbedEval :: forall a . Eff effects a -> opaque a } - -embedEval' :: forall location value opaque effects a . (Member (Reader (Proxy opaque)) effects, Reifies opaque (EmbedEval opaque effects)) => Eval location value opaque effects a -> Eval location value opaque effects (opaque a) -embedEval' action = do - proxy <- ask @(Proxy opaque) - pure (unEmbedEval (reflect proxy) (lowerEff action)) - - -variable' :: Member (Variable value) effects => Name -> Eval location value opaque effects value -variable' = send . Variable - -data Variable value return where - Variable :: Name -> Variable value value - -runVariable :: forall location value opaque effects a - . ( Members '[ Fail - , Reader (Map Name location) - ] effects - , Show location - ) - => (location -> Eval location value opaque effects (Maybe value)) - -> Eval location value opaque (Variable value ': effects) a - -> Eval location value opaque effects a -runVariable deref = go - where go :: forall a . Eval location value opaque (Variable value ': effects) a -> Eval location value opaque effects a - go = interpret (\ (Variable name) -> do - addr <- lookup' name >>= maybeM (raiseEff (fail ("free variable: " <> show name))) - deref addr >>= maybeM (raiseEff (fail ("uninitialized address: " <> show addr)))) - - -unit' :: Member (Unit value) effects => Eval location value opaque effects value -unit' = send Unit - - -data Unit value return where - Unit :: Unit value value - - -bool :: Member (Boolean value) effects => Bool -> Eval location value opaque effects value -bool = send . Bool - -asBool' :: Member (Boolean value) effects => value -> Eval location value opaque effects Bool -asBool' = send . AsBool - -iff :: Member (Boolean value) effects => value -> Eval location value opaque effects a -> Eval location value opaque effects a -> Eval location value opaque effects a -iff c t e = asBool' c >>= \ c' -> if c' then t else e - -data Boolean value return where - Bool :: Bool -> Boolean value value - AsBool :: value -> Boolean value Bool - - -data Value opaque location - = Closure [Name] (opaque (Value opaque location)) (Map Name location) - | Unit' - | Bool' Bool - -liftHandler :: Functor opaque => (forall a . opaque a -> opaque' a) -> Value opaque location -> Value opaque' location -liftHandler handler = go where go (Closure names body env) = Closure names (handler (go <$> body)) env - -runFunctionValue :: forall location opaque effects effects' a - . ( Members '[ Reader (Map Name location) - ] effects - , Members '[ Reader (Map Name location) - ] effects' - , (Function opaque (Value opaque location) \\ effects) effects' - ) - => (Name -> Eval location (Value opaque location) opaque effects location) - -> (location -> Value opaque location -> Eval location (Value opaque location) opaque effects ()) - -> Eval location (Value opaque location) opaque effects a - -> Eval location (Value opaque location) opaque effects' a -runFunctionValue alloc assign = go - where go :: forall a . Eval location (Value opaque location) opaque effects a -> Eval location (Value opaque location) opaque effects' a - go = interpretAny $ \ eff -> case eff of - Lambda params fvs body -> do - env <- Map.filterWithKey (fmap (`Set.member` fvs) . const) <$> ask - pure (Closure params body env) - Call (Closure paramNames body env) params -> go $ do - bindings <- foldr (uncurry (Map.insert)) env <$> sequenceA (zipWith (\ name param -> do - v <- param - a <- alloc name - assign a v - pure (name, a)) paramNames (map unembedEval params)) - local (Map.unionWith const bindings) (unembedEval body) - -runUnitValue :: (Unit (Value opaque location) \\ effects) effects' - => Eval location (Value opaque location) opaque effects a - -> Eval location (Value opaque location) opaque effects' a -runUnitValue = interpretAny (\ Unit -> pure Unit') - -runBooleanValue :: (Boolean (Value opaque location) \\ effects) effects' - => Eval location (Value opaque location) opaque effects a - -> Eval location (Value opaque location) opaque effects' a -runBooleanValue = interpretAny (\ eff -> case eff of - Bool b -> pure (Bool' b) - AsBool (Bool' b) -> pure b) - - -data Type - = Type :-> Type - | Product [Type] - | TVar Int - | BoolT - deriving (Eq, Ord, Show) - -runFunctionType :: forall opaque effects a - . Members '[ Fresh - , NonDet - , Reader (Map Name Name) - , State (Map Name (Set Type)) - ] effects - => Eval Name Type opaque (Function opaque Type ': effects) a - -> Eval Name Type opaque effects a -runFunctionType = interpret $ \ eff -> case eff of - Lambda params _ body -> runFunctionType $ do - (bindings, tvars) <- foldr (\ name rest -> do - a <- allocType name - tvar <- TVar <$> fresh - assignType a tvar - bimap (Map.insert name a) (tvar :) <$> rest) (pure (Map.empty, [])) params - (Product tvars :->) <$> local (Map.unionWith const bindings) (unembedEval @_ @_ @_ @_ @(Function opaque Type ': effects) body) - Call fn params -> runFunctionType $ do - paramTypes <- traverse (unembedEval @_ @_ @_ @_ @(Function opaque Type ': effects)) params - case fn of - Product argTypes :-> ret -> do - guard (and (zipWith (==) paramTypes argTypes)) - pure ret - _ -> empty - -runUnitType :: Eval location Type opaque (Unit Type ': effects) a - -> Eval location Type opaque effects a -runUnitType = interpret (\ Unit -> pure (Product [])) - -runBooleanType :: Member NonDet effects - => Eval location Type opaque (Boolean Type ': effects) a - -> Eval location Type opaque effects a -runBooleanType = interpret (\ eff -> case eff of - Bool _ -> pure BoolT - AsBool BoolT -> pure True <|> pure False) - - class Show value => AbstractFunction location value effects where -- | Build a closure (a binder like a lambda or method definition). closure :: [Name] -- ^ The parameter names. diff --git a/vendor/effects b/vendor/effects index b45d9cacf..4b4f2956d 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit b45d9cacf9af0e9e9ae9244f1ad334741a9d4f6c +Subproject commit 4b4f2956d8a4d5542990431a1d0a5735f48f917e From 33d31e045f79630ebf1983285e3c7834982e9cb6 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 24 May 2018 12:04:29 -0400 Subject: [PATCH 169/174] appease hlint --- src/Language/Haskell/Assignment.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index 2e6d7642e..ad7fa2849 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -92,7 +92,7 @@ functionDeclaration = makeTerm <*> children (Declaration.Function <$> pure [] <*> variableIdentifier - <*> ((manyTermsTill expression (symbol FunctionBody)) <|> pure []) + <*> (manyTermsTill expression (symbol FunctionBody) <|> pure []) <*> functionBody) integer :: Assignment @@ -103,4 +103,4 @@ float = makeTerm <$> symbol Float <*> (Literal.Float <$> 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 end = manyTill (step <|> comment) end +manyTermsTill step = manyTill (step <|> comment) From 5ac256e340e350c4f93168ddebafafbfaad3586f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 12:09:20 -0400 Subject: [PATCH 170/174] :hammer: fix the type in the spec --- test/SpecHelpers.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 093fc20aa..9df506259 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -94,7 +94,7 @@ testEvaluating deNamespace :: Value Precise -> Maybe (Name, [Name]) deNamespace = fmap (namespaceName &&& Env.names . namespaceScope) . prjValue @(Namespace Precise) -derefQName :: Heap Precise (Cell Precise) (Value Precise) -> NonEmpty Name -> Environment Precise (Value Precise) -> Maybe (Value Precise) +derefQName :: Heap Precise (Cell Precise) (Value Precise) -> NonEmpty Name -> Environment Precise -> Maybe (Value Precise) derefQName heap = go where go (n1 :| ns) env = Env.lookup n1 env >>= flip heapLookup heap >>= getLast . unLatest >>= case ns of [] -> Just From 3a5d1de16205a5b14c2ca9cc24689ec7fd596cc9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 12:21:45 -0400 Subject: [PATCH 171/174] :fire: redundant hiding. --- 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 ef1fa79d9..a3add57f0 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -28,7 +28,7 @@ import Data.Abstract.Ref import Data.Scientific (Scientific) import Data.Semigroup.Reducer hiding (unit) import Data.Semilattice.Lower -import Prelude hiding (fail) +import Prelude import Prologue hiding (TypeError) -- | This datum is passed into liftComparison to handle the fact that Ruby and PHP From d819051bf49535557437c851ce8681a793d6ad3c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 12:22:55 -0400 Subject: [PATCH 172/174] Placate hlint. --- src/Data/Abstract/Exports.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Exports.hs b/src/Data/Abstract/Exports.hs index 12cea0c74..f3c027d87 100644 --- a/src/Data/Abstract/Exports.hs +++ b/src/Data/Abstract/Exports.hs @@ -23,7 +23,7 @@ null :: Exports location -> Bool null = Map.null . unExports toEnvironment :: Exports location -> Environment location -toEnvironment exports = unpairs (mapMaybe sequenceA (map (second (fmap Address)) (toList (unExports exports)))) +toEnvironment exports = unpairs (mapMaybe (sequenceA . second (fmap Address)) (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 From d9b13aec04c10e31ef8006ecc3aec29b3b1e79cd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 12:23:14 -0400 Subject: [PATCH 173/174] Simplify further. --- src/Data/Abstract/Exports.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Exports.hs b/src/Data/Abstract/Exports.hs index f3c027d87..4c71e508d 100644 --- a/src/Data/Abstract/Exports.hs +++ b/src/Data/Abstract/Exports.hs @@ -23,7 +23,7 @@ null :: Exports location -> Bool null = Map.null . unExports toEnvironment :: Exports location -> Environment location -toEnvironment exports = unpairs (mapMaybe (sequenceA . second (fmap Address)) (toList (unExports exports))) +toEnvironment exports = unpairs (mapMaybe (traverse (fmap Address)) (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 From 2ca068a484e337788f2d98a5c2424b40ddbcfb2b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 12:30:42 -0400 Subject: [PATCH 174/174] Fix a renaming. --- src/Language/Haskell/Assignment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index 636ae40b2..0da96796c 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -72,7 +72,7 @@ comment :: Assignment comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) variableIdentifier :: Assignment -variableIdentifier = makeTerm <$> symbol VariableIdentifier <*> (Syntax.Identifier . FV.name <$> source) +variableIdentifier = makeTerm <$> symbol VariableIdentifier <*> (Syntax.Identifier . Name.name <$> source) constructorIdentifier :: Assignment constructorIdentifier = makeTerm <$> symbol ConstructorIdentifier <*> (Syntax.Identifier . Name.name <$> source)