mirror of
https://github.com/github/semantic.git
synced 2024-12-19 12:51:52 +03:00
Merge branch 'master' into docker-build-image
This commit is contained in:
Timothy Clem
GitHub
commit
d5a35836be
@ -11,198 +11,35 @@ import Data.Scientific (Scientific)
|
||||
import Data.Scientific.Exts
|
||||
import Data.Semigroup.Reducer
|
||||
import qualified Data.Set as Set
|
||||
import Data.Sum
|
||||
import Prologue hiding (TypeError, project)
|
||||
import Prelude hiding (Float, Integer, String, Rational)
|
||||
import qualified Prelude
|
||||
import Prologue
|
||||
|
||||
type ValueConstructors location
|
||||
= '[Array
|
||||
, Boolean
|
||||
, Class location
|
||||
, Closure location
|
||||
, Float
|
||||
, Hash
|
||||
, Integer
|
||||
, KVPair
|
||||
, Namespace location
|
||||
, Null
|
||||
, Rational
|
||||
, String
|
||||
, Symbol
|
||||
, Tuple
|
||||
, Unit
|
||||
, Hole
|
||||
]
|
||||
|
||||
-- | Open union of primitive values that terms can be evaluated to.
|
||||
-- Fix by another name.
|
||||
newtype Value location = Value (Sum (ValueConstructors location) (Value location))
|
||||
data Value location
|
||||
= Closure PackageInfo ModuleInfo [Name] Label (Environment location)
|
||||
| Unit
|
||||
| Boolean Bool
|
||||
| Integer (Number.Number Integer)
|
||||
| Rational (Number.Number Rational)
|
||||
| Float (Number.Number Scientific)
|
||||
| String ByteString
|
||||
| Symbol ByteString
|
||||
| Tuple [Value location]
|
||||
| Array [Value location]
|
||||
| Class Name (Environment location)
|
||||
| Namespace Name (Environment location)
|
||||
| KVPair (Value location) (Value location)
|
||||
| Hash [Value location]
|
||||
| Null
|
||||
| Hole
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
-- | Identical to 'inject', but wraps the resulting sub-entity in a 'Value'.
|
||||
injValue :: (f :< ValueConstructors location) => f (Value location) -> Value location
|
||||
injValue = Value . inject
|
||||
|
||||
-- | Identical to 'prj', but unwraps the argument out of its 'Value' wrapper.
|
||||
prjValue :: (f :< ValueConstructors location) => Value location -> Maybe (f (Value location))
|
||||
prjValue (Value v) = project v
|
||||
|
||||
-- | Convenience function for projecting two values.
|
||||
prjPair :: (f :< ValueConstructors location , g :< ValueConstructors location)
|
||||
=> (Value location, Value location)
|
||||
-> Maybe (f (Value location), g (Value location))
|
||||
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)
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq location => Eq1 (Closure location) where liftEq = genericLiftEq
|
||||
instance Ord location => Ord1 (Closure location) where liftCompare = genericLiftCompare
|
||||
instance Show location => Show1 (Closure location) where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- | The unit value. Typically used to represent the result of imperative statements.
|
||||
data Unit value = Unit
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Unit where liftEq = genericLiftEq
|
||||
instance Ord1 Unit where liftCompare = genericLiftCompare
|
||||
instance Show1 Unit where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
data Hole value = Hole
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Hole where liftEq = genericLiftEq
|
||||
instance Ord1 Hole where liftCompare = genericLiftCompare
|
||||
instance Show1 Hole where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- | Boolean values.
|
||||
newtype Boolean value = Boolean { getBoolean :: Bool }
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Boolean where liftEq = genericLiftEq
|
||||
instance Ord1 Boolean where liftCompare = genericLiftCompare
|
||||
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- | Arbitrary-width integral values.
|
||||
newtype Integer value = Integer (Number.Number Prelude.Integer)
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Integer where liftEq = genericLiftEq
|
||||
instance Ord1 Integer where liftCompare = genericLiftCompare
|
||||
instance Show1 Integer where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- | Arbitrary-width rational values values.
|
||||
newtype Rational value = Rational (Number.Number Prelude.Rational)
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Rational where liftEq = genericLiftEq
|
||||
instance Ord1 Rational where liftCompare = genericLiftCompare
|
||||
instance Show1 Rational where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- | String values.
|
||||
newtype String value = String ByteString
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 String where liftEq = genericLiftEq
|
||||
instance Ord1 String where liftCompare = genericLiftCompare
|
||||
instance Show1 String where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- | Possibly-interned Symbol values.
|
||||
-- TODO: Should this store a 'Text'?
|
||||
newtype Symbol value = Symbol ByteString
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Symbol where liftEq = genericLiftEq
|
||||
instance Ord1 Symbol where liftCompare = genericLiftCompare
|
||||
instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- | Float values.
|
||||
newtype Float value = Float (Number.Number Scientific)
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Float where liftEq = genericLiftEq
|
||||
instance Ord1 Float where liftCompare = genericLiftCompare
|
||||
instance Show1 Float where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- | Zero or more values. Fixed-size at interpretation time.
|
||||
-- TODO: Investigate whether we should use Vector for this.
|
||||
-- TODO: Should we have a Some type over a nonemmpty list? Or does this merit one?
|
||||
newtype Tuple value = Tuple [value]
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Tuple where liftEq = genericLiftEq
|
||||
instance Ord1 Tuple where liftCompare = genericLiftCompare
|
||||
instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- | Zero or more values. Dynamically resized as needed at interpretation time.
|
||||
-- TODO: Vector? Seq?
|
||||
newtype Array value = Array [value]
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Array where liftEq = genericLiftEq
|
||||
instance Ord1 Array where liftCompare = genericLiftCompare
|
||||
instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- | Class values. There will someday be a difference between classes and objects,
|
||||
-- but for the time being we're pretending all languages have prototypical inheritance.
|
||||
data Class location value = Class
|
||||
{ _className :: Name
|
||||
, _classScope :: Environment location
|
||||
} deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq location => Eq1 (Class location) where liftEq = genericLiftEq
|
||||
instance Ord location => Ord1 (Class location) where liftCompare = genericLiftCompare
|
||||
instance Show location => Show1 (Class location) where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
data Namespace location value = Namespace
|
||||
{ namespaceName :: Name
|
||||
, namespaceScope :: Environment location
|
||||
} deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq location => Eq1 (Namespace location) where liftEq = genericLiftEq
|
||||
instance Ord location => Ord1 (Namespace location) where liftCompare = genericLiftCompare
|
||||
instance Show location => Show1 (Namespace location) where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
data KVPair value = KVPair value value
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 KVPair where liftEq = genericLiftEq
|
||||
instance Ord1 KVPair where liftCompare = genericLiftCompare
|
||||
instance Show1 KVPair where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- You would think this would be a @Map value value@ or a @[(value, value)].
|
||||
-- You would be incorrect, as we can't derive a Generic1 instance for the above,
|
||||
-- and in addition a 'Map' representation would lose information given hash literals
|
||||
-- that assigned multiple values to one given key. Instead, this holds KVPair
|
||||
-- values. The smart constructor for hashes in 'AbstractValue' ensures that these are
|
||||
-- only populated with pairs.
|
||||
newtype Hash value = Hash [value]
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Hash where liftEq = genericLiftEq
|
||||
instance Ord1 Hash where liftCompare = genericLiftCompare
|
||||
instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
data Null value = Null
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Eq1 Null where liftEq = genericLiftEq
|
||||
instance Ord1 Null where liftCompare = genericLiftCompare
|
||||
instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
|
||||
instance Ord location => ValueRoots location (Value location) where
|
||||
valueRoots v
|
||||
| Just (Closure _ _ _ _ env) <- prjValue v = Env.addresses env
|
||||
| Closure _ _ _ _ env <- v = Env.addresses env
|
||||
| otherwise = mempty
|
||||
|
||||
|
||||
instance AbstractHole (Value location) where
|
||||
hole = injValue Hole
|
||||
hole = Hole
|
||||
|
||||
instance ( Members '[ Allocator location (Value location)
|
||||
, Reader (Environment location)
|
||||
@ -222,11 +59,11 @@ instance ( Members '[ Allocator location (Value location)
|
||||
packageInfo <- currentPackage
|
||||
moduleInfo <- currentModule
|
||||
l <- label body
|
||||
injValue . Closure packageInfo moduleInfo parameters l . Env.bind (foldr Set.delete freeVariables parameters) <$> getEnv
|
||||
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
|
||||
case op of
|
||||
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.
|
||||
@ -237,7 +74,7 @@ instance ( Members '[ Allocator location (Value location)
|
||||
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)
|
||||
_ -> throwValueError (CallError op)
|
||||
|
||||
|
||||
-- | Construct a 'Value' wrapping the value arguments (if any).
|
||||
@ -256,51 +93,51 @@ instance ( Members '[ Allocator location (Value location)
|
||||
, Show location
|
||||
)
|
||||
=> AbstractValue location (Value location) (Goto effects (Value location) ': effects) where
|
||||
unit = pure . injValue $ Unit
|
||||
integer = pure . injValue . Integer . Number.Integer
|
||||
boolean = pure . injValue . Boolean
|
||||
string = pure . injValue . String
|
||||
float = pure . injValue . Float . Number.Decimal
|
||||
symbol = pure . injValue . Symbol
|
||||
rational = pure . injValue . Rational . Number.Ratio
|
||||
unit = pure Unit
|
||||
integer = pure . Integer . Number.Integer
|
||||
boolean = pure . Boolean
|
||||
string = pure . String
|
||||
float = pure . Float . Number.Decimal
|
||||
symbol = pure . Symbol
|
||||
rational = pure . Rational . Number.Ratio
|
||||
|
||||
multiple = pure . injValue . Tuple
|
||||
array = pure . injValue . Array
|
||||
multiple = pure . Tuple
|
||||
array = pure . Array
|
||||
|
||||
kvPair k = pure . injValue . KVPair k
|
||||
kvPair k = pure . KVPair k
|
||||
|
||||
null = pure . injValue $ Null
|
||||
null = pure Null
|
||||
|
||||
asPair val
|
||||
| Just (KVPair k v) <- prjValue val = pure (k, v)
|
||||
| KVPair k v <- val = pure (k, v)
|
||||
| otherwise = throwValueError $ KeyValueError val
|
||||
|
||||
hash = pure . injValue . Hash . fmap (injValue . uncurry KVPair)
|
||||
hash = pure . Hash . map (uncurry KVPair)
|
||||
|
||||
klass n [] env = pure . injValue $ Class n env
|
||||
klass n [] env = pure $ Class n env
|
||||
klass n supers env = do
|
||||
product <- foldl mergeEnvs emptyEnv . catMaybes <$> traverse scopedEnvironment supers
|
||||
pure . injValue $ Class n (mergeEnvs product env)
|
||||
pure $ Class n (mergeEnvs product env)
|
||||
|
||||
namespace n env = do
|
||||
maybeAddr <- lookupEnv n
|
||||
env' <- maybe (pure emptyEnv) (asNamespaceEnv <=< deref) maybeAddr
|
||||
pure (injValue (Namespace n (Env.mergeNewer env' env)))
|
||||
pure (Namespace n (Env.mergeNewer env' env))
|
||||
where asNamespaceEnv v
|
||||
| Just (Namespace _ env') <- prjValue v = pure env'
|
||||
| Namespace _ env' <- v = pure env'
|
||||
| otherwise = throwValueError $ NamespaceError ("expected " <> show v <> " to be a namespace")
|
||||
|
||||
scopedEnvironment o
|
||||
| Just (Class _ env) <- prjValue o = pure (Just env)
|
||||
| Just (Namespace _ env) <- prjValue o = pure (Just env)
|
||||
| Class _ env <- o = pure (Just env)
|
||||
| Namespace _ env <- o = pure (Just env)
|
||||
| otherwise = pure Nothing
|
||||
|
||||
asString v
|
||||
| Just (String n) <- prjValue v = pure n
|
||||
| String n <- v = pure n
|
||||
| otherwise = throwValueError $ StringError v
|
||||
|
||||
ifthenelse cond if' else' = do
|
||||
bool <- maybe (throwValueError (BoolError cond)) (pure . getBoolean) (prjValue cond)
|
||||
bool <- case cond of { Boolean b -> pure b ; _ -> throwValueError (BoolError cond) }
|
||||
if bool then if' else else'
|
||||
|
||||
index = go where
|
||||
@ -308,26 +145,26 @@ instance ( Members '[ Allocator location (Value location)
|
||||
| ii > genericLength list = throwValueError (BoundsError list ii)
|
||||
| otherwise = pure (genericIndex list ii)
|
||||
go arr idx
|
||||
| (Just (Array arr, Integer (Number.Integer i))) <- prjPair (arr, idx) = tryIdx arr i
|
||||
| (Just (Tuple tup, Integer (Number.Integer i))) <- prjPair (arr, idx) = tryIdx tup i
|
||||
| (Array arr, Integer (Number.Integer i)) <- (arr, idx) = tryIdx arr i
|
||||
| (Tuple tup, Integer (Number.Integer i)) <- (arr, idx) = tryIdx tup i
|
||||
| otherwise = throwValueError (IndexError arr idx)
|
||||
|
||||
liftNumeric f arg
|
||||
| Just (Integer (Number.Integer i)) <- prjValue arg = integer $ f i
|
||||
| Just (Float (Number.Decimal d)) <- prjValue arg = float $ f d
|
||||
| Just (Rational (Number.Ratio r)) <- prjValue arg = rational $ f r
|
||||
| Integer (Number.Integer i) <- arg = integer $ f i
|
||||
| Float (Number.Decimal d) <- arg = float $ f d
|
||||
| Rational (Number.Ratio r) <- arg = rational $ f r
|
||||
| otherwise = throwValueError (NumericError arg)
|
||||
|
||||
liftNumeric2 f left right
|
||||
| Just (Integer i, Integer j) <- prjPair pair = tentative f i j & specialize
|
||||
| Just (Integer i, Rational j) <- prjPair pair = tentative f i j & specialize
|
||||
| Just (Integer i, Float j) <- prjPair pair = tentative f i j & specialize
|
||||
| Just (Rational i, Integer j) <- prjPair pair = tentative f i j & specialize
|
||||
| Just (Rational i, Rational j) <- prjPair pair = tentative f i j & specialize
|
||||
| Just (Rational i, Float j) <- prjPair pair = tentative f i j & specialize
|
||||
| Just (Float i, Integer j) <- prjPair pair = tentative f i j & specialize
|
||||
| Just (Float i, Rational j) <- prjPair pair = tentative f i j & specialize
|
||||
| Just (Float i, Float j) <- prjPair pair = tentative f i j & specialize
|
||||
| (Integer i, Integer j) <- pair = tentative f i j & specialize
|
||||
| (Integer i, Rational j) <- pair = tentative f i j & specialize
|
||||
| (Integer i, Float j) <- pair = tentative f i j & specialize
|
||||
| (Rational i, Integer j) <- pair = tentative f i j & specialize
|
||||
| (Rational i, Rational j) <- pair = tentative f i j & specialize
|
||||
| (Rational i, Float j) <- pair = tentative f i j & specialize
|
||||
| (Float i, Integer j) <- pair = tentative f i j & specialize
|
||||
| (Float i, Rational j) <- pair = tentative f i j & specialize
|
||||
| (Float i, Float j) <- pair = tentative f i j & specialize
|
||||
| otherwise = throwValueError (Numeric2Error left right)
|
||||
where
|
||||
tentative x i j = attemptUnsafeArithmetic (x i j)
|
||||
@ -341,13 +178,13 @@ instance ( Members '[ Allocator location (Value location)
|
||||
pair = (left, right)
|
||||
|
||||
liftComparison comparator left right
|
||||
| Just (Integer (Number.Integer i), Integer (Number.Integer j)) <- prjPair pair = go i j
|
||||
| Just (Integer (Number.Integer i), Float (Number.Decimal j)) <- prjPair pair = go (fromIntegral i) j
|
||||
| Just (Float (Number.Decimal i), Integer (Number.Integer j)) <- prjPair pair = go i (fromIntegral j)
|
||||
| Just (Float (Number.Decimal i), Float (Number.Decimal j)) <- prjPair pair = go i j
|
||||
| Just (String i, String j) <- prjPair pair = go i j
|
||||
| Just (Boolean i, Boolean j) <- prjPair pair = go i j
|
||||
| Just (Unit, Unit) <- prjPair pair = boolean True
|
||||
| (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = go i j
|
||||
| (Integer (Number.Integer i), Float (Number.Decimal j)) <- pair = go (fromIntegral i) j
|
||||
| (Float (Number.Decimal i), Integer (Number.Integer j)) <- pair = go i (fromIntegral j)
|
||||
| (Float (Number.Decimal i), Float (Number.Decimal j)) <- pair = go i j
|
||||
| (String i, String j) <- pair = go i j
|
||||
| (Boolean i, Boolean j) <- pair = go i j
|
||||
| (Unit, Unit) <- pair = boolean True
|
||||
| otherwise = throwValueError (ComparisonError left right)
|
||||
where
|
||||
-- Explicit type signature is necessary here because we're passing all sorts of things
|
||||
@ -365,11 +202,11 @@ instance ( Members '[ Allocator location (Value location)
|
||||
|
||||
|
||||
liftBitwise operator target
|
||||
| Just (Integer (Number.Integer i)) <- prjValue target = integer $ operator i
|
||||
| Integer (Number.Integer i) <- target = integer $ operator i
|
||||
| otherwise = throwValueError (BitwiseError target)
|
||||
|
||||
liftBitwise2 operator left right
|
||||
| Just (Integer (Number.Integer i), Integer (Number.Integer j)) <- prjPair pair = integer $ operator i j
|
||||
| (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = integer $ operator i j
|
||||
| otherwise = throwValueError (Bitwise2Error left right)
|
||||
where pair = (left, right)
|
||||
|
||||
|
||||
@ -7,7 +7,10 @@ module Parsing.TreeSitter
|
||||
import Prologue
|
||||
|
||||
import Control.Concurrent.Async
|
||||
import Control.Monad
|
||||
import Control.Exception (throwIO)
|
||||
import Control.Monad.Effect
|
||||
import Control.Monad.Effect.Trace
|
||||
import Control.Monad.IO.Class
|
||||
import Data.AST (AST, Node (Node))
|
||||
import Data.Blob
|
||||
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
|
||||
@ -18,6 +21,7 @@ import Data.Term
|
||||
import Foreign
|
||||
import Foreign.C.Types (CBool (..))
|
||||
import Foreign.Marshal.Array (allocaArray)
|
||||
import Semantic.IO hiding (Source)
|
||||
import System.Timeout
|
||||
|
||||
import qualified TreeSitter.Language as TS
|
||||
@ -27,50 +31,65 @@ import qualified TreeSitter.Tree as TS
|
||||
|
||||
newtype Timeout = Milliseconds Int
|
||||
|
||||
-- Change this to putStrLn if you want to debug the locking/cancellation code.
|
||||
-- TODO: Someday we should run this all in Eff so that we can 'trace'.
|
||||
dbg :: String -> IO ()
|
||||
dbg = const (pure ())
|
||||
data Result grammar
|
||||
= Failed
|
||||
| Succeeded (AST [] grammar)
|
||||
|
||||
runParser :: (Enum grammar, Bounded grammar) => Ptr TS.Parser -> Source -> IO (Maybe (AST [] grammar))
|
||||
runParser parser blobSource = unsafeUseAsCStringLen (sourceBytes blobSource) $ \ (source, len) ->
|
||||
runParser :: (Enum grammar, Bounded grammar) => Ptr TS.Parser -> Source -> IO (Result grammar)
|
||||
runParser parser blobSource = unsafeUseAsCStringLen (sourceBytes blobSource) $ \ (source, len) -> do
|
||||
alloca (\ rootPtr -> do
|
||||
let acquire = do
|
||||
dbg "Starting parse"
|
||||
-- Change this to TS.ts_parser_loop_until_cancelled if you want to test out cancellation
|
||||
TS.ts_parser_parse_string parser nullPtr source len
|
||||
|
||||
let release t
|
||||
| t == nullPtr = dbg "Parse failed"
|
||||
| otherwise = dbg "Parse completed" *> TS.ts_tree_delete t
|
||||
| t == nullPtr = pure ()
|
||||
| otherwise = TS.ts_tree_delete t
|
||||
|
||||
let go treePtr = do
|
||||
if treePtr == nullPtr
|
||||
then pure Nothing
|
||||
then pure Failed
|
||||
else do
|
||||
TS.ts_tree_root_node_p treePtr rootPtr
|
||||
fmap Just (peek rootPtr >>= anaM toAST)
|
||||
ptr <- peek rootPtr
|
||||
Succeeded <$> anaM toAST ptr
|
||||
bracket acquire release go)
|
||||
|
||||
-- | The semantics of @bracket before after handler@ are as follows:
|
||||
-- * Exceptions in @before@ and @after@ are thrown in IO.
|
||||
-- * @after@ is called on IO exceptions in @handler@, and then rethrown in IO.
|
||||
-- * If @handler@ completes successfully, @after@ is called
|
||||
-- Call 'catchException' at the call site if you want to recover.
|
||||
bracket' :: (Member IO r) => IO a -> (a -> IO b) -> (a -> Eff r c) -> Eff r c
|
||||
bracket' before after action = do
|
||||
a <- liftIO before
|
||||
let cleanup = liftIO (after a)
|
||||
res <- action a `catchException` (\(e :: SomeException) -> cleanup >> liftIO (throwIO e))
|
||||
res <$ cleanup
|
||||
|
||||
-- | Parse 'Source' with the given 'TS.Language' and return its AST.
|
||||
-- Returns Nothing if the operation timed out.
|
||||
parseToAST :: (Bounded grammar, Enum grammar) => Timeout -> Ptr TS.Language -> Blob -> IO (Maybe (AST [] grammar))
|
||||
parseToAST (Milliseconds s) language Blob{..} = bracket TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do
|
||||
parseToAST :: (Bounded grammar, Enum grammar, Members '[Trace, IO] effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar))
|
||||
parseToAST (Milliseconds s) language Blob{..} = bracket' TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do
|
||||
let parserTimeout = s * 1000
|
||||
|
||||
liftIO $ do
|
||||
TS.ts_parser_halt_on_error parser (CBool 1)
|
||||
TS.ts_parser_set_language parser language
|
||||
|
||||
parsing <- async (runParser parser blobSource)
|
||||
trace "tree-sitter: beginning parsing"
|
||||
|
||||
parsing <- liftIO . async $ runParser parser blobSource
|
||||
|
||||
-- Kick the parser off asynchronously and wait according to the provided timeout.
|
||||
res <- timeout parserTimeout (wait parsing)
|
||||
res <- liftIO . timeout parserTimeout $ wait parsing
|
||||
|
||||
-- If we get a Nothing back, then we failed, so we need to disable the parser, which
|
||||
-- will let the call to runParser terminate, cleaning up appropriately
|
||||
when (isNothing res) (TS.ts_parser_set_enabled parser (CBool 0))
|
||||
|
||||
pure (join res)
|
||||
case res of
|
||||
Just Failed -> Nothing <$ trace "tree-sitter: parsing failed"
|
||||
Just (Succeeded ast) -> Just ast <$ trace "tree-sitter: parsing succeeded"
|
||||
Nothing -> do
|
||||
trace "tree-sitter: parsing timed out"
|
||||
Nothing <$ liftIO (TS.ts_parser_set_enabled parser (CBool 0))
|
||||
|
||||
|
||||
toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node)
|
||||
|
||||
@ -1,34 +1,35 @@
|
||||
{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
|
||||
module Semantic.IO
|
||||
( readFile
|
||||
, readFilePair
|
||||
, isDirectory
|
||||
, readBlobPairsFromHandle
|
||||
, readBlobsFromHandle
|
||||
, readProjectFromPaths
|
||||
, readBlobsFromDir
|
||||
, findFiles
|
||||
, languageForFilePath
|
||||
, NoLanguageForBlob(..)
|
||||
, noLanguageForBlob
|
||||
, readBlob
|
||||
, readBlobs
|
||||
, readBlobPairs
|
||||
, readProject
|
||||
, findFilesInDir
|
||||
, write
|
||||
( Destination(..)
|
||||
, Files
|
||||
, Handle(..)
|
||||
, getHandle
|
||||
, IO.IOMode(..)
|
||||
, NoLanguageForBlob(..)
|
||||
, Source(..)
|
||||
, catchException
|
||||
, findFiles
|
||||
, findFilesInDir
|
||||
, getHandle
|
||||
, isDirectory
|
||||
, languageForFilePath
|
||||
, noLanguageForBlob
|
||||
, openFileForReading
|
||||
, readBlob
|
||||
, readBlobPairs
|
||||
, readBlobPairsFromHandle
|
||||
, readBlobs
|
||||
, readBlobsFromDir
|
||||
, readBlobsFromHandle
|
||||
, readFile
|
||||
, readFilePair
|
||||
, readProject
|
||||
, readProjectFromPaths
|
||||
, rethrowing
|
||||
, runFiles
|
||||
, stderr
|
||||
, stdin
|
||||
, stdout
|
||||
, stderr
|
||||
, openFileForReading
|
||||
, Source(..)
|
||||
, Destination(..)
|
||||
, Files
|
||||
, runFiles
|
||||
, rethrowing
|
||||
, write
|
||||
) where
|
||||
|
||||
import qualified Control.Exception as Exc
|
||||
|
||||
@ -195,7 +195,7 @@ runParser :: Members '[Reader Options, Telemetry, Exc SomeException, IO, Trace]
|
||||
runParser blob@Blob{..} parser = case parser of
|
||||
ASTParser language ->
|
||||
time "parse.tree_sitter_ast_parse" languageTag $
|
||||
IO.rethrowing (parseToAST defaultTimeout language blob)
|
||||
parseToAST defaultTimeout language blob
|
||||
>>= maybeM (throwError (SomeException ParserTimedOut))
|
||||
|
||||
AssignmentParser parser assignment -> do
|
||||
|
||||
@ -37,14 +37,14 @@ spec = parallel $ do
|
||||
|
||||
it "subclasses" $ do
|
||||
((res, _), _) <- evaluate "subclass.py"
|
||||
res `shouldBe` Right [injValue (String "\"bar\"")]
|
||||
res `shouldBe` Right [String "\"bar\""]
|
||||
|
||||
it "handles multiple inheritance left-to-right" $ do
|
||||
((res, _), _) <- evaluate "multiple_inheritance.py"
|
||||
res `shouldBe` Right [injValue (String "\"foo!\"")]
|
||||
res `shouldBe` Right [String "\"foo!\""]
|
||||
|
||||
where
|
||||
ns n = Just . Latest . Last . Just . injValue . Namespace n
|
||||
ns n = Just . Latest . Last . Just . Namespace n
|
||||
addr = Address . Precise
|
||||
fixtures = "test/fixtures/python/analysis/"
|
||||
evaluate entry = evalPythonProject (fixtures <> entry)
|
||||
|
||||
@ -22,7 +22,7 @@ spec = parallel $ do
|
||||
describe "Ruby" $ do
|
||||
it "evaluates require_relative" $ do
|
||||
((res, state), _) <- evaluate "main.rb"
|
||||
res `shouldBe` Right [injValue (Value.Integer (Number.Integer 1))]
|
||||
res `shouldBe` Right [Value.Integer (Number.Integer 1)]
|
||||
Env.names (environment state) `shouldContain` ["foo"]
|
||||
|
||||
it "evaluates load" $ do
|
||||
@ -36,47 +36,47 @@ spec = parallel $ do
|
||||
|
||||
it "evaluates subclass" $ do
|
||||
((res, state), _) <- evaluate "subclass.rb"
|
||||
res `shouldBe` Right [injValue (String "\"<bar>\"")]
|
||||
res `shouldBe` Right [String "\"<bar>\""]
|
||||
Env.names (environment state) `shouldContain` [ "Bar", "Foo" ]
|
||||
|
||||
(derefQName (heap state) ("Bar" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"])
|
||||
|
||||
it "evaluates modules" $ do
|
||||
((res, state), _) <- evaluate "modules.rb"
|
||||
res `shouldBe` Right [injValue (String "\"<hello>\"")]
|
||||
res `shouldBe` Right [String "\"<hello>\""]
|
||||
Env.names (environment state) `shouldContain` [ "Bar" ]
|
||||
|
||||
it "handles break correctly" $ do
|
||||
((res, _), _) <- evaluate "break.rb"
|
||||
res `shouldBe` Right [injValue (Value.Integer (Number.Integer 3))]
|
||||
res `shouldBe` Right [Value.Integer (Number.Integer 3)]
|
||||
|
||||
it "handles break correctly" $ do
|
||||
((res, _), _) <- evaluate "next.rb"
|
||||
res `shouldBe` Right [injValue (Value.Integer (Number.Integer 8))]
|
||||
res `shouldBe` Right [Value.Integer (Number.Integer 8)]
|
||||
|
||||
it "calls functions with arguments" $ do
|
||||
((res, _), _) <- evaluate "call.rb"
|
||||
res `shouldBe` Right [injValue (Value.Integer (Number.Integer 579))]
|
||||
res `shouldBe` Right [Value.Integer (Number.Integer 579)]
|
||||
|
||||
it "evaluates early return statements" $ do
|
||||
((res, _), _) <- evaluate "early-return.rb"
|
||||
res `shouldBe` Right [injValue (Value.Integer (Number.Integer 123))]
|
||||
res `shouldBe` Right [Value.Integer (Number.Integer 123)]
|
||||
|
||||
it "has prelude" $ do
|
||||
((res, _), _) <- evaluate "preluded.rb"
|
||||
res `shouldBe` Right [injValue (String "\"<foo>\"")]
|
||||
res `shouldBe` Right [String "\"<foo>\""]
|
||||
|
||||
it "evaluates __LINE__" $ do
|
||||
((res, _), _) <- evaluate "line.rb"
|
||||
res `shouldBe` Right [injValue (Value.Integer (Number.Integer 4))]
|
||||
res `shouldBe` Right [Value.Integer (Number.Integer 4)]
|
||||
|
||||
it "resolves builtins used in the prelude" $ do
|
||||
((res, _), traces) <- evaluate "puts.rb"
|
||||
res `shouldBe` Right [injValue Unit]
|
||||
res `shouldBe` Right [Unit]
|
||||
traces `shouldContain` [ "\"hello\"" ]
|
||||
|
||||
where
|
||||
ns n = Just . Latest . Last . Just . injValue . Namespace n
|
||||
ns n = Just . Latest . Last . Just . Namespace n
|
||||
addr = Address . Precise
|
||||
fixtures = "test/fixtures/ruby/analysis/"
|
||||
evaluate entry = evalRubyProject (fixtures <> entry)
|
||||
|
||||
@ -36,7 +36,7 @@ spec = parallel $ do
|
||||
|
||||
it "evaluates early return statements" $ do
|
||||
((res, _), _) <- evaluate "early-return.ts"
|
||||
res `shouldBe` Right [injValue (Value.Float (Number.Decimal 123.0))]
|
||||
res `shouldBe` Right [Value.Float (Number.Decimal 123.0)]
|
||||
|
||||
where
|
||||
fixtures = "test/fixtures/typescript/analysis/"
|
||||
|
||||
@ -20,13 +20,13 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
it "constructs integers" $ do
|
||||
(expected, _) <- evaluate (integer 123)
|
||||
expected `shouldBe` Right (injValue (Value.Integer (Number.Integer 123)))
|
||||
expected `shouldBe` Right (Value.Integer (Number.Integer 123))
|
||||
|
||||
it "calls functions" $ do
|
||||
(expected, _) <- evaluate $ do
|
||||
identity <- closure [name "x"] lowerBound (variable (name "x"))
|
||||
call identity [integer 123]
|
||||
expected `shouldBe` Right (injValue (Value.Integer (Number.Integer 123)))
|
||||
expected `shouldBe` Right (Value.Integer (Number.Integer 123))
|
||||
|
||||
evaluate
|
||||
= runM
|
||||
|
||||
@ -24,7 +24,7 @@ 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.Abstract.Value (Value(..), ValueError, runValueError)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Blob as X
|
||||
import Data.ByteString.Builder (toLazyByteString)
|
||||
@ -92,13 +92,18 @@ testEvaluating
|
||||
. runTermEvaluator @_ @Precise
|
||||
|
||||
deNamespace :: Value Precise -> Maybe (Name, [Name])
|
||||
deNamespace = fmap (namespaceName &&& Env.names . namespaceScope) . prjValue @(Namespace Precise)
|
||||
deNamespace (Namespace name scope) = Just (name, Env.names scope)
|
||||
deNamespace _ = Nothing
|
||||
|
||||
namespaceScope :: Value Precise -> Maybe (Environment Precise)
|
||||
namespaceScope (Namespace _ scope) = Just scope
|
||||
namespaceScope _ = Nothing
|
||||
|
||||
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
|
||||
(n2 : ns) -> fmap namespaceScope . prjValue @(Namespace Precise) >=> go (n2 :| ns)
|
||||
(n2 : ns) -> namespaceScope >=> go (n2 :| ns)
|
||||
|
||||
newtype Verbatim = Verbatim ByteString
|
||||
deriving (Eq)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user