Merge branch 'master' into quiet-analysis

src/Analysis/Abstract/Evaluating.hs

@@ -1,23 +1,23 @@
 {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, Rank2Types, StandaloneDeriving, TypeFamilies, UndecidableInstances #-}
 module Analysis.Abstract.Evaluating
-( type Evaluating
+( Evaluating
 , findValue
 , findEnv
 , findHeap
 ) where
 
-import Control.Abstract.Analysis
-import Control.Monad.Effect
-import Data.Abstract.Configuration
+import           Control.Abstract.Analysis
+import           Control.Monad.Effect
+import           Data.Abstract.Configuration
 import qualified Data.Abstract.Environment as Env
-import Data.Abstract.Evaluatable
-import Data.Abstract.Heap
-import Data.Abstract.Module
-import Data.Abstract.ModuleTable
+import           Data.Abstract.Evaluatable
+import           Data.Abstract.Heap
+import           Data.Abstract.Module
+import           Data.Abstract.ModuleTable
 import qualified Data.IntMap as IntMap
 import qualified Data.Map.Monoidal as Monoidal
-import Prelude hiding (fail)
-import Prologue
+import           Prelude hiding (fail)
+import           Prologue
 
 -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@.
 newtype Evaluating term value effects a = Evaluating (Eff effects a)

src/Control/Abstract/Evaluator.hs

@@ -1,29 +1,29 @@
 {-# LANGUAGE ConstrainedClassMethods, DataKinds, FunctionalDependencies, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Control.Abstract.Evaluator
-( MonadEvaluator(..)
-, MonadEnvironment(..)
-, modifyEnv
-, modifyExports
-, addExport
-, fullEnvironment
-, MonadHeap(..)
-, modifyHeap
-, localize
-, lookupHeap
-, assign
-, MonadModuleTable(..)
-, modifyModuleTable
-, MonadControl(..)
-, MonadThrow(..)
-, resumeException
-, EnvironmentFor
-, ExportsFor
-, HeapFor
-, CellFor
-, LiveFor
-, LocationFor
-, ConfigurationFor
-) where
+  ( MonadEvaluator(..)
+  , MonadEnvironment(..)
+  , modifyEnv
+  , modifyExports
+  , addExport
+  , fullEnvironment
+  , MonadHeap(..)
+  , modifyHeap
+  , localize
+  , lookupHeap
+  , assign
+  , MonadModuleTable(..)
+  , modifyModuleTable
+  , MonadControl(..)
+  , MonadThrow(..)
+  -- Type synonyms specialized for location types
+  , CellFor
+  , ConfigurationFor
+  , EnvironmentFor
+  , ExportsFor
+  , HeapFor
+  , LiveFor
+  , LocationFor
+  ) where
 
 import Control.Effect
 import Control.Monad.Effect.Resumable
@@ -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
-   throwException = raise . throwError
+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,14 +173,15 @@ 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
 
 instance Eq1 (ValueExc value) where
-  liftEq _ (ValueExc a) (ValueExc b)   = a == b
+  liftEq _ (ValueExc a)  (ValueExc b)  = a == b
   liftEq _ (StringExc a) (StringExc b) = a == b
-  liftEq _ _ _                         = False
+  liftEq _ _             _             = False
 
 deriving instance Show (ValueExc value resume)
 instance Show1 (ValueExc value) where

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/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

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)
@@ -239,15 +249,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 +269,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

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)