1
1
mirror of https://github.com/github/semantic.git synced 2024-12-26 16:33:03 +03:00

Merge branch 'master' into quiet-analysis

This commit is contained in:
Rob Rix 2018-03-26 12:30:19 -04:00
commit 41f2cdd6a9
9 changed files with 97 additions and 75 deletions

View File

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

View File

@ -1,29 +1,29 @@
{-# LANGUAGE ConstrainedClassMethods, DataKinds, FunctionalDependencies, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# LANGUAGE ConstrainedClassMethods, DataKinds, FunctionalDependencies, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Control.Abstract.Evaluator module Control.Abstract.Evaluator
( MonadEvaluator(..) ( MonadEvaluator(..)
, MonadEnvironment(..) , MonadEnvironment(..)
, modifyEnv , modifyEnv
, modifyExports , modifyExports
, addExport , addExport
, fullEnvironment , fullEnvironment
, MonadHeap(..) , MonadHeap(..)
, modifyHeap , modifyHeap
, localize , localize
, lookupHeap , lookupHeap
, assign , assign
, MonadModuleTable(..) , MonadModuleTable(..)
, modifyModuleTable , modifyModuleTable
, MonadControl(..) , MonadControl(..)
, MonadThrow(..) , MonadThrow(..)
, resumeException -- Type synonyms specialized for location types
, EnvironmentFor , CellFor
, ExportsFor , ConfigurationFor
, HeapFor , EnvironmentFor
, CellFor , ExportsFor
, LiveFor , HeapFor
, LocationFor , LiveFor
, ConfigurationFor , LocationFor
) where ) where
import Control.Effect import Control.Effect
import Control.Monad.Effect.Resumable import Control.Monad.Effect.Resumable
@ -170,7 +170,7 @@ modifyModuleTable f = do
-- | A 'Monad' abstracting jumps in imperative control. -- | 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@. -- | 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. -- 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 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 class Monad m => MonadThrow exc m where
throwException :: exc v -> m v 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 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. -- | The cell for an abstract value type.
type CellFor value = Cell (LocationFor value) value 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. -- | The configuration for term and abstract value types.
type ConfigurationFor term value = Configuration (LocationFor value) term value 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. -- | The location type (the body of 'Address'es) which should be used for an abstract value type.
type family LocationFor value :: * type family LocationFor value :: *

View File

@ -105,6 +105,9 @@ class (Monad m, Show value) => MonadValue value m where
-- | Eliminate boolean values. TODO: s/boolean/truthy -- | Eliminate boolean values. TODO: s/boolean/truthy
ifthenelse :: value -> m a -> m a -> m a 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. -- | Build a class value from a name and environment.
klass :: Name -- ^ The new class's identifier klass :: Name -- ^ The new class's identifier
-> [value] -- ^ A list of superclasses -> [value] -- ^ A list of superclasses
@ -170,14 +173,15 @@ class ValueRoots value where
valueRoots :: value -> LiveFor value valueRoots :: value -> LiveFor value
-- The type of exceptions that can be thrown when constructing values in `MonadValue`.
data ValueExc value resume where data ValueExc value resume where
ValueExc :: Prelude.String -> ValueExc value value ValueExc :: Prelude.String -> ValueExc value value
StringExc :: Prelude.String -> ValueExc value ByteString StringExc :: Prelude.String -> ValueExc value ByteString
instance Eq1 (ValueExc value) where 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 _ (StringExc a) (StringExc b) = a == b
liftEq _ _ _ = False liftEq _ _ _ = False
deriving instance Show (ValueExc value resume) deriving instance Show (ValueExc value resume)
instance Show1 (ValueExc value) where instance Show1 (ValueExc value) where

View File

@ -1,4 +1,4 @@
{-# LANGUAGE TypeFamilies, TypeOperators, UndecidableInstances, ScopedTypeVariables #-} {-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Control.Effect where module Control.Effect where
import Control.Monad.Effect as Effect 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 type Result (Resumable exc) a = Either (SomeExc exc) a
runEffect = runError 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. -- | Types wrapping 'Eff' actions.
-- --

View File

@ -25,7 +25,7 @@ moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the mo
moduleForBlob rootDir blob = Module (moduleNameForPath (modulePathForBlob blob)) (blobPath blob) moduleForBlob rootDir blob = Module (moduleNameForPath (modulePathForBlob blob)) (blobPath blob)
where modulePathForBlob Blob{..} | Just Go <- blobLanguage = takeDirectory (modulePath blobPath) where modulePathForBlob Blob{..} | Just Go <- blobLanguage = takeDirectory (modulePath blobPath)
| otherwise = 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 modulePath = dropExtensions . maybe takeFileName makeRelative rootDir
moduleNameForPath :: FilePath -> ModuleName moduleNameForPath :: FilePath -> ModuleName

View File

@ -23,6 +23,7 @@ data Type
| Array [Type] -- ^ Arrays. Note that this is heterogenous. | Array [Type] -- ^ Arrays. Note that this is heterogenous.
| Hash [(Type, Type)] -- ^ Heterogenous key-value maps. | Hash [(Type, Type)] -- ^ Heterogenous key-value maps.
| Object -- ^ Objects. Once we have some notion of inheritance we'll need to store a superclass. | 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) deriving (Eq, Ord, Show)
-- TODO: À la carte representation of types. -- TODO: À la carte representation of types.
@ -31,6 +32,8 @@ data Type
-- | Unify two 'Type's. -- | Unify two 'Type's.
unify :: MonadFail m => Type -> Type -> m Type unify :: MonadFail m => Type -> Type -> m Type
unify (a1 :-> b1) (a2 :-> b2) = (:->) <$> unify a1 a2 <*> unify b1 b2 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. -- FIXME: this should be constructing a substitution.
unify (Var _) b = pure b unify (Var _) b = pure b
unify a (Var _) = pure a unify a (Var _) = pure a
@ -70,6 +73,8 @@ instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, Mon
hash = pure . Hash hash = pure . Hash
kvPair k v = pure (Product [k, v]) kvPair k v = pure (Product [k, v])
null = pure Null
klass _ _ _ = pure Object klass _ _ _ = pure Object
namespace _ _ = pure Unit namespace _ _ = pure Unit

View File

@ -23,6 +23,7 @@ type ValueConstructors
, Integer , Integer
, KVPair , KVPair
, Namespace , Namespace
, Null
, Rational , Rational
, String , String
, Symbol , Symbol
@ -175,6 +176,13 @@ instance Eq1 Hash where liftEq = genericLiftEq
instance Ord1 Hash where liftCompare = genericLiftCompare instance Ord1 Hash where liftCompare = genericLiftCompare
instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec 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 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 kvPair k = pure . injValue . KVPair k
null = pure . injValue $ Null
asPair k asPair k
| Just (KVPair k v) <- prjValue k = pure (k, v) | Just (KVPair k v) <- prjValue k = pure (k, v)
| otherwise = fail ("expected key-value pair, got " <> show k) | 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) | otherwise = fail ("Invalid operand to liftNumeric: " <> show arg)
liftNumeric2 f left right liftNumeric2 f left right
| Just (Integer i, Integer 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, Rational j) <- prjPair pair = f i j & specialize
| Just (Integer i, Float 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, Integer j) <- prjPair pair = f i j & specialize
| Just (Rational i, Rational 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 (Rational i, Float j) <- prjPair pair = f i j & specialize
| Just (Float i, Integer 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, Rational j) <- prjPair pair = f i j & specialize
| Just (Float i, Float 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) | otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair)
where where
-- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor -- 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 liftComparison comparator left right
| Just (Integer (Number.Integer i), Integer (Number.Integer j)) <- prjPair pair = go i j | 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 (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), 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 (Float (Number.Decimal i), Float (Number.Decimal j)) <- prjPair pair = go i j
| Just (String i, String 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 (Boolean i, Boolean j) <- prjPair pair = go i j
| Just (Unit, Unit) <- prjPair pair = boolean True | Just (Unit, Unit) <- prjPair pair = boolean True
| otherwise = fail ("Type error: invalid arguments to liftComparison: " <> show pair) | otherwise = fail ("Type error: invalid arguments to liftComparison: " <> show pair)
where where
-- Explicit type signature is necessary here because we're passing all sorts of things -- Explicit type signature is necessary here because we're passing all sorts of things

View File

@ -283,7 +283,7 @@ instance Evaluatable QualifiedImport where
where where
moduleName = freeVariable (subterm from) moduleName = freeVariable (subterm from)
renames importedEnv renames importedEnv
| null xs = fmap prepend (Env.names importedEnv) | Prologue.null xs = fmap prepend (Env.names importedEnv)
| otherwise = xs | otherwise = xs
prefix = freeVariable (subterm alias) prefix = freeVariable (subterm alias)
prepend n = (n, prefix <> n) prepend n = (n, prefix <> n)
@ -306,7 +306,7 @@ instance Evaluatable Import where
where where
moduleName = freeVariable (subterm from) moduleName = freeVariable (subterm from)
renamed importedEnv renamed importedEnv
| null xs = importedEnv | Prologue.null xs = importedEnv
| otherwise = Env.overwrite xs importedEnv | otherwise = Env.overwrite xs importedEnv
-- | Side effect only imports (no symbols made available to the calling environment). -- | Side effect only imports (no symbols made available to the calling environment).

View File

@ -8,8 +8,8 @@ import qualified Data.ByteString.Char8 as B
import Data.Monoid (Endo (..), appEndo) import Data.Monoid (Endo (..), appEndo)
import Data.Scientific (Scientific) import Data.Scientific (Scientific)
import Diffing.Algorithm import Diffing.Algorithm
import Prelude hiding (Float, fail) import Prelude hiding (Float, fail, null)
import Prologue hiding (Set, hash) import Prologue hiding (Set, hash, null)
import Text.Read (readMaybe) import Text.Read (readMaybe)
-- Boolean -- Boolean
@ -169,9 +169,7 @@ instance Eq1 Null where liftEq = genericLiftEq
instance Ord1 Null where liftCompare = genericLiftCompare instance Ord1 Null where liftCompare = genericLiftCompare
instance Show1 Null where liftShowsPrec = genericLiftShowsPrec instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Null instance Evaluatable Null where eval = const null
instance Evaluatable Null
newtype Symbol a = Symbol { symbolContent :: ByteString } newtype Symbol a = Symbol { symbolContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)