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)