github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-27 12:57:49 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #1973 from github/define-preludes-as-builtins

Browse Source 
Define preludes as builtins
This commit is contained in:
Timothy Clem 2018-06-18 14:11:33 -07:00 committed by GitHub
commit a2aeec581b
17 changed files with 139 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
preludes/javascript.js
View File

@ -1,2 +0,0 @@
// can't quite define console.log in a way we can evaluate yet, but...
// function log(x) { return __semantic_print(x) }

3
preludes/python.py
View File

@ -1,3 +0,0 @@
def print(x):
__semantic_print(x)
return x

13
preludes/ruby.rb
View File

@ -1,13 +0,0 @@
class Object
def new
self
end
def inspect
return "<object>"
end
end
def puts(obj)
__semantic_print(obj)
end

1
semantic.cabal
View File

@ -127,7 +127,6 @@ library
, Language.PHP.Assignment
, Language.PHP.Grammar
, Language.PHP.Syntax
, Language.Preluded
, Language.Python.Assignment
, Language.Python.Grammar
, Language.Python.Syntax

47
src/Control/Abstract/Primitive.hs
View File

@ -5,25 +5,42 @@ import Control.Abstract.Environment
import Control.Abstract.Evaluator
import Control.Abstract.Heap
import Control.Abstract.Value
import qualified Data.Abstract.Environment as Env
import Data.Abstract.Name
import Data.Text (pack, unpack)
import Data.Text (unpack)
import Prologue
builtin :: ( HasCallStack
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
)
=> String
-> Evaluator address value effects value
-> Evaluator address value effects ()
builtin s def = withCurrentCallStack callStack $ do
let name' = name ("__semantic_" <> pack s)
addr <- alloc name'
bind name' addr
define :: ( HasCallStack
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
)
=> Name
-> Evaluator address value effects value
-> Evaluator address value effects ()
define name def = withCurrentCallStack callStack $ do
addr <- alloc name
bind name addr
def >>= assign addr
defineClass :: ( AbstractValue address value effects
, HasCallStack
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
)
=> Name
-> [Name]
-> Evaluator address value effects a
-> Evaluator address value effects ()
defineClass name superclasses scope = define name $ do
env <- locally $ do
void scope
Env.head <$> getEnv
klass name (map (string . formatName) superclasses) env
lambda :: (AbstractFunction address value effects, Member Fresh effects)
=> (Name -> Evaluator address value effects address)
-> Evaluator address value effects value
@ -43,4 +60,4 @@ defineBuiltins :: ( AbstractValue address value effects
)
=> Evaluator address value effects ()
defineBuiltins =
builtin "print" (lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit))
define "__semantic_print" (lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit))

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

