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

Merge branch 'master' into charliesome/value-ref-address

Browse Source
This commit is contained in:
Charlie Somerville 2018-05-29 11:37:35 -05:00
commit e0b4be74a9
88 changed files with 1710 additions and 665 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.ghci
View File

@ -3,7 +3,7 @@
-- See docs/💡ProTip!.md
:undef pretty
:def pretty \ _ -> return (unlines ["let colour = putStrLn . Language.Haskell.HsColour.hscolour Language.Haskell.HsColour.TTY Language.Haskell.HsColour.Colourise.defaultColourPrefs Prelude.False Prelude.False \"\" Prelude.False . Text.Show.Pretty.ppShow", ":set -interactive-print colour"])
:def pretty \ _ -> return (unlines [":set -interactive-print Semantic.Util.prettyShow"])
-- See docs/💡ProTip!.md
:undef no-pretty

2
.gitignore vendored
View File

@ -24,3 +24,5 @@ bin/
.bundle/
.licenses/vendor/gems
.licenses/log/
codex.tags

28
semantic.cabal
View File

@ -11,6 +11,10 @@ build-type: Simple
-- extra-source-files:
cabal-version: >=1.10
flag release
description: Build with optimizations on (for CI or deployment builds)
default: False
library
hs-source-dirs: src
exposed-modules:
@ -42,6 +46,7 @@ library
, Control.Abstract.Heap
, Control.Abstract.Matching
, Control.Abstract.Modules
, Control.Abstract.Primitive
, Control.Abstract.Roots
, Control.Abstract.TermEvaluator
, Control.Abstract.Value
@ -58,9 +63,11 @@ library
, Data.Abstract.Live
, Data.Abstract.Module
, Data.Abstract.ModuleTable
, Data.Abstract.Name
, Data.Abstract.Number
, Data.Abstract.Package
, Data.Abstract.Path
, Data.Abstract.Ref
, Data.Abstract.Type
, Data.Abstract.Value
-- General datatype definitions & generic algorithms
@ -77,6 +84,7 @@ library
, Data.Language
, Data.Map.Monoidal
, Data.Mergeable
, Data.Options
, Data.Patch
, Data.Project
, Data.Range
@ -110,6 +118,9 @@ library
, Language.Go.Assignment
, Language.Go.Syntax
, Language.Go.Type
, Language.Haskell.Grammar
, Language.Haskell.Assignment
, Language.Haskell.Syntax
, Language.JSON.Grammar
, Language.JSON.Assignment
, Language.Ruby.Grammar
@ -157,7 +168,7 @@ library
, Serializing.Format
, Serializing.SExpression
-- Custom Prelude
other-modules: Prologue
, Prologue
build-depends: base >= 4.8 && < 5
, aeson
, algebraic-graphs
@ -180,6 +191,7 @@ library
, gitrev
, Glob
, hashable
, hscolour
, kdt
, mersenne-random-pure64
, mtl
@ -188,6 +200,7 @@ library
, optparse-applicative
, parallel
, parsers
, pretty-show
, recursion-schemes
, reducers
, scientific
@ -202,6 +215,7 @@ library
, unordered-containers
, haskell-tree-sitter
, tree-sitter-go
, tree-sitter-haskell
, tree-sitter-json
, tree-sitter-php
, tree-sitter-python
@ -221,13 +235,19 @@ library
, StandaloneDeriving
, StrictData
, TypeApplications
ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -O -j
if flag(release)
ghc-options: -Wall -Werror -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -O1 -j
else
ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -O0 -j
ghc-prof-options: -fprof-auto
executable semantic
hs-source-dirs: app
main-is: Main.hs
ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A4m -n2m" -static -j -O
if flag(release)
ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A4m -n2m" -static -j -O1 -j
else
ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A4m -n2m" -static -j -O0 -j
cc-options: -DU_STATIC_IMPLEMENTATION=1
cpp-options: -DU_STATIC_IMPLEMENTATION=1
build-depends: base
@ -328,7 +348,7 @@ 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
ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A4m -n2m -T" -static -j -O1
cc-options: -DU_STATIC_IMPLEMENTATION=1
cpp-options: -DU_STATIC_IMPLEMENTATION=1
default-language: Haskell2010

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

@ -8,8 +8,8 @@ module Analysis.Abstract.Caching
import Control.Abstract
import Data.Abstract.Address
import Data.Abstract.Cache
import Data.Abstract.Evaluatable
import Data.Abstract.Module
import Data.Abstract.Ref
import Data.Semilattice.Lower
import Data.Semigroup.Reducer (Reducer)
import Prologue
@ -65,7 +65,7 @@ cachingTerms :: ( Cacheable term location (Cell location) value
, Reader (Cache term location (Cell location) value)
, Reader (Live location value)
, State (Cache term location (Cell location) value)
, State (Environment location value)
, State (Environment location)
, State (Heap location (Cell location) value)
] effects
)
@ -86,13 +86,12 @@ convergingModules :: ( AbstractValue location value effects
, Fresh
, NonDet
, Reader (Cache term location (Cell location) value)
, Reader (Environment location value)
, Reader (Environment location)
, Reader (Live location value)
, Resumable (AddressError location value)
, Resumable (EnvironmentError value)
, Resumable (EvalError value)
, State (Cache term location (Cell location) value)
, State (Environment location value)
, State (Environment location)
, State (Heap location (Cell location) value)
] effects
, Reducer value (Cell location value)

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

