github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-25 07:55:12 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into deployment-setup

Browse Source
This commit is contained in:
Timothy Clem 2018-05-24 10:13:25 -07:00 committed by GitHub
commit a15efb9327
56 changed files with 1381 additions and 476 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
semantic.cabal
View File

@ -46,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
@ -62,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

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

@ -7,8 +7,8 @@ module Analysis.Abstract.Caching
import Control.Abstract
import Data.Abstract.Cache
import Data.Abstract.Evaluatable
import Data.Abstract.Module
import Data.Abstract.Ref
import Data.Semilattice.Lower
import Prologue
@ -63,7 +63,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
)
@ -84,13 +84,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
)

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

@ -9,10 +9,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, value))
, exports :: Exports location value
, modules :: ModuleTable (Maybe (Environment location, value))
, exports :: Exports location
}
deriving instance (Eq (Cell location value), Eq location, Eq value) => Eq (EvaluatingState location value)
@ -23,19 +23,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, value)))
': State (Exports location value)
': State (ModuleTable (Maybe (Environment 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, value)))
. runState lowerBound -- State (Exports location)
. runState lowerBound -- State (ModuleTable (Maybe (Environment 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

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

@ -16,8 +16,8 @@ module Analysis.Abstract.Graph
import Algebra.Graph.Export.Dot hiding (vertexName)
import Control.Abstract
import Data.Abstract.Address
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
@ -52,9 +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
, State (Environment (Located location) value)
, State (Environment (Located location))
, State (Graph Vertex)
] effects
, term ~ Term (Sum syntax) ann
@ -125,8 +125,8 @@ moduleInclusion v = do
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

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)

36
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,25 +11,16 @@ 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 Data.Abstract.FreeVariables
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 Prologue
-- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the location, term, and value types.
@ -43,16 +33,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 value where
-- Represents a value:
Rval :: value -> ValueRef 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 value
-- Represents an object member:
LvalMember :: value -> Name -> ValueRef value
deriving (Eq, Ord, Show)
-- Effects

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

@ -24,8 +24,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
@ -63,8 +63,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)
@ -72,8 +72,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
@ -90,8 +90,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 value)
@ -104,9 +104,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

@ -26,7 +26,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, value)))
lookupModule :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Maybe (Environment location, value)))
lookupModule = send . Lookup
-- | Resolve a list of module paths to a possible module table entry.
@ -40,19 +40,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, value))
require :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment 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, value))
load :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, value))
load = send . Load
data Modules location value return where
Load :: ModulePath -> Modules location value (Maybe (Environment location value, value))
Lookup :: ModulePath -> Modules location value (Maybe (Maybe (Environment location value, value)))
Load :: ModulePath -> Modules location value (Maybe (Environment location, value))
Lookup :: ModulePath -> Modules location value (Maybe (Maybe (Environment location, value)))
Resolve :: [FilePath] -> Modules location value (Maybe ModulePath)
List :: FilePath -> Modules location value [ModulePath]
@ -61,10 +61,10 @@ sendModules = send
runModules :: forall term location value effects a
. Members '[ Resumable (LoadError location value)
, State (ModuleTable (Maybe (Environment location value, value)))
, State (ModuleTable (Maybe (Environment location, value)))
, Trace
] effects
=> (Module term -> Evaluator location value (Modules location value ': effects) (Environment location value, value))
=> (Module term -> Evaluator location value (Modules location value ': effects) (Environment location, value))
-> Evaluator location value (Modules location value ': effects) a
-> Evaluator location value (Reader (ModuleTable [Module term]) ': effects) a
runModules evaluateModule = go
@ -89,17 +89,17 @@ runModules evaluateModule = go
pure (find isMember names)
List dir -> modulePathsInDir dir <$> askModuleTable @term)
getModuleTable :: Member (State (ModuleTable (Maybe (Environment location value, value)))) effects => Evaluator location value effects (ModuleTable (Maybe (Environment location value, value)))
getModuleTable :: Member (State (ModuleTable (Maybe (Environment location, value)))) effects => Evaluator location value effects (ModuleTable (Maybe (Environment location, value)))
getModuleTable = get
cacheModule :: Member (State (ModuleTable (Maybe (Environment location value, value)))) effects => ModulePath -> Maybe (Environment location value, value) -> Evaluator location value effects (Maybe (Environment location value, value))
cacheModule :: Member (State (ModuleTable (Maybe (Environment location, value)))) effects => ModulePath -> Maybe (Environment location, value) -> Evaluator location value effects (Maybe (Environment 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, value)) }
newtype Merging m location value = Merging { runMerging :: m (Maybe (Environment location, value)) }
instance Applicative m => Semigroup (Merging m location value) where
Merging a <> Merging b = Merging (merge <$> a <*> b)
@ -113,7 +113,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, value))
ModuleNotFound :: ModulePath -> LoadError location value (Maybe (Environment location, value))
deriving instance Eq (LoadError location value resume)
deriving instance Show (LoadError location value resume)
@ -122,7 +122,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, value))
moduleNotFound :: Member (Resumable (LoadError location value)) effects => ModulePath -> Evaluator location value effects (Maybe (Environment 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

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

@ -0,0 +1,61 @@
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.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 value)
-> Evaluator location value effects 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))

