github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-28 18:23:44 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into grammar-guide

Browse Source
This commit is contained in:
Ayman Nadeem 2018-03-13 09:47:24 -07:00 committed by GitHub
commit 8371d88d69
49 changed files with 921 additions and 671 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
bench/Main.hs Normal file
View File

@ -0,0 +1,29 @@
module Main where
import Criterion.Main
import Semantic.Util
import Data.Monoid
import Control.Monad
-- We use `fmap show` to ensure that all the parts of the result of evaluation are
-- evaluated themselves. While an NFData instance is the most morally correct way
-- to do this, I'm reluctant to add NFData instances to every single datatype in the
-- project—coercing the result into a string will suffice, though it throws off the
-- memory allocation results a bit.
pyEval :: FilePath -> Benchmarkable
pyEval = whnfIO . fmap show . evaluatePythonFile . ("bench/bench-fixtures/python/" <>)
rbEval :: FilePath -> Benchmarkable
rbEval = whnfIO . fmap show . evaluateRubyFile . ("bench/bench-fixtures/ruby/" <>)
main :: IO ()
main = defaultMain
[ bgroup "python" [ bench "assignment" $ pyEval "simple-assignment.py"
, bench "function def" $ pyEval "function-definition.py"
, bench "if + function calls" $ pyEval "if-statement-functions.py"
]
, bgroup "ruby" [ bench "assignment" $ rbEval "simple-assignment.rb"
, bench "function def" $ rbEval "function-definition.rb"
, bench "if + function calls" $ rbEval "if-statement-functions.rb"
]
]

14
bench/bench-fixtures/python/function-definition.py Normal file
View File

@ -0,0 +1,14 @@
def a():
b
def c(d):
e
def g(g, *h):
i
def h(i=1):
i
def i(j="default", **c):
j

12
bench/bench-fixtures/python/if-statement-functions.py Normal file
View File

@ -0,0 +1,12 @@
def foo(): return "bipp"
def bar(): return foo()
def baz(): return bar()
def why(): return "elle"
if True:
baz()
else:
why()

5
bench/bench-fixtures/python/simple-assignment.py Normal file
View File

@ -0,0 +1,5 @@
foo = 2
bar = foo
dang = 3
song = dang
song

19
bench/bench-fixtures/ruby/function-definition.rb Normal file
View File

@ -0,0 +1,19 @@
def a()
"b"
end
def c(d)
"e"
end
def g(g_)
"i"
end
def h(i=1)
i
end
def i()
"j"
end

21
bench/bench-fixtures/ruby/if-statement-functions.rb Normal file
View File

@ -0,0 +1,21 @@
def foo()
"bipp"
end
def bar()
foo()
end
def baz()
bar()
end
def why()
return "elle"
end
if true
baz()
else
why()
end

5
bench/bench-fixtures/ruby/simple-assignment.rb Normal file
View File

@ -0,0 +1,5 @@
foo = 2
bar = foo
dang = 3
song = dang
song

21
semantic.cabal
View File

@ -19,7 +19,7 @@ library
-- , Analysis.Abstract.Collecting
, Analysis.Abstract.Dead
, Analysis.Abstract.Evaluating
-- , Analysis.Abstract.Tracing
, Analysis.Abstract.Tracing
, Analysis.ConstructorName
, Analysis.CyclomaticComplexity
, Analysis.Decorator
@ -37,11 +37,9 @@ library
-- Control flow
, Control.Effect
-- Effects used for program analysis
, Control.Monad.Effect.Cache
, Control.Monad.Effect.Fresh
-- , Control.Monad.Effect.GC
, Control.Monad.Effect.NonDet
-- , Control.Monad.Effect.Trace
-- Datatypes for abstract interpretation
, Data.Abstract.Address
, Data.Abstract.Cache
@ -65,6 +63,7 @@ library
, Data.Functor.Classes.Generic
, Data.JSON.Fields
, Data.Language
, Data.Map.Monoidal
, Data.Mergeable
, Data.Output
, Data.Patch
@ -141,7 +140,6 @@ library
, bifunctors
, bytestring
, cmark-gfm
, comonad
, containers
, directory
, effects
@ -160,9 +158,8 @@ library
, optparse-applicative
, parallel
, parsers
, pointed
, recursion-schemes
, semigroups
, reducers
, scientific
, split
, stm-chans
@ -252,6 +249,18 @@ test-suite test
default-language: Haskell2010
default-extensions: DeriveFunctor, DeriveGeneric, FlexibleContexts, FlexibleInstances, OverloadedStrings, RecordWildCards
benchmark evaluation
hs-source-dirs: bench
type: exitcode-stdio-1.0
main-is: Main.hs
ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A4m -n2m -T" -static -j -O
cc-options: -DU_STATIC_IMPLEMENTATION=1
cpp-options: -DU_STATIC_IMPLEMENTATION=1
build-depends: base
, criterion
, semantic
source-repository head
type: git
location: https://github.com/github/semantic

206
src/Analysis/Abstract/Caching.hs
View File