@ -10,10 +10,10 @@ import Data.Semilattice.Lower
-- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@.
data EvaluatingState location value = EvaluatingState
{ environment :: Environment location value
{ environment :: Environment location
, heap :: Heap location (Cell location) value
, modules :: ModuleTable (Maybe (Environment location value, Address location value))
, exports :: Exports location value
, modules :: ModuleTable (Maybe (Environment location, Address location value))
, exports :: Exports location
}
deriving instance (Eq (Cell location value), Eq location, Eq value) => Eq (EvaluatingState location value)
@ -24,19 +24,19 @@ deriving instance (Show (Cell location value), Show location, Show value) => Sho
evaluating :: Evaluator location value
( Fail
': Fresh
': Reader (Environment location value)
': State (Environment location value)
': Reader (Environment location)
': State (Environment location)
': State (Heap location (Cell location) value)
': State (ModuleTable (Maybe (Environment location value, Address location value)))
': State (Exports location value)
': State (ModuleTable (Maybe (Environment location, Address location value)))
': State (Exports location)
': effects) result
-> Evaluator location value effects (Either String result, EvaluatingState location value)
evaluating
= fmap (\ ((((result, env), heap), modules), exports) -> (result, EvaluatingState env heap modules exports))
. runState lowerBound -- State (Exports location value)
. runState lowerBound -- State (ModuleTable (Maybe (Environment location value, Address location value)))
. runState lowerBound -- State (Exports location)
. runState lowerBound -- State (ModuleTable (Maybe (Environment location, Address location value)))
. runState lowerBound -- State (Heap location (Cell location) value)
. runState lowerBound -- State (Environment location value)
. runReader lowerBound -- Reader (Environment location value)
. runState lowerBound -- State (Environment location)
. runReader lowerBound -- Reader (Environment location)
. runFresh 0
. runFail

61
src/Analysis/Abstract/Graph.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators #-}
module Analysis.Abstract.Graph
( Graph(..)
, Vertex(..)
@ -7,9 +7,8 @@ module Analysis.Abstract.Graph
, variableDefinition
, moduleInclusion
, packageInclusion
, packageGraph
, graphingTerms
, graphingLoadErrors
, graphingPackages
, graphingModules
, graphing
) where
@ -17,9 +16,8 @@ module Analysis.Abstract.Graph
import Algebra.Graph.Export.Dot hiding (vertexName)
import Control.Abstract
import Data.Abstract.Address
import Data.Abstract.Evaluatable (LoadError (..))
import Data.Abstract.FreeVariables
import Data.Abstract.Module (Module(moduleInfo), ModuleInfo(..))
import Data.Abstract.Name
import Data.Abstract.Package (PackageInfo(..))
import Data.Aeson hiding (Result)
import Data.ByteString.Builder
@ -54,10 +52,9 @@ style = (defaultStyle (byteString . vertexName))
-- | Add vertices to the graph for evaluated identifiers.
graphingTerms :: ( Element Syntax.Identifier syntax
, Members '[ Reader (Environment (Located location) value)
, Members '[ Reader (Environment (Located location))
, Reader ModuleInfo
, Reader PackageInfo
, State (Environment (Located location) value)
, State (Environment (Located location))
, State (Graph Vertex)
] effects
, term ~ Term (Sum syntax) ann
@ -72,34 +69,34 @@ graphingTerms recur term@(In _ syntax) = do
_ -> pure ()
recur term
-- | Add vertices to the graph for 'LoadError's.
graphingLoadErrors :: Members '[ Reader ModuleInfo
, Resumable (LoadError location value)
, State (Graph Vertex)
] effects
=> SubtermAlgebra (Base term) term (TermEvaluator term location value effects a)
-> SubtermAlgebra (Base term) term (TermEvaluator term location value effects a)
graphingLoadErrors recur term = TermEvaluator (runTermEvaluator (recur term) `resumeLoadError` (\ (ModuleNotFound name) -> moduleInclusion (Module (BC.pack name)) *> moduleNotFound name))
graphingPackages :: Members '[ Reader ModuleInfo
, Reader PackageInfo
, State (Graph Vertex)
] effects
=> SubtermAlgebra Module term (TermEvaluator term location value effects a)
-> SubtermAlgebra Module term (TermEvaluator term location value effects a)
graphingPackages recur m = packageInclusion (moduleVertex (moduleInfo m)) *> recur m
-- | Add vertices to the graph for evaluated modules and the packages containing them.
graphingModules :: Members '[ Reader ModuleInfo
, Reader PackageInfo
graphingModules :: forall term location value effects a
. Members '[ Modules location value
, Reader ModuleInfo
, State (Graph Vertex)
] effects
=> SubtermAlgebra Module term (TermEvaluator term location value effects a)
-> SubtermAlgebra Module term (TermEvaluator term location value effects a)
graphingModules recur m = do
let name = BC.pack (modulePath (moduleInfo m))
packageInclusion (Module name)
moduleInclusion (Module name)
recur m
graphingModules recur m = interpose @(Modules location value) pure (\ m yield -> case m of
Load path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
Lookup path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
_ -> send m >>= yield)
(recur m)
packageGraph :: PackageInfo -> Graph Vertex
packageGraph = vertex . Package . unName . packageName
packageVertex :: PackageInfo -> Vertex
packageVertex = Package . unName . packageName
moduleGraph :: ModuleInfo -> Graph Vertex
moduleGraph = vertex . Module . BC.pack . modulePath
moduleVertex :: ModuleInfo -> Vertex
moduleVertex = Module . BC.pack . modulePath
-- | Add an edge from the current package to the passed vertex.
packageInclusion :: ( Effectful m
@ -112,7 +109,7 @@ packageInclusion :: ( Effectful m
-> m effects ()
packageInclusion v = do
p <- currentPackage
appendGraph (packageGraph p `connect` vertex v)
appendGraph (vertex (packageVertex p) `connect` vertex v)
-- | Add an edge from the current module to the passed vertex.
moduleInclusion :: ( Effectful m
@ -125,17 +122,17 @@ moduleInclusion :: ( Effectful m
-> m effects ()
moduleInclusion v = do
m <- currentModule
appendGraph (moduleGraph m `connect` vertex v)
appendGraph (vertex (moduleVertex m) `connect` vertex v)
-- | Add an edge from the passed variable name to the module it originated within.
variableDefinition :: ( Member (Reader (Environment (Located location) value)) effects
, Member (State (Environment (Located location) value)) effects
variableDefinition :: ( Member (Reader (Environment (Located location))) effects
, Member (State (Environment (Located location))) effects
, Member (State (Graph Vertex)) effects
)
=> Name
-> TermEvaluator term (Located location) value effects ()
variableDefinition name = do
graph <- maybe lowerBound (moduleGraph . locationModule . unAddress) <$> TermEvaluator (lookupEnv name)
graph <- maybe lowerBound (vertex . moduleVertex . locationModule . unAddress) <$> TermEvaluator (lookupEnv name)
appendGraph (vertex (Variable (unName name)) `connect` graph)
appendGraph :: (Effectful m, Member (State (Graph Vertex)) effects) => Graph Vertex -> m effects ()

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

@ -14,7 +14,7 @@ import Prologue
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
tracingTerms :: ( Corecursive term
, Members '[ Reader (Live location value)
, State (Environment location value)
, State (Environment location)
, State (Heap location (Cell location) value)
, Writer (trace (Configuration term location (Cell location) value))
] effects

4
src/Analysis/Declaration.hs
View File

@ -5,7 +5,7 @@ module Analysis.Declaration
, declarationAlgebra
) where
import Data.Abstract.FreeVariables (Name(..))
import Data.Abstract.Name (unName)
import Data.Blob
import Data.Error (Error(..), showExpectation)
import Data.Language as Language
@ -130,7 +130,7 @@ getSource blobSource = toText . flip Source.slice blobSource . getField
instance (Syntax.Identifier :< fs, Expression.MemberAccess :< fs) => CustomHasDeclaration (Sum fs) Expression.Call where
customToDeclaration Blob{..} _ (Expression.Call _ (Term (In fromAnn fromF), _) _ _)
| Just (Expression.MemberAccess (Term (In leftAnn leftF)) (Term (In idenAnn _))) <- project fromF = Just $ CallReference (getSource idenAnn) mempty blobLanguage (memberAccess leftAnn leftF)
| Just (Syntax.Identifier (Name name)) <- project fromF = Just $ CallReference (T.decodeUtf8 name) mempty blobLanguage []
| Just (Syntax.Identifier name) <- project fromF = Just $ CallReference (T.decodeUtf8 (unName name)) mempty blobLanguage []
| otherwise = Just $ CallReference (getSource fromAnn) mempty blobLanguage []
where
memberAccess modAnn termFOut

4
src/Analysis/IdentifierName.hs
View File

@ -5,7 +5,7 @@ module Analysis.IdentifierName
, identifierLabel
) where
import Data.Abstract.FreeVariables (Name (..))
import Data.Abstract.Name (unName)
import Data.Aeson
import Data.JSON.Fields
import Data.Sum
@ -41,7 +41,7 @@ instance Apply IdentifierName fs => CustomIdentifierName (Sum fs) where
customIdentifierName = apply @IdentifierName identifierName
instance CustomIdentifierName Data.Syntax.Identifier where
customIdentifierName (Data.Syntax.Identifier (Name name)) = Just name
customIdentifierName (Data.Syntax.Identifier name) = Just (unName name)
data Strategy = Default | Custom

1
src/Control/Abstract.hs
View File

@ -11,6 +11,7 @@ import Control.Abstract.Exports as X
import Control.Abstract.Heap as X
import Control.Abstract.Goto as X
import Control.Abstract.Modules as X
import Control.Abstract.Primitive as X
import Control.Abstract.Roots as X
import Control.Abstract.TermEvaluator as X
import Control.Abstract.Value as X

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

@ -6,7 +6,7 @@ module Control.Abstract.Addressable
import Control.Abstract.Context
import Control.Abstract.Evaluator
import Data.Abstract.Address
import Data.Abstract.FreeVariables
import Data.Abstract.Name
import Prologue
-- | Defines allocation and dereferencing of 'Address'es in a 'Heap'.

2
src/Control/Abstract/Configuration.hs
View File

@ -12,5 +12,5 @@ import Control.Abstract.TermEvaluator
import Data.Abstract.Configuration
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: Members '[Reader (Live location value), State (Environment location value), State (Heap location (Cell location) value)] effects => term -> TermEvaluator term location value effects (Configuration term location (Cell location) value)
getConfiguration :: Members '[Reader (Live location value), State (Environment location), State (Heap location (Cell location) value)] effects => term -> TermEvaluator term location value effects (Configuration term location (Cell location) value)
getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEnv <*> TermEvaluator getHeap

22
src/Control/Abstract/Environment.hs
View File

@ -20,53 +20,53 @@ module Control.Abstract.Environment
import Control.Abstract.Evaluator
import Data.Abstract.Address
import Data.Abstract.Environment as Env
import Data.Abstract.FreeVariables
import Data.Abstract.Name
import Prologue
-- | Retrieve the environment.
getEnv :: Member (State (Environment location value)) effects => Evaluator location value effects (Environment location value)
getEnv :: Member (State (Environment location)) effects => Evaluator location value effects (Environment location)
getEnv = get
-- | Set the environment.
putEnv :: Member (State (Environment location value)) effects => Environment location value -> Evaluator location value effects ()
putEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value effects ()
putEnv = put
-- | Update the global environment.
modifyEnv :: Member (State (Environment location value)) effects => (Environment location value -> Environment location value) -> Evaluator location value effects ()
modifyEnv :: Member (State (Environment location)) effects => (Environment location -> Environment location) -> Evaluator location value effects ()
modifyEnv = modify'
-- | Sets the environment for the lifetime of the given action.
withEnv :: Member (State (Environment location value)) effects => Environment location value -> Evaluator location value effects a -> Evaluator location value effects a
withEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value effects a -> Evaluator location value effects a
withEnv = localState . const
-- | Retrieve the default environment.
defaultEnvironment :: Member (Reader (Environment location value)) effects => Evaluator location value effects (Environment location value)
defaultEnvironment :: Member (Reader (Environment location)) effects => Evaluator location value effects (Environment location)
defaultEnvironment = ask
-- | Set the default environment for the lifetime of an action.
-- Usually only invoked in a top-level evaluation function.
withDefaultEnvironment :: Member (Reader (Environment location value)) effects => Environment location value -> Evaluator location value effects a -> Evaluator location value effects a
withDefaultEnvironment :: Member (Reader (Environment location)) effects => Environment location -> Evaluator location value effects a -> Evaluator location value effects a
withDefaultEnvironment e = local (const e)
-- | Obtain an environment that is the composition of the current and default environments.
-- Useful for debugging.
fullEnvironment :: Members '[Reader (Environment location value), State (Environment location value)] effects => Evaluator location value effects (Environment location value)
fullEnvironment :: Members '[Reader (Environment location), State (Environment location)] effects => Evaluator location value effects (Environment location)
fullEnvironment = mergeEnvs <$> getEnv <*> defaultEnvironment
-- | Run an action with a locally-modified environment.
localEnv :: Member (State (Environment location value)) effects => (Environment location value -> Environment location value) -> Evaluator location value effects a -> Evaluator location value effects a
localEnv :: Member (State (Environment location)) effects => (Environment location -> Environment location) -> Evaluator location value effects a -> Evaluator location value effects a
localEnv f a = do
modifyEnv (f . Env.push)
result <- a
result <$ modifyEnv Env.pop
-- | Run a computation in a new local environment.
localize :: Member (State (Environment location value)) effects => Evaluator location value effects a -> Evaluator location value effects a
localize :: Member (State (Environment location)) effects => Evaluator location value effects a -> Evaluator location value effects a
localize = localEnv id
-- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
lookupEnv :: Members '[Reader (Environment location value), State (Environment location value)] effects => Name -> Evaluator location value effects (Maybe (Address location value))
lookupEnv :: Members '[Reader (Environment location), State (Environment location)] effects => Name -> Evaluator location value effects (Maybe (Address location value))
lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)

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

@ -1,7 +1,6 @@
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
module Control.Abstract.Evaluator
( Evaluator(..)
, ValueRef(..)
-- * Effects
, Return(..)
, earlyReturn
@ -12,26 +11,17 @@ module Control.Abstract.Evaluator
, throwContinue
, catchLoopControl
, runLoopControl
, module Control.Monad.Effect
, module Control.Monad.Effect.Fail
, module Control.Monad.Effect.Fresh
, module Control.Monad.Effect.NonDet
, module Control.Monad.Effect.Reader
, module Control.Monad.Effect.Resumable
, module Control.Monad.Effect.State
, module Control.Monad.Effect.Trace
, module X
) where
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.Resumable
import Control.Monad.Effect.State
import Control.Monad.Effect.Trace
import Control.Monad.Effect 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.Resumable as X
import Control.Monad.Effect.State as X
import Control.Monad.Effect.Trace as X
import Data.Abstract.Address
import Data.Abstract.FreeVariables
import Prologue
-- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the location, term, and value types.
@ -44,17 +34,6 @@ newtype Evaluator location value effects a = Evaluator { runEvaluator :: Eff eff
deriving instance Member NonDet effects => Alternative (Evaluator location value effects)
-- | 'ValueRef' is the type subterms evaluate to and can represent either values directly ('Rval'), or references to values (lvals - such as local variables or object members)
data ValueRef location value where
-- Represents a value:
Rval :: Address location value -> ValueRef location value
-- Represents a local variable. No environment is attached - it's assumed that LvalLocal will be evaluated in the same scope it was constructed:
LvalLocal :: Name -> ValueRef location value
-- Represents an object member:
LvalMember :: Address location value -> Name -> ValueRef location value
deriving (Eq, Ord, Show)
-- Effects
-- | An effect for explicitly returning out of a function/method body.

12
src/Control/Abstract/Exports.hs
View File

@ -10,24 +10,24 @@ module Control.Abstract.Exports
import Control.Abstract.Evaluator
import Data.Abstract.Address
import Data.Abstract.Exports
import Data.Abstract.FreeVariables
import Data.Abstract.Name
-- | Get the global export state.
getExports :: Member (State (Exports location value)) effects => Evaluator location value effects (Exports location value)
getExports :: Member (State (Exports location)) effects => Evaluator location value effects (Exports location)
getExports = get
-- | Set the global export state.
putExports :: Member (State (Exports location value)) effects => Exports location value -> Evaluator location value effects ()
putExports :: Member (State (Exports location)) effects => Exports location -> Evaluator location value effects ()
putExports = put
-- | Update the global export state.
modifyExports :: Member (State (Exports location value)) effects => (Exports location value -> Exports location value) -> Evaluator location value effects ()
modifyExports :: Member (State (Exports location)) effects => (Exports location -> Exports location) -> Evaluator location value effects ()
modifyExports = modify'
-- | Add an export to the global export state.
addExport :: Member (State (Exports location value)) effects => Name -> Name -> Maybe (Address location value) -> Evaluator location value effects ()
addExport :: Member (State (Exports location)) effects => Name -> Name -> Maybe (Address location value) -> Evaluator location value effects ()
addExport name alias = modifyExports . insert name alias
-- | Sets the global export state for the lifetime of the given action.
withExports :: Member (State (Exports location value)) effects => Exports location value -> Evaluator location value effects a -> Evaluator location value effects a
withExports :: Member (State (Exports location)) effects => Exports location -> Evaluator location value effects a -> Evaluator location value effects a
withExports = localState . const

18
src/Control/Abstract/Heap.hs
View File

@ -25,8 +25,8 @@ import Control.Abstract.Environment
import Control.Abstract.Evaluator
import Data.Abstract.Address
import Data.Abstract.Environment
import Data.Abstract.FreeVariables
import Data.Abstract.Heap
import Data.Abstract.Name
import Data.Semigroup.Reducer
import Prologue
@ -76,8 +76,8 @@ assign address = modifyHeap . heapInsert address
-- | Look up or allocate an address for a 'Name'.
lookupOrAlloc :: Members '[ Allocator location value
, Reader (Environment location value)
, State (Environment location value)
, Reader (Environment location)
, State (Environment location)
] effects
=> Name
-> Evaluator location value effects (Address location value)
@ -85,8 +85,8 @@ lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure
letrec :: ( Members '[ Allocator location value
, Reader (Environment location value)
, State (Environment location value)
, Reader (Environment location)
, State (Environment location)
, State (Heap location (Cell location) value)
] effects
, Ord location
@ -103,8 +103,8 @@ letrec name body = do
-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
letrec' :: Members '[ Allocator location value
, Reader (Environment location value)
, State (Environment location value)
, Reader (Environment location)
, State (Environment location)
] effects
=> Name
-> (Address location value -> Evaluator location value effects a)
@ -117,9 +117,9 @@ letrec' name body = do
-- | Look up and dereference the given 'Name', throwing an exception for free variables.
variable :: Members '[ Allocator location value
, Reader (Environment location value)
, Reader (Environment location)
, Resumable (EnvironmentError value)
, State (Environment location value)
, State (Environment location)
, State (Heap location (Cell location) value)
] effects
=> Name

24
src/Control/Abstract/Modules.hs
View File

@ -27,7 +27,7 @@ import Data.Language
import Prologue
-- | Retrieve an evaluated module, if any. The outer 'Maybe' indicates whether we’ve begun loading the module or not, while the inner 'Maybe' indicates whether we’ve completed loading it or not. Thus, @Nothing@ means we’ve never tried to load it, @Just Nothing@ means we’ve started but haven’t yet finished loading it, and @Just (Just (env, value))@ indicates the result of a completed load.
lookupModule :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Maybe (Environment location value, Address location value)))
lookupModule :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Maybe (Environment location, Address location value)))
lookupModule = send . Lookup
-- | Resolve a list of module paths to a possible module table entry.
@ -41,19 +41,19 @@ listModulesInDir = sendModules . List
-- | Require/import another module by name and return its environment and value.
--
-- Looks up the module's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module.
require :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location value, Address location value))
require :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, Address location value))
require path = lookupModule path >>= maybeM (load path)
-- | Load another module by name and return its environment and value.
--
-- Always loads/evaluates.
load :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location value, Address location value))
load :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, Address location value))
load = send . Load
data Modules location value return where
Load :: ModulePath -> Modules location value (Maybe (Environment location value, Address location value))
Lookup :: ModulePath -> Modules location value (Maybe (Maybe (Environment location value, Address location value)))
Load :: ModulePath -> Modules location value (Maybe (Environment location, Address location value))
Lookup :: ModulePath -> Modules location value (Maybe (Maybe (Environment location, Address location value)))
Resolve :: [FilePath] -> Modules location value (Maybe ModulePath)
List :: FilePath -> Modules location value [ModulePath]
@ -62,10 +62,10 @@ sendModules = send
runModules :: forall term location value effects a
. Members '[ Resumable (LoadError location value)
, State (ModuleTable (Maybe (Environment location value, Address location value)))
, State (ModuleTable (Maybe (Environment location, Address location value)))
, Trace
] effects
=> (Module term -> Evaluator location value (Modules location value ': effects) (Environment location value, Address location value))
=> (Module term -> Evaluator location value (Modules location value ': effects) (Environment location, Address location value))
-> Evaluator location value (Modules location value ': effects) a
-> Evaluator location value (Reader (ModuleTable [Module term]) ': effects) a
runModules evaluateModule = go
@ -90,17 +90,17 @@ runModules evaluateModule = go
pure (find isMember names)
List dir -> modulePathsInDir dir <$> askModuleTable @term)
getModuleTable :: Member (State (ModuleTable (Maybe (Environment location value, Address location value)))) effects => Evaluator location value effects (ModuleTable (Maybe (Environment location value, Address location value)))
getModuleTable :: Member (State (ModuleTable (Maybe (Environment location, Address location value)))) effects => Evaluator location value effects (ModuleTable (Maybe (Environment location, Address location value)))
getModuleTable = get
cacheModule :: Member (State (ModuleTable (Maybe (Environment location value, Address location value)))) effects => ModulePath -> Maybe (Environment location value, Address location value) -> Evaluator location value effects (Maybe (Environment location value, Address location value))
cacheModule :: Member (State (ModuleTable (Maybe (Environment location, Address location value)))) effects => ModulePath -> Maybe (Environment location, Address location value) -> Evaluator location value effects (Maybe (Environment location, Address location value))
cacheModule path result = modify' (ModuleTable.insert path result) $> result
askModuleTable :: Member (Reader (ModuleTable [Module term])) effects => Evaluator location value effects (ModuleTable [Module term])
askModuleTable = ask
newtype Merging m location value = Merging { runMerging :: m (Maybe (Environment location value, Address location value)) }
newtype Merging m location value = Merging { runMerging :: m (Maybe (Environment location, Address location value)) }
instance Applicative m => Semigroup (Merging m location value) where
Merging a <> Merging b = Merging (merge <$> a <*> b)
@ -114,7 +114,7 @@ instance Applicative m => Monoid (Merging m location value) where
-- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name.
data LoadError location value resume where
ModuleNotFound :: ModulePath -> LoadError location value (Maybe (Environment location value, Address location value))
ModuleNotFound :: ModulePath -> LoadError location value (Maybe (Environment location, Address location value))
deriving instance Eq (LoadError location value resume)
deriving instance Show (LoadError location value resume)
@ -123,7 +123,7 @@ instance Show1 (LoadError location value) where
instance Eq1 (LoadError location value) where
liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b
moduleNotFound :: Member (Resumable (LoadError location value)) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location value, Address location value))
moduleNotFound :: Member (Resumable (LoadError location value)) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, Address location value))
moduleNotFound = throwResumable . ModuleNotFound
resumeLoadError :: Member (Resumable (LoadError location value)) effects => Evaluator location value effects a -> (forall resume . LoadError location value resume -> Evaluator location value effects resume) -> Evaluator location value effects a

62
src/Control/Abstract/Primitive.hs Normal file
View File

@ -0,0 +1,62 @@
module Control.Abstract.Primitive where
import Control.Abstract.Addressable
import Control.Abstract.Context
import Control.Abstract.Environment
import Control.Abstract.Evaluator
import Control.Abstract.Heap
import Control.Abstract.Value
import Data.Abstract.Address
import Data.Abstract.Environment
import Data.Abstract.Name
import Data.ByteString.Char8 (pack, unpack)
import Data.Semigroup.Reducer hiding (unit)
import Data.Semilattice.Lower
import Prologue
builtin :: ( HasCallStack
, Members '[ Allocator location value
, Reader (Environment location)
, Reader ModuleInfo
, Reader Span
, State (Environment location)
, State (Heap location (Cell location) value)
] effects
, Ord location
, Reducer value (Cell location value)
)
=> String
-> Evaluator location value effects value
-> Evaluator location value effects ()
builtin n def = withCurrentCallStack callStack $ do
let name' = name ("__semantic_" <> pack n)
addr <- alloc name'
modifyEnv (insert name' addr)
def >>= assign addr
lambda :: (AbstractFunction location value effects, Member Fresh effects)
=> Set Name
-> (Name -> Evaluator location value effects (Address location value))
-> Evaluator location value effects (Address location value)
lambda fvs body = do
var <- nameI <$> fresh
closure [var] fvs (body var)
defineBuiltins :: ( AbstractValue location value effects
, HasCallStack
, Members '[ Allocator location value
, Fresh
, Reader (Environment location)
, Reader ModuleInfo
, Reader Span
, Resumable (EnvironmentError value)
, State (Environment location)
, State (Heap location (Cell location) value)
, Trace
] effects
, Ord location
, Reducer value (Cell location value)
)
=> Evaluator location value effects ()
defineBuiltins =
builtin "print" (lambda lowerBound (\ v -> variable v >>= asString >>= trace . unpack >> unit >>= box) >>= deref)

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