108
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,27 @@ 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 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 value] -> Evaluator location value effects 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 +104,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 +125,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 +133,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 value] -> Evaluator location value effects 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 +155,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 +171,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 +190,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 +207,47 @@ 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 value
-> Evaluator location value effects value
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
)
=> ValueRef value
-> Evaluator location value effects value
value (LvalLocal var) = variable var
value (LvalMember obj prop) = evaluateInScopedEnv (pure obj) (variable prop)
value (Rval val) = pure val
-- | 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
)
=> Subterm term (Evaluator location value effects (ValueRef value))
-> Evaluator location value effects value
subtermValue = value <=< subtermRef
-- | 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

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

@ -2,36 +2,37 @@
module Data.Abstract.Evaluatable
( module X
, Evaluatable(..)
, evaluatePackageWith
, isolate
, traceResolve
-- | Effects
, EvalError(..)
, throwEvalError
, runEvalError
, runEvalErrorWith
, Unspecialized(..)
, runUnspecialized
, runUnspecializedWith
, EvalError(..)
, runEvalError
, runEvalErrorWith
, value
, subtermValue
, 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 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.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
@ -57,17 +58,17 @@ type EvaluatableConstraints location term value effects =
, Members '[ Allocator location value
, LoopControl 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 value
, State (Environment location value)
, State (Exports location value)
, State (Environment location)
, State (Exports location)
, State (Heap location (Cell location) value)
, Trace
] effects
@ -76,148 +77,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)
, State (Environment location value)
] effects
)
=> Evaluator location value effects value
-> Evaluator location value effects value
-> Evaluator location value effects value
evaluateInScopedEnv scopedEnvTerm term = do
value <- scopedEnvTerm
scopedEnv <- scopedEnvironment value
maybe (throwEvalError (EnvironmentLookupError value)) (flip localEnv term . mergeEnvs) scopedEnv
deriving instance Eq a => Eq (EvalError a b)
deriving instance Show a => Show (EvalError a b)
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 a b where
Unspecialized :: Prelude.String -> Unspecialized value (ValueRef value)
instance Eq1 (Unspecialized a) where
liftEq _ (Unspecialized a) (Unspecialized b) = a == b
deriving instance Eq (Unspecialized a b)
deriving instance Show (Unspecialized a b)
instance Show1 (Unspecialized a) 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
)
=> ValueRef value
-> Evaluator location value effects value
value (LvalLocal var) = variable var
value (LvalMember obj prop) = evaluateInScopedEnv (pure obj) (variable prop)
value (Rval val) = pure 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
)
=> Subterm term (Evaluator location value effects (ValueRef value))
-> Evaluator location value effects value
subtermValue = value <=< 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 (Rval <$> 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?
@ -226,13 +85,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, value)))
, State (ModuleTable (Maybe (Environment location, value)))
, Trace
] outer
, Recursive term
@ -273,9 +132,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))
unit
_ <- runInModule moduleInfoFromCallStack (TermEvaluator (defineBuiltins *> unit))
fst <$> evalModule prelude
withPrelude Nothing a = a
@ -296,5 +153,84 @@ newtype Gotos location value outer = Gotos { getGotos :: GotoTable (LoopControl
-- | 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

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

@ -0,0 +1,14 @@
{-# LANGUAGE GADTs #-}
module Data.Abstract.Ref where
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 value where
-- | A value.
Rval :: value -> ValueRef 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 value
-- | An object member.
LvalMember :: value -> Name -> ValueRef value
deriving (Eq, Ord, Show)

46
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,22 +101,19 @@ 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 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
@ -126,6 +122,30 @@ instance ( Members '[ Allocator location Type
bimap (Env.insert name a) (tvar :) <$> rest) (pure (emptyEnv, [])) names
(zeroOrMoreProduct tvars :->) <$> localEnv (mergeEnvs env) (body `catchReturn` \ (Return value) -> pure 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 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 params
let needed = zeroOrMoreProduct paramTypes :-> Var tvar
unified <- op `unify` needed
case unified of
_ :-> ret -> pure ret
gotten -> throwResumable (UnificationError needed gotten)
loop f = f empty

92
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 (Value location)
, Reader (Environment location (Value location))
, Reader (Environment location)
, Reader ModuleInfo
, Reader PackageInfo
, Resumable (ValueError location)
, Return (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 (Value location) ': effects) where
closure parameters freeVariables body = do
packageInfo <- currentPackage
moduleInfo <- currentModule
l <- label body
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
v <- param
a <- alloc name
assign a v
Env.insert name a <$> rest) (pure env) (zip names params)
localEnv (mergeEnvs bindings) (body `catchReturn` \ (Return value) -> pure value)
Nothing -> throwValueError (CallError op)
-- | Construct a 'Value' wrapping the value arguments (if any).
instance ( Members '[ Allocator location (Value location)
, LoopControl (Value location)
, Reader (Environment location)
, Reader ModuleInfo
, Reader PackageInfo
, Resumable (ValueError location)
, Return (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,27 +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
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
v <- param
a <- alloc name
assign a v
Env.insert name a <$> rest) (pure env) (zip names params)
localEnv (mergeEnvs bindings) (body `catchReturn` \ (Return value) -> pure value)
Nothing -> throwValueError (CallError op)
loop x = catchLoopControl (fix x) (\ control -> case control of
Break value -> pure 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.
@ -380,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)

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

54
src/Language/Haskell/Assignment.hs
View File

@ -9,18 +9,23 @@ module Language.Haskell.Assignment
import Assigning.Assignment hiding (Assignment, Error)
import Data.Record
import Data.Sum
import Data.Syntax (emptyTerm, handleError, parseError, makeTerm, contextualize, postContextualize)
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.FreeVariables as FV
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
@ -37,16 +42,26 @@ assignment :: Assignment
assignment = handleError $ module' <|> parseError
module' :: Assignment
module' = makeTerm <$> symbol Module <*> children (Syntax.Module <$> moduleIdentifier <*> pure [] <*> (where' <|> emptyTerm))
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 = [
constructorIdentifier
comment
, constructorIdentifier
, float
, functionDeclaration
, integer
, moduleIdentifier
, comment
, variableIdentifier
, where'
]
@ -56,11 +71,36 @@ 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 . FV.name <$> source)
constructorIdentifier = makeTerm <$> symbol ConstructorIdentifier <*> (Syntax.Identifier . Name.name <$> source)
moduleIdentifier :: Assignment
moduleIdentifier = makeTerm <$> symbol ModuleIdentifier <*> (Syntax.Identifier . FV.name <$> source)
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)

10
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
@ -445,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)
@ -651,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))
@ -712,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')
@ -748,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

@ -55,18 +55,17 @@ 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
)
=> Subterm term (Evaluator location value effects (ValueRef value))
-> (ModulePath -> Evaluator location value effects (Maybe (Environment location value, value)))
-> (ModulePath -> Evaluator location value effects (Maybe (Environment location, value)))
-> Evaluator location value effects (ValueRef 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
Rval <$> go (NonEmpty.zip (FV.name . BC.pack <$> qualifiedName) modulePaths)
eval (QualifiedImport qname@(QualifiedName qualifiedName)) = do
modulePaths <- resolvePythonModules qname
Rval <$> go (NonEmpty.zip (name . BC.pack <$> qualifiedName) modulePaths)
where
-- Evaluate and import the last module, updating the environment
go ((name, path) :| []) = evalQualifiedImport name path

2
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

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
)

2
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

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

5
src/Semantic/Graph.hs
View File

@ -112,9 +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
@ -130,7 +129,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/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

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)))))