Merge branch 'master' into quiet-analysis

src/Analysis/Abstract/Evaluating.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, Rank2Types, StandaloneDeriving, TypeFamilies, UndecidableInstances #-}
 module Analysis.Abstract.Evaluating
-( type Evaluating
+( Evaluating
 , findValue
 , findEnv
 , findHeap

src/Control/Abstract/Evaluator.hs

@@ -15,14 +15,14 @@ module Control.Abstract.Evaluator
   , modifyModuleTable
   , MonadControl(..)
   , MonadThrow(..)
-, resumeException
+  -- Type synonyms specialized for location types
+  , CellFor
+  , ConfigurationFor
   , EnvironmentFor
   , ExportsFor
   , HeapFor
-, CellFor
   , LiveFor
   , LocationFor
-, ConfigurationFor
   ) where
 
 import Control.Effect
@@ -170,7 +170,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.
@@ -179,33 +179,31 @@ class Monad m => MonadControl term m | m -> term 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
 
-instance (Monad (m effects), Effectful m, Members '[Resumable exc] effects) => MonadThrow exc (m effects) where
+instance (Effectful m, Members '[Resumable exc] effects, Monad (m effects)) => MonadThrow exc (m effects) where
   throwException = raise . throwError
 
-resumeException :: forall exc m e a. (Effectful m, Resumable exc :< e) => m e a -> (forall v. (v -> m e a) -> exc v -> m e a) -> m e a
-resumeException m handle = raise (resumeError (lower m) (\yield -> lower . handle (raise . yield)))
-
-
--- | The environment for an abstract value type.
-type EnvironmentFor v = Env.Environment (LocationFor v) v
-
--- | The exports for an abstract value type.
-type ExportsFor v = Export.Exports (LocationFor v) v
-
--- | 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 environment for an abstract value type.
+type EnvironmentFor value = Env.Environment (LocationFor value) value
+
+-- | The exports for an abstract value type.
+type ExportsFor value = Export.Exports (LocationFor value) value
+
+-- | The 'Heap' for an abstract value type.
+type HeapFor value = Heap (LocationFor value) value
+
+-- | The address set type for an abstract value type.
+type LiveFor value = Live (LocationFor value) value
+
 -- | The location type (the body of 'Address'es) which should be used for an abstract value type.
 type family LocationFor value :: *

src/Control/Abstract/Value.hs

@@ -105,6 +105,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
@@ -170,6 +173,7 @@ class ValueRoots value where
   valueRoots :: value -> LiveFor value
 
 
+-- The type of exceptions that can be thrown when constructing values in `MonadValue`.
 data ValueExc value resume where
   ValueExc :: Prelude.String -> ValueExc value value
   StringExc :: Prelude.String -> ValueExc value ByteString

src/Control/Effect.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies, TypeOperators, UndecidableInstances, ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Control.Effect where
 
 import Control.Monad.Effect as Effect
@@ -68,6 +68,13 @@ instance RunEffect (Resumable exc) a where
   type Result (Resumable exc) a = Either (SomeExc exc) a
   runEffect = runError
 
+resumeException :: (Resumable exc :< e, Effectful m) => m e a -> (forall v . (v -> m e a) -> exc v -> m e a) -> m e a
+resumeException m handle = raise (resumeError (lower m) (\yield -> lower . handle (raise . yield)))
+
+-- | Reassociate 'Either's, combining errors into 'Left' values and successes in a single level of 'Right'.
+mergeEither :: Either a (Either b c) -> Either (Either a b) c
+mergeEither = either (Left . Left) (either (Left . Right) Right)
+
 
 -- | Types wrapping 'Eff' actions.
 --

src/Data/Abstract/Type.hs

@@ -23,6 +23,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.
@@ -31,6 +32,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
@@ -70,6 +73,8 @@ instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, Mon
   hash       = pure . Hash
   kvPair k v = pure (Product [k, v])
 
+  null          = pure Null
+
   klass _ _ _   = pure Object
   namespace _ _ = pure Unit
 

src/Data/Abstract/Value.hs

@@ -23,6 +23,7 @@ type ValueConstructors
     , Integer
     , KVPair
     , Namespace
+    , Null
     , Rational
     , String
     , Symbol
@@ -175,6 +176,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
+
 
 type instance LocationFor Value = Precise
 
@@ -199,6 +207,8 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where
 
   kvPair k = pure . injValue . KVPair k
 
+  null     = pure . injValue $ Null
+
   asPair k
     | Just (KVPair k v) <- prjValue k = pure (k, v)
     | otherwise = fail ("expected key-value pair, got " <> show k)

src/Data/Syntax/Declaration.hs

@@ -283,7 +283,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)
@@ -306,7 +306,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).

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)