@ -1,10 +1,12 @@
{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GADTs, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Evaluatable
( module X
, Evaluatable(..)
, evaluatePackageWith
, traceResolve
-- | Effects
-- * Preludes
, HasPrelude(..)
-- * Effects
, EvalError(..)
, throwEvalError
, runEvalError
@ -30,6 +32,7 @@ import Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Name as X
import Data.Abstract.Package as Package
import Data.Abstract.Ref as X
import Data.Language
import Data.Scientific (Scientific)
import Data.Semigroup.App
import Data.Semigroup.Foldable
@ -62,7 +65,7 @@ class Show1 constr => Evaluatable constr where
-- | Evaluate a given package.
evaluatePackageWith :: forall address term value inner inner' inner'' outer
evaluatePackageWith :: forall proxy lang address term value inner inner' inner'' outer
. ( AbstractValue address value inner
-- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' locations require knowledge of 'currentModule' to run. Can we fix that?
, Addressable address inner'
@ -70,6 +73,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer
, Evaluatable (Base term)
, Foldable (Cell address)
, FreeVariables term
, HasPrelude lang
, Member Fresh outer
, Member (Resumable (AddressError address value)) outer
, Member (Resumable (EnvironmentError address)) outer
@ -87,15 +91,16 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer
, inner' ~ (Reader ModuleInfo ': inner'')
, inner'' ~ (Modules address value ': Reader Span ': Reader PackageInfo ': outer)
)
=> (SubtermAlgebra Module term (TermEvaluator term address value inner address) -> SubtermAlgebra Module term (TermEvaluator term address value inner address))
=> proxy lang
-> (SubtermAlgebra Module term (TermEvaluator term address value inner address) -> SubtermAlgebra Module term (TermEvaluator term address value inner address))
-> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address)))
-> Package term
-> TermEvaluator term address value outer [(address, Environment address)]
evaluatePackageWith analyzeModule analyzeTerm package
evaluatePackageWith lang analyzeModule analyzeTerm package
= runReader (packageInfo package)
. runReader lowerBound
. runReader (packageModules (packageBody package))
. withPrelude (packagePrelude (packageBody package))
. withPrelude package
$ \ preludeEnv
-> raiseHandler (runModules (runTermEvaluator . evalModule preludeEnv))
. traverse (uncurry (evaluateEntryPoint preludeEnv))
@ -121,13 +126,14 @@ evaluatePackageWith analyzeModule analyzeTerm package
bindAll env
maybe (pure ptr) ((`call` []) <=< deref <=< variable) sym
evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule lowerBound)) $ do
(_, builtinsEnv) <- runInModule lowerBound moduleInfoFromCallStack (TermEvaluator (defineBuiltins *> box unit))
second (mergeEnvs builtinsEnv) <$> evalModule builtinsEnv prelude
withPrelude Nothing f = f lowerBound
withPrelude (Just prelude) f = do
(_, preludeEnv) <- evalPrelude prelude
withPrelude :: Package term
-> (Environment address -> TermEvaluator term address value (Reader (ModuleTable (NonEmpty (Module term))) ': Reader Span ': Reader PackageInfo ': outer) a)
-> TermEvaluator term address value (Reader (ModuleTable (NonEmpty (Module term))) ': Reader Span ': Reader PackageInfo ': outer) a
withPrelude _ f = do
(_, preludeEnv) <- raiseHandler (runModules (runTermEvaluator . evalModule lowerBound)) . runInModule lowerBound moduleInfoFromCallStack . TermEvaluator $ do
defineBuiltins
definePrelude lang
box unit
f preludeEnv
@ -135,6 +141,55 @@ traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator ad
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
-- Preludes
class HasPrelude (language :: Language) where
definePrelude :: ( AbstractValue address value effects
, HasCallStack
, Member (Allocator address value) effects
, Member (Env address) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (EnvironmentError address)) effects
, Member Trace effects
)
=> proxy language
-> Evaluator address value effects ()
definePrelude _ = pure ()
instance HasPrelude 'Go
instance HasPrelude 'Haskell
instance HasPrelude 'Java
instance HasPrelude 'JavaScript
instance HasPrelude 'PHP
builtInPrint :: ( AbstractIntro value
, AbstractFunction address value effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Env address) effects, Member (Allocator address value) effects)
=> Name
-> Evaluator address value effects address
builtInPrint v = do
print <- variable "__semantic_print" >>= deref
void $ call print [variable v]
box unit
instance HasPrelude 'Python where
definePrelude _ =
define "print" (lambda builtInPrint)
instance HasPrelude 'Ruby where
definePrelude _ = do
define "puts" (lambda builtInPrint)
defineClass "Object" [] $ do
define "inspect" (lambda (const (box (string "<object>"))))
instance HasPrelude 'TypeScript
-- FIXME: define console.log using __semantic_print
-- Effects
-- | The type of error thrown when failing to evaluate a term.

7
src/Data/Abstract/Package.hs
View File

@ -22,7 +22,6 @@ newtype Version = Version { versionString :: String }
data PackageBody term = PackageBody
{ packageModules :: ModuleTable (NonEmpty (Module term))
, packagePrelude :: Maybe (Module term)
, packageEntryPoints :: ModuleTable (Maybe Name)
}
deriving (Eq, Functor, Ord, Show)
@ -35,8 +34,8 @@ data Package term = Package
}
deriving (Eq, Functor, Ord, Show)
fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> Int -> [Module term] -> Map.Map FilePath FilePath -> Package term
fromModules name version prelude entryPoints modules resolutions =
Package (PackageInfo name version resolutions) (PackageBody (ModuleTable.fromModules modules) prelude entryPoints')
fromModules :: PackageName -> Maybe Version -> Int -> [Module term] -> Map.Map FilePath FilePath -> Package term
fromModules name version entryPoints modules resolutions =
Package (PackageInfo name version resolutions) (PackageBody (ModuleTable.fromModules modules) entryPoints')
where
entryPoints' = ModuleTable . Map.fromList $ (,Nothing) . modulePath . moduleInfo <$> if entryPoints == 0 then modules else take entryPoints modules

22
src/Language/Preluded.hs
View File

@ -1,22 +0,0 @@
{-# LANGUAGE DataKinds, TypeFamilies #-}
module Language.Preluded
( Preluded (..)
) where
import GHC.TypeLits
import qualified Language.Python.Assignment as Python
import qualified Language.Ruby.Assignment as Ruby
import qualified Language.TypeScript.Assignment as TypeScript
class Preluded syntax where
type PreludePath syntax :: Symbol
instance Preluded Ruby.Term where
type PreludePath Ruby.Term = "preludes/ruby.rb"
instance Preluded Python.Term where
type PreludePath Python.Term = "preludes/python.py"
instance Preluded TypeScript.Term where
type PreludePath TypeScript.Term = "preludes/javascript.js"

28
src/Parsing/Parser.hs
View File

@ -25,6 +25,7 @@ module Parsing.Parser
import Assigning.Assignment
import qualified CMarkGFM
import Data.Abstract.Evaluatable (HasPrelude)
import Data.AST
import Data.Kind
import Data.Language
@ -32,16 +33,13 @@ import Data.Record
import Data.Sum
import qualified Data.Syntax as Syntax
import Data.Term
import Data.Project
import Foreign.Ptr
import qualified GHC.TypeLits as TypeLevel
import qualified Language.Go.Assignment as Go
import qualified Language.Haskell.Assignment as Haskell
import qualified Language.Java.Assignment as Java
import qualified Language.JSON.Assignment as JSON
import qualified Language.Markdown.Assignment as Markdown
import qualified Language.PHP.Assignment as PHP
import Language.Preluded
import qualified Language.Python.Assignment as Python
import qualified Language.Ruby.Assignment as Ruby
import qualified Language.TypeScript.Assignment as TypeScript
@ -63,10 +61,12 @@ type family ApplyAll' (typeclasses :: [(* -> *) -> Constraint]) (fs :: [* -> *])
-- | A parser, suitable for program analysis, for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints.
data SomeAnalysisParser typeclasses ann where
SomeAnalysisParser :: ( Element Syntax.Identifier fs
, ApplyAll' typeclasses fs)
SomeAnalysisParser :: ( ApplyAll' typeclasses fs
, Element Syntax.Identifier fs
, HasPrelude lang
)
=> Parser (Term (Sum fs) ann) -- ^ A parser.
-> Maybe File -- ^ Maybe path to prelude.
-> Proxy lang
-> SomeAnalysisParser typeclasses ann
-- | A parser for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints.
@ -81,14 +81,14 @@ someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax
=> proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@.
-> Language -- ^ The 'Language' to select.
-> SomeAnalysisParser typeclasses (Record Location) -- ^ A 'SomeAnalysisParser abstracting the syntax type to be produced.
someAnalysisParser _ Go = SomeAnalysisParser goParser Nothing
someAnalysisParser _ Java = SomeAnalysisParser javaParser Nothing
someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath TypeScript.Term))) JavaScript)
someAnalysisParser _ Haskell = SomeAnalysisParser haskellParser Nothing
someAnalysisParser _ PHP = SomeAnalysisParser phpParser Nothing
someAnalysisParser _ Python = SomeAnalysisParser pythonParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) Python)
someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) Ruby)
someAnalysisParser _ TypeScript = SomeAnalysisParser typescriptParser Nothing
someAnalysisParser _ Go = SomeAnalysisParser goParser (Proxy :: Proxy 'Go)
someAnalysisParser _ Haskell = SomeAnalysisParser haskellParser (Proxy :: Proxy 'Haskell)
someAnalysisParser _ Java = SomeAnalysisParser javaParser (Proxy :: Proxy 'Java)
someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser (Proxy :: Proxy 'JavaScript)
someAnalysisParser _ PHP = SomeAnalysisParser phpParser (Proxy :: Proxy 'PHP)
someAnalysisParser _ Python = SomeAnalysisParser pythonParser (Proxy :: Proxy 'Python)
someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser (Proxy :: Proxy 'Ruby)
someAnalysisParser _ TypeScript = SomeAnalysisParser typescriptParser (Proxy :: Proxy 'TypeScript)
someAnalysisParser _ l = error $ "Analysis not supported for: " <> show l

16
src/Semantic/Graph.hs
View File

@ -38,20 +38,20 @@ import Semantic.Task as Task
data GraphType = ImportGraph | CallGraph
runGraph :: ( Member (Distribute WrappedTask) effs, Member Files effs, Member Resolution effs, Member Task effs, Member Trace effs)
runGraph :: ( Member (Distribute WrappedTask) effs, Member Resolution effs, Member Task effs, Member Trace effs)
=> GraphType
-> Bool
-> Project
-> Eff effs (Graph Vertex)
runGraph graphType includePackages project
| SomeAnalysisParser parser prelude <- someAnalysisParser
| SomeAnalysisParser parser lang <- someAnalysisParser
(Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do
package <- parsePackage parser prelude project
package <- parsePackage parser project
let analyzeTerm = withTermSpans . case graphType of
ImportGraph -> id
CallGraph -> graphingTerms
analyzeModule = (if includePackages then graphingPackages else id) . graphingModules
analyze runGraphAnalysis (evaluatePackageWith analyzeModule analyzeTerm package) >>= extractGraph
analyze runGraphAnalysis (evaluatePackageWith lang analyzeModule analyzeTerm package) >>= extractGraph
where extractGraph result = case result of
(((_, graph), _), _) -> pure (simplify graph)
runGraphAnalysis
@ -94,16 +94,14 @@ newtype GraphEff address a = GraphEff
}
-- | Parse a list of files into a 'Package'.
parsePackage :: (Member (Distribute WrappedTask) effs, Member Files effs, Member Resolution effs, Member Task effs, Member Trace effs)
parsePackage :: (Member (Distribute WrappedTask) effs, Member Resolution effs, Member Trace effs)
=> Parser term -- ^ A parser.
-> Maybe File -- ^ Prelude (optional).
-> Project -- ^ Project to parse into a package.
-> Eff effs (Package term)
parsePackage parser preludeFile project@Project{..} = do
prelude <- traverse (parseModule parser Nothing) preludeFile
parsePackage parser project@Project{..} = do
p <- parseModules parser project
resMap <- Task.resolutionMap project
let pkg = Package.fromModules n Nothing prelude (length projectEntryPoints) p resMap
let pkg = Package.fromModules n Nothing (length projectEntryPoints) p resMap
pkg <$ trace ("project: " <> show pkg)
where

28
src/Semantic/Util.hs
View File

@ -17,10 +17,8 @@ import Data.Functor.Foldable
import qualified Data.Language as Language
import Data.Sum (weaken)
import Data.Term
import qualified GHC.TypeLits as TypeLevel
import Language.Haskell.HsColour
import Language.Haskell.HsColour.Colourise
import Language.Preluded
import Parsing.Parser
import Prologue hiding (weaken)
import Semantic.Graph
@ -29,10 +27,6 @@ import Semantic.Task
import Text.Show (showListWith)
import Text.Show.Pretty (ppShow)
import qualified Language.Python.Assignment as Python
import qualified Language.Ruby.Assignment as Ruby
import qualified Language.TypeScript.Assignment as TypeScript
justEvaluating
= runM
. evaluating
@ -87,22 +81,18 @@ checking
. runAddressError
. runTypeError
evalGoProject path = justEvaluating =<< evaluateProject goParser Language.Go Nothing path
evalRubyProject path = justEvaluating =<< evaluateProject rubyParser Language.Ruby rubyPrelude path
evalPHPProject path = justEvaluating =<< evaluateProject phpParser Language.PHP Nothing path
evalPythonProject path = justEvaluating =<< evaluateProject pythonParser Language.Python pythonPrelude path
evalJavaScriptProject path = justEvaluating =<< evaluateProject typescriptParser Language.JavaScript javaScriptPrelude path
evalTypeScriptProject path = justEvaluating =<< evaluateProject typescriptParser Language.TypeScript Nothing path
evalGoProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go path
evalRubyProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby path
evalPHPProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP path
evalPythonProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python path
evalJavaScriptProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.JavaScript) typescriptParser Language.JavaScript path
evalTypeScriptProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser Language.TypeScript path
typecheckGoFile path = checking =<< evaluateProjectWithCaching goParser Language.Go Nothing path
rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) Language.Ruby
pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) Language.Python
javaScriptPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath TypeScript.Term))) Language.JavaScript
typecheckGoFile path = checking =<< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Go) goParser Language.Go path
-- Evaluate a project, starting at a single entrypoint.
evaluateProject parser lang prelude path = evaluatePackageWith id withTermSpans . fmap quieterm <$> runTask (readProject Nothing path lang [] >>= parsePackage parser prelude)
evaluateProjectWithCaching parser lang prelude path = evaluatePackageWith convergingModules (withTermSpans . cachingTerms) . fmap quieterm <$> runTask (readProject Nothing path lang [] >>= parsePackage parser prelude)
evaluateProject proxy parser lang path = evaluatePackageWith proxy id withTermSpans . fmap quieterm <$> runTask (readProject Nothing path lang [] >>= parsePackage parser)
evaluateProjectWithCaching proxy parser lang path = evaluatePackageWith proxy convergingModules (withTermSpans . cachingTerms) . fmap quieterm <$> runTask (readProject Nothing path lang [] >>= parsePackage parser)
parseFile :: Parser term -> FilePath -> IO term

2
test/Analysis/Go/Spec.hs
View File

@ -25,4 +25,4 @@ spec = parallel $ do
where
fixtures = "test/fixtures/go/analysis/"
evaluate entry = evalGoProject (fixtures <> entry)
evalGoProject path = testEvaluating <$> evaluateProject goParser Language.Go Nothing path
evalGoProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go path

2
test/Analysis/PHP/Spec.hs
View File

@ -32,4 +32,4 @@ spec = parallel $ do
where
fixtures = "test/fixtures/php/analysis/"
evaluate entry = evalPHPProject (fixtures <> entry)
evalPHPProject path = testEvaluating <$> evaluateProject phpParser Language.PHP Nothing path
evalPHPProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP path

2
test/Analysis/Python/Spec.hs
View File

@ -46,4 +46,4 @@ spec = parallel $ do
ns n = Just . Latest . Last . Just . Namespace n
fixtures = "test/fixtures/python/analysis/"
evaluate entry = evalPythonProject (fixtures <> entry)
evalPythonProject path = testEvaluating <$> evaluateProject pythonParser Language.Python pythonPrelude path
evalPythonProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python path

2
test/Analysis/Ruby/Spec.hs
View File

@ -77,4 +77,4 @@ spec = parallel $ do
ns n = Just . Latest . Last . Just . Namespace n
fixtures = "test/fixtures/ruby/analysis/"
evaluate entry = evalRubyProject (fixtures <> entry)
evalRubyProject path = testEvaluating <$> evaluateProject rubyParser Language.Ruby rubyPrelude path
evalRubyProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby path

2
test/Analysis/TypeScript/Spec.hs
View File

@ -40,4 +40,4 @@ spec = parallel $ do
where
fixtures = "test/fixtures/typescript/analysis/"
evaluate entry = evalTypeScriptProject (fixtures <> entry)
evalTypeScriptProject path = testEvaluating <$> evaluateProject typescriptParser Language.TypeScript Nothing path
evalTypeScriptProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser Language.TypeScript path

1
test/SpecHelpers.hs
View File

@ -32,6 +32,7 @@ import Data.Blob as X
import Data.ByteString.Builder (toLazyByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Project as X
import Data.Proxy as X
import Data.Functor.Listable as X
import Data.Language as X
import Data.List.NonEmpty as X (NonEmpty(..))