@ -1,12 +1,17 @@
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE GADTs, Rank2Types #-}
module Control.Abstract.Value
( AbstractValue(..)
, AbstractFunction(..)
, AbstractHole(..)
, Comparator(..)
, asBool
, while
, doWhile
, forLoop
, makeNamespace
, evaluateInScopedEnv
, value
, subtermValue
, ValueRoots(..)
) where
@ -16,9 +21,10 @@ import Control.Abstract.Evaluator
import Control.Abstract.Heap
import Data.Abstract.Address (Address)
import Data.Abstract.Environment as Env
import Data.Abstract.FreeVariables
import Data.Abstract.Live (Live)
import Data.Abstract.Name
import Data.Abstract.Number as Number
import Data.Abstract.Ref
import Data.Scientific (Scientific)
import Data.Semigroup.Reducer hiding (unit)
import Data.Semilattice.Lower
@ -38,16 +44,29 @@ data Comparator
class AbstractHole value where
hole :: value
class Show value => AbstractFunction location value effects where
-- | Build a closure (a binder like a lambda or method definition).
closure :: [Name] -- ^ The parameter names.
-> Set Name -- ^ The set of free variables to close over.
-> Evaluator location value effects (Address location value) -- ^ The evaluator for the body of the closure.
-> Evaluator location value effects (Address location value)
-- | Evaluate an application (like a function call).
call :: value
-> [Evaluator location value effects (Address location value)]
-> Evaluator location value effects (Address location value)
-- | 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 Show value => AbstractValue location value effects where
class AbstractFunction location value effects => AbstractValue location value effects where
-- | Construct an abstract unit value.
-- TODO: This might be the same as the empty tuple for some value types
unit :: Evaluator location value effects value
-- | Construct an abstract integral value.
integer :: Prelude.Integer -> Evaluator location value effects value
integer :: Integer -> Evaluator location value effects value
-- | Lift a unary operator over a 'Num' to a function on 'value's.
liftNumeric :: (forall a . Num a => a -> a)
@ -87,7 +106,7 @@ class Show value => AbstractValue location value effects where
float :: Scientific -> Evaluator location value effects value
-- | Construct a rational value.
rational :: Prelude.Rational -> Evaluator location value effects value
rational :: Rational -> Evaluator location value effects value
-- | Construct an N-ary tuple of multiple (possibly-disjoint) values
multiple :: [value] -> Evaluator location value effects value
@ -108,10 +127,7 @@ class Show value => AbstractValue location value effects where
asString :: value -> Evaluator location value effects ByteString
-- | Eliminate boolean values. TODO: s/boolean/truthy
ifthenelse :: value -> Evaluator location value effects value -> Evaluator location value effects value -> Evaluator location value effects value
-- | Extract a 'Bool' from a given value.
asBool :: value -> Evaluator location value effects Bool
ifthenelse :: value -> Evaluator location value effects a -> Evaluator location value effects a -> Evaluator location value effects a
-- | Construct the nil/null datatype.
null :: Evaluator location value effects value
@ -119,32 +135,21 @@ class Show value => AbstractValue location value effects where
-- | @index x i@ computes @x[i]@, with zero-indexing.
index :: value -> value -> Evaluator location value effects value
-- | Determine whether the given datum is a 'Hole'.
isHole :: value -> Evaluator location value effects Bool
-- | Build a class value from a name and environment.
klass :: Name -- ^ The new class's identifier
-> [value] -- ^ A list of superclasses
-> Environment location value -- ^ The environment to capture
klass :: Name -- ^ The new class's identifier
-> [value] -- ^ A list of superclasses
-> Environment location -- ^ The environment to capture
-> Evaluator location value effects value
-- | Build a namespace value from a name and environment stack
--
-- Namespaces model closures with monoidal environments.
namespace :: Name -- ^ The namespace's identifier
-> Environment location value -- ^ The environment to mappend
namespace :: Name -- ^ The namespace's identifier
-> Environment location -- ^ The environment to mappend
-> Evaluator location value effects value
-- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
scopedEnvironment :: value -> Evaluator location value effects (Maybe (Environment location value))
-- | Build a closure (a binder like a lambda or method definition).
closure :: [Name] -- ^ The parameter names.
-> Set Name -- ^ The set of free variables to close over.
-> Evaluator location value effects value -- ^ The evaluator for the body of the closure.
-> Evaluator location value effects value
-- | Evaluate an application (like a function call).
call :: value -> [Evaluator location value effects (Address location value)] -> Evaluator location value effects (Address location value)
scopedEnvironment :: value -> Evaluator location value effects (Maybe (Environment location))
-- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion.
--
@ -152,9 +157,13 @@ class Show value => AbstractValue location value effects where
loop :: (Evaluator location value effects value -> Evaluator location value effects value) -> Evaluator location value effects value
-- | Attempt to extract a 'Prelude.Bool' from a given value.
-- | Extract a 'Bool' from a given value.
asBool :: AbstractValue location value effects => value -> Evaluator location value effects Bool
asBool value = ifthenelse value (pure True) (pure False)
-- | C-style for loops.
forLoop :: ( AbstractValue location value effects
, Member (State (Environment location value)) effects
, Member (State (Environment location)) effects
)
=> Evaluator location value effects value -- ^ Initial statement
-> Evaluator location value effects value -- ^ Condition
@ -164,7 +173,7 @@ forLoop :: ( AbstractValue location value effects
forLoop initial cond step body =
localize (initial *> while cond (body *> step))
-- | The fundamental looping primitive, built on top of ifthenelse.
-- | The fundamental looping primitive, built on top of 'ifthenelse'.
while :: AbstractValue location value effects
=> Evaluator location value effects value
-> Evaluator location value effects value
@ -183,7 +192,7 @@ doWhile body cond = loop $ \ continue -> body *> do
ifthenelse this continue unit
makeNamespace :: ( AbstractValue location value effects
, Member (State (Environment location value)) effects
, Member (State (Environment location)) effects
, Member (State (Heap location (Cell location) value)) effects
, Ord location
, Reducer value (Cell location value)
@ -200,6 +209,75 @@ makeNamespace name addr super = do
v <$ assign addr v
-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
evaluateInScopedEnv :: ( AbstractValue location value effects
, Member (State (Environment location)) effects
)
=> Evaluator location value effects value
-> Evaluator location value effects a
-> Evaluator location value effects a
evaluateInScopedEnv scopedEnvTerm term = do
scopedEnv <- scopedEnvTerm >>= scopedEnvironment
maybe term (flip localEnv term . mergeEnvs) scopedEnv
-- | Evaluates a 'Value' returning the referenced value
value :: ( AbstractValue location value effects
, Members '[ Allocator location value
, Reader (Environment location)
, Resumable (EnvironmentError value)
, State (Environment location)
, State (Heap location (Cell location) value)
] effects
, Ord location
, Reducer value (Cell location value)
)
=> ValueRef location value
-> Evaluator location value effects value
value = deref <=< address
-- | Evaluates a 'Subterm' to its rval
subtermValue :: ( AbstractValue location value effects
, Members '[ Allocator location value
, Reader (Environment location)
, Resumable (EnvironmentError value)
, State (Environment location)
, State (Heap location (Cell location) value)
] effects
, Ord location
, Reducer value (Cell location value)
)
=> Subterm term (Evaluator location value effects (ValueRef location value))
-> Evaluator location value effects value
subtermValue = value <=< subtermRef
address :: ( AbstractValue location value effects
, Members '[ Allocator location value
, Reader (Environment location)
, Resumable (EnvironmentError value)
, State (Environment location)
, State (Heap location (Cell location) value)
] effects
, Ord location
, Reducer value (Cell location value)
)
=> ValueRef location value
-> Evaluator location value effects (Address location value)
address (LvalLocal var) = fromJust <$> lookupEnv var
address (LvalMember obj prop) = evaluateInScopedEnv (deref obj) (fromJust <$> lookupEnv prop)
address (Rval addr) = pure addr
rvalBox :: ( Members '[ Allocator location value
, State (Heap location (Cell location) value)
] effects
, Ord location
, Reducer value (Cell location value)
)
=> value
-> Evaluator location value effects (ValueRef location value)
rvalBox val = Rval <$> (box val)
-- | Value types, e.g. closures, which can root a set of addresses.
class ValueRoots location value where
-- | Compute the set of addresses rooted by a given value.

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

@ -1,8 +1,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}
module Data.Abstract.Address where
import Data.Abstract.FreeVariables
import Data.Abstract.Module (ModuleInfo)
import Data.Abstract.Name
import Data.Abstract.Package (PackageInfo)
import Data.Monoid (Last(..))
import Data.Semigroup.Reducer
@ -35,7 +35,7 @@ newtype Monovariant = Monovariant { unMonovariant :: Name }
deriving (Eq, Ord)
instance Show Monovariant where
showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unName . unMonovariant
showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unMonovariant
data Located location = Located

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

@ -1,9 +1,9 @@
{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, TypeFamilies #-}
module Data.Abstract.Cache where
import Control.Abstract.Evaluator
import Data.Abstract.Configuration
import Data.Abstract.Heap
import Data.Abstract.Ref
import Data.Map.Monoidal as Monoidal
import Data.Semilattice.Lower
import Prologue

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

@ -6,9 +6,9 @@ import Data.Abstract.Live
-- | A single point in a program’s execution.
data Configuration term location cell value = Configuration
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
, configurationRoots :: Live location value -- ^ The set of rooted addresses.
, configurationEnvironment :: Environment location value -- ^ The environment binding any free variables in 'configurationTerm'.
, configurationHeap :: Heap location cell value -- ^ The heap of values.
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
, configurationRoots :: Live location value -- ^ The set of rooted addresses.
, configurationEnvironment :: Environment location -- ^ The environment binding any free variables in 'configurationTerm'.
, configurationHeap :: Heap location cell value -- ^ The heap of values.
}
deriving (Eq, Ord, Show)

1
src/Data/Abstract/Declarations.hs
View File

@ -2,6 +2,7 @@
module Data.Abstract.Declarations where
import Data.Abstract.FreeVariables
import Data.Abstract.Name
import Data.Sum
import Data.Term
import Prologue

56
src/Data/Abstract/Environment.hs
View File

@ -19,8 +19,8 @@ module Data.Abstract.Environment
) where
import Data.Abstract.Address
import Data.Abstract.FreeVariables
import Data.Abstract.Live
import Data.Abstract.Name
import Data.Align
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
@ -35,36 +35,32 @@ import Prologue
-- | A LIFO stack of maps of names to addresses, representing a lexically-scoped evaluation environment.
-- All behaviors can be assumed to be frontmost-biased: looking up "a" will check the most specific
-- scope for "a", then the next, and so on.
newtype Environment location value = Environment { unEnvironment :: NonEmpty (Map.Map Name (Address location value)) }
newtype Environment location = Environment { unEnvironment :: NonEmpty (Map.Map Name location) }
deriving (Eq, Ord)
instance Eq location => Eq1 (Environment location) where liftEq eq (Environment a) (Environment b) = liftEq (liftEq (liftEq eq)) a b
instance Ord location => Ord1 (Environment location) where liftCompare compare (Environment a) (Environment b) = liftCompare (liftCompare (liftCompare compare)) a b
instance Show location => Show1 (Environment location) where liftShowsPrec _ _ = showsPrec
mergeEnvs :: Environment location value -> Environment location value -> Environment location value
mergeEnvs :: Environment location -> Environment location -> Environment location
mergeEnvs (Environment (a :| as)) (Environment (b :| bs)) =
Environment ((<>) a b :| alignWith (mergeThese (<>)) as bs)
emptyEnv :: Environment location value
emptyEnv :: Environment location
emptyEnv = Environment (lowerBound :| [])
-- | Make and enter a new empty scope in the given environment.
push :: Environment location value -> Environment location value
push :: Environment location -> Environment location
push (Environment (a :| as)) = Environment (mempty :| a : as)
-- | Remove the frontmost scope.
pop :: Environment location value -> Environment location value
pop :: Environment location -> Environment location
pop (Environment (_ :| [])) = emptyEnv
pop (Environment (_ :| a : as)) = Environment (a :| as)
-- | Drop all scopes save for the frontmost one.
head :: Environment location value -> Environment location value
head :: Environment location -> Environment location
head (Environment (a :| _)) = Environment (a :| [])
-- | Take the union of two environments. When duplicate keys are found in the
-- name to address map, the second definition wins.
mergeNewer :: Environment location value -> Environment location value -> Environment location value
mergeNewer :: Environment location -> Environment location -> Environment location
mergeNewer (Environment a) (Environment b) =
Environment (NonEmpty.fromList . reverse $ alignWith (mergeThese combine) (reverse as) (reverse bs))
where
@ -76,45 +72,45 @@ mergeNewer (Environment a) (Environment b) =
--
-- >>> pairs shadowed
-- [("foo",Precise 1)]
pairs :: Environment location value -> [(Name, Address location value)]
pairs = Map.toList . fold . unEnvironment
pairs :: Environment location -> [(Name, Address location value)]
pairs = map (second Address) . Map.toList . fold . unEnvironment
unpairs :: [(Name, Address location value)] -> Environment location value
unpairs = Environment . pure . Map.fromList
unpairs :: [(Name, Address location value)] -> Environment location
unpairs = Environment . pure . Map.fromList . map (second unAddress)
-- | Lookup a 'Name' in the environment.
--
-- >>> lookup (name "foo") shadowed
-- Just (Precise 1)
lookup :: Name -> Environment location value -> Maybe (Address location value)
lookup k = foldMapA (Map.lookup k) . unEnvironment
lookup :: Name -> Environment location -> Maybe (Address location value)
lookup k = fmap Address . foldMapA (Map.lookup k) . unEnvironment
-- | Insert a 'Name' in the environment.
insert :: Name -> Address location value -> Environment location value -> Environment location value
insert name address (Environment (a :| as)) = Environment (Map.insert name address a :| as)
insert :: Name -> Address location value -> Environment location -> Environment location
insert name (Address value) (Environment (a :| as)) = Environment (Map.insert name value a :| as)
-- | Remove a 'Name' from the environment.
--
-- >>> delete (name "foo") shadowed
-- Environment []
delete :: Name -> Environment location value -> Environment location value
delete :: Name -> Environment location -> Environment location
delete name = trim . Environment . fmap (Map.delete name) . unEnvironment
trim :: Environment location value -> Environment location value
trim :: Environment location -> Environment location
trim (Environment (a :| as)) = Environment (a :| filtered)
where filtered = filter (not . Map.null) as
bind :: Foldable t => t Name -> Environment location value -> Environment location value
bind :: Foldable t => t Name -> Environment location -> Environment location
bind names env = unpairs (mapMaybe lookupName (toList names))
where
lookupName name = (,) name <$> lookup name env
-- | Get all bound 'Name's in an environment.
names :: Environment location value -> [Name]
names :: Environment location -> [Name]
names = fmap fst . pairs
-- | Lookup and alias name-value bindings from an environment.
overwrite :: [(Name, Name)] -> Environment location value -> Environment location value
overwrite :: [(Name, Name)] -> Environment location -> Environment location
overwrite pairs env = unpairs $ mapMaybe lookupAndAlias pairs
where
lookupAndAlias (oldName, newName) = (,) newName <$> lookup oldName env
@ -122,14 +118,14 @@ overwrite pairs env = unpairs $ mapMaybe lookupAndAlias pairs
-- | Retrieve the 'Live' set of addresses to which the given free variable names are bound.
--
-- Unbound names are silently dropped.
roots :: (Ord location, Foldable t) => Environment location value -> t Name -> Live location value
roots :: (Ord location, Foldable t) => Environment location -> t Name -> Live location value
roots env = foldMap (maybe mempty liveSingleton . flip lookup env)
addresses :: Ord location => Environment location value -> Live location value
addresses :: Ord location => Environment location -> Live location value
addresses = fromAddresses . map snd . pairs
instance Lower (Environment location value) where lowerBound = emptyEnv
instance Lower (Environment location) where lowerBound = emptyEnv
instance Show location => Show (Environment location value) where
showsPrec d = showsUnaryWith showsPrec "Environment" d . map (first unName) . pairs
instance Show location => Show (Environment location) where
showsPrec d = showsUnaryWith showsPrec "Environment" d . pairs

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

