From 24c2eb7d6786c6bb10448e75e377ffab64a2db5a Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 26 Mar 2018 11:11:11 -0400 Subject: [PATCH 01/12] docs --- 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 28aab0f28..9097cb2c1 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -155,6 +155,7 @@ doWhile body cond = loop $ \ continue -> body *> do ifthenelse this continue unit +-- The type of exceptions that can be thrown when constructing values in `MonadValue`. data ValueExc v where ValueExc :: Prelude.String -> ValueExc Value StringExc :: Prelude.String -> ValueExc ByteString From 31eef41359348df7a9490e76b8b5f3dc8b57ad42 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 11:35:37 -0400 Subject: [PATCH 02/12] Dedent. --- src/Data/Abstract/Module.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index b07cad360..719cefede 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -25,7 +25,7 @@ moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the mo moduleForBlob rootDir blob = Module (moduleNameForPath (modulePathForBlob blob)) (blobPath blob) where modulePathForBlob Blob{..} | Just Go <- blobLanguage = takeDirectory (modulePath blobPath) | otherwise = modulePath blobPath - -- TODO: Need a better way to handle module registration and resolution + -- TODO: Need a better way to handle module registration and resolution modulePath = dropExtensions . maybe takeFileName makeRelative rootDir moduleNameForPath :: FilePath -> ModuleName From 1e2f63adaf0d4707861057def2e3e68096e51c64 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 11:58:33 -0400 Subject: [PATCH 03/12] :fire: an unnecessary functional dependency. --- src/Control/Abstract/Evaluator.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index d7c1fbc55..643fd9695 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -169,7 +169,7 @@ modifyModuleTable f = do -- | A 'Monad' abstracting jumps in imperative control. -class Monad m => MonadControl term m | m -> term where +class Monad m => MonadControl term m where -- | Allocate a 'Label' for the given @term@. -- -- Labels must be allocated before being jumped to with 'goto', but are suitable for nonlocal jumps; thus, they can be used to implement coroutines, exception handling, call with current continuation, and other esoteric control mechanisms. From 719f33106d416da5241777e27493826946de7226 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 12:00:26 -0400 Subject: [PATCH 04/12] Spell out the parameters to the synonyms. --- src/Control/Abstract/Evaluator.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 643fd9695..80768be2f 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -185,10 +185,10 @@ instance (Effectful m, Members '[Resumable exc] effects, Monad (m effects)) => M -- | The environment for an abstract value type. -type EnvironmentFor v = Env.Environment (LocationFor v) v +type EnvironmentFor value = Env.Environment (LocationFor value) value -- | The exports for an abstract value type. -type ExportsFor v = Export.Exports (LocationFor v) v +type ExportsFor value = Export.Exports (LocationFor value) value -- | The 'Heap' for an abstract value type. type HeapFor value = Heap (LocationFor value) value From 7cd0558266e312a2661141c869e787ee9d02d486 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 26 Mar 2018 12:01:09 -0400 Subject: [PATCH 05/12] Evaluate nil/null literals. --- src/Control/Abstract/Value.hs | 6 ++++++ src/Data/Abstract/Type.hs | 3 +++ src/Data/Abstract/Value.hs | 8 ++++++++ src/Data/Syntax/Declaration.hs | 4 ++-- src/Data/Syntax/Literal.hs | 8 +++----- 5 files changed, 22 insertions(+), 7 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 46b230015..53d8e094a 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -95,6 +95,9 @@ class (Monad m, Show value) => MonadValue value m where -- | Eliminate boolean values. TODO: s/boolean/truthy ifthenelse :: value -> m a -> m a -> m a + -- | Construct the nil/null datatype. + null :: m value + -- | Build a class value from a name and environment. klass :: Name -- ^ The new class's identifier -> [value] -- ^ A list of superclasses @@ -173,6 +176,8 @@ instance ( Monad m kvPair k = pure . injValue . Value.KVPair k + null = pure . injValue $ Value.Null + asPair k | Just (Value.KVPair k v) <- prjValue k = pure (k, v) | otherwise = fail ("expected key-value pair, got " <> show k) @@ -305,6 +310,7 @@ instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, Mon klass _ _ _ = pure Object namespace _ _ = pure Type.Unit + null = pure Type.Null scopedEnvironment _ = pure mempty diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index c89f8148b..3872240f9 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -22,6 +22,7 @@ data Type | Array [Type] -- ^ Arrays. Note that this is heterogenous. | Hash [(Type, Type)] -- ^ Heterogenous key-value maps. | Object -- ^ Objects. Once we have some notion of inheritance we'll need to store a superclass. + | Null -- ^ The null type. Unlike 'Unit', this unifies with any other type. deriving (Eq, Ord, Show) -- TODO: À la carte representation of types. @@ -30,6 +31,8 @@ data Type -- | Unify two 'Type's. unify :: MonadFail m => Type -> Type -> m Type unify (a1 :-> b1) (a2 :-> b2) = (:->) <$> unify a1 a2 <*> unify b1 b2 +unify a Null = pure a +unify Null b = pure b -- FIXME: this should be constructing a substitution. unify (Var _) b = pure b unify a (Var _) = pure a diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 43b5cb526..95871fc8f 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -25,6 +25,7 @@ type ValueConstructors , Integer , KVPair , Namespace + , Null , Rational , String , Symbol @@ -177,6 +178,13 @@ instance Eq1 Hash where liftEq = genericLiftEq instance Ord1 Hash where liftCompare = genericLiftCompare instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec +data Null value = Null + deriving (Eq, Generic1, Ord, Show) + +instance Eq1 Null where liftEq = genericLiftEq +instance Ord1 Null where liftCompare = genericLiftCompare +instance Show1 Null where liftShowsPrec = genericLiftShowsPrec + -- | The environment for an abstract value type. type EnvironmentFor v = Environment (LocationFor v) v diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 5104e479b..eceb537c8 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -284,7 +284,7 @@ instance Evaluatable QualifiedImport where where moduleName = freeVariable (subterm from) renames importedEnv - | null xs = fmap prepend (Env.names importedEnv) + | Prologue.null xs = fmap prepend (Env.names importedEnv) | otherwise = xs prefix = freeVariable (subterm alias) prepend n = (n, prefix <> n) @@ -307,7 +307,7 @@ instance Evaluatable Import where where moduleName = freeVariable (subterm from) renamed importedEnv - | null xs = importedEnv + | Prologue.null xs = importedEnv | otherwise = Env.overwrite xs importedEnv -- | Side effect only imports (no symbols made available to the calling environment). diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 1fb1adfda..a437429ab 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -8,8 +8,8 @@ import qualified Data.ByteString.Char8 as B import Data.Monoid (Endo (..), appEndo) import Data.Scientific (Scientific) import Diffing.Algorithm -import Prelude hiding (Float, fail) -import Prologue hiding (Set, hash) +import Prelude hiding (Float, fail, null) +import Prologue hiding (Set, hash, null) import Text.Read (readMaybe) -- Boolean @@ -169,9 +169,7 @@ instance Eq1 Null where liftEq = genericLiftEq instance Ord1 Null where liftCompare = genericLiftCompare instance Show1 Null where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for Null -instance Evaluatable Null - +instance Evaluatable Null where eval = const null newtype Symbol a = Symbol { symbolContent :: ByteString } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) From 6dd5e5954a2a3ee44e6fc77bfec3ebcb3dc28ddd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 12:01:49 -0400 Subject: [PATCH 06/12] :fire: some quantification. --- src/Analysis/Abstract/Evaluating.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 6d3c36027..cc1e161a1 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -46,17 +46,17 @@ type EvaluatingEffects term value ] -- | Find the value in the 'Final' result of running. -findValue :: forall value term effects. (effects ~ RequiredEffects term value (Evaluating term value effects)) +findValue :: (effects ~ RequiredEffects term value (Evaluating term value effects)) => Final effects value -> Either Prelude.String (Either (SomeExc (Unspecialized value)) (Either (SomeExc (ValueExc value)) value)) findValue (((((v, _), _), _), _), _) = v -- | Find the 'Environment' in the 'Final' result of running. -findEnv :: forall value term effects . (effects ~ RequiredEffects term value (Evaluating term value effects)) +findEnv :: (effects ~ RequiredEffects term value (Evaluating term value effects)) => Final effects value -> EnvironmentFor value findEnv (((((_, env), _), _), _), _) = env -- | Find the 'Heap' in the 'Final' result of running. -findHeap :: forall value term effects . (effects ~ RequiredEffects term value (Evaluating term value effects)) +findHeap :: (effects ~ RequiredEffects term value (Evaluating term value effects)) => Final effects value -> Monoidal.Map (LocationFor value) (CellFor value) findHeap (((((_, _), Heap heap), _), _), _) = heap From 14daa521372d4d28e43dd98459c493a34b40b5a5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 12:02:36 -0400 Subject: [PATCH 07/12] Tidy up the language pragmas. --- src/Analysis/Abstract/Evaluating.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index cc1e161a1..23196139c 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses, Rank2Types, ScopedTypeVariables, - StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, + StandaloneDeriving, TypeApplications, TypeFamilies, UndecidableInstances #-} module Analysis.Abstract.Evaluating ( type Evaluating , findValue From eda416652c093f3c2ab2dcaa8c600e566381a3e0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 12:02:54 -0400 Subject: [PATCH 08/12] :fire: the `type` keyword which is making stylish-haskell sad. --- src/Analysis/Abstract/Evaluating.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 23196139c..ed2d85d7e 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, UndecidableInstances #-} module Analysis.Abstract.Evaluating -( type Evaluating +( Evaluating , findValue , findEnv , findHeap From 46e7af71d28a5eed69689d9e9ac90c91c6911188 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 12:05:09 -0400 Subject: [PATCH 09/12] Indent. --- src/Control/Abstract/Evaluator.hs | 46 +++++++++++++++---------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 80768be2f..3806abc59 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,28 +1,28 @@ {-# LANGUAGE ConstrainedClassMethods, DataKinds, FunctionalDependencies, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Evaluator -( MonadEvaluator(..) -, MonadEnvironment(..) -, modifyEnv -, modifyExports -, addExport -, fullEnvironment -, MonadHeap(..) -, modifyHeap -, localize -, lookupHeap -, assign -, MonadModuleTable(..) -, modifyModuleTable -, MonadControl(..) -, MonadThrow(..) -, EnvironmentFor -, ExportsFor -, HeapFor -, CellFor -, LiveFor -, LocationFor -, ConfigurationFor -) where + ( MonadEvaluator(..) + , MonadEnvironment(..) + , modifyEnv + , modifyExports + , addExport + , fullEnvironment + , MonadHeap(..) + , modifyHeap + , localize + , lookupHeap + , assign + , MonadModuleTable(..) + , modifyModuleTable + , MonadControl(..) + , MonadThrow(..) + , EnvironmentFor + , ExportsFor + , HeapFor + , CellFor + , LiveFor + , LocationFor + , ConfigurationFor + ) where import Control.Effect import Control.Monad.Effect.Resumable From 1b0cfb20da0e3d419bba0290d1345ae3160136bd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 12:07:21 -0400 Subject: [PATCH 10/12] Sort the synonyms. --- src/Control/Abstract/Evaluator.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 3806abc59..161ab5924 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -15,13 +15,14 @@ module Control.Abstract.Evaluator , modifyModuleTable , MonadControl(..) , MonadThrow(..) + -- Type synonyms specialized for location types + , CellFor + , ConfigurationFor , EnvironmentFor , ExportsFor , HeapFor - , CellFor , LiveFor , LocationFor - , ConfigurationFor ) where import Control.Effect @@ -177,6 +178,7 @@ class Monad m => MonadControl term m where -- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated in e.g. a 'MonadAnalysis' instance). goto :: Label -> m term + class Monad m => MonadThrow exc m where throwException :: exc v -> m v @@ -184,6 +186,12 @@ instance (Effectful m, Members '[Resumable exc] effects, Monad (m effects)) => M throwException = raise . throwError +-- | The cell for an abstract value type. +type CellFor value = Cell (LocationFor value) value + +-- | The configuration for term and abstract value types. +type ConfigurationFor term value = Configuration (LocationFor value) term value + -- | The environment for an abstract value type. type EnvironmentFor value = Env.Environment (LocationFor value) value @@ -193,14 +201,8 @@ type ExportsFor value = Export.Exports (LocationFor value) value -- | The 'Heap' for an abstract value type. type HeapFor value = Heap (LocationFor value) value --- | The cell for an abstract value type. -type CellFor value = Cell (LocationFor value) value - -- | The address set type for an abstract value type. type LiveFor value = Live (LocationFor value) value --- | The configuration for term and abstract value types. -type ConfigurationFor term value = Configuration (LocationFor value) term value - -- | The location type (the body of 'Address'es) which should be used for an abstract value type. type family LocationFor value :: * From e8dfa26c97e899693ac2b226d36a1bce50059f78 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 12:08:48 -0400 Subject: [PATCH 11/12] :memo: MonadThrow. --- src/Control/Abstract/Evaluator.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 161ab5924..0fbf77d29 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -179,6 +179,7 @@ class Monad m => MonadControl term m where goto :: Label -> m term +-- | 'Monad's which can throw exceptions of type @exc v@ which can be resumed with a value of type @v@. class Monad m => MonadThrow exc m where throwException :: exc v -> m v From 0db30a6d8c7ba1656f3c85cd120800a66fc387b5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 12:12:56 -0400 Subject: [PATCH 12/12] Align a bunch of cases. --- src/Data/Abstract/Value.hs | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index e8cc66584..32c3a7181 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -239,15 +239,15 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where | otherwise = fail ("Invalid operand to liftNumeric: " <> show arg) liftNumeric2 f left right - | Just (Integer i, Integer j) <- prjPair pair = f i j & specialize - | Just (Integer i, Rational j) <- prjPair pair = f i j & specialize - | Just (Integer i, Float j) <- prjPair pair = f i j & specialize + | Just (Integer i, Integer j) <- prjPair pair = f i j & specialize + | Just (Integer i, Rational j) <- prjPair pair = f i j & specialize + | Just (Integer i, Float j) <- prjPair pair = f i j & specialize | Just (Rational i, Integer j) <- prjPair pair = f i j & specialize | Just (Rational i, Rational j) <- prjPair pair = f i j & specialize | Just (Rational i, Float j) <- prjPair pair = f i j & specialize - | Just (Float i, Integer j) <- prjPair pair = f i j & specialize - | Just (Float i, Rational j) <- prjPair pair = f i j & specialize - | Just (Float i, Float j) <- prjPair pair = f i j & specialize + | Just (Float i, Integer j) <- prjPair pair = f i j & specialize + | Just (Float i, Rational j) <- prjPair pair = f i j & specialize + | Just (Float i, Float j) <- prjPair pair = f i j & specialize | otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair) where -- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor @@ -259,12 +259,12 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where liftComparison comparator left right | Just (Integer (Number.Integer i), Integer (Number.Integer j)) <- prjPair pair = go i j - | Just (Integer (Number.Integer i), Float (Number.Decimal j)) <- prjPair pair = go (fromIntegral i) j - | Just (Float (Number.Decimal i), Integer (Number.Integer j)) <- prjPair pair = go i (fromIntegral j) - | Just (Float (Number.Decimal i), Float (Number.Decimal j)) <- prjPair pair = go i j - | Just (String i, String j) <- prjPair pair = go i j - | Just (Boolean i, Boolean j) <- prjPair pair = go i j - | Just (Unit, Unit) <- prjPair pair = boolean True + | Just (Integer (Number.Integer i), Float (Number.Decimal j)) <- prjPair pair = go (fromIntegral i) j + | Just (Float (Number.Decimal i), Integer (Number.Integer j)) <- prjPair pair = go i (fromIntegral j) + | Just (Float (Number.Decimal i), Float (Number.Decimal j)) <- prjPair pair = go i j + | Just (String i, String j) <- prjPair pair = go i j + | Just (Boolean i, Boolean j) <- prjPair pair = go i j + | Just (Unit, Unit) <- prjPair pair = boolean True | otherwise = fail ("Type error: invalid arguments to liftComparison: " <> show pair) where -- Explicit type signature is necessary here because we're passing all sorts of things