@ -1,123 +1,113 @@
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, UndecidableInstances #-}
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.Caching
( evaluateCache )
where
( type Caching
) where
import Prologue
import Data.Monoid (Alt(..))
import Control.Abstract.Evaluator
import Control.Effect
import Control.Monad.Effect.Fail
import Control.Monad.Effect.Fresh
import Control.Monad.Effect.NonDet
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Data.Abstract.Address
import Control.Abstract.Analysis
import Data.Abstract.Cache
import Data.Abstract.Configuration
import Data.Abstract.Environment
import Data.Abstract.Evaluatable
import Data.Abstract.ModuleTable
import Data.Abstract.Live
import Data.Abstract.Store
import Data.Abstract.Value
import qualified Data.Set as Set
import Data.Monoid (Alt (..))
import Prologue
-- | The effects necessary for caching analyses.
type CachingEffects t v
= '[ Fresh -- For 'MonadFresh'.
, Reader (Live (LocationFor v) v) -- For 'MonadGC'.
, Reader (Environment (LocationFor v) v) -- For 'MonadEnv'.
, State (Environment (LocationFor v) v) -- For 'MonadEvaluator'.
, Fail -- For 'MonadFail'.
, NonDetEff -- For 'Alternative' & 'MonadNonDet'.
, State (Store (LocationFor v) v) -- For 'MonadStore'.
, Reader (Cache (LocationFor v) t v) -- For 'MonadCacheIn'.
, State (Cache (LocationFor v) t v) -- For 'MonadCacheOut'.
, Reader (ModuleTable t) -- Cache of unevaluated modules
, State (ModuleTable (EnvironmentFor v)) -- Cache of evaluated modules
]
type CachingEffects term value effects
= Fresh -- For 'MonadFresh'.
': NonDetEff -- For 'Alternative' and 'MonadNonDet'.
': Reader (CacheFor term value) -- The in-cache used as an oracle while converging on a result.
': State (CacheFor term value) -- The out-cache used to record results in each iteration of convergence.
': effects
newtype CachingAnalysis term value a = CachingAnalysis { runCachingAnalysis :: Evaluator (CachingEffects term value) term value a }
deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadFresh, MonadNonDet)
-- | The cache for term and abstract value types.
type CacheFor term value = Cache (LocationFor value) term value
deriving instance MonadEvaluator term value (CachingAnalysis term value)
-- | A (coinductively-)cached analysis suitable for guaranteeing termination of (suitably finitized) analyses over recursive programs.
newtype Caching m term value (effects :: [* -> *]) a = Caching (m term value effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
-- TODO: reabstract these later on
deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Caching m term value effects)
deriving instance MonadStore value (m term value effects) => MonadStore value (Caching m term value effects)
deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Caching m term value effects)
deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Caching m term value effects)
askCache :: CachingAnalysis t v (Cache (LocationFor v) t v)
askCache = CachingAnalysis (Evaluator ask)
-- | Functionality used to perform caching analysis. This is not exported, and exists primarily for organizational reasons.
class MonadEvaluator term value m => MonadCaching term value m where
-- | Look up the set of values for a given configuration in the in-cache.
consultOracle :: ConfigurationFor term value -> m (Set (value, StoreFor value))
-- | Run an action with the given in-cache.
withOracle :: CacheFor term value -> m a -> m a
localCache :: (Cache (LocationFor v) t v -> Cache (LocationFor v) t v) -> CachingAnalysis t v a -> CachingAnalysis t v a
localCache f (CachingAnalysis (Evaluator a)) = CachingAnalysis (Evaluator (local f a))
-- | Look up the set of values for a given configuration in the out-cache.
lookupCache :: ConfigurationFor term value -> m (Maybe (Set (value, StoreFor value)))
-- | Run an action, caching its result and 'Store' under the given configuration.
caching :: ConfigurationFor term value -> Set (value, StoreFor value) -> m value -> m value
asksCache :: (Cache (LocationFor v) t v -> a) -> CachingAnalysis t v a
asksCache f = f <$> askCache
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
isolateCache :: m a -> m (CacheFor term value)
getsCache :: (Cache (LocationFor v) t v -> a) -> CachingAnalysis t v a
getsCache f = f <$> getCache
instance ( Effectful (m term value)
, Members (CachingEffects term value '[]) effects
, MonadEvaluator term value (m term value effects)
, Ord (CellFor value)
, Ord (LocationFor value)
, Ord term
, Ord value
)
=> MonadCaching term value (Caching m term value effects) where
consultOracle configuration = raise (fromMaybe mempty . cacheLookup configuration <$> ask)
withOracle cache = raise . local (const cache) . lower
getCache :: CachingAnalysis t v (Cache (LocationFor v) t v)
getCache = CachingAnalysis (Evaluator get)
lookupCache configuration = raise (cacheLookup configuration <$> get)
caching configuration values action = do
raise (modify (cacheSet configuration values))
result <- (,) <$> action <*> getStore
raise (modify (cacheInsert configuration result))
pure (fst result)
putCache :: Cache (LocationFor v) t v -> CachingAnalysis t v ()
putCache v = CachingAnalysis (Evaluator (put v))
modifyCache :: (Cache (LocationFor v) t v -> Cache (LocationFor v) t v) -> CachingAnalysis t v ()
modifyCache f = fmap f getCache >>= putCache
isolateCache action = raise (put (mempty :: CacheFor term value)) *> action *> raise get
-- | This instance coinductively iterates the analysis of a term until the results converge.
instance ( Corecursive t
, Ord t
, Ord v
, Ord (Cell (LocationFor v) v)
, Evaluatable (Base t)
, Foldable (Cell (LocationFor v))
, FreeVariables t
, MonadAddressable (LocationFor v) v (CachingAnalysis t v)
, MonadValue t v (CachingAnalysis t v)
, Recursive t
, Semigroup (Cell (LocationFor v) v)
instance ( Corecursive term
, Effectful (m term value)
, MonadAnalysis term value (m term value effects)
, MonadFresh (m term value effects)
, MonadNonDet (m term value effects)
, Members (CachingEffects term value '[]) effects
, Ord (CellFor value)
, Ord (LocationFor value)
, Ord term
, Ord value
)
=> MonadAnalysis t v (CachingAnalysis t v) where
=> MonadAnalysis term value (Caching m term value effects) where
-- We require the 'CachingEffects' in addition to the underlying analysis’ 'RequiredEffects'.
type RequiredEffects term value (Caching m term value effects) = CachingEffects term value (RequiredEffects term value (m term value effects))
-- Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
analyzeTerm e = do
c <- getConfiguration (embedSubterm e)
cached <- lookupCache c
case cached of
Just pairs -> scatter pairs
Nothing -> do
pairs <- consultOracle c
caching c pairs (liftAnalyze analyzeTerm e)
evaluateModule e = do
c <- getConfiguration e
-- Convergence here is predicated upon an Eq instance, not α-equivalence
cache <- converge (\ prevCache -> do
putCache (mempty :: Cache (LocationFor v) t v)
cache <- converge (\ prevCache -> isolateCache $ do
putStore (configurationStore c)
-- We need to reset fresh generation so that this invocation converges.
reset 0
-- This is subtle: though the calling context supports nondeterminism, we want
-- to corral all the nondeterminism that happens in this @eval@ invocation, so
-- that it doesn't "leak" to the calling context and diverge
-- (otherwise this would never complete).
_ <- localCache (const prevCache) (gather Set.singleton (memoizeEval e))
getCache) mempty
-- that it doesn't "leak" to the calling context and diverge (otherwise this
-- would never complete). We don’t need to use the values, so we 'gather' the
-- nondeterministic values into @()@.
withOracle prevCache (gather (const ()) (Caching (evaluateModule e)))) mempty
maybe empty scatter (cacheLookup c cache)
-- | Coinductively-cached evaluation.
evaluateCache :: forall v term
. ( Ord v
, Ord term
, Ord (LocationFor v)
, Ord (Cell (LocationFor v) v)
, Corecursive term
, Evaluatable (Base term)
, FreeVariables term
, Foldable (Cell (LocationFor v))
, Functor (Base term)
, Recursive term
, MonadAddressable (LocationFor v) v (CachingAnalysis term v)
, MonadValue term v (CachingAnalysis term v)
, Semigroup (Cell (LocationFor v) v)
, ValueRoots (LocationFor v) v
)
=> term
-> Final (CachingEffects term v) v
evaluateCache = run @(CachingEffects term v) . runEvaluator . runCachingAnalysis . evaluateTerm
-- | Iterate a monadic action starting from some initial seed until the results converge.
--
-- This applies the Kleene fixed-point theorem to finitize a monotone action. cf https://en.wikipedia.org/wiki/Kleene_fixed-point_theorem
@ -133,40 +123,6 @@ converge f = loop
else
loop x'
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: Ord (LocationFor v) => t -> CachingAnalysis t v (Configuration (LocationFor v) t v)
getConfiguration term = Configuration term mempty <$> askLocalEnv <*> getStore
-- | Nondeterministically write each of a collection of stores & return their associated results.
scatter :: (Alternative m, Foldable t, MonadEvaluator term v m) => t (a, Store (LocationFor v) v) -> m a
scatter :: (Alternative m, Foldable t, MonadEvaluator term value m) => t (a, Store (LocationFor value) value) -> m a
scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value))
-- | Evaluation of a single iteration of an analysis, given a 'MonadCacheIn' instance as an oracle for results and a 'MonadCacheOut' instance to record computed results in.
memoizeEval :: forall v term
. ( Ord v
, Ord term
, Ord (LocationFor v)
, Ord (Cell (LocationFor v) v)
, Corecursive term
, Evaluatable (Base term)
, FreeVariables term
, Foldable (Cell (LocationFor v))
, Functor (Base term)
, Recursive term
, MonadAddressable (LocationFor v) v (CachingAnalysis term v)
, MonadValue term v (CachingAnalysis term v)
, Semigroup (Cell (LocationFor v) v)
)
=> SubtermAlgebra (Base term) term (CachingAnalysis term v v)
memoizeEval e = do
c <- getConfiguration (embedSubterm e)
cached <- getsCache (cacheLookup c)
case cached of
Just pairs -> scatter pairs
Nothing -> do
pairs <- asksCache (fromMaybe mempty . cacheLookup c)
modifyCache (cacheSet c pairs)
v <- eval e
store' <- getStore
modifyCache (cacheInsert c (v, store'))
pure v

107
src/Analysis/Abstract/Dead.hs
View File

@ -1,84 +1,55 @@
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, UndecidableInstances #-}
module Analysis.Abstract.Dead where
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators #-}
module Analysis.Abstract.Dead
( type DeadCode
) where
import Control.Abstract.Addressable
import Control.Abstract.Evaluator
import Control.Effect
import Control.Monad.Effect.Fail
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Data.Abstract.Address
import Data.Abstract.Evaluatable
import Data.Abstract.ModuleTable
import Data.Abstract.Store
import Data.Abstract.Value
import Control.Abstract.Analysis
import Data.Semigroup.Reducer as Reducer
import Data.Set (delete)
import Prologue
-- | The effects necessary for dead code analysis.
type DeadCodeEffects t v
= '[ State (Dead t) -- The set of dead terms
, Fail -- Failure with an error message
, State (Store (LocationFor v) v) -- The heap
, State (EnvironmentFor v) -- Global (imperative) environment
, Reader (EnvironmentFor v) -- Local environment (e.g. binding over a closure)
, Reader (ModuleTable t) -- Cache of unevaluated modules
, State (ModuleTable (EnvironmentFor v)) -- Cache of evaluated modules
]
-- | Run a dead code analysis of the given program.
evaluateDead :: forall term value
. ( Corecursive term
, Evaluatable (Base term)
, Foldable (Base term)
, FreeVariables term
, MonadAddressable (LocationFor value) value (DeadCodeAnalysis term value)
, MonadValue term value (DeadCodeAnalysis term value)
, Ord (LocationFor value)
, Ord term
, Recursive term
, Semigroup (Cell (LocationFor value) value)
)
=> term
-> Final (DeadCodeEffects term value) value
evaluateDead term = run @(DeadCodeEffects term value) . runEvaluator . runDeadCodeAnalysis $ do
killAll (subterms term)
evaluateTerm term
where subterms :: (Ord a, Recursive a, Foldable (Base a)) => a -> Dead a
subterms term = para (foldMap (uncurry ((<>) . point))) term <> point term
-- | A newtype wrapping 'Evaluator' which performs a dead code analysis on evaluation.
newtype DeadCodeAnalysis term value a = DeadCodeAnalysis { runDeadCodeAnalysis :: Evaluator (DeadCodeEffects term value) term value a }
deriving (Applicative, Functor, Monad, MonadFail)
deriving instance MonadEvaluator term value (DeadCodeAnalysis term value)
-- | An analysis tracking dead (unreachable) code.
newtype DeadCode m term value (effects :: [* -> *]) a = DeadCode (m term value effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (DeadCode m term value effects)
deriving instance MonadStore value (m term value effects) => MonadStore value (DeadCode m term value effects)
deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (DeadCode m term value effects)
deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (DeadCode m term value effects)
-- | A set of “dead” (unreachable) terms.
newtype Dead a = Dead { unDead :: Set a }
deriving (Eq, Foldable, Semigroup, Monoid, Ord, Pointed, Show)
newtype Dead term = Dead { unDead :: Set term }
deriving (Eq, Foldable, Semigroup, Monoid, Ord, Show)
deriving instance Ord term => Reducer term (Dead term)
-- | Update the current 'Dead' set.
killAll :: Dead t -> DeadCodeAnalysis t v ()
killAll = DeadCodeAnalysis . Evaluator . put
killAll :: (Effectful (m term value), Member (State (Dead term)) effects) => Dead term -> DeadCode m term value effects ()
killAll = raise . put
-- | Revive a single term, removing it from the current 'Dead' set.
revive :: Ord t => t -> DeadCodeAnalysis t v ()
revive t = DeadCodeAnalysis (Evaluator (modify (Dead . delete t . unDead)))
revive :: (Effectful (m term value), Member (State (Dead term)) effects) => Ord term => term -> DeadCode m term value effects ()
revive t = raise (modify (Dead . delete t . unDead))
-- | Compute the set of all subterms recursively.
subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead term
subterms term = term `cons` para (foldMap (uncurry cons)) term
instance ( Corecursive t
, Evaluatable (Base t)
, FreeVariables t
, MonadAddressable (LocationFor v) v (DeadCodeAnalysis t v)
, MonadValue t v (DeadCodeAnalysis t v)
, Ord t
, Recursive t
, Semigroup (Cell (LocationFor v) v)
instance ( Corecursive term
, Effectful (m term value)
, Foldable (Base term)
, Member (State (Dead term)) effects
, MonadAnalysis term value (m term value effects)
, Ord term
)
=> MonadAnalysis t v (DeadCodeAnalysis t v) where
=> MonadAnalysis term value (DeadCode m term value effects) where
type RequiredEffects term value (DeadCode m term value effects) = State (Dead term) ': RequiredEffects term value (m term value effects)
analyzeTerm term = do
revive (embedSubterm term)
eval term
liftAnalyze analyzeTerm term
evaluateModule term = do
killAll (subterms term)
DeadCode (evaluateModule term)

116
src/Analysis/Abstract/Evaluating.hs
View File

@ -1,65 +1,56 @@
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, MultiParamTypeClasses, UndecidableInstances #-}
module Analysis.Abstract.Evaluating where
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.Evaluating
( type Evaluating
, evaluate
, evaluates
) where
import Control.Abstract.Evaluator
import Control.Effect
import Control.Monad.Effect hiding (run)
import Control.Monad.Effect.Fail
import Control.Monad.Effect.Fresh
import Control.Monad.Effect.NonDet
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Data.Abstract.Address
import Data.Abstract.Configuration
import Data.Abstract.Evaluatable
import Data.Abstract.ModuleTable
import Data.Abstract.Store
import Data.Abstract.Value
import Data.Blob
import Data.List.Split (splitWhen)
import Prologue
import qualified Data.ByteString.Char8 as BC
import Data.List.Split (splitWhen)
import qualified Data.Map as Map
import Prelude hiding (fail)
import Prologue
import System.FilePath.Posix
-- | The effects necessary for concrete interpretation.
type EvaluationEffects t v
= '[ Fail -- Failure with an error message
, State (Store (LocationFor v) v) -- The heap
, State (EnvironmentFor v) -- Global (imperative) environment
, Reader (EnvironmentFor v) -- Local environment (e.g. binding over a closure)
, Reader (ModuleTable t) -- Cache of unevaluated modules
, State (ModuleTable (EnvironmentFor v)) -- Cache of evaluated modules
]
-- | Evaluate a term to a value.
evaluate :: forall v term
evaluate :: forall value term
. ( Evaluatable (Base term)
, FreeVariables term
, MonadAddressable (LocationFor v) v (Evaluation term v)
, MonadValue term v (Evaluation term v)
, Ord (LocationFor v)
, MonadAddressable (LocationFor value) value (Evaluating term value (EvaluatingEffects term value))
, MonadValue term value (Evaluating term value (EvaluatingEffects term value))
, Recursive term
, Semigroup (Cell (LocationFor v) v)
)
=> term
-> Final (EvaluationEffects term v) v
evaluate = run @(EvaluationEffects term v) . runEvaluator . runEvaluation . evaluateTerm
-> Final (EvaluatingEffects term value) value
evaluate = runAnalysis @(Evaluating term value) . evaluateModule
-- | Evaluate terms and an entry point to a value.
evaluates :: forall v term
evaluates :: forall value term
. ( Evaluatable (Base term)
, FreeVariables term
, MonadAddressable (LocationFor v) v (Evaluation term v)
, MonadValue term v (Evaluation term v)
, Ord (LocationFor v)
, MonadAddressable (LocationFor value) value (Evaluating term value (EvaluatingEffects term value))
, MonadValue term value (Evaluating term value (EvaluatingEffects term value))
, Recursive term
, Semigroup (Cell (LocationFor v) v)
)
=> [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated
-> (Blob, term) -- Entrypoint
-> Final (EvaluationEffects term v) v
evaluates pairs (b, t) = run @(EvaluationEffects term v) (runEvaluator (runEvaluation (withModules b pairs (evaluateTerm t))))
-> Final (EvaluatingEffects term value) value
evaluates pairs (b, t) = runAnalysis @(Evaluating term value) (withModules b pairs (evaluateModule t))
-- | Run an action with the passed ('Blob', @term@) pairs available for imports.
withModules :: (MonadAnalysis term value m, MonadEvaluator term value m) => Blob -> [(Blob, term)] -> m a -> m a
withModules :: MonadAnalysis term value m => Blob -> [(Blob, term)] -> m a -> m a
withModules Blob{..} pairs = localModuleTable (const moduleTable)
where
moduleTable = ModuleTable (Map.fromList (map (first moduleName) pairs))
@ -67,18 +58,55 @@ withModules Blob{..} pairs = localModuleTable (const moduleTable)
moduleName Blob{..} = toName (dropExtensions (makeRelative rootDir blobPath))
toName str = qualifiedName (fmap BC.pack (splitWhen (== pathSeparator) str))
-- | An analysis performing concrete evaluation of @term@s to @value@s.
newtype Evaluation term value a = Evaluation { runEvaluation :: Evaluator (EvaluationEffects term value) term value a }
deriving (Applicative, Functor, Monad, MonadFail)
-- | 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)
deriving (Applicative, Functor, Effectful, Monad)
deriving instance MonadEvaluator term value (Evaluation term value)
instance ( Evaluatable (Base t)
, FreeVariables t
, MonadAddressable (LocationFor v) v (Evaluation t v)
, MonadValue t v (Evaluation t v)
, Recursive t
, Semigroup (Cell (LocationFor v) v)
deriving instance Member Fail effects => MonadFail (Evaluating term value effects)
deriving instance Member Fresh effects => MonadFresh (Evaluating term value effects)
deriving instance Member NonDetEff effects => Alternative (Evaluating term value effects)
deriving instance Member NonDetEff effects => MonadNonDet (Evaluating term value effects)
-- | Effects necessary for evaluating (whether concrete or abstract).
type EvaluatingEffects term value
= '[ Fail -- Failure with an error message
, Reader (EnvironmentFor value) -- Local environment (e.g. binding over a closure)
, State (EnvironmentFor value) -- Global (imperative) environment
, State (StoreFor value) -- The heap
, Reader (ModuleTable term) -- Cache of unevaluated modules
, State (ModuleTable (EnvironmentFor value)) -- Cache of evaluated modules
]
instance Members '[Reader (EnvironmentFor value), State (EnvironmentFor value)] effects => MonadEnvironment value (Evaluating term value effects) where
getGlobalEnv = raise get
putGlobalEnv = raise . put
askLocalEnv = raise ask
localEnv f a = raise (local f (lower a))
instance Member (State (StoreFor value)) effects => MonadStore value (Evaluating term value effects) where
getStore = raise get
putStore = raise . put
instance Members '[Reader (ModuleTable term), State (ModuleTable (EnvironmentFor value))] effects => MonadModuleTable term value (Evaluating term value effects) where
getModuleTable = raise get
putModuleTable = raise . put
askModuleTable = raise ask
localModuleTable f a = raise (local f (lower a))
instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value (Evaluating term value effects) where
getConfiguration term = Configuration term mempty <$> askLocalEnv <*> getStore
instance ( Evaluatable (Base term)
, FreeVariables term
, Members (EvaluatingEffects term value) effects
, MonadAddressable (LocationFor value) value (Evaluating term value effects)
, MonadValue term value (Evaluating term value effects)
, Recursive term
)
=> MonadAnalysis t v (Evaluation t v) where
=> MonadAnalysis term value (Evaluating term value effects) where
type RequiredEffects term value (Evaluating term value effects) = EvaluatingEffects term value
analyzeTerm = eval

102
src/Analysis/Abstract/Tracing.hs
View File

@ -1,73 +1,45 @@
{-# LANGUAGE AllowAmbiguousTypes, DataKinds, ScopedTypeVariables, TypeApplications, TypeFamilies #-}
module Analysis.Abstract.Tracing where
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.Tracing
( type Tracing
) where
import Prologue
import Control.Effect
import Control.Monad.Effect hiding (run)
import Control.Monad.Effect.Addressable
import Control.Monad.Effect.Env
import Control.Monad.Effect.Fail
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Control.Monad.Effect.Trace
import Control.Abstract.Analysis
import Control.Monad.Effect.Writer
import Data.Abstract.Address
import Data.Abstract.Configuration
import Data.Abstract.Environment
import Data.Abstract.Eval
import Data.Abstract.Store
import Data.Abstract.Value
import Data.Semigroup.Reducer as Reducer
import Prologue
-- | The effects necessary for tracing analyses.
type Tracing g t v
= '[ Writer (g (Configuration (LocationFor v) t v)) -- For 'MonadTrace'.
, Fail -- For 'MonadFail'.
, State (Store (LocationFor v) v) -- For 'MonadStore'.
, Reader (Environment (LocationFor v) v) -- For 'MonadEnv'.
]
-- | Trace analysis.
--
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
newtype Tracing (trace :: * -> *) m term value (effects :: [* -> *]) a = Tracing (m term value effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
-- | Linear trace analysis.
evalTrace :: forall v term
. ( Ord v, Ord term, Ord (Cell (LocationFor v) v)
, Functor (Base term)
, Recursive term
, Addressable (LocationFor v) (Eff (Tracing [] term v))
, MonadGC v (Eff (Tracing [] term v))
, Semigroup (Cell (LocationFor v) v)
, Eval term v (Eff (Tracing [] term v)) (Base term)
)
=> term -> Final (Tracing [] term v) v
evalTrace = run @(Tracing [] term v) . fix (evTell @[] (\ recur yield -> eval recur yield . project)) pure
deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Tracing trace m term value effects)
deriving instance MonadStore value (m term value effects) => MonadStore value (Tracing trace m term value effects)
deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Tracing trace m term value effects)
deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Tracing trace m term value effects)
-- | Reachable configuration analysis.
evalReach :: forall v term
. ( Ord v, Ord term, Ord (LocationFor v), Ord (Cell (LocationFor v) v)
, Functor (Base term)
, Recursive term
, Addressable (LocationFor v) (Eff (Tracing Set term v))
, MonadGC v (Eff (Tracing Set term v))
, Semigroup (Cell (LocationFor v) v)
, Eval term v (Eff (Tracing Set term v)) (Base term)
)
=> term -> Final (Tracing Set term v) v
evalReach = run @(Tracing Set term v) . fix (evTell @Set (\ recur yield -> eval recur yield . project)) pure
-- | Small-step evaluation which records every visited configuration.
evTell :: forall g t m v
. ( Monoid (g (Configuration (LocationFor v) t v))
, Pointed g
, MonadTrace t v g m
, MonadEnv v m
, MonadStore v m
, MonadGC v m
instance ( Corecursive term
, Effectful (m term value)
, Member (Writer (trace (ConfigurationFor term value))) effects
, MonadAnalysis term value (m term value effects)
, Ord (LocationFor value)
, Reducer (ConfigurationFor term value) (trace (ConfigurationFor term value))
)
=> (((v -> m v) -> t -> m v) -> (v -> m v) -> t -> m v)
-> ((v -> m v) -> t -> m v)
-> (v -> m v) -> t -> m v
evTell ev0 ev' yield e = do
env <- askEnv
store <- getStore
roots <- askRoots
trace (point (Configuration e roots env store) :: g (Configuration (LocationFor v) t v))
ev0 ev' yield e
=> MonadAnalysis term value (Tracing trace m term value effects) where
type RequiredEffects term value (Tracing trace m term value effects) = Writer (trace (ConfigurationFor term value)) ': RequiredEffects term value (m term value effects)
analyzeTerm term = do
config <- getConfiguration (embedSubterm term)
trace (Reducer.unit config)
liftAnalyze analyzeTerm term
-- | Log the given trace of configurations.
trace :: ( Effectful (m term value)
, Member (Writer (trace (ConfigurationFor term value))) effects
)
=> trace (ConfigurationFor term value)
-> Tracing trace m term value effects ()
trace = raise . tell

58
src/Control/Abstract/Addressable.hs
View File

@ -1,73 +1,59 @@
{-# LANGUAGE FunctionalDependencies, TypeFamilies, UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}
module Control.Abstract.Addressable where
import Control.Abstract.Evaluator
import Control.Abstract.Analysis
import Control.Applicative
import Control.Monad ((<=<))
import Control.Monad.Effect.Fail
import Data.Abstract.Address
import Data.Abstract.Environment
import Data.Abstract.FreeVariables
import Data.Abstract.Store
import Data.Abstract.Value
import Data.Foldable (asum, toList)
import Data.Pointed
import Data.Semigroup
import Data.Semigroup.Reducer
import Prelude hiding (fail)
-- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store.
class (Monad m, Ord l, Pointed (Cell l), l ~ LocationFor a) => MonadAddressable l a m | m -> a where
deref :: Address l a
-> m a
class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => MonadAddressable l value m where
deref :: Address l value -> m value
alloc :: Name
-> m (Address l a)
alloc :: Name -> m (Address l value)
-- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address.
--
-- The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers.
lookupOrAlloc :: ( FreeVariables t
, MonadAddressable (LocationFor a) a m
, MonadEvaluator t a m
, Semigroup (Cell (LocationFor a) a)
lookupOrAlloc :: ( FreeVariables term
, MonadAddressable (LocationFor value) value m
, MonadStore value m
, Semigroup (CellFor value)
)
=> t
-> a
-> Environment (LocationFor a) a
-> m (Name, Address (LocationFor a) a)
=> term
-> value
-> Environment (LocationFor value) value
-> m (Name, Address (LocationFor value) value)
lookupOrAlloc term = let [name] = toList (freeVariables term) in
lookupOrAlloc' name
-- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address.
lookupOrAlloc' :: ( Semigroup (Cell (LocationFor a) a)
, MonadAddressable (LocationFor a) a m
, MonadEvaluator t a m
lookupOrAlloc' :: ( Semigroup (CellFor value)
, MonadAddressable (LocationFor value) value m
, MonadStore value m
)
=> Name
-> a
-> Environment (LocationFor a) a
-> m (Name, Address (LocationFor a) a)
-> value
-> Environment (LocationFor value) value
-> m (Name, Address (LocationFor value) value)
lookupOrAlloc' name v env = do
a <- maybe (alloc name) pure (envLookup name env)
assign a v
pure (name, a)
-- | Write a value to the given 'Address' in the 'Store'.
assign :: ( Ord (LocationFor a)
, MonadEvaluator t a m
, Pointed (Cell (LocationFor a))
, Semigroup (Cell (LocationFor a) a)
)
=> Address (LocationFor a) a
-> a
-> m ()
assign address = modifyStore . storeInsert address
-- Instances
-- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
instance (Monad m, MonadEvaluator t v m, LocationFor v ~ Precise) => MonadAddressable Precise v m where
instance (MonadFail m, LocationFor value ~ Precise, MonadStore value m) => MonadAddressable Precise value m where
deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup
where
-- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced).
@ -78,7 +64,7 @@ instance (Monad m, MonadEvaluator t v m, LocationFor v ~ Precise) => MonadAddres
-- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
instance (Alternative m, LocationFor v ~ Monovariant, Monad m, MonadEvaluator t v m) => MonadAddressable Monovariant v m where
instance (Alternative m, LocationFor value ~ Monovariant, MonadStore value m, Ord value) => MonadAddressable Monovariant value m where
deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup
alloc = pure . Address . Monovariant

64
src/Control/Abstract/Analysis.hs
View File

@ -1,18 +1,64 @@
{-# LANGUAGE DefaultSignatures, FunctionalDependencies #-}
module Control.Abstract.Analysis where
{-# LANGUAGE DataKinds, MultiParamTypeClasses, TypeFamilies #-}
module Control.Abstract.Analysis
( MonadAnalysis(..)
, evaluateTerm
, liftAnalyze
, runAnalysis
, module X
, Subterm(..)
, SubtermAlgebra
) where
import Control.Abstract.Evaluator as X
import Control.Effect as X
import qualified Control.Monad.Effect as Effect
import Control.Monad.Effect.Fail as X
import Control.Monad.Effect.Fresh as X
import Control.Monad.Effect.NonDet as X
import Control.Monad.Effect.Reader as X
import Control.Monad.Effect.State as X
import Data.Coerce
import Prologue
-- | A 'Monad' in which one can evaluate some specific term type to some specific value type.
--
-- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses.
class Monad m => MonadAnalysis term value m | m -> term, m -> value where
class (MonadEvaluator term value m, Recursive term) => MonadAnalysis term value m where
-- | The effects necessary to run the analysis. Analyses which are composed on top of (wrap) other analyses should include the inner analyses 'RequiredEffects' in their own list.
type family RequiredEffects term value m :: [* -> *]
-- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances.
analyzeTerm :: SubtermAlgebra (Base term) term (m value)
-- | Evaluate a term to a value using the semantics of the current analysis.
--
-- This should always be called instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves.
evaluateTerm :: MonadAnalysis term value m => term -> m value
default evaluateTerm :: (MonadAnalysis term value m, Recursive term) => term -> m value
evaluateTerm = foldSubterms analyzeTerm
-- | Evaluate a (root-level) term to a value using the semantics of the current analysis. This should be used to evaluate single-term programs as well as each module in multi-term programs.
evaluateModule :: term -> m value
evaluateModule = evaluateTerm
-- | Evaluate a term to a value using the semantics of the current analysis.
--
-- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'.
evaluateTerm :: MonadAnalysis term value m => term -> m value
evaluateTerm = foldSubterms analyzeTerm
-- | Lift a 'SubtermAlgebra' for an underlying analysis into a containing analysis. Use this when defining an analysis which can be composed onto other analyses to ensure that a call to 'analyzeTerm' occurs in the inner analysis and not the outer one.
liftAnalyze :: ( Coercible ( m term value (effects :: [* -> *]) value) (t m term value effects value)
, Coercible (t m term value effects value) ( m term value effects value)
, Functor (Base term)
)
=> SubtermAlgebra (Base term) term ( m term value effects value)
-> SubtermAlgebra (Base term) term (t m term value effects value)
liftAnalyze analyze term = coerce (analyze (second coerce <$> term))
-- | Run an analysis, performing its effects and returning the result alongside any state.
--
-- This enables us to refer to the analysis type as e.g. @Analysis1 (Analysis2 Evaluating) Term Value@ without explicitly mentioning its effects (which are inferred to be simply its 'RequiredEffects').
runAnalysis :: ( Effectful m
, RunEffects effects a
, RequiredEffects term value (m effects) ~ effects
, MonadAnalysis term value (m effects)
)
=> m effects a
-> Final effects a
runAnalysis = Effect.run . runEffects . lower

115
src/Control/Abstract/Evaluator.hs
View File

@ -1,16 +1,23 @@
{-# LANGUAGE DataKinds, FunctionalDependencies, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, UndecidableInstances #-}
module Control.Abstract.Evaluator where
{-# LANGUAGE ConstrainedClassMethods, FunctionalDependencies #-}
module Control.Abstract.Evaluator
( MonadEvaluator(..)
, MonadEnvironment(..)
, modifyGlobalEnv
, MonadStore(..)
, modifyStore
, assign
, MonadModuleTable(..)
, modifyModuleTable
) where
import Control.Applicative
import Control.Monad.Effect
import Control.Monad.Effect.Fail
import Control.Monad.Effect.Fresh
import Control.Monad.Effect.NonDet
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Data.Abstract.Address
import Data.Abstract.Configuration
import Data.Abstract.ModuleTable
import Data.Abstract.Store
import Data.Abstract.Value
import Data.Semigroup.Reducer
import Prelude hiding (fail)
import Prologue
-- | A 'Monad' providing the basic essentials for evaluation.
--
@ -18,66 +25,72 @@ import Prelude hiding (fail)
-- - environments binding names to addresses
-- - a heap mapping addresses to (possibly sets of) values
-- - tables of modules available for import
class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where
class ( MonadEnvironment value m
, MonadFail m
, MonadModuleTable term value m
, MonadStore value m
)
=> MonadEvaluator term value m | m -> term, m -> value where
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: Ord (LocationFor value) => term -> m (ConfigurationFor term value)
-- | A 'Monad' abstracting local and global environments.
class Monad m => MonadEnvironment value m | m -> value where
-- | Retrieve the global environment.
getGlobalEnv :: m (EnvironmentFor value)
-- | Set the global environment
putGlobalEnv :: EnvironmentFor value -> m ()
-- | Update the global environment.
modifyGlobalEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m ()
-- | Retrieve the local environment.
askLocalEnv :: m (EnvironmentFor value)
-- | Run an action with a locally-modified environment.
localEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m a -> m a
-- | Update the global environment.
modifyGlobalEnv :: MonadEvaluator term value m => (EnvironmentFor value -> EnvironmentFor value) -> m ()
modifyGlobalEnv f = do
env <- getGlobalEnv
putGlobalEnv $! f env
-- | A 'Monad' abstracting a heap of values.
class Monad m => MonadStore value m | m -> value where
-- | Retrieve the heap.
getStore :: m (StoreFor value)
-- | Update the heap.
modifyStore :: (StoreFor value -> StoreFor value) -> m ()
-- | Set the heap.
putStore :: StoreFor value -> m ()
-- | Update the heap.
modifyStore :: MonadStore value m => (StoreFor value -> StoreFor value) -> m ()
modifyStore f = do
s <- getStore
putStore $! f s
-- | Write a value to the given 'Address' in the 'Store'.
assign :: ( Ord (LocationFor value)
, MonadStore value m
, Reducer value (CellFor value)
)
=> Address (LocationFor value) value
-> value
-> m ()
assign address = modifyStore . storeInsert address
-- | A 'Monad' abstracting tables of modules available for import.
class Monad m => MonadModuleTable term value m | m -> term, m -> value where
-- | Retrieve the table of evaluated modules.
getModuleTable :: m (ModuleTable (EnvironmentFor value))
-- | Update the table of evaluated modules.
modifyModuleTable :: (ModuleTable (EnvironmentFor value) -> ModuleTable (EnvironmentFor value)) -> m ()
-- | Set the table of evaluated modules.
putModuleTable :: ModuleTable (EnvironmentFor value) -> m ()
-- | Retrieve the table of unevaluated modules.
askModuleTable :: m (ModuleTable term)
-- | Run an action with a locally-modified table of unevaluated modules.
localModuleTable :: (ModuleTable term -> ModuleTable term) -> m a -> m a
instance Members '[ Fail
, Reader (EnvironmentFor value)
, State (EnvironmentFor value)
, State (StoreFor value)
, Reader (ModuleTable term)
, State (ModuleTable (EnvironmentFor value))
] effects
=> MonadEvaluator term value (Evaluator effects term value) where
getGlobalEnv = Evaluator get
putGlobalEnv = Evaluator . put
modifyGlobalEnv f = Evaluator (modify f)
askLocalEnv = Evaluator ask
localEnv f a = Evaluator (local f (runEvaluator a))
getStore = Evaluator get
modifyStore f = Evaluator (modify f)
getModuleTable = Evaluator get
modifyModuleTable f = Evaluator (modify f)
askModuleTable = Evaluator ask
localModuleTable f a = Evaluator (local f (runEvaluator a))
putStore :: MonadEvaluator t value m => StoreFor value -> m ()
putStore = modifyStore . const
-- | An evaluator of @term@s to @value@s, producing incremental results of type @a@ using a list of @effects@.
newtype Evaluator effects term value a = Evaluator { runEvaluator :: Eff effects a }
deriving (Applicative, Functor, Monad)
deriving instance Member Fail effects => MonadFail (Evaluator effects term value)
deriving instance Member NonDetEff effects => Alternative (Evaluator effects term value)
deriving instance Member NonDetEff effects => MonadNonDet (Evaluator effects term value)
deriving instance Member Fresh effects => MonadFresh (Evaluator effects term value)
-- | Update the evaluated module table.
modifyModuleTable :: MonadModuleTable term value m => (ModuleTable (EnvironmentFor value) -> ModuleTable (EnvironmentFor value)) -> m ()
modifyModuleTable f = do
table <- getModuleTable
putModuleTable $! f table

126
src/Control/Abstract/Value.hs
View File

@ -1,77 +1,116 @@
{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Control.Abstract.Value where
import Control.Abstract.Addressable
import Control.Abstract.Analysis
import Control.Abstract.Evaluator
import Control.Monad.Effect.Fresh
import Data.Abstract.Address
import Data.Abstract.Environment
import Data.Abstract.FreeVariables
import Data.Abstract.Value as Value
import Data.Abstract.Type as Type
import Data.Scientific (Scientific)
import Prologue
import Data.Abstract.Value as Value
import Data.Bitraversable
import Data.Scientific (Scientific, fromFloatDigits, toRealFloat)
import Prelude hiding (fail)
import Prologue
-- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc).
--
-- This allows us to abstract the choice of whether to evaluate under binders for different value types.
class (MonadEvaluator t v m) => MonadValue t v m where
class (MonadAnalysis term value m, Show value) => MonadValue term value m where
-- | Construct an abstract unit value.
unit :: m v
-- TODO: This might be the same as the empty tuple for some value types
unit :: m value
-- | Construct an abstract integral value.
integer :: Prelude.Integer -> m v
integer :: Prelude.Integer -> m value
-- | Lift a unary operator over a 'Num' to a function on 'value's.
liftNumeric :: (forall a . Num a => a -> a)
-> (value -> m value)
-- | Lift a pair of binary operators to a function on 'value's.
-- You usually pass the same operator as both arguments, except in the cases where
-- Haskell provides different functions for integral and fractional operations, such
-- as division, exponentiation, and modulus.
liftNumeric2 :: (forall a . (Real a, Floating a) => a -> a -> a)
-> (forall b . Integral b => b -> b -> b)
-> (value -> value -> m value)
-- | Construct an abstract boolean value.
boolean :: Bool -> m v
boolean :: Bool -> m value
-- | Construct an abstract string value.
string :: ByteString -> m v
string :: ByteString -> m value
-- | Construct a floating-point value.
float :: Scientific -> m v
float :: Scientific -> m value
-- | Construct an N-ary tuple of multiple (possibly-disjoint) values
multiple :: [value] -> m value
-- | Construct an abstract interface value.
interface :: v -> m v
interface :: value -> m value
-- | Eliminate boolean values. TODO: s/boolean/truthy
ifthenelse :: v -> m v -> m v -> m v
ifthenelse :: value -> m a -> m a -> m a
-- | Evaluate an abstraction (a binder like a lambda or method definition).
abstract :: [Name] -> Subterm t (m v) -> m v
abstract :: [Name] -> Subterm term (m value) -> m value
-- | Evaluate an application (like a function call).
apply :: v -> [Subterm t (m v)] -> m v
apply :: value -> [Subterm term (m value)] -> m value
-- | Extract the environment from an interface value.
environment :: v -> m (EnvironmentFor v)
environment :: value -> m (EnvironmentFor value)
-- | Attempt to extract a 'Prelude.Bool' from a given value.
toBool :: MonadValue term value m => value -> m Bool
toBool v = ifthenelse v (pure True) (pure False)
-- | Construct a 'Value' wrapping the value arguments (if any).
instance ( FreeVariables t
, MonadAddressable location (Value location t) m
, MonadAnalysis t (Value location t) m
, MonadEvaluator t (Value location t) m
, Recursive t
, Semigroup (Cell location (Value location t))
instance ( MonadAddressable location (Value location term) m
, MonadAnalysis term (Value location term) m
, Show location
, Show term
)
=> MonadValue t (Value location t) m where
=> MonadValue term (Value location term) m where
unit = pure $ inj Value.Unit
integer = pure . inj . Integer
boolean = pure . inj . Boolean
string = pure . inj . Value.String
float = pure . inj . Value.Float
interface v = inj . Value.Interface v <$> getGlobalEnv
unit = pure . injValue $ Value.Unit
integer = pure . injValue . Integer
boolean = pure . injValue . Boolean
string = pure . injValue . Value.String
float = pure . injValue . Value.Float
multiple vals =
pure . injValue $ Value.Tuple vals
interface v = injValue . Value.Interface v <$> getGlobalEnv
ifthenelse cond if' else'
| Just (Boolean b) <- prj cond = if b then if' else else'
| otherwise = fail "not defined for non-boolean conditions"
| Just (Boolean b) <- prjValue cond = if b then if' else else'
| otherwise = fail ("not defined for non-boolean conditions: " <> show cond)
abstract names (Subterm body _) = inj . Closure names body <$> askLocalEnv
liftNumeric f arg
| Just (Integer i) <- prjValue arg = pure . injValue . Integer $ f i
| Just (Value.Float i) <- prjValue arg = pure . injValue . Value.Float $ f i
| otherwise = fail ("Invalid operand to liftNumeric: " <> show arg)
liftNumeric2 f g left right
| Just (Integer i, Integer j) <- prjPair pair = pure . injValue . Integer $ g i j
| Just (Integer i, Value.Float j) <- prjPair pair = pure . injValue . float $ f (fromIntegral i) (munge j)
| Just (Value.Float i, Value.Float j) <- prjPair pair = pure . injValue . float $ f (munge i) (munge j)
| Just (Value.Float i, Integer j) <- prjPair pair = pure . injValue . float $ f (munge i) (fromIntegral j)
| otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair)
where
-- Yucky hack to work around the lack of a Floating instance for Scientific.
-- This may possibly lose precision, but there's little we can do about that.
munge :: Scientific -> Double
munge = toRealFloat
float :: Double -> Value.Float a
float = Value.Float . fromFloatDigits
pair = (left, right)
abstract names (Subterm body _) = injValue . Closure names body <$> askLocalEnv
apply op params = do
Closure names body env <- maybe (fail "expected a closure") pure (prj op)
Closure names body env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op)
bindings <- foldr (\ (name, param) rest -> do
v <- subtermValue param
a <- alloc name
@ -80,11 +119,11 @@ instance ( FreeVariables t
localEnv (mappend bindings) (evaluateTerm body)
environment v
| Just (Interface _ env) <- prj v = pure env
| otherwise = pure mempty
| Just (Interface _ env) <- prjValue v = pure env
| otherwise = pure mempty
-- | Discard the value arguments (if any), constructing a 'Type.Type' instead.
instance (Alternative m, MonadEvaluator t Type m, MonadFresh m) => MonadValue t Type m where
instance (Alternative m, MonadAnalysis term Type m, MonadFresh m) => MonadValue term Type m where
abstract names (Subterm _ body) = do
(env, tvars) <- foldr (\ name rest -> do
a <- alloc name
@ -100,11 +139,22 @@ instance (Alternative m, MonadEvaluator t Type m, MonadFresh m) => MonadValue t
boolean _ = pure Bool
string _ = pure Type.String
float _ = pure Type.Float
multiple = pure . Type.Product
-- TODO
interface = undefined
ifthenelse cond if' else' = unify cond Bool *> (if' <|> else')
liftNumeric _ Type.Float = pure Type.Float
liftNumeric _ Int = pure Int
liftNumeric _ _ = fail "Invalid type in unary numeric operation"
liftNumeric2 _ _ left right = case (left, right) of
(Type.Float, Int) -> pure Type.Float
(Int, Type.Float) -> pure Type.Float
_ -> unify left right
apply op params = do
tvar <- fresh
paramTypes <- traverse subtermValue params

27
src/Control/Effect.hs
View File

@ -1,7 +1,6 @@
{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE DataKinds, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Control.Effect where
import Prologue
import qualified Control.Monad.Effect as Effect
import Control.Monad.Effect.Fail
import Control.Monad.Effect.Internal hiding (run)
@ -9,10 +8,12 @@ import Control.Monad.Effect.NonDetEff
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Control.Monad.Effect.Writer
import Data.Semigroup.Reducer
import Prologue
-- | Run a computation in 'Eff' to completion, interpreting each effect with some sensible defaults, and return the 'Final' result.
run :: RunEffects fs a => Eff fs a -> Final fs a
run = Effect.run . runEffects
-- | Run an 'Effectful' computation to completion, interpreting each effect with some sensible defaults, and return the 'Final' result.
run :: (Effectful m, RunEffects effects a) => m effects a -> Final effects a
run = Effect.run . runEffects . lower
-- | A typeclass to run a computation to completion, interpreting each effect with some sensible defaults.
class RunEffects fs a where
@ -60,6 +61,20 @@ instance Monoid w => RunEffect (Writer w) a where
-- | 'NonDetEff' effects are interpreted into a nondeterministic set of result values.
instance Ord a => RunEffect NonDetEff a where
type Result NonDetEff a = Set a
runEffect = relay (pure . point) (\ m k -> case m of
runEffect = relay (pure . unit) (\ m k -> case m of
MZero -> pure mempty
MPlus -> mappend <$> k True <*> k False)
-- | Types wrapping 'Eff' actions.
--
-- Most instances of 'Effectful' will be derived using @-XGeneralizedNewtypeDeriving@, with these ultimately bottoming out on the instance for 'Eff' (for which 'raise' and 'lower' are simply the identity). Because of this, types can be nested arbitrarily deeply and still call 'raise'/'lower' just once to get at the (ultimately) underlying 'Eff'.
class Effectful (m :: [* -> *] -> * -> *) where
-- | Raise an action in 'Eff' into an action in @m@.
raise :: Eff effects a -> m effects a
-- | Lower an action in @m@ into an action in 'Eff'.
lower :: m effects a -> Eff effects a
instance Effectful Eff where
raise = id
lower = id

63
src/Control/Monad/Effect/Cache.hs
View File

@ -1,63 +0,0 @@
{-# LANGUAGE MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
module Control.Monad.Effect.Cache where
import Control.Monad.Effect
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Data.Abstract.Cache
import Data.Abstract.Value
-- | 'Monad's offering a readable 'Cache' of values & stores for each configuration in a program.
--
-- This (in-)cache is used as an oracle for the results of recursive computations, allowing us to finitize potentially nonterminating control flow by repeatedly computing the results until analysis converges on a stable value. Each iteration of this process must consult this cache only _after_ evaluating the configuration itself in order to ensure soundness (since it could otherwise produce stale results for some configurations).
--
-- Since finitization crucially depends on convergence, this cache should only be used with value abstractions that will converge for multiple disjoint assignments of a given variable, e.g. its type, and not with precisely-modelled values. To illustrate why, consider a simple incrementing recursive function:
--
-- > inc :: Integer -> a
-- > inc n = inc (n + 1)
--
-- @n@ differs at every iteration, and thus a precise modelling of the integral value will not converge in the store: each iteration will allocate a new address & write a distinct value into it. Modelling values with their types _will_ converge, however, as the type at each iteration is the same.
class Monad m => MonadCacheIn t v m where
-- | Retrieve the local in-cache.
askCache :: m (Cache (LocationFor v) t v)
-- | Run a computation with a locally-modified in-cache.
localCache :: (Cache (LocationFor v) t v -> Cache (LocationFor v) t v) -> m a -> m a
instance (Reader (Cache (LocationFor v) t v) :< fs) => MonadCacheIn t v (Eff fs) where
askCache = ask
localCache = local
-- | Project a value out of the in-cache.
asksCache :: MonadCacheIn t v m => (Cache (LocationFor v) t v -> a) -> m a
asksCache f = f <$> askCache
-- | 'Monad's offering a readable & writable 'Cache' of values & stores for each configuration in a program.
--
-- This (out-)cache is used to store the results of recursive computations, allowing us to finitize each iteration of an analysis by first looking up the current configuration in the cache and only evaluating:
--
-- 1. If the configuration has not been visited before, and
-- 2. _after_ copying the previous iteration’s results (from the in-cache, and defaulting to a 'mempty' set of results) into the out-cache.
--
-- Thus, visiting the same configuration twice recursively will terminate, since we’ll have consulted the in-cache as an oracle before evaluating, and after evaluating, the resulting value and store should be appended into the out-cache. Then, once the current iteration of the analysis has completed, the updated out-cache will be used as the oracle for the next iteration, until such time as the cache converges.
--
-- See also 'MonadCacheIn' for discussion of the conditions of finitization.
class Monad m => MonadCacheOut t v m where
-- | Retrieve the current out-cache.
getCache :: m (Cache (LocationFor v) t v)
-- | Update the current out-cache.
putCache :: Cache (LocationFor v) t v -> m ()
instance (State (Cache (LocationFor v) t v) :< fs) => MonadCacheOut t v (Eff fs) where
getCache = get
putCache = put
-- | Project a value out of the out-cache.
getsCache :: MonadCacheOut t v m => (Cache (LocationFor v) t v -> a) -> m a
getsCache f = f <$> getCache
-- | Modify the current out-cache using a given function.
modifyCache :: MonadCacheOut t v m => (Cache (LocationFor v) t v -> Cache (LocationFor v) t v) -> m ()
modifyCache f = fmap f getCache >>= putCache

4
src/Control/Monad/Effect/NonDet.hs
View File

@ -4,15 +4,15 @@ module Control.Monad.Effect.NonDet
, NonDetEff
) where
import Prologue
import Control.Monad.Effect.Internal
import Control.Monad.Effect.NonDetEff
import Prologue
-- | 'Monad's offering local isolation of nondeterminism effects.
class (Alternative m, Monad m) => MonadNonDet m where
-- | Run a computation, gathering any nondeterministically produced results into a single 'Monoid'al value.
gather :: Monoid b
=> (a -> b) -- ^ A function constructing a 'Monoid'al value from a single computed result. This might typically be @point@ (for @Pointed@ functors), 'pure' (for 'Applicative's), or some similar singleton constructor.
=> (a -> b) -- ^ A function constructing a 'Monoid'al value from a single computed result. This might typically be @unit@ (for @Reducer@s), 'pure' (for 'Applicative's), or some similar singleton constructor.
-> m a -- ^ The computation to run locally-nondeterministically.
-> m b -- ^ A _deterministic_ computation producing the 'Monoid'al accumulation of the _locally-nondeterministic_ result values.

17
src/Control/Monad/Effect/Trace.hs
View File

@ -1,17 +0,0 @@
{-# LANGUAGE MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
module Control.Monad.Effect.Trace where
import Control.Monad.Effect
import Control.Monad.Effect.Writer
import Data.Abstract.Configuration
import Data.Abstract.Value
-- | 'Monad's offering a writable trace of configurations.
--
-- @t@ is the type of terms, @v@ the type of values, @g@ the type of the collection represented by the log (e.g. '[]' for regular traces, or @Set@ for the trace of reachable states).
class Monad m => MonadTrace t v g m where
-- | Log the given collection of configurations.
trace :: g (Configuration (LocationFor v) t v) -> m ()
instance (Writer (g (Configuration (LocationFor v) t v)) :< fs) => MonadTrace t v g (Eff fs) where
trace = tell

13
src/Data/Abstract/Address.hs
View File

@ -1,8 +1,9 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeFamilyDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeFamilies, TypeFamilyDependencies #-}
module Data.Abstract.Address where
import Prologue
import Data.Abstract.FreeVariables
import Data.Semigroup.Reducer
import Prologue
-- | An abstract address with a location of @l@ pointing to a variable of type @a@.
newtype Address l a = Address { unAddress :: l }
@ -33,10 +34,12 @@ newtype Latest a = Latest { unLatest :: a }
deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
instance Semigroup (Latest a) where
(<>) = flip const
_ <> a = a
instance Pointed Latest where
point = Latest
instance Reducer a (Latest a) where
unit = Latest
cons _ = id
snoc _ = unit
instance Eq1 Latest where liftEq = genericLiftEq
instance Ord1 Latest where liftCompare = genericLiftCompare

15
src/Data/Abstract/Cache.hs
View File

@ -1,32 +1,33 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-}
module Data.Abstract.Cache where
import Prologue
import Data.Abstract.Address
import Data.Abstract.Configuration
import Data.Abstract.Store
import Data.Map as Map
import Data.Map.Monoidal as Monoidal
import Prologue
-- | A map of 'Configuration's to 'Set's of resulting values & 'Store's.
newtype Cache l t v = Cache { unCache :: Map.Map (Configuration l t v) (Set (v, Store l v)) }
newtype Cache l t v = Cache { unCache :: Monoidal.Map (Configuration l t v) (Set (v, Store l v)) }
deriving instance (Eq l, Eq t, Eq v, Eq (Cell l v)) => Eq (Cache l t v)
deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Ord (Cache l t v)
deriving instance (Show l, Show t, Show v, Show (Cell l v)) => Show (Cache l t v)
deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Semigroup (Cache l t v)
deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Monoid (Cache l t v)
deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Reducer (Configuration l t v, (v, Store l v)) (Cache l t v)
-- | Look up the resulting value & 'Store' for a given 'Configuration'.
cacheLookup :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Cache l t v -> Maybe (Set (v, Store l v))
cacheLookup key = Map.lookup key . unCache
cacheLookup key = Monoidal.lookup key . unCache
-- | Set the resulting value & 'Store' for a given 'Configuration', overwriting any previous entry.
cacheSet :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Set (v, Store l v) -> Cache l t v -> Cache l t v
cacheSet key value = Cache . Map.insert key value . unCache
cacheSet key value = Cache . Monoidal.insert key value . unCache
-- | Insert the resulting value & 'Store' for a given 'Configuration', appending onto any previous entry.
cacheInsert :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> (v, Store l v) -> Cache l t v -> Cache l t v
cacheInsert key value = Cache . Map.insertWith (<>) key (point value) . unCache
cacheInsert = curry cons
instance (Eq l, Eq t, Eq1 (Cell l)) => Eq1 (Cache l t) where

4
src/Data/Abstract/Configuration.hs
View File

@ -6,6 +6,10 @@ import Data.Abstract.Address
import Data.Abstract.Environment
import Data.Abstract.Live
import Data.Abstract.Store
import Data.Abstract.Value
-- | The configuration for term and abstract value types.
type ConfigurationFor term value = Configuration (LocationFor value) term value
-- | A single point in a program’s execution.
data Configuration l t v

25
src/Data/Abstract/Evaluatable.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE DefaultSignatures, FunctionalDependencies, UndecidableInstances #-}
{-# LANGUAGE DefaultSignatures, MultiParamTypeClasses, UndecidableInstances #-}
module Data.Abstract.Evaluatable
( Evaluatable(..)
, module Addressable
@ -12,15 +12,11 @@ module Data.Abstract.Evaluatable
import Control.Abstract.Addressable as Addressable
import Control.Abstract.Analysis as Analysis
import Control.Abstract.Evaluator
import Control.Abstract.Value as Value
import Control.Monad.Effect.Fail
import Data.Abstract.Address
import Data.Abstract.Environment
import Data.Abstract.FreeVariables as FreeVariables
import Data.Abstract.ModuleTable
import Data.Abstract.Value
import Data.Algebra
import Data.Functor.Classes
import Data.Proxy
import Data.Semigroup
@ -34,10 +30,7 @@ class Evaluatable constr where
eval :: ( FreeVariables term
, MonadAddressable (LocationFor value) value m
, MonadAnalysis term value m
, MonadEvaluator term value m
, MonadValue term value m
, Ord (LocationFor value)
, Semigroup (Cell (LocationFor value) value)
)
=> SubtermAlgebra constr term (m value)
default eval :: (MonadFail m, Show1 constr) => SubtermAlgebra constr term (m value)
@ -77,27 +70,25 @@ instance Evaluatable [] where
-- | Require/import another term/file and return an Effect.
--
-- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module.
require :: ( MonadAnalysis term v m
, MonadEvaluator term v m
, MonadValue term v m
require :: ( MonadAnalysis term value m
, MonadValue term value m
)
=> ModuleName
-> m (EnvironmentFor v)
-> m (EnvironmentFor value)
require name = getModuleTable >>= maybe (load name) pure . moduleTableLookup name
-- | Load another term/file and return an Effect.
--
-- Always loads/evaluates.
load :: ( MonadAnalysis term v m
, MonadEvaluator term v m
, MonadValue term v m
load :: ( MonadAnalysis term value m
, MonadValue term value m
)
=> ModuleName
-> m (EnvironmentFor v)
-> m (EnvironmentFor value)
load name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name
where notFound = fail ("cannot load module: " <> show name)
evalAndCache e = do
v <- evaluateTerm e
v <- evaluateModule e
env <- environment v
modifyModuleTable (moduleTableInsert name env)
pure env

24
src/Data/Abstract/Store.hs
View File

@ -1,14 +1,15 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-}
module Data.Abstract.Store where
import Prologue
import Data.Abstract.Address
import Data.Abstract.Live
import qualified Data.Map as Map
import qualified Data.Map.Monoidal as Monoidal
import Data.Semigroup.Reducer
import Prologue
-- | A map of addresses onto cells holding their values.
newtype Store l a = Store { unStore :: Map.Map l (Cell l a) }
deriving (Generic1, Monoid, Semigroup)
newtype Store l a = Store { unStore :: Monoidal.Map l (Cell l a) }
deriving (Generic1)
deriving instance (Eq l, Eq (Cell l a)) => Eq (Store l a)
deriving instance (Ord l, Ord (Cell l a)) => Ord (Store l a)
@ -19,23 +20,26 @@ instance (Show l, Show1 (Cell l)) => Show1 (Store l) where liftShowsPrec = gener
deriving instance Foldable (Cell l) => Foldable (Store l)
deriving instance Functor (Cell l) => Functor (Store l)
deriving instance Traversable (Cell l) => Traversable (Store l)
deriving instance (Ord l, Semigroup (Cell l a)) => Semigroup (Store l a)
deriving instance (Ord l, Semigroup (Cell l a)) => Monoid (Store l a)
deriving instance (Ord l, Reducer a (Cell l a)) => Reducer (l, a) (Store l a)
-- | Look up the cell of values for an 'Address' in a 'Store', if any.
storeLookup :: Ord l => Address l a -> Store l a -> Maybe (Cell l a)
storeLookup (Address address) = Map.lookup address . unStore
storeLookup (Address address) = Monoidal.lookup address . unStore
-- | Look up the list of values stored for a given address, if any.
storeLookupAll :: (Ord l, Foldable (Cell l)) => Address l a -> Store l a -> Maybe [a]
storeLookupAll address = fmap toList . storeLookup address
-- | Append a value onto the cell for a given address, inserting a new cell if none existed.
storeInsert :: (Ord l, Semigroup (Cell l a), Pointed (Cell l)) => Address l a -> a -> Store l a -> Store l a
storeInsert (Address address) value = Store . Map.insertWith (<>) address (point value) . unStore
storeInsert :: (Ord l, Reducer a (Cell l a)) => Address l a -> a -> Store l a -> Store l a
storeInsert (Address address) value = flip snoc (address, value)
-- | The number of addresses extant in a 'Store'.
storeSize :: Store l a -> Int
storeSize = Map.size . unStore
storeSize = Monoidal.size . unStore
-- | Restrict a 'Store' to only those 'Address'es in the given 'Live' set (in essence garbage collecting the rest).
storeRestrict :: Ord l => Store l a -> Live l a -> Store l a
storeRestrict (Store m) roots = Store (Map.filterWithKey (\ address _ -> Address address `liveMember` roots) m)
storeRestrict (Store m) roots = Store (Monoidal.filterWithKey (\ address _ -> Address address `liveMember` roots) m)

65
src/Data/Abstract/Value.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE ConstraintKinds, DataKinds, FunctionalDependencies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
{-# LANGUAGE ConstraintKinds, DataKinds, FunctionalDependencies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
module Data.Abstract.Value where
import Data.Abstract.Address
@ -13,32 +13,49 @@ import Prologue
import Prelude hiding (Float, Integer, String, fail)
import qualified Prelude
type ValueConstructors location
= '[Closure location
type ValueConstructors location term
= '[Closure location term
, Interface location
, Unit
, Boolean
, Float
, Integer
, String
, Tuple
]
-- | Open union of primitive values that terms can be evaluated to.
type Value location = Union (ValueConstructors location)
-- Fix by another name.
newtype Value location term = Value { deValue :: Union (ValueConstructors location term) (Value location term) }
deriving (Eq, Show, Ord)
-- | Identical to 'inj', but wraps the resulting sub-entity in a 'Value'.
injValue :: (f :< ValueConstructors location term) => f (Value location term) -> Value location term
injValue = Value . inj
-- | Identical to 'prj', but unwraps the argument out of its 'Value' wrapper.
prjValue :: (f :< ValueConstructors location term) => Value location term -> Maybe (f (Value location term))
prjValue = prj . deValue
-- | Convenience function for projecting two values.
prjPair :: ( f :< ValueConstructors loc term1 , g :< ValueConstructors loc term2)
=> (Value loc term1, Value loc term2)
-> Maybe (f (Value loc term1), g (Value loc term2))
prjPair = bitraverse prjValue prjValue
-- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union.
-- TODO: Wrap the Value union in a newtype to differentiate from (eventual) à la carte Types.
-- | A function value consisting of a list of parameters, the body of the function, and an environment of bindings captured by the body.
data Closure location term = Closure [Name] term (Environment location (Value location term))
data Closure location term value = Closure [Name] term (Environment location value)
deriving (Eq, Generic1, Ord, Show)
instance (Eq location) => Eq1 (Closure location) where liftEq = genericLiftEq
instance (Ord location) => Ord1 (Closure location) where liftCompare = genericLiftCompare
instance (Show location) => Show1 (Closure location) where liftShowsPrec = genericLiftShowsPrec
instance (Eq location, Eq term) => Eq1 (Closure location term) where liftEq = genericLiftEq
instance (Ord location, Ord term) => Ord1 (Closure location term) where liftCompare = genericLiftCompare
instance (Show location, Show term) => Show1 (Closure location term) where liftShowsPrec = genericLiftShowsPrec
-- | A program value consisting of the value of the program and it's enviornment of bindings.
data Interface location term = Interface (Value location term) (Environment location (Value location term))
data Interface location value = Interface value (Environment location value)
deriving (Eq, Generic1, Ord, Show)
instance (Eq location) => Eq1 (Interface location) where liftEq = genericLiftEq
@ -46,7 +63,7 @@ instance (Ord location) => Ord1 (Interface location) where liftCompare = generic
instance (Show location) => Show1 (Interface location) where liftShowsPrec = genericLiftShowsPrec
-- | The unit value. Typically used to represent the result of imperative statements.
data Unit term = Unit
data Unit value = Unit
deriving (Eq, Generic1, Ord, Show)
instance Eq1 Unit where liftEq = genericLiftEq
@ -54,7 +71,7 @@ instance Ord1 Unit where liftCompare = genericLiftCompare
instance Show1 Unit where liftShowsPrec = genericLiftShowsPrec
-- | Boolean values.
newtype Boolean term = Boolean Prelude.Bool
newtype Boolean value = Boolean Prelude.Bool
deriving (Eq, Generic1, Ord, Show)
instance Eq1 Boolean where liftEq = genericLiftEq
@ -62,7 +79,7 @@ instance Ord1 Boolean where liftCompare = genericLiftCompare
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
-- | Arbitrary-width integral values.
newtype Integer term = Integer Prelude.Integer
newtype Integer value = Integer Prelude.Integer
deriving (Eq, Generic1, Ord, Show)
instance Eq1 Integer where liftEq = genericLiftEq
@ -70,7 +87,7 @@ instance Ord1 Integer where liftCompare = genericLiftCompare
instance Show1 Integer where liftShowsPrec = genericLiftShowsPrec
-- | String values.
newtype String term = String ByteString
newtype String value = String ByteString
deriving (Eq, Generic1, Ord, Show)
instance Eq1 String where liftEq = genericLiftEq
@ -78,19 +95,33 @@ instance Ord1 String where liftCompare = genericLiftCompare
instance Show1 String where liftShowsPrec = genericLiftShowsPrec
-- | Float values.
newtype Float term = Float Scientific
newtype Float value = Float Scientific
deriving (Eq, Generic1, Ord, Show)
instance Eq1 Float where liftEq = genericLiftEq
instance Ord1 Float where liftCompare = genericLiftCompare
instance Show1 Float where liftShowsPrec = genericLiftShowsPrec
-- Zero or more values.
-- TODO: Investigate whether we should use Vector for this.
-- TODO: Should we have a Some type over a nonemmpty list? Or does this merit one?
newtype Tuple value = Tuple [value]
deriving (Eq, Generic1, Ord, Show)
instance Eq1 Tuple where liftEq = genericLiftEq
instance Ord1 Tuple where liftCompare = genericLiftCompare
instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
-- | The environment for an abstract value type.
type EnvironmentFor v = Environment (LocationFor v) v
-- | The store for an abstract value type.
type StoreFor v = Store (LocationFor v) v
-- | The cell for an abstract value type.
type CellFor value = Cell (LocationFor value) value
-- | The location type (the body of 'Address'es) which should be used for an abstract value type.
type family LocationFor value :: * where
LocationFor (Value location term) = location
@ -103,8 +134,8 @@ class ValueRoots l v | v -> l where
instance (FreeVariables term, Ord location) => ValueRoots location (Value location term) where
valueRoots v
| Just (Closure names body env) <- prj v = envRoots env (foldr Set.delete (freeVariables body) names)
| otherwise = mempty
| Just (Closure names body env) <- prjValue v = envRoots env (foldr Set.delete (freeVariables (body :: term)) names)
| otherwise = mempty
instance ValueRoots Monovariant Type.Type where
valueRoots _ = mempty

6
src/Data/Algebra.hs
View File

@ -14,6 +14,7 @@ module Data.Algebra
, openFToOpenR
) where
import Data.Bifunctor
import Data.Functor.Foldable ( Base
, Corecursive(embed)
, Recursive(project)
@ -45,7 +46,10 @@ type OpenRAlgebra f t a = forall b . (b -> (t, a)) -> f b -> a
-- | A subterm and its computed value, used in 'SubtermAlgebra'.
data Subterm t a = Subterm { subterm :: !t, subtermValue :: !a }
deriving (Eq, Ord, Show)
deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
instance Bifunctor Subterm where
bimap f g (Subterm a b) = Subterm (f a) (g b)
-- | Like an R-algebra, but using 'Subterm' to label the fields instead of an anonymous pair.
type SubtermAlgebra f t a = f (Subterm t a) -> a

5
src/Data/Diff.hs
View File

@ -82,11 +82,6 @@ merging :: Functor syntax => Term syntax ann -> Diff syntax ann ann
merging = cata (\ (In ann syntax) -> mergeF (In (ann, ann) syntax))
diffPatch :: Diff syntax ann1 ann2 -> Maybe (Patch (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2)))
diffPatch diff = case unDiff diff of
Patch patch -> Just patch
_ -> Nothing
diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann1 ann2 -> [Patch (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2))]
diffPatches = para $ \ diff -> case diff of
Patch patch -> bimap (fmap fst) (fmap fst) patch : bifoldMap (foldMap snd) (foldMap snd) patch

44
src/Data/Map/Monoidal.hs Normal file
View File

@ -0,0 +1,44 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
-- | This module defines a 'Map' type whose 'Monoid' and 'Reducer' instances merge values using the 'Semigroup' instance for the underlying type.
module Data.Map.Monoidal
( Map
, lookup
, size
, insert
, filterWithKey
, module Reducer
) where
import qualified Data.Map as Map
import Data.Semigroup.Reducer as Reducer
import Prelude hiding (lookup)
import Prologue hiding (Map)
newtype Map key value = Map { unMap :: Map.Map key value }
deriving (Eq, Eq1, Eq2, Foldable, Functor, Ord, Ord1, Ord2, Show, Show1, Show2, Traversable)
lookup :: Ord key => key -> Map key value -> Maybe value
lookup key = Map.lookup key . unMap
size :: Map key value -> Int
size = Map.size . unMap
insert :: Ord key => key -> value -> Map key value -> Map key value
insert key value = Map . Map.insert key value . unMap
filterWithKey :: (key -> value -> Bool) -> Map key value -> Map key value
filterWithKey f = Map . Map.filterWithKey f . unMap
instance (Ord key, Semigroup value) => Semigroup (Map key value) where
Map a <> Map b = Map (Map.unionWith (<>) a b)
instance (Ord key, Semigroup value) => Monoid (Map key value) where
mempty = Map Map.empty
mappend = (<>)
instance (Ord key, Reducer a value) => Reducer (key, a) (Map key value) where
unit (key, a) = Map (Map.singleton key (unit a))
cons (key, a) (Map m) = Map (Map.insertWith (<>) key (unit a) m)
snoc (Map m) (key, a) = Map (Map.insertWith (flip (<>)) key (unit a) m)

3
src/Data/Syntax.hs
View File

@ -7,6 +7,7 @@ import Data.Abstract.Evaluatable
import Data.AST
import Data.Range
import Data.Record
import qualified Data.Set as Set
import Data.Span
import Data.Term
import Diffing.Algorithm hiding (Empty)
@ -112,7 +113,7 @@ instance Evaluatable Identifier where
maybe (fail ("free variable: " <> show name)) deref (envLookup name env)
instance FreeVariables1 Identifier where
liftFreeVariables _ (Identifier x) = point x
liftFreeVariables _ (Identifier x) = Set.singleton x
newtype Program a = Program [a]

25
src/Data/Syntax/Declaration.hs
View File

@ -1,11 +1,11 @@
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}
module Data.Syntax.Declaration where
import Prologue
import Data.Abstract.Environment
import Data.Abstract.Evaluatable
import Diffing.Algorithm
import qualified Data.Map as Map
import Prologue
data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a }
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
@ -88,7 +88,7 @@ instance Evaluatable OptionalParameter
-- TODO: Should we replace this with Function and differentiate by context?
-- TODO: How should we distinguish class/instance methods?
-- TODO: It would be really nice to have a more meaningful type contained in here than [a]
-- | A declaration of possibly many variables such as var foo = 5, bar = 6 in JavaScript.
newtype VariableDeclaration a = VariableDeclaration { variableDeclarations :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
@ -97,9 +97,9 @@ instance Eq1 VariableDeclaration where liftEq = genericLiftEq
instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare
instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for VariableDeclaration
instance Evaluatable VariableDeclaration
instance Evaluatable VariableDeclaration where
eval (VariableDeclaration []) = unit
eval (VariableDeclaration decs) = multiple =<< traverse subtermValue decs
-- | A TypeScript/Java style interface declaration to implement.
data InterfaceDeclaration a = InterfaceDeclaration { interfaceDeclarationContext :: ![a], interfaceDeclarationIdentifier :: !a, interfaceDeclarationBody :: !a }
@ -156,8 +156,19 @@ instance Eq1 Module where liftEq = genericLiftEq
instance Ord1 Module where liftCompare = genericLiftCompare
instance Show1 Module where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Module
instance Evaluatable Module
-- TODO: Fix this extremely bogus instance (copied from that of Program)
-- In Go, functions in the same module can be spread across files.
-- We need to ensure that all input files have aggregated their content into
-- a coherent module before we begin evaluating a module.
instance Evaluatable Module where
eval (Module _ xs) = eval' xs
where
eval' [] = unit >>= interface
eval' [x] = subtermValue x >>= interface
eval' (x:xs) = do
_ <- subtermValue x
env <- getGlobalEnv
localEnv (envUnion env) (eval' xs)
-- | A decorator in Python
data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a }

27
src/Data/Syntax/Expression.hs
View File

@ -2,7 +2,9 @@
module Data.Syntax.Expression where
import Data.Abstract.Evaluatable
import Data.Fixed
import Diffing.Algorithm
import Prelude hiding (fail)
import Prologue hiding (apply)
-- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell.
@ -51,8 +53,15 @@ instance Ord1 Arithmetic where liftCompare = genericLiftCompare
instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Arithmetic
instance Evaluatable Arithmetic
instance Evaluatable Arithmetic where
eval = traverse subtermValue >=> go where
go (Plus a b) = liftNumeric2 (+) (+) a b
go (Minus a b) = liftNumeric2 (-) (-) a b
go (Times a b) = liftNumeric2 (*) (*) a b
go (DividedBy a b) = liftNumeric2 (/) div a b
go (Modulo a b) = liftNumeric2 mod' mod a b
go (Power a b) = liftNumeric2 (**) (^) a b
go (Negate a) = liftNumeric negate a
-- | Boolean operators.
data Boolean a
@ -66,9 +75,17 @@ instance Eq1 Boolean where liftEq = genericLiftEq
instance Ord1 Boolean where liftCompare = genericLiftCompare
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Boolean
instance Evaluatable Boolean
instance Evaluatable Boolean where
-- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands
eval = go . fmap subtermValue where
go (And a b) = do
cond <- a
ifthenelse cond b (pure cond)
go (Or a b) = do
cond <- a
ifthenelse cond (pure cond) b
go (Not a) = a >>= toBool >>= boolean . not
go (XOr a b) = liftA2 (/=) (a >>= toBool) (b >>= toBool) >>= boolean
-- | Javascript delete operator
newtype Delete a = Delete a

5
src/Data/Syntax/Literal.hs
View File

@ -236,9 +236,8 @@ instance Eq1 Tuple where liftEq = genericLiftEq
instance Ord1 Tuple where liftCompare = genericLiftCompare
instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Tuple
instance Evaluatable Tuple
instance Evaluatable Tuple where
eval (Tuple cs) = multiple =<< traverse subtermValue cs
newtype Set a = Set { setElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)

86
src/Language/Go/Syntax.hs
View File

@ -2,51 +2,70 @@
module Language.Go.Syntax where
import Prologue
import Data.Abstract.Evaluatable
import Diffing.Algorithm
-- A composite literal in Go
data Composite a = Composite { compositeType :: !a, compositeElement :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Composite where liftEq = genericLiftEq
instance Ord1 Composite where liftCompare = genericLiftCompare
instance Show1 Composite where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Composite
instance Evaluatable Composite
-- | A default pattern in a Go select or switch statement (e.g. `switch { default: s() }`).
newtype DefaultPattern a = DefaultPattern { defaultPatternBody :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 DefaultPattern where liftEq = genericLiftEq
instance Ord1 DefaultPattern where liftCompare = genericLiftCompare
instance Show1 DefaultPattern where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for DefaultPattern
instance Evaluatable DefaultPattern
-- | A defer statement in Go (e.g. `defer x()`).
newtype Defer a = Defer { deferBody :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Defer where liftEq = genericLiftEq
instance Ord1 Defer where liftCompare = genericLiftCompare
instance Show1 Defer where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Defer
instance Evaluatable Defer
-- | A go statement (i.e. go routine) in Go (e.g. `go x()`).
newtype Go a = Go { goBody :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Go where liftEq = genericLiftEq
instance Ord1 Go where liftCompare = genericLiftCompare
instance Show1 Go where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Go
instance Evaluatable Go
-- | A label statement in Go (e.g. `label:continue`).
data Label a = Label { _labelName :: !a, labelStatement :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Label where liftEq = genericLiftEq
instance Ord1 Label where liftCompare = genericLiftCompare
instance Show1 Label where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Label
instance Evaluatable Label
-- | A rune literal in Go (e.g. `'⌘'`).
newtype Rune a = Rune { _runeLiteral :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
-- TODO: Implement Eval instance for Rune
instance Evaluatable Rune
instance Eq1 Rune where liftEq = genericLiftEq
instance Ord1 Rune where liftCompare = genericLiftCompare
@ -54,7 +73,10 @@ instance Show1 Rune where liftShowsPrec = genericLiftShowsPrec
-- | A select statement in Go (e.g. `select { case x := <-c: x() }` where each case is a send or receive operation on channels).
data Select a = Select { selectCases :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
-- TODO: Implement Eval instance for Select
instance Evaluatable Select
instance Eq1 Select where liftEq = genericLiftEq
instance Ord1 Select where liftCompare = genericLiftCompare
@ -62,80 +84,110 @@ instance Show1 Select where liftShowsPrec = genericLiftShowsPrec
-- | A send statement in Go (e.g. `channel <- value`).
data Send a = Send { sendReceiver :: !a, sendValue :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Send where liftEq = genericLiftEq
instance Ord1 Send where liftCompare = genericLiftCompare
instance Show1 Send where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Send
instance Evaluatable Send
-- | A slice expression in Go (e.g. `a[1:4:3]` where a is a list, 1 is the low bound, 4 is the high bound, and 3 is the max capacity).
data Slice a = Slice { sliceName :: !a, sliceLow :: !a, sliceHigh :: !a, sliceCapacity :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Slice where liftEq = genericLiftEq
instance Ord1 Slice where liftCompare = genericLiftCompare
instance Show1 Slice where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Slice
instance Evaluatable Slice
-- | A type switch statement in Go (e.g. `switch x.(type) { // cases }`).
data TypeSwitch a = TypeSwitch { typeSwitchSubject :: !a, typeSwitchCases :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 TypeSwitch where liftEq = genericLiftEq
instance Ord1 TypeSwitch where liftCompare = genericLiftCompare
instance Show1 TypeSwitch where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for TypeSwitch
instance Evaluatable TypeSwitch
-- | A type switch guard statement in a Go type switch statement (e.g. `switch i := x.(type) { // cases}`).
newtype TypeSwitchGuard a = TypeSwitchGuard { typeSwitchGuardSubject :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 TypeSwitchGuard where liftEq = genericLiftEq
instance Ord1 TypeSwitchGuard where liftCompare = genericLiftCompare
instance Show1 TypeSwitchGuard where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for TypeSwitchGuard
instance Evaluatable TypeSwitchGuard
-- | A receive statement in a Go select statement (e.g. `case value := <-channel` )
data Receive a = Receive { receiveSubject :: !a, receiveExpression :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Receive where liftEq = genericLiftEq
instance Ord1 Receive where liftCompare = genericLiftCompare
instance Show1 Receive where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Receive
instance Evaluatable Receive
-- | A receive operator unary expression in Go (e.g. `<-channel` )
data ReceiveOperator a = ReceiveOperator a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ReceiveOperator where liftEq = genericLiftEq
instance Ord1 ReceiveOperator where liftCompare = genericLiftCompare
instance Show1 ReceiveOperator where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for ReceiveOperator
instance Evaluatable ReceiveOperator
-- | A field declaration in a Go struct type declaration.
data Field a = Field { fieldContext :: ![a], fieldName :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Field where liftEq = genericLiftEq
instance Ord1 Field where liftCompare = genericLiftCompare
instance Show1 Field where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Field
instance Evaluatable Field
-- | A type assertion in Go (e.g. `x.(T)` where the value of `x` is not nil and is of type `T`).
data TypeAssertion a = TypeAssertion { typeAssertionSubject :: !a, typeAssertionType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 TypeAssertion where liftEq = genericLiftEq
instance Ord1 TypeAssertion where liftCompare = genericLiftCompare
instance Show1 TypeAssertion where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for TypeAssertion
instance Evaluatable TypeAssertion
-- | A type conversion expression in Go (e.g. `T(x)` where `T` is a type and `x` is an expression that can be converted to type `T`).
data TypeConversion a = TypeConversion { typeConversionType :: !a, typeConversionSubject :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 TypeConversion where liftEq = genericLiftEq
instance Ord1 TypeConversion where liftCompare = genericLiftCompare
instance Show1 TypeConversion where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for TypeConversion
instance Evaluatable TypeConversion
-- | Variadic arguments and parameters in Go (e.g. parameter: `param ...Type`, argument: `Type...`).
data Variadic a = Variadic { variadicContext :: [a], variadicIdentifier :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Variadic where liftEq = genericLiftEq
instance Ord1 Variadic where liftCompare = genericLiftCompare
instance Show1 Variadic where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Variadic
instance Evaluatable Variadic

16
src/Language/Go/Type.hs
View File

@ -2,28 +2,38 @@
module Language.Go.Type where
import Prologue
import Data.Abstract.Evaluatable
import Diffing.Algorithm
-- | A Bidirectional channel in Go (e.g. `chan`).
newtype BidirectionalChannel a = BidirectionalChannel a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 BidirectionalChannel where liftEq = genericLiftEq
instance Ord1 BidirectionalChannel where liftCompare = genericLiftCompare
instance Show1 BidirectionalChannel where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for BidirectionalChannel
instance Evaluatable BidirectionalChannel
-- | A Receive channel in Go (e.g. `<-chan`).
newtype ReceiveChannel a = ReceiveChannel a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ReceiveChannel where liftEq = genericLiftEq
instance Ord1 ReceiveChannel where liftCompare = genericLiftCompare
instance Show1 ReceiveChannel where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for ReceiveChannel
instance Evaluatable ReceiveChannel
-- | A Send channel in Go (e.g. `chan<-`).
newtype SendChannel a = SendChannel a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 SendChannel where liftEq = genericLiftEq
instance Ord1 SendChannel where liftCompare = genericLiftCompare
instance Show1 SendChannel where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for SendChannel
instance Evaluatable SendChannel

2
src/Language/TypeScript/Syntax.hs
View File

@ -85,6 +85,8 @@ newtype Tuple a = Tuple { _tupleElements :: [a] }
instance Eq1 Tuple where liftEq = genericLiftEq
instance Ord1 Tuple where liftCompare = genericLiftCompare
instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
-- This is a tuple type, not a tuple value, so we can't lean on the shared Tuple value
instance Evaluatable Tuple
data Constructor a = Constructor { _constructorTypeParameters :: !a, _constructorFormalParameters :: ![a], _constructorType :: !a }

1
src/Prologue.hs
View File

@ -51,7 +51,6 @@ import Data.Functor.Classes.Generic as X
import Data.Functor.Foldable as X (Base, Recursive(..), Corecursive(..))
import Data.Mergeable as X (Mergeable)
import Data.Monoid as X (Monoid(..), First(..), Last(..))
import Data.Pointed as X
import Data.Proxy as X (Proxy(..))
import Data.Semigroup as X (Semigroup(..))
import Data.Traversable as X

63
src/Semantic/Util.hs
View File

@ -1,11 +1,13 @@
-- MonoLocalBinds is to silence a warning about a simplifiable constraint.
{-# LANGUAGE DataKinds, MonoLocalBinds, TypeOperators, TypeApplications #-}
{-# LANGUAGE DataKinds, MonoLocalBinds, TypeApplications, TypeOperators #-}
module Semantic.Util where
import Prologue
import Analysis.Abstract.Caching
import Analysis.Abstract.Dead
import Analysis.Abstract.Evaluating
import Analysis.Abstract.Tracing
import Analysis.Declaration
import Control.Abstract.Analysis
import Control.Monad.IO.Class
import Data.Abstract.Address
import Data.Abstract.Type
@ -20,50 +22,65 @@ import Data.Term
import Diffing.Algorithm
import Diffing.Interpreter
import Parsing.Parser
import Prologue
import Semantic
import Semantic.IO as IO
import Semantic.Task
import qualified Language.Ruby.Assignment as Ruby
import qualified Language.Go.Assignment as Go
import qualified Language.Python.Assignment as Python
import qualified Language.Ruby.Assignment as Ruby
import qualified Language.TypeScript.Assignment as TypeScript
type RubyValue = Value Precise (Term (Union Ruby.Syntax) (Record Location))
type PythonValue = Value Precise (Term (Union Python.Syntax) (Record Location))
type TypeScriptValue = Value Precise (Term (Union TypeScript.Syntax) (Record Location))
type Language a = Value Precise (Term (Union a) (Record Location))
type GoValue = Language Go.Syntax
type RubyValue = Language Ruby.Syntax
type PythonValue = Language Python.Syntax
type TypeScriptValue = Language TypeScript.Syntax
file :: MonadIO m => FilePath -> m Blob
file path = fromJust <$> IO.readFile path (languageForFilePath path)
-- Ruby
evaluateRubyFile path = Prelude.fst . evaluate @RubyValue <$>
(file path >>= runTask . parse rubyParser)
evaluateRubyFile path = fst . evaluate @RubyValue . snd <$> parseFile rubyParser path
evaluateRubyFiles paths = do
blobs@(b:bs) <- traverse file paths
(t:ts) <- runTask $ traverse (parse rubyParser) blobs
pure $ evaluates @RubyValue (zip bs ts) (b, t)
first:rest <- traverse (parseFile rubyParser) paths
pure $ evaluates @RubyValue rest first
-- Go
typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluateModule . snd <$>
parseFile goParser path
evaluateGoFile path = runAnalysis @(Evaluating Go.Term GoValue) . evaluateModule . snd <$>
parseFile goParser path
-- Python
typecheckPythonFile path = evaluateCache @Type <$>
(file path >>= runTask . parse pythonParser)
typecheckPythonFile path = runAnalysis @(Caching Evaluating Python.Term Type) . evaluateModule . snd <$> parseFile pythonParser path
evaluatePythonFile path = evaluate @PythonValue <$>
(file path >>= runTask . parse pythonParser)
tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path
evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path
evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path
evaluatePythonFiles paths = do
blobs@(b:bs) <- traverse file paths
(t:ts) <- runTask $ traverse (parse pythonParser) blobs
pure $ evaluates @PythonValue (zip bs ts) (b, t)
first:rest <- traverse (parseFile pythonParser) paths
pure $ evaluates @PythonValue rest first
-- TypeScript
evaluateTypeScriptFile path = Prelude.fst . evaluate @TypeScriptValue <$>
(file path >>= runTask . parse typescriptParser)
evaluateTypeScriptFile path = fst . evaluate @TypeScriptValue . snd <$> parseFile typescriptParser path
evaluateTypeScriptFiles paths = do
blobs@(b:bs) <- traverse file paths
(t:ts) <- runTask $ traverse (parse typescriptParser) blobs
pure $ evaluates @TypeScriptValue (zip bs ts) (b, t)
first:rest <- traverse (parseFile typescriptParser) paths
pure $ evaluates @TypeScriptValue rest first
parseFile :: Parser term -> FilePath -> IO (Blob, term)
parseFile parser path = runTask $ do
blob <- file path
(,) blob <$> parse parser blob
-- Diff helpers

2
test/Assigning/Assignment/Spec.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE DataKinds #-}
module Assigning.Assignment.Spec where
module Assigning.Assignment.Spec (spec) where
import Assigning.Assignment
import Data.AST

2
test/Data/Functor/Classes/Generic/Spec.hs
View File

@ -1,4 +1,4 @@
module Data.Functor.Classes.Generic.Spec where
module Data.Functor.Classes.Generic.Spec (spec) where
import Data.Functor.Classes.Generic
import Data.Functor.Listable

2
test/Data/Mergeable/Spec.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
module Data.Mergeable.Spec where
module Data.Mergeable.Spec (spec) where
import Control.Applicative (Alternative(..))
import Data.Functor.Identity

2
test/Data/Source/Spec.hs
View File

@ -1,4 +1,4 @@
module Data.Source.Spec where
module Data.Source.Spec (spec) where
import Data.Char (chr)
import Data.Functor.Listable

2
test/Integration/Spec.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, OverloadedStrings #-}
module Integration.Spec where
module Integration.Spec (spec) where
import qualified Data.ByteString as B
import Data.Foldable (find, traverse_)

4
test/Rendering/Imports/Spec.hs
View File

@ -1,4 +1,4 @@
module Rendering.Imports.Spec where
module Rendering.Imports.Spec (spec) where
import Analysis.Declaration (HasDeclaration, declarationAlgebra)
import Analysis.ModuleDef (HasModuleDef, moduleDefAlgebra)
@ -10,7 +10,7 @@ import qualified Data.Map as Map
import qualified Semantic.Util as Util
import Rendering.Imports
import Rendering.Renderer
import Rendering.TOC.Spec
import Rendering.TOC.Spec hiding (spec)
import Semantic
import Semantic.Task
import SpecHelpers

2
test/Rendering/TOC/Spec.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE DataKinds, TypeOperators #-}
module Rendering.TOC.Spec where
module Rendering.TOC.Spec (spec) where
import Analysis.Decorator (constructorNameAndConstantFields)
import Analysis.Declaration

2
test/Semantic/CLI/Spec.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE DuplicateRecordFields #-}
module Semantic.CLI.Spec where
module Semantic.CLI.Spec (spec) where
import Control.Monad (when)
import Data.ByteString (ByteString)

2
test/Semantic/IO/Spec.hs
View File

@ -1,4 +1,4 @@
module Semantic.IO.Spec where
module Semantic.IO.Spec (spec) where
import Data.Blob
import Data.Functor.Both as Both

2
test/Semantic/Stat/Spec.hs
View File

@ -1,4 +1,4 @@
module Semantic.Stat.Spec where
module Semantic.Stat.Spec (spec) where
import Semantic.Stat
import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall)

10
test/SpecHelpers.hs
View File

@ -3,7 +3,6 @@ module SpecHelpers
( diffFilePaths
, parseFilePath
, readFilePair
, languageForFilePath
, Verbatim(..)
, verbatim
, readFileVerbatim
@ -31,18 +30,13 @@ diffFilePaths paths = readFilePair paths >>= runTask . diffBlobPair SExpressionD
-- | Returns an s-expression parse tree for the specified FilePath.
parseFilePath :: FilePath -> IO B.ByteString
parseFilePath path = IO.readFile path (languageForFilePath path) >>= pure . fromJust >>= runTask . parseBlob SExpressionTermRenderer
parseFilePath path = IO.readFile path (IO.languageForFilePath path) >>= pure . fromJust >>= runTask . parseBlob SExpressionTermRenderer
-- | Read two files to a BlobPair.
readFilePair :: Both FilePath -> IO BlobPair
readFilePair paths = let paths' = fmap (\p -> (p, languageForFilePath p)) paths in
readFilePair paths = let paths' = fmap (\p -> (p, IO.languageForFilePath p)) paths in
runBothWith IO.readFilePair paths'
-- | Returns a Maybe Language based on the FilePath's extension.
languageForFilePath :: FilePath -> Maybe Language
languageForFilePath = languageForType . takeExtension
readFileVerbatim :: FilePath -> IO Verbatim
readFileVerbatim = fmap verbatim . B.readFile