@ -2,40 +2,38 @@
module Data.Abstract.Evaluatable
( module X
, Evaluatable(..)
, evaluatePackageWith
, isolate
, traceResolve
-- | Effects
, EvalError(..)
, throwEvalError
, runEvalError
, runEvalErrorWith
, Unspecialized(..)
, runUnspecialized
, runUnspecializedWith
, EvalError(..)
, runEvalError
, runEvalErrorWith
, rvalBox
, value
, address
, subtermValue
, subtermAddress
, evaluateInScopedEnv
, evaluatePackageWith
, throwEvalError
, traceResolve
, builtin
, isolate
, Modules
, Cell
) where
import Control.Abstract as X hiding (Goto(..), LoopControl(..), Modules(..), Return(..), TermEvaluator(..))
import Control.Abstract.Evaluator (LoopControl, Return(..))
import Control.Abstract.Goto (Goto(..))
import Control.Abstract.Modules (Modules(..))
import Control.Abstract.TermEvaluator (TermEvaluator(..))
import Data.Abstract.Address
import Control.Abstract
import Control.Abstract.Context as X
import Control.Abstract.Environment as X hiding (runEnvironmentError, runEnvironmentErrorWith)
import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn)
import Control.Abstract.Exports as X
import Control.Abstract.Heap as X hiding (AddressError(..), runAddressError, runAddressErrorWith)
import Control.Abstract.Modules as X (Modules, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve)
import Control.Abstract.Value as X
import Data.Abstract.Address as X
import Data.Abstract.Declarations as X
import Data.Abstract.Environment as X
import Data.Abstract.Exports as Exports
import Data.Abstract.FreeVariables as X
import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Name as X
import Data.Abstract.Package as Package
import Data.ByteString.Char8 (pack, unpack)
import Data.Abstract.Ref as X
import Data.Scientific (Scientific)
import Data.Semigroup.App
import Data.Semigroup.Foldable
@ -69,17 +67,17 @@ type EvaluatableConstraints location term value effects =
, Members '[ Allocator location value
, LoopControl location value
, Modules location value
, Reader (Environment location value)
, Reader (Environment location)
, Reader ModuleInfo
, Reader PackageInfo
, Reader Span
, Resumable (EnvironmentError value)
, Resumable (EvalError value)
, Resumable EvalError
, Resumable ResolutionError
, Resumable (Unspecialized value)
, Return location value
, State (Environment location value)
, State (Exports location value)
, State (Environment location)
, State (Exports location)
, State (Heap location (Cell location) value)
, Trace
] effects
@ -88,199 +86,6 @@ type EvaluatableConstraints location term value effects =
)
-- | The type of error thrown when failing to evaluate a term.
data EvalError value resume where
FreeVariablesError :: [Name] -> EvalError value Name
-- Indicates that our evaluator wasn't able to make sense of these literals.
IntegerFormatError :: ByteString -> EvalError value Integer
FloatFormatError :: ByteString -> EvalError value Scientific
RationalFormatError :: ByteString -> EvalError value Rational
DefaultExportError :: EvalError value ()
ExportError :: ModulePath -> Name -> EvalError value ()
EnvironmentLookupError :: value -> EvalError value value
runEvalError :: Effectful (m value) => m value (Resumable (EvalError value) ': effects) a -> m value effects (Either (SomeExc (EvalError value)) a)
runEvalError = runResumable
runEvalErrorWith :: Effectful (m value) => (forall resume . EvalError value resume -> m value effects resume) -> m value (Resumable (EvalError value) ': effects) a -> m value effects a
runEvalErrorWith = runResumableWith
-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
-- Throws an 'EnvironmentLookupError' if @scopedEnvTerm@ does not have an environment.
evaluateInScopedEnv :: ( AbstractValue location value effects
, Members '[ Resumable (EvalError value)
, Allocator location value
, State (Environment location value)
, State (Heap location (Cell location) value)
] effects
, Ord location
, Reducer value (Cell location value)
)
=> Evaluator location value effects value
-> Evaluator location value effects (Address location value)
-> Evaluator location value effects (Address location value)
evaluateInScopedEnv scopedEnvTerm term = do
value <- scopedEnvTerm
scopedEnv <- scopedEnvironment value
let mab x = localEnv (mergeEnvs x) term
maybe (box =<< throwEvalError (EnvironmentLookupError value)) mab scopedEnv
deriving instance Eq value => Eq (EvalError value resume)
deriving instance Show value => Show (EvalError value resume)
instance Show value => Show1 (EvalError value) where
liftShowsPrec _ _ = showsPrec
instance Eq term => Eq1 (EvalError term) where
liftEq _ (FreeVariablesError a) (FreeVariablesError b) = a == b
liftEq _ DefaultExportError DefaultExportError = True
liftEq _ (ExportError a b) (ExportError c d) = (a == c) && (b == d)
liftEq _ (IntegerFormatError a) (IntegerFormatError b) = a == b
liftEq _ (FloatFormatError a) (FloatFormatError b) = a == b
liftEq _ (RationalFormatError a) (RationalFormatError b) = a == b
liftEq _ (EnvironmentLookupError a) (EnvironmentLookupError b) = a == b
liftEq _ _ _ = False
throwEvalError :: Member (Resumable (EvalError value)) effects => EvalError value resume -> Evaluator location value effects resume
throwEvalError = throwResumable
data Unspecialized value b where
Unspecialized :: Prelude.String -> Unspecialized value value
instance Eq1 (Unspecialized value) where
liftEq _ (Unspecialized a) (Unspecialized b) = a == b
deriving instance Eq (Unspecialized value resume)
deriving instance Show (Unspecialized value resume)
instance Show1 (Unspecialized value) where
liftShowsPrec _ _ = showsPrec
-- | Evaluates a 'Value' returning the referenced value
value :: ( AbstractValue location value effects
, Members '[ Allocator location value
, Reader (Environment location value)
, Resumable (EnvironmentError value)
, Resumable (EvalError value)
, State (Environment location value)
, State (Heap location (Cell location) value)
] effects
, Ord location
, Reducer value (Cell location value)
)
=> ValueRef location value
-> Evaluator location value effects value
value (LvalLocal var) = variable var
value (LvalMember obj prop) = deref =<< evaluateInScopedEnv (deref obj) (fromJust <$> lookupEnv prop)
value (Rval val) = deref val
address :: ( AbstractValue location value effects
, Members '[ Allocator location value
, Reader (Environment location value)
, Resumable (EnvironmentError value)
, Resumable (EvalError value)
, State (Environment location value)
, State (Heap location (Cell location) value)
] effects
, Ord location
, Reducer value (Cell location value)
)
=> ValueRef location value
-> Evaluator location value effects (Address location value)
address (LvalLocal var) = fromJust <$> lookupEnv var
address (LvalMember obj prop) = evaluateInScopedEnv (deref obj) (fromJust <$> lookupEnv prop)
address (Rval addr) = pure addr
rvalBox :: ( Members '[ Allocator location value
, State (Heap location (Cell location) value)
] effects
, Ord location
, Reducer value (Cell location value)
)
=> value
-> Evaluator location value effects (ValueRef location value)
rvalBox val = Rval <$> (box val)
-- | Evaluates a 'Subterm' to its rval
subtermValue :: ( AbstractValue location value effects
, Members '[ Allocator location value
, Reader (Environment location value)
, Resumable (EnvironmentError value)
, Resumable (EvalError value)
, State (Environment location value)
, State (Heap location (Cell location) value)
] effects
, Ord location
, Reducer value (Cell location value)
)
=> Subterm term (Evaluator location value effects (ValueRef location value))
-> Evaluator location value effects value
subtermValue = value <=< subtermRef
subtermAddress :: ( AbstractValue location value effects
, Members '[ Allocator location value
, Reader (Environment location value)
, Resumable (EnvironmentError value)
, Resumable (EvalError value)
, State (Environment location value)
, State (Heap location (Cell location) value)
] effects
, Ord location
, Reducer value (Cell location value)
)
=> Subterm term (Evaluator location value effects (ValueRef location value))
-> Evaluator location value effects (Address location value)
subtermAddress = address <=< subtermRef
runUnspecialized :: Effectful (m value) => m value (Resumable (Unspecialized value) ': effects) a -> m value effects (Either (SomeExc (Unspecialized value)) a)
runUnspecialized = runResumable
runUnspecializedWith :: Effectful (m value) => (forall resume . Unspecialized value resume -> m value effects resume) -> m value (Resumable (Unspecialized value) ': effects) a -> m value effects a
runUnspecializedWith = runResumableWith
-- Instances
-- | If we can evaluate any syntax which can occur in a 'Sum', we can evaluate the 'Sum'.
instance Apply Evaluatable fs => Evaluatable (Sum fs) where
eval = apply @Evaluatable eval
-- | Evaluating a 'TermF' ignores its annotation, evaluating the underlying syntax.
instance Evaluatable s => Evaluatable (TermF s a) where
eval = eval . termFOut
--- | '[]' is treated as an imperative sequence of statements/declarations s.t.:
---
--- 1. Each statement’s effects on the store are accumulated;
--- 2. Each statement can affect the environment of later statements (e.g. by 'modify'-ing the environment); and
--- 3. Only the last statement’s return value is returned.
instance Evaluatable [] where
-- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists.
eval = maybe (rvalBox =<< unit) (runApp . foldMap1 (App . subtermRef)) . nonEmpty
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator location value effects ()
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
builtin :: ( HasCallStack
, Members '[ Allocator location value
, Reader (Environment location value)
, Reader ModuleInfo
, Reader Span
, State (Environment location value)
, State (Heap location (Cell location) value)
] effects
, Ord location
, Reducer value (Cell location value)
)
=> String
-> Evaluator location value effects value
-> Evaluator location value effects ()
builtin n def = withCurrentCallStack callStack $ do
let name = X.name ("__semantic_" <> pack n)
addr <- alloc name
modifyEnv (X.insert name addr)
def >>= assign addr
-- | Evaluate a given package.
evaluatePackageWith :: forall location term value inner inner' outer
-- 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? If not, can we factor this effect list out?
@ -289,13 +94,13 @@ evaluatePackageWith :: forall location term value inner inner' outer
, EvaluatableConstraints location term value inner
, Members '[ Fail
, Fresh
, Reader (Environment location value)
, Reader (Environment location)
, Resumable (AddressError location value)
, Resumable (LoadError location value)
, State (Environment location value)
, State (Exports location value)
, State (Environment location)
, State (Exports location)
, State (Heap location (Cell location) value)
, State (ModuleTable (Maybe (Environment location value, Address location value)))
, State (ModuleTable (Maybe (Environment location, Address location value)))
, Trace
] outer
, Recursive term
@ -339,9 +144,7 @@ evaluatePackageWith analyzeModule analyzeTerm package
maybe v ((`call` []) <=< variable) sym
evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule)) $ do
_ <- runInModule moduleInfoFromCallStack . TermEvaluator $ do
builtin "print" (closure ["s"] lowerBound (variable "s" >>= asString >>= trace . unpack >> unit))
box =<< unit
_ <- runInModule moduleInfoFromCallStack (TermEvaluator (defineBuiltins *> (box =<< unit)))
fst <$> evalModule prelude
withPrelude Nothing a = a
@ -377,5 +180,84 @@ newtype Gotos location value outer = Gotos {
-- | Isolate the given action with an empty global environment and exports.
isolate :: Members '[State (Environment location value), State (Exports location value)] effects => Evaluator location value effects a -> Evaluator location value effects a
isolate :: Members '[State (Environment location), State (Exports location)] effects => Evaluator location value effects a -> Evaluator location value effects a
isolate = withEnv lowerBound . withExports lowerBound
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator location value effects ()
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
-- Effects
-- | The type of error thrown when failing to evaluate a term.
data EvalError return where
FreeVariablesError :: [Name] -> EvalError Name
-- Indicates that our evaluator wasn't able to make sense of these literals.
IntegerFormatError :: ByteString -> EvalError Integer
FloatFormatError :: ByteString -> EvalError Scientific
RationalFormatError :: ByteString -> EvalError Rational
DefaultExportError :: EvalError ()
ExportError :: ModulePath -> Name -> EvalError ()
deriving instance Eq (EvalError return)
deriving instance Show (EvalError return)
instance Eq1 EvalError where
liftEq _ (FreeVariablesError a) (FreeVariablesError b) = a == b
liftEq _ DefaultExportError DefaultExportError = True
liftEq _ (ExportError a b) (ExportError c d) = (a == c) && (b == d)
liftEq _ (IntegerFormatError a) (IntegerFormatError b) = a == b
liftEq _ (FloatFormatError a) (FloatFormatError b) = a == b
liftEq _ (RationalFormatError a) (RationalFormatError b) = a == b
liftEq _ _ _ = False
instance Show1 EvalError where
liftShowsPrec _ _ = showsPrec
throwEvalError :: (Effectful m, Member (Resumable EvalError) effects) => EvalError resume -> m effects resume
throwEvalError = throwResumable
runEvalError :: Effectful m => m (Resumable EvalError ': effects) a -> m effects (Either (SomeExc EvalError) a)
runEvalError = runResumable
runEvalErrorWith :: Effectful m => (forall resume . EvalError resume -> m effects resume) -> m (Resumable EvalError ': effects) a -> m effects a
runEvalErrorWith = runResumableWith
data Unspecialized a b where
Unspecialized :: String -> Unspecialized value (ValueRef value)
deriving instance Eq (Unspecialized a b)
deriving instance Show (Unspecialized a b)
instance Eq1 (Unspecialized a) where
liftEq _ (Unspecialized a) (Unspecialized b) = a == b
instance Show1 (Unspecialized a) where
liftShowsPrec _ _ = showsPrec
runUnspecialized :: Effectful (m value) => m value (Resumable (Unspecialized value) ': effects) a -> m value effects (Either (SomeExc (Unspecialized value)) a)
runUnspecialized = runResumable
runUnspecializedWith :: Effectful (m value) => (forall resume . Unspecialized value resume -> m value effects resume) -> m value (Resumable (Unspecialized value) ': effects) a -> m value effects a
runUnspecializedWith = runResumableWith
-- Instances
-- | If we can evaluate any syntax which can occur in a 'Sum', we can evaluate the 'Sum'.
instance Apply Evaluatable fs => Evaluatable (Sum fs) where
eval = apply @Evaluatable eval
-- | Evaluating a 'TermF' ignores its annotation, evaluating the underlying syntax.
instance Evaluatable s => Evaluatable (TermF s a) where
eval = eval . termFOut
--- | '[]' is treated as an imperative sequence of statements/declarations s.t.:
---
--- 1. Each statement’s effects on the store are accumulated;
--- 2. Each statement can affect the environment of later statements (e.g. by 'modify'-ing the environment); and
--- 3. Only the last statement’s return value is returned.
instance Evaluatable [] where
-- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists.
eval = maybe (Rval <$> unit) (runApp . foldMap1 (App . subtermRef)) . nonEmpty

21
src/Data/Abstract/Exports.hs
View File

@ -11,30 +11,27 @@ import Prelude hiding (null)
import Prologue hiding (null)
import Data.Abstract.Address
import Data.Abstract.Environment (Environment, unpairs)
import Data.Abstract.FreeVariables
import Data.Abstract.Name
import qualified Data.Map as Map
import Data.Semilattice.Lower
-- | A map of export names to an alias & address tuple.
newtype Exports location value = Exports { unExports :: Map.Map Name (Name, Maybe (Address location value)) }
newtype Exports location = Exports { unExports :: Map.Map Name (Name, Maybe location) }
deriving (Eq, Lower, Monoid, Ord, Semigroup)
null :: Exports location value -> Bool
null :: Exports location -> Bool
null = Map.null . unExports
toEnvironment :: Exports location value -> Environment location value
toEnvironment exports = unpairs (mapMaybe collectExport (toList (unExports exports)))
where
collectExport (_, Nothing) = Nothing
collectExport (n, Just value) = Just (n, value)
toEnvironment :: Exports location -> Environment location
toEnvironment exports = unpairs (mapMaybe (traverse (fmap Address)) (toList (unExports exports)))
insert :: Name -> Name -> Maybe (Address location value) -> Exports location value -> Exports location value
insert name alias address = Exports . Map.insert name (alias, address) . unExports
insert :: Name -> Name -> Maybe (Address location value) -> Exports location -> Exports location
insert name alias address = Exports . Map.insert name (alias, unAddress <$> address) . unExports
-- TODO: Should we filter for duplicates here?
aliases :: Exports location value -> [(Name, Name)]
aliases :: Exports location -> [(Name, Name)]
aliases = Map.toList . fmap fst . unExports
instance Show location => Show (Exports location value) where
instance Show location => Show (Exports location) where
showsPrec d = showsUnaryWith showsPrec "Exports" d . Map.toList . unExports

16
src/Data/Abstract/FreeVariables.hs
View File

@ -1,25 +1,11 @@
{-# LANGUAGE DefaultSignatures, GeneralizedNewtypeDeriving, UndecidableInstances #-}
module Data.Abstract.FreeVariables where
import qualified Data.ByteString.Char8 as BC
import Data.String
import Data.Abstract.Name
import Data.Sum
import Data.Term
import Prologue
-- | The type of variable names.
newtype Name = Name { unName :: ByteString }
deriving (Eq, Hashable, Ord)
name :: ByteString -> Name
name = Name
instance IsString Name where
fromString = Name . BC.pack
instance Show Name where showsPrec d (Name str) = showsPrec d str
-- | Types which can contain unbound variables.
class FreeVariables term where
-- | The set of free variables in the given value.

55
src/Data/Abstract/Name.hs Normal file
View File

@ -0,0 +1,55 @@
module Data.Abstract.Name
( Name
-- * Constructors
, name
, nameI
, unName
) where
import qualified Data.ByteString.Char8 as BC
import qualified Data.Char as Char
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.String
import Prologue
-- | The type of variable names.
data Name
= Name ByteString
| I Int
deriving (Eq, Ord)
-- | Construct a 'Name' from a 'ByteString'.
name :: ByteString -> Name
name = Name
-- | Construct a 'Name' from an 'Int'. This is suitable for automatic generation, e.g. using a Fresh effect, but should not be used for human-generated names.
nameI :: Int -> Name
nameI = I
-- | Extract a human-readable 'ByteString' from a 'Name'.
unName :: Name -> ByteString
unName (Name name) = name
unName (I i) = Text.encodeUtf8 . Text.pack $ '_' : (alphabet !! a) : replicate n 'ʹ'
where alphabet = ['a'..'z']
(n, a) = i `divMod` length alphabet
instance IsString Name where
fromString = Name . BC.pack
-- $
-- >>> I 0
-- "_a"
-- >>> I 26
-- "_aʹ"
instance Show Name where
showsPrec _ = prettyShowString . Text.unpack . Text.decodeUtf8 . unName
where prettyShowString str = showChar '"' . foldr ((.) . prettyChar) id str . showChar '"'
prettyChar c
| c `elem` ['\\', '\"'] = Char.showLitChar c
| Char.isPrint c = showChar c
| otherwise = Char.showLitChar c
instance Hashable Name where
hashWithSalt salt (Name name) = hashWithSalt salt name
hashWithSalt salt (I i) = salt `hashWithSalt` (1 :: Int) `hashWithSalt` i

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

@ -1,10 +1,10 @@
{-# LANGUAGE TupleSections #-}
module Data.Abstract.Package where
import Data.Abstract.FreeVariables
import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import qualified Data.Map as Map
import Data.Abstract.Name
type PackageName = Name

15
src/Data/Abstract/Ref.hs Normal file
View File

@ -0,0 +1,15 @@
{-# LANGUAGE GADTs #-}
module Data.Abstract.Ref where
import Data.Abstract.Address
import Data.Abstract.Name
-- | 'ValueRef' is the type subterms evaluate to and can represent either values directly ('Rval'), or references to values (lvals - such as local variables or object members)
data ValueRef location value where
-- | A value.
Rval :: Address location value -> ValueRef location value
-- | A local variable. No environment is attached—it’s assumed that 'LvalLocal' will be evaluated in the same scope it was constructed in.
LvalLocal :: Name -> ValueRef location value
-- | An object member.
LvalMember :: Address location value -> Name -> ValueRef location value
deriving (Eq, Ord, Show)

48
src/Data/Abstract/Type.hs
View File

@ -9,7 +9,6 @@ module Data.Abstract.Type
import Control.Abstract
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Data.Semigroup.Foldable (foldMap1)
import Data.Semigroup.Reducer (Reducer)
import Prologue hiding (TypeError)
@ -102,30 +101,51 @@ instance Ord location => ValueRoots location Type where
instance AbstractHole Type where
hole = Hole
-- | Discard the value arguments (if any), constructing a 'Type' instead.
instance ( Members '[ Allocator location Type
, Fresh
, NonDet
, Reader (Environment location Type)
, Resumable (AddressError location Type)
, Resumable (EvalError Type)
, Reader (Environment location)
, Resumable TypeError
, Return location Type
, State (Environment location Type)
, State (Environment location)
, State (Heap location (Cell location) Type)
] effects
, Ord location
, Reducer Type (Cell location Type)
)
=> AbstractValue location Type effects where
=> AbstractFunction location Type effects where
closure names _ body = do
(env, tvars) <- foldr (\ name rest -> do
a <- alloc name
tvar <- Var <$> fresh
assign a tvar
bimap (Env.insert name a) (tvar :) <$> rest) (pure (emptyEnv, [])) names
(zeroOrMoreProduct tvars :->) <$> localEnv (mergeEnvs env) (body `catchReturn` \ (Return value) -> deref value)
((zeroOrMoreProduct tvars :->) <$> localEnv (mergeEnvs env) (body `catchReturn` \ (Return value) -> deref value))
call op params = do
tvar <- fresh
paramTypes <- sequenceA params
let needed = zeroOrMoreProduct paramTypes :-> Var tvar
unified <- op `unify` needed
case unified of
_ :-> ret -> pure ret
gotten -> throwResumable (UnificationError needed gotten)
-- | Discard the value arguments (if any), constructing a 'Type' instead.
instance ( Members '[ Allocator location Type
, Fresh
, NonDet
, Reader (Environment location)
, Resumable TypeError
, Return location Type
, State (Environment location)
, State (Heap location (Cell location) Type)
] effects
, Ord location
, Reducer Type (Cell location Type)
)
=> AbstractValue location Type effects where
unit = pure Unit
integer _ = pure Int
boolean _ = pure Bool
@ -152,9 +172,6 @@ instance ( Members '[ Allocator location Type
t1 <- fresh
t2 <- fresh
unify t (Var t1 :* Var t2) $> (Var t1, Var t2)
asBool t = unify t Bool *> (pure True <|> pure False)
isHole ty = pure (ty == Hole)
index arr sub = do
_ <- unify sub Int
@ -181,13 +198,4 @@ instance ( Members '[ Allocator location Type
(Int, Float) -> pure Int
_ -> unify left right $> Bool
call op params = do
tvar <- fresh
paramTypes <- sequenceA $ map (>>= deref) params
let needed = zeroOrMoreProduct paramTypes :-> Var tvar
unified <- op `unify` needed
case unified of
_ :-> ret -> box ret
gotten -> box =<< throwResumable (UnificationError needed gotten)
loop f = f empty

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

@ -4,7 +4,7 @@ module Data.Abstract.Value where
import Control.Abstract
import Data.Abstract.Environment (Environment, emptyEnv, mergeEnvs)
import qualified Data.Abstract.Environment as Env
import Data.Abstract.FreeVariables
import Data.Abstract.Name
import qualified Data.Abstract.Number as Number
import Data.List (genericIndex, genericLength)
import Data.Scientific (Scientific)
@ -57,7 +57,7 @@ prjPair = bitraverse prjValue prjValue
-- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union.
-- | A function value consisting of a package & module info, a list of parameter 'Name's, a 'Label' to jump to the body of the function, and an 'Environment' of bindings captured by the body.
data Closure location value = Closure PackageInfo ModuleInfo [Name] Label (Environment location value)
data Closure location value = Closure PackageInfo ModuleInfo [Name] Label (Environment location)
deriving (Eq, Generic1, Ord, Show)
instance Eq location => Eq1 (Closure location) where liftEq = genericLiftEq
@ -80,7 +80,7 @@ instance Ord1 Hole where liftCompare = genericLiftCompare
instance Show1 Hole where liftShowsPrec = genericLiftShowsPrec
-- | Boolean values.
newtype Boolean value = Boolean Prelude.Bool
newtype Boolean value = Boolean { getBoolean :: Bool }
deriving (Eq, Generic1, Ord, Show)
instance Eq1 Boolean where liftEq = genericLiftEq
@ -151,7 +151,7 @@ instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
-- but for the time being we're pretending all languages have prototypical inheritance.
data Class location value = Class
{ _className :: Name
, _classScope :: Environment location value
, _classScope :: Environment location
} deriving (Eq, Generic1, Ord, Show)
instance Eq location => Eq1 (Class location) where liftEq = genericLiftEq
@ -160,7 +160,7 @@ instance Show location => Show1 (Class location) where liftShowsPrec = genericLi
data Namespace location value = Namespace
{ namespaceName :: Name
, namespaceScope :: Environment location value
, namespaceScope :: Environment location
} deriving (Eq, Generic1, Ord, Show)
instance Eq location => Eq1 (Namespace location) where liftEq = genericLiftEq
@ -204,16 +204,51 @@ instance Ord location => ValueRoots location (Value location) where
instance AbstractHole (Value location) where
hole = injValue Hole
-- | Construct a 'Value' wrapping the value arguments (if any).
instance ( Members '[ Allocator location (Value location)
, Fail
, LoopControl location (Value location)
, Reader (Environment location (Value location))
, Reader (Environment location)
, Reader ModuleInfo
, Reader PackageInfo
, Resumable (ValueError location)
, Return location (Value location)
, State (Environment location (Value location))
, State (Environment location)
, State (Heap location (Cell location) (Value location))
] effects
, Ord location
, Reducer (Value location) (Cell location (Value location))
, Show location
)
=> AbstractFunction location (Value location) (Goto effects location (Value location) ': effects) where
closure parameters freeVariables body = do
packageInfo <- currentPackage
moduleInfo <- currentModule
l <- label body
env <- getEnv
let cls = injValue . Closure packageInfo moduleInfo parameters l . Env.bind (foldr Set.delete freeVariables parameters) $ env
box cls
call op params = do
case prjValue op of
Just (Closure packageInfo moduleInfo names label env) -> do
body <- goto label
-- Evaluate the bindings and body with the closure’s package/module info in scope in order to
-- charge them to the closure's origin.
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
bindings <- foldr (\ (name, param) rest -> do
a <- param
Env.insert name a <$> rest) (pure env) (zip names params)
localEnv (mergeEnvs bindings) (body `catchReturn` \ (Return value) -> pure value)
Nothing -> box =<< throwValueError (CallError op)
-- | Construct a 'Value' wrapping the value arguments (if any).
instance ( Members '[ Allocator location (Value location)
, LoopControl location (Value location)
, Reader (Environment location)
, Reader ModuleInfo
, Reader PackageInfo
, Resumable (ValueError location)
, Return location (Value location)
, State (Environment location)
, State (Heap location (Cell location) (Value location))
] effects
, Ord location
@ -265,18 +300,8 @@ instance ( Members '[ Allocator location (Value location)
| otherwise = throwValueError $ StringError v
ifthenelse cond if' else' = do
isHole <- isHole cond
if isHole then
pure hole
else do
bool <- asBool cond
if bool then if' else else'
asBool val
| Just (Boolean b) <- prjValue val = pure b
| otherwise = throwValueError $ BoolError val
isHole val = pure (prjValue val == Just Hole)
bool <- maybe (throwValueError (BoolError cond)) (pure . getBoolean) (prjValue cond)
if bool then if' else else'
index = go where
tryIdx list ii
@ -348,25 +373,6 @@ instance ( Members '[ Allocator location (Value location)
| otherwise = throwValueError (Bitwise2Error left right)
where pair = (left, right)
closure parameters freeVariables body = do
packageInfo <- currentPackage
moduleInfo <- currentModule
l <- label (body >>= box)
injValue . Closure packageInfo moduleInfo parameters l . Env.bind (foldr Set.delete freeVariables parameters) <$> getEnv
call op params = do
case prjValue op of
Just (Closure packageInfo moduleInfo names label env) -> do
body <- goto label
-- Evaluate the bindings and body with the closure’s package/module info in scope in order to
-- charge them to the closure's origin.
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
bindings <- foldr (\ (name, param) rest -> do
a <- param
Env.insert name a <$> rest) (pure env) (zip names params)
localEnv (mergeEnvs bindings) (body `catchReturn` \ (Return value) -> pure value)
Nothing -> box =<< throwValueError (CallError op)
loop x = catchLoopControl (fix x) (\ control -> case control of
Break value -> deref value
-- FIXME: Figure out how to deal with this. Ruby treats this as the result of the current block iteration, while PHP specifies a breakout level and TypeScript appears to take a label.
@ -378,7 +384,7 @@ data ValueError location resume where
StringError :: Value location -> ValueError location ByteString
BoolError :: Value location -> ValueError location Bool
IndexError :: Value location -> Value location -> ValueError location (Value location)
NamespaceError :: Prelude.String -> ValueError location (Environment location (Value location))
NamespaceError :: Prelude.String -> ValueError location (Environment location)
CallError :: Value location -> ValueError location (Value location)
NumericError :: Value location -> ValueError location (Value location)
Numeric2Error :: Value location -> Value location -> ValueError location (Value location)

3
src/Data/Language.hs
View File

@ -7,6 +7,7 @@ import Data.Aeson
-- | A programming language.
data Language
= Go
| Haskell
| JavaScript
| JSON
| JSX
@ -21,6 +22,7 @@ data Language
languageForType :: String -> Maybe Language
languageForType mediaType = case mediaType of
".json" -> Just JSON
".hs" -> Just Haskell
".md" -> Just Markdown
".rb" -> Just Ruby
".go" -> Just Go
@ -36,6 +38,7 @@ languageForType mediaType = case mediaType of
extensionsForLanguage :: Language -> [String]
extensionsForLanguage language = case language of
Go -> [".go"]
Haskell -> [".hs"]
JavaScript -> [".js"]
PHP -> [".php"]
Python -> [".py"]

1
src/Data/Options.hs Normal file
View File

@ -0,0 +1 @@
module Data.Options where

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

@ -29,6 +29,7 @@ data Comparison a
| GreaterThan !a !a
| GreaterThanEqual !a !a
| Equal !a !a
| StrictEqual !a !a
| Comparison !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
@ -45,7 +46,10 @@ instance Evaluatable Comparison where
(LessThanEqual a b) -> liftComparison (Concrete (<=)) a b
(GreaterThan a b) -> liftComparison (Concrete (>)) a b
(GreaterThanEqual a b) -> liftComparison (Concrete (>=)) a b
-- TODO: in PHP and JavaScript, the equals operator performs type coercion.
-- We need some mechanism to customize this behavior per-language.
(Equal a b) -> liftComparison (Concrete (==)) a b
(StrictEqual a b) -> liftComparison (Concrete (==)) a b
(Comparison a b) -> liftComparison Generalized a b
-- | Binary arithmetic operators.

1
src/Data/Syntax/Statement.hs
View File

@ -1,7 +1,6 @@
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, ViewPatterns #-}
module Data.Syntax.Statement where
import Control.Abstract.Evaluator (ValueRef(..))
import qualified Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Data.ByteString.Char8 (unpack)

2
src/Language/Go/Assignment.hs
View File

@ -7,7 +7,7 @@ module Language.Go.Assignment
) where
import Assigning.Assignment hiding (Assignment, Error)
import Data.Abstract.FreeVariables (name)
import Data.Abstract.Name (name)
import Data.Record
import Data.Syntax (contextualize, emptyTerm, parseError, handleError, infixContext, makeTerm, makeTerm', makeTerm'', makeTerm1)
import Language.Go.Grammar as Grammar

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

@ -1,8 +1,7 @@
{-# LANGUAGE DeriveAnyClass #-}
module Language.Go.Syntax where
import Data.Abstract.Evaluatable hiding (Label)
import Data.Abstract.FreeVariables (Name (..), name)
import Data.Abstract.Evaluatable
import Data.Abstract.Module
import qualified Data.Abstract.Package as Package
import Data.Abstract.Path

106
src/Language/Haskell/Assignment.hs Normal file
View File

@ -0,0 +1,106 @@
{-# LANGUAGE DataKinds, RankNTypes, TypeOperators #-}
module Language.Haskell.Assignment
( assignment
, Syntax
, Grammar
, Term
) where
import Assigning.Assignment hiding (Assignment, Error)
import Data.Record
import Data.Sum
import Data.Syntax (emptyTerm, handleError, parseError, makeTerm, makeTerm'', contextualize, postContextualize)
import Language.Haskell.Grammar as Grammar
import qualified Assigning.Assignment as Assignment
import qualified Data.Abstract.Name as Name
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Comment as Comment
import qualified Data.Syntax.Declaration as Declaration
import qualified Data.Syntax.Literal as Literal
import qualified Data.Term as Term
import qualified Language.Haskell.Syntax as Syntax
import Prologue
type Syntax = '[
Comment.Comment
, Declaration.Function
, Literal.Float
, Literal.Integer
, Syntax.Context
, Syntax.Empty
, Syntax.Error
, Syntax.Identifier
, Syntax.Module
, []
]
type Term = Term.Term (Sum Syntax) (Record Location)
type Assignment = Assignment' Term
type Assignment' a = HasCallStack => Assignment.Assignment [] Grammar a
assignment :: Assignment
assignment = handleError $ module' <|> parseError
module' :: Assignment
module' = makeTerm
<$> symbol Module
<*> children (Syntax.Module <$> (moduleIdentifier <|> emptyTerm) <*> pure [] <*> (where' <|> expressions <|> emptyTerm))
expressions :: Assignment
expressions = makeTerm'' <$> location <*> many expression
expression :: Assignment
expression = term (handleError (choice expressionChoices))
expressionChoices :: [Assignment.Assignment [] Grammar Term]
expressionChoices = [
comment
, constructorIdentifier
, float
, functionDeclaration
, integer
, moduleIdentifier
, variableIdentifier
, where'
]
term :: Assignment -> Assignment
term term = contextualize comment (postContextualize comment term)
comment :: Assignment
comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source)
variableIdentifier :: Assignment
variableIdentifier = makeTerm <$> symbol VariableIdentifier <*> (Syntax.Identifier . Name.name <$> source)
constructorIdentifier :: Assignment
constructorIdentifier = makeTerm <$> symbol ConstructorIdentifier <*> (Syntax.Identifier . Name.name <$> source)
moduleIdentifier :: Assignment
moduleIdentifier = makeTerm <$> symbol ModuleIdentifier <*> (Syntax.Identifier . Name.name <$> source)
where' :: Assignment
where' = makeTerm <$> (symbol Where <|> symbol Where') <*> children (many expression)
functionBody :: Assignment
functionBody = makeTerm <$> symbol FunctionBody <*> children (many expression)
functionDeclaration :: Assignment
functionDeclaration = makeTerm
<$> symbol FunctionDeclaration
<*> children (Declaration.Function
<$> pure []
<*> variableIdentifier
<*> (manyTermsTill expression (symbol FunctionBody) <|> pure [])
<*> functionBody)
integer :: Assignment
integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source)
float :: Assignment
float = makeTerm <$> symbol Float <*> (Literal.Float <$> source)
-- | Match a series of terms or comments until a delimiter is matched.
manyTermsTill :: Assignment.Assignment [] Grammar Term -> Assignment.Assignment [] Grammar b -> Assignment.Assignment [] Grammar [Term]
manyTermsTill step = manyTill (step <|> comment)

13
src/Language/Haskell/Grammar.hs Normal file
View File

@ -0,0 +1,13 @@
{-# LANGUAGE TemplateHaskell #-}
module Language.Haskell.Grammar where
import Language.Haskell.TH
import TreeSitter.Language
import TreeSitter.Haskell
-- Regenerate template haskell code when these files change:
addDependentFileRelative "../../../vendor/haskell-tree-sitter/languages/haskell/vendor/tree-sitter-haskell/src/parser.c"
-- | Statically-known rules corresponding to symbols in the grammar.
-- v2 - bump this to regenerate
mkSymbolDatatype (mkName "Grammar") tree_sitter_haskell

22
src/Language/Haskell/Syntax.hs Normal file
View File

@ -0,0 +1,22 @@
{-# LANGUAGE DeriveAnyClass #-}
module Language.Haskell.Syntax where
import Data.Abstract.Evaluatable
import Data.JSON.Fields
import Diffing.Algorithm
import Prelude
import Prologue
data Module a = Module { moduleIdentifier :: !a
, moduleExports :: ![a]
, moduleStatements :: !a
}
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Module where liftEq = genericLiftEq
instance Ord1 Module where liftCompare = genericLiftCompare
instance Show1 Module where liftShowsPrec = genericLiftShowsPrec
instance ToJSONFields1 Module
instance Evaluatable Module where

60
src/Language/PHP/Assignment.hs
View File

@ -12,7 +12,7 @@ import Data.Sum
import Data.Syntax (emptyTerm, handleError, parseError, infixContext, makeTerm, makeTerm', makeTerm1, contextualize, postContextualize)
import Language.PHP.Grammar as Grammar
import qualified Assigning.Assignment as Assignment
import qualified Data.Abstract.FreeVariables as FV
import qualified Data.Abstract.Name as Name
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Comment as Comment
@ -234,30 +234,32 @@ augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpressi
binaryExpression :: Assignment
binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm expression (term (expression <|> classTypeDesignator))
[ (inject .) . Expression.And <$ symbol AnonAnd
, (inject .) . Expression.Or <$ symbol AnonOr
, (inject .) . Expression.XOr <$ symbol AnonXor
, (inject .) . Expression.Or <$ symbol AnonPipePipe
, (inject .) . Expression.And <$ symbol AnonAmpersandAmpersand
, (inject .) . Expression.BOr <$ symbol AnonPipe
, (inject .) . Expression.BXOr <$ symbol AnonCaret
, (inject .) . Expression.BAnd <$ symbol AnonAmpersand
, (inject .) . Expression.Or <$ symbol AnonQuestionQuestion -- Not sure if this is right.
, (inject .) . Expression.Equal <$ (symbol AnonEqualEqual <|> symbol AnonEqualEqualEqual)
, (inject .) . invert Expression.Equal <$ (symbol AnonBangEqual <|> symbol AnonLAngleRAngle <|> symbol AnonBangEqualEqual)
, (inject .) . Expression.LessThan <$ symbol AnonLAngle
, (inject .) . Expression.GreaterThan <$ symbol AnonRAngle
, (inject .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual
, (inject .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual
, (inject .) . Expression.Comparison <$ symbol AnonLAngleEqualRAngle
, (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle
, (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle
, (inject .) . Expression.Plus <$ symbol AnonPlus
, (inject .) . Expression.Minus <$ symbol AnonMinus
, (inject .) . Expression.Times <$ (symbol AnonStar <|> symbol AnonDot)
, (inject .) . Expression.DividedBy <$ symbol AnonSlash
, (inject .) . Expression.Modulo <$ symbol AnonPercent
, (inject .) . Expression.InstanceOf <$ symbol AnonInstanceof
[ (inject .) . Expression.And <$ symbol AnonAnd
, (inject .) . Expression.Or <$ symbol AnonOr
, (inject .) . Expression.XOr <$ symbol AnonXor
, (inject .) . Expression.Or <$ symbol AnonPipePipe
, (inject .) . Expression.And <$ symbol AnonAmpersandAmpersand
, (inject .) . Expression.BOr <$ symbol AnonPipe
, (inject .) . Expression.BXOr <$ symbol AnonCaret
, (inject .) . Expression.BAnd <$ symbol AnonAmpersand
, (inject .) . Expression.Or <$ symbol AnonQuestionQuestion -- Not sure if this is right.
, (inject .) . Expression.Equal <$ symbol AnonEqualEqual
, (inject .) . Expression.StrictEqual <$ symbol AnonEqualEqualEqual
, (inject .) . invert Expression.Equal <$ (symbol AnonBangEqual <|> symbol AnonLAngleRAngle <|> symbol AnonBangEqualEqual)
, (inject .) . invert Expression.StrictEqual <$ symbol AnonBangEqualEqual
, (inject .) . Expression.LessThan <$ symbol AnonLAngle
, (inject .) . Expression.GreaterThan <$ symbol AnonRAngle
, (inject .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual
, (inject .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual
, (inject .) . Expression.Comparison <$ symbol AnonLAngleEqualRAngle
, (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle
, (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle
, (inject .) . Expression.Plus <$ symbol AnonPlus
, (inject .) . Expression.Minus <$ symbol AnonMinus
, (inject .) . Expression.Times <$ (symbol AnonStar <|> symbol AnonDot)
, (inject .) . Expression.DividedBy <$ symbol AnonSlash
, (inject .) . Expression.Modulo <$ symbol AnonPercent
, (inject .) . Expression.InstanceOf <$ symbol AnonInstanceof
]) where invert cons a b = Expression.Not (makeTerm1 (cons a b))
conditionalExpression :: Assignment
@ -443,7 +445,7 @@ classConstDeclaration :: Assignment
classConstDeclaration = makeTerm <$> symbol ClassConstDeclaration <*> children (Syntax.ClassConstDeclaration <$> (term visibilityModifier <|> emptyTerm) <*> manyTerm constElement)
visibilityModifier :: Assignment
visibilityModifier = makeTerm <$> symbol VisibilityModifier <*> (Syntax.Identifier . FV.name <$> source)
visibilityModifier = makeTerm <$> symbol VisibilityModifier <*> (Syntax.Identifier . Name.name <$> source)
constElement :: Assignment
constElement = makeTerm <$> symbol ConstElement <*> children (Statement.Assignment [] <$> term name <*> term expression)
@ -649,7 +651,7 @@ propertyDeclaration :: Assignment
propertyDeclaration = makeTerm <$> symbol PropertyDeclaration <*> children (Syntax.PropertyDeclaration <$> term propertyModifier <*> someTerm propertyElement)
propertyModifier :: Assignment
propertyModifier = (makeTerm <$> symbol PropertyModifier <*> children (Syntax.PropertyModifier <$> (term visibilityModifier <|> emptyTerm) <*> (term staticModifier <|> emptyTerm))) <|> term (makeTerm <$> symbol PropertyModifier <*> (Syntax.Identifier . FV.name <$> source))
propertyModifier = (makeTerm <$> symbol PropertyModifier <*> children (Syntax.PropertyModifier <$> (term visibilityModifier <|> emptyTerm) <*> (term staticModifier <|> emptyTerm))) <|> term (makeTerm <$> symbol PropertyModifier <*> (Syntax.Identifier . Name.name <$> source))
propertyElement :: Assignment
propertyElement = makeTerm <$> symbol PropertyElement <*> children (Statement.Assignment [] <$> term variableName <*> term propertyInitializer) <|> (symbol PropertyElement *> children (term variableName))
@ -710,7 +712,7 @@ namespaceAliasingClause = makeTerm <$> symbol NamespaceAliasingClause <*> childr
-- | TODO Do something better than Identifier
namespaceFunctionOrConst :: Assignment
namespaceFunctionOrConst = makeTerm <$> symbol NamespaceFunctionOrConst <*> (Syntax.Identifier . FV.name <$> source)
namespaceFunctionOrConst = makeTerm <$> symbol NamespaceFunctionOrConst <*> (Syntax.Identifier . Name.name <$> source)
globalDeclaration :: Assignment
globalDeclaration = makeTerm <$> symbol GlobalDeclaration <*> children (Syntax.GlobalDeclaration <$> manyTerm simpleVariable')
@ -746,7 +748,7 @@ variableName :: Assignment
variableName = makeTerm <$> symbol VariableName <*> children (Syntax.VariableName <$> term name)
name :: Assignment
name = makeTerm <$> (symbol Name <|> symbol Name') <*> (Syntax.Identifier . FV.name <$> source)
name = makeTerm <$> (symbol Name <|> symbol Name') <*> (Syntax.Identifier . Name.name <$> source)
functionStaticDeclaration :: Assignment
functionStaticDeclaration = makeTerm <$> symbol FunctionStaticDeclaration <*> children (Declaration.VariableDeclaration <$> manyTerm staticVariableDeclaration)

9
src/Language/PHP/Syntax.hs
View File

@ -57,12 +57,11 @@ resolvePHPName n = do
include :: ( AbstractValue location value effects
, Members '[ Allocator location value
, Modules location value
, Reader (Environment location value)
, Reader (Environment location)
, Resumable ResolutionError
, Resumable (EnvironmentError value)
, Resumable (EvalError value)
, State (Environment location value)
, State (Exports location value)
, State (Environment location)
, State (Exports location)
, State (Heap location (Cell location) value)
, Trace
] effects
@ -70,7 +69,7 @@ include :: ( AbstractValue location value effects
, Reducer value (Cell location value)
)
=> Subterm term (Evaluator location value effects (ValueRef location value))
-> (ModulePath -> Evaluator location value effects (Maybe (Environment location value, Address location value)))
-> (ModulePath -> Evaluator location value effects (Maybe (Environment location, Address location value)))
-> Evaluator location value effects (ValueRef location value)
include pathTerm f = do
name <- subtermValue pathTerm >>= asString

2
src/Language/Python/Assignment.hs
View File

@ -8,7 +8,7 @@ module Language.Python.Assignment
) where
import Assigning.Assignment hiding (Assignment, Error)
import Data.Abstract.FreeVariables (name)
import Data.Abstract.Name (name)
import Data.Record
import Data.Syntax (contextualize, emptyTerm, handleError, infixContext, makeTerm, makeTerm', makeTerm'', makeTerm1, parseError, postContextualize)
import GHC.Stack

13
src/Language/Python/Syntax.hs
View File

@ -3,7 +3,6 @@ module Language.Python.Syntax where
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import qualified Data.Abstract.FreeVariables as FV
import Data.Abstract.Module
import Data.Align.Generic
import qualified Data.ByteString.Char8 as BC
@ -131,9 +130,9 @@ instance Evaluatable Import where
evalQualifiedImport :: ( AbstractValue location value effects
, Members '[ Allocator location value
, Modules location value
, Reader (Environment location value)
, State (Environment location value)
, State (Exports location value)
, Reader (Environment location)
, State (Environment location)
, State (Exports location)
, State (Heap location (Cell location) value)
] effects
, Ord location
@ -158,9 +157,9 @@ instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec
-- import a.b.c
instance Evaluatable QualifiedImport where
eval (QualifiedImport (RelativeQualifiedName _ _)) = raiseEff (fail "technically this is not allowed in python")
eval (QualifiedImport name@(QualifiedName qualifiedName)) = do
modulePaths <- resolvePythonModules name
rvalBox =<< go (NonEmpty.zip (FV.name . BC.pack <$> qualifiedName) modulePaths)
eval (QualifiedImport qname@(QualifiedName qualifiedName)) = do
modulePaths <- resolvePythonModules qname
rvalBox =<< go (NonEmpty.zip (name . BC.pack <$> qualifiedName) modulePaths)
where
-- Evaluate and import the last module, updating the environment
go ((name, path) :| []) = evalQualifiedImport name path

6
src/Language/Ruby/Assignment.hs
View File

@ -7,11 +7,11 @@ module Language.Ruby.Assignment
) where
import Assigning.Assignment hiding (Assignment, Error)
import Data.Abstract.Name (name)
import Data.List (elem)
import Data.Record
import Data.Syntax (contextualize, postContextualize, emptyTerm, parseError, handleError, infixContext, makeTerm, makeTerm', makeTerm'', makeTerm1)
import Language.Ruby.Grammar as Grammar
import Data.Abstract.FreeVariables (name)
import qualified Assigning.Assignment as Assignment
import Data.Sum
import qualified Data.Syntax as Syntax
@ -455,6 +455,10 @@ binary = makeTerm' <$> symbol Binary <*> children (infixTerm expression expressi
, (inject .) . Ruby.Syntax.LowOr <$ symbol AnonOr
, (inject .) . Expression.BOr <$ symbol AnonPipe
, (inject .) . Expression.BXOr <$ symbol AnonCaret
-- TODO: AnonEqualEqualEqual corresponds to Ruby's "case equality"
-- function, which (unless overridden) is true if b is an instance
-- of or inherits from a. We need a custom equality operator
-- for this situation.
, (inject .) . Expression.Equal <$ (symbol AnonEqualEqual <|> symbol AnonEqualEqualEqual)
, (inject .) . invert Expression.Equal <$ symbol AnonBangEqual
, (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle

6
src/Language/Ruby/Syntax.hs
View File

@ -81,7 +81,7 @@ doRequire :: ( AbstractValue location value effects
, Member (Modules location value) effects
)
=> M.ModulePath
-> Evaluator location value effects (Environment location value, value)
-> Evaluator location value effects (Environment location, value)
doRequire path = do
result <- join <$> lookupModule path
case result of
@ -111,8 +111,8 @@ instance Evaluatable Load where
doLoad :: ( AbstractValue location value effects
, Members '[ Modules location value
, Resumable ResolutionError
, State (Environment location value)
, State (Exports location value)
, State (Environment location)
, State (Exports location)
, Trace
] effects
)

46
src/Language/TypeScript/Assignment.hs
View File

@ -7,7 +7,7 @@ module Language.TypeScript.Assignment
) where
import Assigning.Assignment hiding (Assignment, Error)
import Data.Abstract.FreeVariables (name)
import Data.Abstract.Name (name)
import qualified Assigning.Assignment as Assignment
import Data.Record
import Data.Sum
@ -832,27 +832,29 @@ tryStatement = makeTry <$> symbol TryStatement <*> children ((,,) <$> term state
binaryExpression :: Assignment
binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm expression (term expression)
[ (inject .) . Expression.Plus <$ symbol AnonPlus
, (inject .) . Expression.Minus <$ symbol AnonMinus
, (inject .) . Expression.Times <$ symbol AnonStar
, (inject .) . Expression.DividedBy <$ symbol AnonSlash
, (inject .) . Expression.Modulo <$ symbol AnonPercent
, (inject .) . Expression.Member <$ symbol AnonIn
, (inject .) . Expression.And <$ symbol AnonAmpersandAmpersand
, (inject .) . Expression.BAnd <$ symbol AnonAmpersand
, (inject .) . Expression.Or <$ symbol AnonPipePipe
, (inject .) . Expression.BOr <$ symbol AnonPipe
, (inject .) . Expression.BXOr <$ symbol AnonCaret
, (inject .) . Expression.InstanceOf <$ symbol AnonInstanceof
, (inject .) . Expression.Equal <$ (symbol AnonEqualEqual <|> symbol AnonEqualEqualEqual)
, (inject .) . invert Expression.Equal <$ (symbol AnonBangEqual <|> symbol AnonBangEqualEqual)
, (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle
, (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle
, (inject .) . Expression.UnsignedRShift <$ symbol AnonRAngleRAngleRAngle
, (inject .) . Expression.LessThan <$ symbol AnonLAngle
, (inject .) . Expression.GreaterThan <$ symbol AnonRAngle
, (inject .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual
, (inject .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual
[ (inject .) . Expression.Plus <$ symbol AnonPlus
, (inject .) . Expression.Minus <$ symbol AnonMinus
, (inject .) . Expression.Times <$ symbol AnonStar
, (inject .) . Expression.DividedBy <$ symbol AnonSlash
, (inject .) . Expression.Modulo <$ symbol AnonPercent
, (inject .) . Expression.Member <$ symbol AnonIn
, (inject .) . Expression.And <$ symbol AnonAmpersandAmpersand
, (inject .) . Expression.BAnd <$ symbol AnonAmpersand
, (inject .) . Expression.Or <$ symbol AnonPipePipe
, (inject .) . Expression.BOr <$ symbol AnonPipe
, (inject .) . Expression.BXOr <$ symbol AnonCaret
, (inject .) . Expression.InstanceOf <$ symbol AnonInstanceof
, (inject .) . Expression.Equal <$ symbol AnonEqualEqual
, (inject .) . Expression.StrictEqual <$ symbol AnonEqualEqualEqual
, (inject .) . invert Expression.Equal <$ symbol AnonBangEqual
, (inject .) . invert Expression.StrictEqual <$ symbol AnonBangEqualEqual
, (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle
, (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle
, (inject .) . Expression.UnsignedRShift <$ symbol AnonRAngleRAngleRAngle
, (inject .) . Expression.LessThan <$ symbol AnonLAngle
, (inject .) . Expression.GreaterThan <$ symbol AnonRAngle
, (inject .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual
, (inject .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual
])
where invert cons a b = Expression.Not (makeTerm1 (cons a b))

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

@ -3,7 +3,6 @@ module Language.TypeScript.Syntax where
import qualified Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import qualified Data.Abstract.FreeVariables as FV
import qualified Data.Abstract.Module as M
import Data.Abstract.Package
import Data.Abstract.Path
@ -32,7 +31,7 @@ importPath str = let path = stripQuotes str in ImportPath (BC.unpack path) (path
| otherwise = NonRelative
toName :: ImportPath -> Name
toName = FV.name . BC.pack . unPath
toName = name . BC.pack . unPath
-- Node.js resolution algorithm: https://nodejs.org/api/modules.html#modules_all_together
--
@ -136,9 +135,9 @@ javascriptExtensions = ["js"]
evalRequire :: ( AbstractValue location value effects
, Members '[ Allocator location value
, Modules location value
, Reader (Environment location value)
, State (Environment location value)
, State (Exports location value)
, Reader (Environment location)
, State (Environment location)
, State (Exports location)
, State (Heap location (Cell location) value)
, Trace
] effects

11
src/Parsing/Parser.hs
View File

@ -18,6 +18,7 @@ module Parsing.Parser
, rubyParser
, typescriptParser
, phpParser
, haskellParser
) where
import Assigning.Assignment
@ -33,6 +34,7 @@ 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.JSON.Assignment as JSON
import qualified Language.Markdown.Assignment as Markdown
import qualified Language.PHP.Assignment as PHP
@ -48,6 +50,7 @@ import TreeSitter.PHP
import TreeSitter.Python
import TreeSitter.Ruby
import TreeSitter.TypeScript
import TreeSitter.Haskell
type family ApplyAll' (typeclasses :: [(* -> *) -> Constraint]) (fs :: [* -> *]) :: Constraint where
@ -68,12 +71,14 @@ someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax
, ApplyAll' typeclasses Python.Syntax
, ApplyAll' typeclasses Ruby.Syntax
, ApplyAll' typeclasses TypeScript.Syntax
, ApplyAll' typeclasses Haskell.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 _ JavaScript = SomeAnalysisParser typescriptParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath TypeScript.Term))) (Just JavaScript))
someAnalysisParser _ Haskell = SomeAnalysisParser haskellParser Nothing
someAnalysisParser _ PHP = SomeAnalysisParser phpParser Nothing
someAnalysisParser _ Python = SomeAnalysisParser pythonParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Python))
someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Ruby))
@ -106,6 +111,7 @@ type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (syntax :: * -> *
--
-- > runTask (parse (someParser @'[Show1] language) blob) >>= putStrLn . withSomeTerm show
someParser :: ( ApplyAll typeclasses (Sum Go.Syntax)
, ApplyAll typeclasses (Sum Haskell.Syntax)
, ApplyAll typeclasses (Sum JSON.Syntax)
, ApplyAll typeclasses (Sum Markdown.Syntax)
, ApplyAll typeclasses (Sum Python.Syntax)
@ -118,6 +124,7 @@ someParser :: ( ApplyAll typeclasses (Sum Go.Syntax)
someParser Go = SomeParser goParser
someParser JavaScript = SomeParser typescriptParser
someParser JSON = SomeParser jsonParser
someParser Haskell = SomeParser haskellParser
someParser JSX = SomeParser typescriptParser
someParser Markdown = SomeParser markdownParser
someParser Python = SomeParser pythonParser
@ -144,6 +151,9 @@ jsonParser = AssignmentParser (ASTParser tree_sitter_json) JSON.assignment
typescriptParser :: Parser TypeScript.Term
typescriptParser = AssignmentParser (ASTParser tree_sitter_typescript) TypeScript.assignment
haskellParser :: Parser Haskell.Term
haskellParser = AssignmentParser (ASTParser tree_sitter_haskell) Haskell.assignment
markdownParser :: Parser Markdown.Term
markdownParser = AssignmentParser MarkdownParser Markdown.assignment
@ -163,6 +173,7 @@ data SomeASTParser where
someASTParser :: Language -> SomeASTParser
someASTParser Go = SomeASTParser (ASTParser tree_sitter_go :: Parser (AST [] Go.Grammar))
someASTParser Haskell = SomeASTParser (ASTParser tree_sitter_haskell :: Parser (AST [] Haskell.Grammar))
someASTParser JavaScript = SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar))
someASTParser JSON = SomeASTParser (ASTParser tree_sitter_json :: Parser (AST [] JSON.Grammar))
someASTParser JSX = SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar))

4
src/Rendering/Renderer.hs
View File

@ -39,6 +39,8 @@ data DiffRenderer output where
SExpressionDiffRenderer :: DiffRenderer Builder
-- | Render to a 'ByteString' formatted as a DOT description of the diff.
DOTDiffRenderer :: DiffRenderer (Graph (Vertex DiffTag))
-- | Render to a 'ByteString' formatted using the 'Show' instance.
ShowDiffRenderer :: DiffRenderer Builder
deriving instance Eq (DiffRenderer output)
deriving instance Show (DiffRenderer output)
@ -57,6 +59,8 @@ data TermRenderer output where
ImportsTermRenderer :: TermRenderer ImportSummary
-- | Render to a 'ByteString' formatted as a DOT description of the term.
DOTTermRenderer :: TermRenderer (Graph (Vertex ()))
-- | Render to a 'ByteString' formatted using the 'Show' instance.
ShowTermRenderer :: TermRenderer Builder
deriving instance Eq (TermRenderer output)
deriving instance Show (TermRenderer output)

7
src/Semantic/AST.hs
View File

@ -23,9 +23,10 @@ astParseBlob blob@Blob{..}
| otherwise = noLanguageForBlob blobPath
data ASTFormat = SExpression | JSON
data ASTFormat = SExpression | JSON | Show
deriving (Show)
runASTParse :: Members '[Distribute WrappedTask, Task, Exc SomeException] effects => ASTFormat -> [Blob] -> Eff effects F.Builder
runASTParse SExpression = distributeFoldMap (WrapTask . (withSomeAST (serialize (F.SExpression F.ByShow)) <=< astParseBlob))
runASTParse JSON = serialize F.JSON <=< distributeFoldMap (\ blob -> WrapTask (withSomeAST (render (renderJSONAST blob)) =<< astParseBlob blob))
runASTParse SExpression = distributeFoldMap (WrapTask . (astParseBlob >=> withSomeAST (serialize (F.SExpression F.ByShow))))
runASTParse Show = distributeFoldMap (WrapTask . (astParseBlob >=> withSomeAST (serialize F.Show)))
runASTParse JSON = distributeFoldMap (\ blob -> WrapTask (astParseBlob blob >>= withSomeAST (render (renderJSONAST blob)))) >=> serialize F.JSON

18
src/Semantic/CLI.hs
View File

@ -7,7 +7,6 @@ module Semantic.CLI
) where
import Data.Project
import Data.Language (Language)
import Data.List (intercalate)
import Data.List.Split (splitWhen)
import Data.Version (showVersion)
@ -18,7 +17,7 @@ import Prologue
import Rendering.Renderer
import qualified Semantic.AST as AST
import qualified Semantic.Diff as Diff
import Semantic.Graph as Semantic (Graph, GraphType(..), Vertex, graph, style)
import qualified Semantic.Graph as Graph
import Semantic.IO as IO
import qualified Semantic.Log as Log
import qualified Semantic.Parse as Parse
@ -29,9 +28,6 @@ import Text.Read
main :: IO ()
main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions
runGraph :: Semantic.GraphType -> Maybe FilePath -> FilePath -> Language -> [FilePath] -> Task.TaskEff (Graph Vertex)
runGraph graphType rootDir dir excludeDirs = Semantic.graph graphType <=< Task.readProject rootDir dir excludeDirs
-- | A parser for the application's command-line arguments.
--
-- Returns a 'Task' to read the input, run the requested operation, and write the output to the specified output path or stdout.
@ -61,6 +57,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
<|> flag' (Diff.runDiff JSONDiffRenderer) (long "json" <> help "Output JSON diff trees")
<|> flag' (Diff.runDiff ToCDiffRenderer) (long "toc" <> help "Output JSON table of contents diff summary")
<|> flag' (Diff.runDiff DOTDiffRenderer) (long "dot" <> help "Output the diff as a DOT graph")
<|> flag' (Diff.runDiff ShowDiffRenderer) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)")
filesOrStdin <- Right <$> some (both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin)
pure $ Task.readBlobPairs filesOrStdin >>= renderer
@ -76,6 +73,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
<|> pure defaultSymbolFields)
<|> flag' (Parse.runParse ImportsTermRenderer) (long "import-graph" <> help "Output JSON import graph")
<|> flag' (Parse.runParse DOTTermRenderer) (long "dot" <> help "Output DOT graph parse trees")
<|> flag' (Parse.runParse ShowTermRenderer) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)")
filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
pure $ Task.readBlobs filesOrStdin >>= renderer
@ -83,19 +81,23 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
tsParseArgumentsParser = do
format <- flag AST.SExpression AST.SExpression (long "sexpression" <> help "Output s-expression ASTs (default)")
<|> flag' AST.JSON (long "json" <> help "Output JSON ASTs")
<|> flag' AST.Show (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)")
filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
pure $ Task.readBlobs filesOrStdin >>= AST.runASTParse format
graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or entry point"))
graphArgumentsParser = do
graphType <- flag ImportGraph ImportGraph (long "imports" <> help "Compute an import graph (default)")
<|> flag' CallGraph (long "calls" <> help "Compute a call graph")
graphType <- flag Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)")
<|> flag' Graph.CallGraph (long "calls" <> help "Compute a call graph")
let style = Graph.style
includePackages <- switch (long "packages" <> help "Include a vertex for the package, with edges from it to each module")
serializer <- flag (Task.serialize (DOT style)) (Task.serialize (DOT style)) (long "dot" <> help "Output in DOT graph format (default)")
<|> flag' (Task.serialize JSON) (long "json" <> help "Output JSON graph")
<|> flag' (Task.serialize Show) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)")
rootDir <- rootDirectoryOption
excludeDirs <- excludeDirsOption
File{..} <- argument filePathReader (metavar "DIR:LANGUAGE | FILE")
pure $ runGraph graphType rootDir filePath (fromJust fileLanguage) excludeDirs >>= serializer
pure $ Task.readProject rootDir filePath (fromJust fileLanguage) excludeDirs >>= Graph.runGraph graphType includePackages >>= serializer
rootDirectoryOption = optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR"))
excludeDirsOption = many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR"))

15
src/Semantic/Diff.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}
{-# LANGUAGE ConstraintKinds, GADTs, RankNTypes, ScopedTypeVariables #-}
module Semantic.Diff where
import Analysis.ConstructorName (ConstructorName, constructorLabel)
@ -24,6 +24,7 @@ runDiff :: Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException,
runDiff ToCDiffRenderer = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderToCDiff) >=> serialize JSON
runDiff JSONDiffRenderer = withParsedBlobPairs (const (decorate constructorLabel >=> decorate identifierLabel)) (render . renderJSONDiff) >=> serialize JSON
runDiff SExpressionDiffRenderer = withParsedBlobPairs (const pure) (const (serialize (SExpression ByConstructorName)))
runDiff ShowDiffRenderer = withParsedBlobPairs (const pure) (const (serialize Show))
runDiff DOTDiffRenderer = withParsedBlobPairs (const pure) (const (render renderTreeGraph)) >=> serialize (DOT (diffStyle "diffs"))
data SomeTermPair typeclasses ann where
@ -35,9 +36,11 @@ withSomeTermPair with (SomeTermPair terms) = with terms
diffBlobTOCPairs :: Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs => [BlobPair] -> Eff effs ([TOCSummary], [TOCSummary])
diffBlobTOCPairs = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderRPCToCDiff)
type CanDiff syntax = (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Hashable1 syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax)
withParsedBlobPairs :: (Members '[Distribute WrappedTask, Exc SomeException, IO, Task, Telemetry] effs, Monoid output)
=> (forall syntax . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Hashable1 syntax, ToJSONFields1 syntax, Traversable syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
-> (forall syntax . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Hashable1 syntax, ToJSONFields1 syntax, Traversable syntax) => BlobPair -> Diff syntax (Record fields) (Record fields) -> TaskEff output)
=> (forall syntax . CanDiff syntax => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
-> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax (Record fields) (Record fields) -> TaskEff output)
-> [BlobPair]
-> Eff effs output
withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> WrapTask (withParsedBlobPair decorate blobs >>= withSomeTermPair (diffTerms blobs >=> render blobs)))
@ -48,10 +51,10 @@ withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> WrapTask (wi
where languageTag = languageTagForBlobPair blobs
withParsedBlobPair :: Members '[Distribute WrappedTask, Exc SomeException, Task] effs
=> (forall syntax . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Hashable1 syntax, ToJSONFields1 syntax, Traversable syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
=> (forall syntax . (CanDiff syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
-> BlobPair
-> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Hashable1, ToJSONFields1, Traversable] (Record fields))
-> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, Hashable1, IdentifierName, Show1, ToJSONFields1, Traversable] (Record fields))
withParsedBlobPair decorate blobs
| Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Hashable1, ToJSONFields1, Traversable] <$> languageForBlobPair blobs
| Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, Hashable1, IdentifierName, Show1, ToJSONFields1, Traversable] <$> languageForBlobPair blobs
= SomeTermPair <$> distributeFor blobs (\ blob -> WrapTask (parse parser blob >>= decorate blob))
| otherwise = noLanguageForBlob (pathForBlobPair blobs)

32
src/Semantic/Graph.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE GADTs, TypeOperators #-}
module Semantic.Graph
( graph
( runGraph
, GraphType(..)
, Graph
, Vertex
@ -28,9 +28,9 @@ import Data.Abstract.Module
import Data.Abstract.Package as Package
import Data.Abstract.Value (Value, ValueError(..), runValueErrorWith)
import Data.ByteString.Char8 (pack)
import Data.Graph
import Data.Project
import Data.Record
import Data.Semilattice.Lower
import Data.Term
import Parsing.Parser
import Prologue hiding (MonadError (..))
@ -39,20 +39,22 @@ import Semantic.Task as Task
data GraphType = ImportGraph | CallGraph
graph :: Members '[Distribute WrappedTask, Files, Resolution, Task, Exc SomeException, Telemetry, Trace] effs
=> GraphType
-> Project
-> Eff effs (Graph Vertex)
graph graphType project
runGraph :: Members '[Distribute WrappedTask, Files, Resolution, Task, Exc SomeException, Telemetry, Trace] effs
=> GraphType
-> Bool
-> Project
-> Eff effs (Graph Vertex)
runGraph graphType includePackages project
| SomeAnalysisParser parser prelude <- someAnalysisParser
(Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do
package <- parsePackage parser prelude project
let analyzeTerm = case graphType of
let analyzeTerm = withTermSpans . case graphType of
ImportGraph -> id
CallGraph -> graphingTerms
analyze runGraphAnalysis (evaluatePackageWith graphingModules (withTermSpans . graphingLoadErrors . analyzeTerm) package) >>= extractGraph
analyzeModule = (if includePackages then graphingPackages else id) . graphingModules
analyze runGraphAnalysis (evaluatePackageWith analyzeModule analyzeTerm package) >>= extractGraph
where extractGraph result = case result of
(Right ((_, graph), _), _) -> pure graph
(Right ((_, graph), _), _) -> pure (simplify graph)
_ -> Task.throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result)))
runGraphAnalysis
= run
@ -110,14 +112,8 @@ resumingResolutionError = runResolutionErrorWith (\ err -> trace ("ResolutionErr
resumingLoadError :: Member Trace effects => Evaluator location value (Resumable (LoadError location value) ': effects) a -> Evaluator location value effects a
resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> Nothing)
resumingEvalError :: ( AbstractHole value
, Member Trace effects
, Show value
)
=> Evaluator location value (Resumable (EvalError value) ': effects) a
-> Evaluator location value effects a
resumingEvalError :: Member Trace effects => Evaluator location value (Resumable EvalError ': effects) a -> Evaluator location value effects a
resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *> case err of
EnvironmentLookupError{} -> pure hole
DefaultExportError{} -> pure ()
ExportError{} -> pure ()
IntegerFormatError{} -> pure 0
@ -137,7 +133,7 @@ resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> s
UnallocatedAddress _ -> pure lowerBound
UninitializedAddress _ -> pure hole)
resumingValueError :: (Members '[State (Environment location (Value location)), Trace] effects, Show location) => Evaluator location (Value location) (Resumable (ValueError location) ': effects) a -> Evaluator location (Value location) effects a
resumingValueError :: (Members '[State (Environment location), Trace] effects, Show location) => Evaluator location (Value location) (Resumable (ValueError location) ': effects) a -> Evaluator location (Value location) effects a
resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of
CallError val -> pure val
StringError val -> pure (pack (show val))

5
src/Semantic/Parse.hs
View File

@ -21,13 +21,14 @@ import Serializing.Format
runParse :: Members '[Distribute WrappedTask, Task, Exc SomeException] effs => TermRenderer output -> [Blob] -> Eff effs Builder
runParse JSONTermRenderer = withParsedBlobs (\ blob -> decorate constructorLabel >=> decorate identifierLabel >=> render (renderJSONTerm blob)) >=> serialize JSON
runParse SExpressionTermRenderer = withParsedBlobs (const (serialize (SExpression ByConstructorName)))
runParse ShowTermRenderer = withParsedBlobs (const (serialize Show))
runParse TagsTermRenderer = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> render (renderToTags blob)) >=> serialize JSON
runParse ImportsTermRenderer = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> decorate (packageDefAlgebra blob) >=> render (renderToImports blob)) >=> serialize JSON
runParse (SymbolsTermRenderer fields) = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)) >=> serialize JSON
runParse DOTTermRenderer = withParsedBlobs (const (render renderTreeGraph)) >=> serialize (DOT (termStyle "terms"))
withParsedBlobs :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Monoid output) => (forall syntax . (ConstructorName syntax, HasPackageDef syntax, HasDeclaration syntax, IdentifierName syntax, Foldable syntax, Functor syntax, ToJSONFields1 syntax) => Blob -> Term syntax (Record Location) -> TaskEff output) -> [Blob] -> Eff effs output
withParsedBlobs :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Monoid output) => (forall syntax . (ConstructorName syntax, Foldable syntax, Functor syntax, HasDeclaration syntax, HasPackageDef syntax, IdentifierName syntax, Show1 syntax, ToJSONFields1 syntax) => Blob -> Term syntax (Record Location) -> TaskEff output) -> [Blob] -> Eff effs output
withParsedBlobs render = distributeFoldMap (\ blob -> WrapTask (parseSomeBlob blob >>= withSomeTerm (render blob)))
parseSomeBlob :: Members '[Task, Exc SomeException] effs => Blob -> Eff effs (SomeTerm '[ConstructorName, HasPackageDef, HasDeclaration, IdentifierName, Foldable, Functor, ToJSONFields1] (Record Location))
parseSomeBlob :: Members '[Task, Exc SomeException] effs => Blob -> Eff effs (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, IdentifierName, Show1, ToJSONFields1] (Record Location))
parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (flip parse blob . someParser) blobLanguage

5
src/Semantic/Task.hs
View File

@ -56,6 +56,7 @@ import Control.Monad.Effect.Exception
import Control.Monad.Effect.Reader
import Control.Monad.Effect.Trace
import Data.Blob
import Data.Bool
import Data.ByteString.Builder
import Data.Diff
import qualified Data.Error as Error
@ -173,7 +174,9 @@ runTaskF = interpret $ \ task -> case task of
Decorate algebra term -> pure (decoratorWithAlgebra algebra term)
Semantic.Task.Diff terms -> pure (diffTermPair terms)
Render renderer input -> pure (renderer input)
Serialize format input -> pure (runSerialize format input)
Serialize format input -> do
formatStyle <- asks (bool Colourful Plain . optionsEnableColour)
pure (runSerialize formatStyle format input)
-- | Log an 'Error.Error' at the specified 'Level'.

12
src/Semantic/Util.hs
View File

@ -4,9 +4,8 @@ module Semantic.Util where
import Analysis.Abstract.Caching
import Analysis.Abstract.Collecting
import Analysis.Abstract.Evaluating as X
import Control.Abstract.Evaluator
import Control.Abstract.TermEvaluator
import Analysis.Abstract.Evaluating
import Control.Abstract
import Control.Monad.Effect.Trace (runPrintingTrace)
import Data.Abstract.Address
import Data.Abstract.Evaluatable
@ -19,6 +18,8 @@ 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)
@ -26,6 +27,7 @@ import Semantic.Graph
import Semantic.IO as IO
import Semantic.Task
import Text.Show (showListWith)
import Text.Show.Pretty
import qualified Language.Python.Assignment as Python
import qualified Language.Ruby.Assignment as Ruby
@ -139,3 +141,7 @@ instance Show1 syntax => Show (Quieterm syntax ann) where
quieterm :: (Recursive term, Base term ~ TermF syntax ann) => term -> Quieterm syntax ann
quieterm = cata Quieterm
prettyShow :: Show a => a -> IO ()
prettyShow = putStrLn . hscolour TTY defaultColourPrefs False False "" False . ppShow

23
src/Serializing/Format.hs
View File

@ -1,18 +1,21 @@
{-# LANGUAGE GADTs #-}
module Serializing.Format
( Format(..)
, FormatStyle(..)
, Builder
, runSerialize
, SomeFormat(..)
, Options(..)
) where
import Algebra.Graph.Class
import Data.Aeson (ToJSON(..), fromEncoding)
import Data.ByteString.Builder
import Language.Haskell.HsColour
import Language.Haskell.HsColour.Colourise
import Prologue
import Serializing.DOT
import Serializing.SExpression
import Text.Show.Pretty
data Format input where
DOT :: (Ord vertex, ToGraph graph, ToVertex graph ~ vertex) => Style vertex Builder -> Format graph
@ -20,15 +23,11 @@ data Format input where
SExpression :: (Recursive input, ToSExpression (Base input)) => Options -> Format input
Show :: Show input => Format input
runSerialize :: Format input -> input -> Builder
runSerialize (DOT style) = serializeDOT style
runSerialize JSON = (<> "\n") . fromEncoding . toEncoding
runSerialize (SExpression opts) = serializeSExpression opts
runSerialize Show = stringUtf8 . show
data FormatStyle = Colourful | Plain
-- TODO: it would be kinda neat if we could use pretty-show/hscolour for Show output
-- | Abstract over a 'Format'’s input type.
data SomeFormat where
SomeFormat :: Format input -> SomeFormat
runSerialize :: FormatStyle -> Format input -> input -> Builder
runSerialize _ (DOT style) = serializeDOT style
runSerialize _ JSON = (<> "\n") . fromEncoding . toEncoding
runSerialize _ (SExpression opts) = serializeSExpression opts
runSerialize Colourful Show = (<> "\n") . stringUtf8 . hscolour TTY defaultColourPrefs False False "" False . ppShow
runSerialize Plain Show = (<> "\n") . stringUtf8 . show

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

@ -32,7 +32,7 @@ spec = parallel $ do
it "fails exporting symbols not defined in the module" $ do
((res, _), _) <- evaluate "bad-export.ts"
res `shouldBe` Left (SomeExc (inject @(EvalError (Value Precise)) (ExportError "foo.ts" (Name "pip"))))
res `shouldBe` Left (SomeExc (inject @EvalError (ExportError "foo.ts" (name "pip"))))
it "evaluates early return statements" $ do
((res, _), _) <- evaluate "early-return.ts"

6
test/Data/Functor/Listable.hs
View File

@ -47,7 +47,7 @@ import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Comment as Comment
import qualified Data.Syntax.Declaration as Declaration
import qualified Data.Syntax.Statement as Statement
import qualified Data.Abstract.FreeVariables as FV
import qualified Data.Abstract.Name as Name
import Data.Term
import Data.Text as T (Text, pack)
import qualified Data.Text.Encoding as T
@ -257,8 +257,8 @@ type ListableSyntax = Sum
, []
]
instance Listable FV.Name where
tiers = cons1 FV.name
instance Listable Name.Name where
tiers = cons1 Name.name
instance Listable1 Gram where
liftTiers tiers = liftCons2 (liftTiers (liftTiers tiers)) (liftTiers (liftTiers tiers)) Gram

7
test/Doctests.hs
View File

@ -5,7 +5,12 @@ module Main
import System.Environment
import Test.DocTest
defaultFiles = ["src/Data/Abstract/Environment.hs", "src/Data/Range.hs", "src/Data/Semigroup/App.hs"]
defaultFiles =
[ "src/Data/Abstract/Environment.hs"
, "src/Data/Abstract/Name.hs"
, "src/Data/Range.hs"
, "src/Data/Semigroup/App.hs"
]
main :: IO ()
main = do

5
test/SpecHelpers.hs
View File

@ -20,9 +20,10 @@ import Control.Monad ((>=>))
import Data.Abstract.Address as X
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Data.Abstract.FreeVariables as X hiding (dropExtension)
import Data.Abstract.FreeVariables as X
import Data.Abstract.Heap as X
import Data.Abstract.ModuleTable as X hiding (lookup)
import Data.Abstract.Name as X
import Data.Abstract.Value (Namespace(..), Value, ValueError, injValue, prjValue, runValueError)
import Data.Bifunctor (first)
import Data.Blob as X
@ -93,7 +94,7 @@ testEvaluating
deNamespace :: Value Precise -> Maybe (Name, [Name])
deNamespace = fmap (namespaceName &&& Env.names . namespaceScope) . prjValue @(Namespace Precise)
derefQName :: Heap Precise (Cell Precise) (Value Precise) -> NonEmpty Name -> Environment Precise (Value Precise) -> Maybe (Value Precise)
derefQName :: Heap Precise (Cell Precise) (Value Precise) -> NonEmpty Name -> Environment Precise -> Maybe (Value Precise)
derefQName heap = go
where go (n1 :| ns) env = Env.lookup n1 env >>= flip heapLookup heap >>= getLast . unLatest >>= case ns of
[] -> Just

0
test/fixtures/haskell/corpus/blank.A.hs vendored Normal file
View File

3
test/fixtures/haskell/corpus/blank.parseA.txt vendored Normal file
View File

@ -0,0 +1,3 @@
(Module
(Empty)
([]))

37
test/fixtures/haskell/corpus/literals.A.hs vendored Normal file
View File

@ -0,0 +1,37 @@
module A where
a = 0
a = 1
a = 0o00
a = 0O77
a = 0x00
a = 0XFF
a = 0.00
a = 0.99
a = 0.00e01
a = 0.99E01
a = 0.00e+01
a = 0.99E-01
a = 0.00e-01
a = 0.99E+01
a = 00e01
a = 99E01
a = 00e+01
a = 99E-01
a = 00e-01
a = 99E+01
a = undefined
_a0 = undefined
_A0 = undefined
a0 = undefined
a9 = undefined
aA = undefined
aZ' = undefined
a = True
a = False

37
test/fixtures/haskell/corpus/literals.B.hs vendored Normal file
View File

@ -0,0 +1,37 @@
module A where
b = 0
b = 1
b = 0o00
b = 0O77
b = 0x00
b = 0XFF
b = 0.00
b = 0.99
b = 0.00e01
b = 0.99E01
b = 0.00e+01
b = 0.99E-01
b = 0.00e-01
b = 0.99E+01
b = 00e01
b = 99E01
b = 00e+01
b = 99E-01
b = 00e-01
b = 99E+01
b = undefined
ba0 = undefined
bA0 = undefined
b0 = undefined
b9 = undefined
bA = undefined
bZ' = undefined
b = True
b = False

232
test/fixtures/haskell/corpus/literals.diffA-B.txt vendored Normal file
View File

@ -0,0 +1,232 @@
(Module
(Identifier)
(
(Function
{ (Identifier)
->(Identifier) }
(
(Integer)))
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{-(Function
{-(Identifier)-}
{-(
{-(Integer)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Integer)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Integer)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Integer)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Integer)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}))

230
test/fixtures/haskell/corpus/literals.diffB-A.txt vendored Normal file
View File

@ -0,0 +1,230 @@
(Module
(Identifier)
(
(Function
{ (Identifier)
->(Identifier) }
(
(Integer)))
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Integer)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Float)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
(Function
{ (Identifier)
->(Identifier) }
(
{+(Identifier)+}
{-(Integer)-}))
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{+(Function
{+(Identifier)+}
{+(
{+(Identifier)+})+})+}
{-(Function
{-(Identifier)-}
{-(
{-(Integer)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Integer)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Integer)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Integer)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Float)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}
{-(Function
{-(Identifier)-}
{-(
{-(Identifier)-})-})-}))

119
test/fixtures/haskell/corpus/literals.parseA.txt vendored Normal file
View File

@ -0,0 +1,119 @@
(Module
(Identifier)
(
(Function
(Identifier)
(
(Integer)))
(Function
(Identifier)
(
(Integer)))
(Function
(Identifier)
(
(Integer)))
(Function
(Identifier)
(
(Integer)))
(Function
(Identifier)
(
(Integer)))
(Function
(Identifier)
(
(Integer)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))))

119
test/fixtures/haskell/corpus/literals.parseB.txt vendored Normal file
View File

@ -0,0 +1,119 @@
(Module
(Identifier)
(
(Function
(Identifier)
(
(Integer)))
(Function
(Identifier)
(
(Integer)))
(Function
(Identifier)
(
(Integer)))
(Function
(Identifier)
(
(Integer)))
(Function
(Identifier)
(
(Integer)))
(Function
(Identifier)
(
(Integer)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Float)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))
(Function
(Identifier)
(
(Identifier)))))

2
test/fixtures/javascript/corpus/break.diffA-B.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
test/fixtures/javascript/corpus/break.diffB-A.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
test/fixtures/javascript/corpus/break.parseA.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
test/fixtures/javascript/corpus/break.parseB.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
test/fixtures/javascript/corpus/continue.diffA-B.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
test/fixtures/javascript/corpus/continue.diffB-A.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
test/fixtures/javascript/corpus/continue.parseA.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
test/fixtures/javascript/corpus/continue.parseB.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
test/fixtures/typescript/corpus/break.diffA-B.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
test/fixtures/typescript/corpus/break.diffB-A.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
test/fixtures/typescript/corpus/break.parseA.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
test/fixtures/typescript/corpus/break.parseB.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
test/fixtures/typescript/corpus/continue.diffA-B.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
test/fixtures/typescript/corpus/continue.diffB-A.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
test/fixtures/typescript/corpus/continue.parseA.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
test/fixtures/typescript/corpus/continue.parseB.txt vendored
View File

@ -10,7 +10,7 @@
(Identifier))
(
(If
(Equal
(StrictEqual
(Identifier)
(Float))
(

2
vendor/haskell-tree-sitter vendored

@ -1 +1 @@
Subproject commit 4d08262bc306fe8e233feff4714a9c77b83edd77
Subproject commit e5b4ad8f70454ba67edce974eb3b065ee9f51cb5