mirror of
https://github.com/github/semantic.git
synced 2024-11-24 00:42:33 +03:00
Merge branch 'master' into telemetry-and-config
This commit is contained in:
Rob Rix
GitHub
commit
116bbb99c4
@ -63,6 +63,9 @@ module Assigning.Assignment
|
||||
( Assignment
|
||||
, Location
|
||||
-- Combinators
|
||||
, branchNode
|
||||
, leafNode
|
||||
, toTerm
|
||||
, Alternative(..)
|
||||
, MonadError(..)
|
||||
, MonadFail(..)
|
||||
@ -110,6 +113,21 @@ import Data.Text.Encoding (decodeUtf8')
|
||||
import Text.Parser.Combinators as Parsers hiding (choice)
|
||||
import TreeSitter.Language
|
||||
|
||||
-- | Match a branch node, matching its children with the supplied 'Assignment' & returning the result.
|
||||
branchNode :: (Enum grammar, Ix grammar) => grammar -> Assignment ast grammar a -> Assignment ast grammar a
|
||||
branchNode sym child = symbol sym *> children child
|
||||
|
||||
-- | Match a leaf node, returning the corresponding 'Text'.
|
||||
leafNode :: (Enum grammar, Ix grammar) => grammar -> Assignment ast grammar Text
|
||||
leafNode sym = symbol sym *> source
|
||||
|
||||
-- | Wrap an 'Assignment' producing @syntax@ up into an 'Assignment' producing 'Term's.
|
||||
toTerm :: Element syntax syntaxes
|
||||
=> Assignment ast grammar (syntax (Term (Sum syntaxes) (Record Location)))
|
||||
-> Assignment ast grammar (Term (Sum syntaxes) (Record Location))
|
||||
toTerm syntax = termIn <$> location <*> (inject <$> syntax)
|
||||
|
||||
|
||||
-- | Assignment from an AST with some set of 'symbol's onto some other value.
|
||||
--
|
||||
-- This is essentially a parser.
|
||||
|
||||
@ -73,9 +73,6 @@ class Show value => AbstractIntro value where
|
||||
-- | Construct a rational value.
|
||||
rational :: Rational -> value
|
||||
|
||||
-- | Construct an N-ary tuple of multiple (possibly-disjoint) values
|
||||
multiple :: [value] -> value
|
||||
|
||||
-- | Construct a key-value pair for use in a hash.
|
||||
kvPair :: value -> value -> value
|
||||
|
||||
@ -114,8 +111,11 @@ class (AbstractFunction address value effects, AbstractIntro value) => AbstractV
|
||||
liftBitwise2 :: (forall a . (Integral a, Bits a) => a -> a -> a)
|
||||
-> (value -> value -> Evaluator address value effects value)
|
||||
|
||||
-- | Construct an N-ary tuple of multiple (possibly-disjoint) values
|
||||
tuple :: [address] -> Evaluator address value effects value
|
||||
|
||||
-- | Construct an array of zero or more values.
|
||||
array :: [value] -> Evaluator address value effects value
|
||||
array :: [address] -> Evaluator address value effects value
|
||||
|
||||
-- | Extract the contents of a key-value pair as a tuple.
|
||||
asPair :: value -> Evaluator address value effects (value, value)
|
||||
@ -127,7 +127,7 @@ class (AbstractFunction address value effects, AbstractIntro value) => AbstractV
|
||||
ifthenelse :: value -> Evaluator address value effects a -> Evaluator address value effects a -> Evaluator address value effects a
|
||||
|
||||
-- | @index x i@ computes @x[i]@, with zero-indexing.
|
||||
index :: value -> value -> Evaluator address value effects value
|
||||
index :: value -> value -> Evaluator address value effects address
|
||||
|
||||
-- | Build a class value from a name and environment.
|
||||
klass :: Name -- ^ The new class's identifier
|
||||
|
||||
@ -108,7 +108,6 @@ instance AbstractIntro Type where
|
||||
float _ = Float
|
||||
symbol _ = Symbol
|
||||
rational _ = Rational
|
||||
multiple = zeroOrMoreProduct
|
||||
hash = Hash
|
||||
kvPair k v = k :* v
|
||||
|
||||
@ -151,7 +150,10 @@ instance ( Member (Allocator address Type) effects
|
||||
=> AbstractValue address Type effects where
|
||||
array fields = do
|
||||
var <- fresh
|
||||
Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fields
|
||||
fieldTypes <- traverse deref fields
|
||||
Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes
|
||||
|
||||
tuple fields = zeroOrMoreProduct <$> traverse deref fields
|
||||
|
||||
klass _ _ _ = pure Object
|
||||
namespace _ _ = pure Unit
|
||||
@ -167,7 +169,8 @@ instance ( Member (Allocator address Type) effects
|
||||
index arr sub = do
|
||||
_ <- unify sub Int
|
||||
field <- fresh
|
||||
Var field <$ unify (Array (Var field)) arr
|
||||
_ <- unify (Array (Var field)) arr
|
||||
box (Var field)
|
||||
|
||||
ifthenelse cond if' else' = unify cond Bool *> (if' <|> else')
|
||||
|
||||
|
||||
@ -22,8 +22,8 @@ data Value address body
|
||||
| Float (Number.Number Scientific)
|
||||
| String Text
|
||||
| Symbol Text
|
||||
| Tuple [Value address body]
|
||||
| Array [Value address body]
|
||||
| Tuple [address]
|
||||
| Array [address]
|
||||
| Class Name (Environment address)
|
||||
| Namespace Name (Environment address)
|
||||
| KVPair (Value address body) (Value address body)
|
||||
@ -92,8 +92,6 @@ instance Show address => AbstractIntro (Value address body) where
|
||||
symbol = Symbol
|
||||
rational = Rational . Number.Ratio
|
||||
|
||||
multiple = Tuple
|
||||
|
||||
kvPair = KVPair
|
||||
hash = Hash . map (uncurry KVPair)
|
||||
|
||||
@ -117,7 +115,8 @@ instance ( Coercible body (Eff effects)
|
||||
| KVPair k v <- val = pure (k, v)
|
||||
| otherwise = throwValueError $ KeyValueError val
|
||||
|
||||
array = pure . Array
|
||||
tuple = pure . Tuple
|
||||
array = pure . Array
|
||||
|
||||
klass n [] env = pure $ Class n env
|
||||
klass n supers env = do
|
||||
@ -147,12 +146,12 @@ instance ( Coercible body (Eff effects)
|
||||
|
||||
index = go where
|
||||
tryIdx list ii
|
||||
| ii > genericLength list = throwValueError (BoundsError list ii)
|
||||
| ii > genericLength list = box =<< throwValueError (BoundsError list ii)
|
||||
| otherwise = pure (genericIndex list ii)
|
||||
go arr idx
|
||||
| (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)
|
||||
| otherwise = box =<< throwValueError (IndexError arr idx)
|
||||
|
||||
liftNumeric f arg
|
||||
| Integer (Number.Integer i) <- arg = pure . integer $ f i
|
||||
@ -237,7 +236,7 @@ data ValueError address body resume where
|
||||
-- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching.
|
||||
ArithmeticError :: ArithException -> ValueError address body (Value address body)
|
||||
-- Out-of-bounds error
|
||||
BoundsError :: [Value address body] -> Prelude.Integer -> ValueError address body (Value address body)
|
||||
BoundsError :: [address] -> Prelude.Integer -> ValueError address body (Value address body)
|
||||
|
||||
|
||||
instance Eq address => Eq1 (ValueError address body) where
|
||||
|
||||
@ -26,81 +26,81 @@ import Data.Char (toLower)
|
||||
-- Combinators
|
||||
|
||||
-- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children.
|
||||
makeTerm :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => a -> f (Term (Sum fs) a) -> Term (Sum fs) a
|
||||
makeTerm a = makeTerm' a . inject
|
||||
makeTerm :: (HasCallStack, Element syntax syntaxes, Semigroup ann, Apply Foldable syntaxes) => ann -> syntax (Term (Sum syntaxes) ann) -> Term (Sum syntaxes) ann
|
||||
makeTerm ann = makeTerm' ann . inject
|
||||
|
||||
-- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children.
|
||||
makeTerm' :: (HasCallStack, Semigroup a, Foldable f) => a -> f (Term f a) -> Term f a
|
||||
makeTerm' a f = termIn (sconcat (a :| (termAnnotation <$> toList f))) f
|
||||
makeTerm' :: (HasCallStack, Semigroup ann, Foldable syntax) => ann -> syntax (Term syntax ann) -> Term syntax ann
|
||||
makeTerm' ann syntax = termIn (sconcat (ann :| (termAnnotation <$> toList syntax))) syntax
|
||||
|
||||
-- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children. Removes extra structure if term is a list of a single item.
|
||||
makeTerm'' :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs, Foldable f) => a -> f (Term (Sum fs) a) -> Term (Sum fs) a
|
||||
makeTerm'' a children = case toList children of
|
||||
makeTerm'' :: (HasCallStack, Element syntax syntaxes, Semigroup ann, Apply Foldable syntaxes, Foldable syntax) => ann -> syntax (Term (Sum syntaxes) ann) -> Term (Sum syntaxes) ann
|
||||
makeTerm'' ann children = case toList children of
|
||||
[x] -> x
|
||||
_ -> makeTerm' a (inject children)
|
||||
_ -> makeTerm' ann (inject children)
|
||||
|
||||
-- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation.
|
||||
makeTerm1 :: (HasCallStack, f :< fs, Semigroup a, Apply Foldable fs) => f (Term (Sum fs) a) -> Term (Sum fs) a
|
||||
makeTerm1 :: (HasCallStack, Element syntax syntaxes, Semigroup ann, Apply Foldable syntaxes) => syntax (Term (Sum syntaxes) ann) -> Term (Sum syntaxes) ann
|
||||
makeTerm1 = makeTerm1' . inject
|
||||
|
||||
-- | Lift a non-empty union into a term, appending all subterms’.annotations to make the new term’s annotation.
|
||||
makeTerm1' :: (HasCallStack, Semigroup a, Foldable f) => f (Term f a) -> Term f a
|
||||
makeTerm1' f = case toList f of
|
||||
a : _ -> makeTerm' (termAnnotation a) f
|
||||
-- | Lift a non-empty union into a term, appending all subterms’ annotations to make the new term’s annotation.
|
||||
makeTerm1' :: (HasCallStack, Semigroup ann, Foldable syntax) => syntax (Term syntax ann) -> Term syntax ann
|
||||
makeTerm1' syntax = case toList syntax of
|
||||
a : _ -> makeTerm' (termAnnotation a) syntax
|
||||
_ -> error "makeTerm1': empty structure"
|
||||
|
||||
-- | Construct an empty term at the current position.
|
||||
emptyTerm :: (HasCallStack, Empty :< fs, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Sum fs) (Record Location))
|
||||
emptyTerm :: (HasCallStack, Empty :< syntaxes, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location))
|
||||
emptyTerm = makeTerm . startLocation <$> Assignment.location <*> pure Empty
|
||||
where startLocation ann = Range (start (getField ann)) (start (getField ann)) :. Span (spanStart (getField ann)) (spanStart (getField ann)) :. Nil
|
||||
|
||||
-- | Catch assignment errors into an error term.
|
||||
handleError :: (HasCallStack, Error :< fs, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Sum fs) (Record Location)) -> Assignment.Assignment ast grammar (Term (Sum fs) (Record Location))
|
||||
handleError :: (HasCallStack, Error :< syntaxes, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location)) -> Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location))
|
||||
handleError = flip catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source)
|
||||
|
||||
-- | Catch parse errors into an error term.
|
||||
parseError :: (HasCallStack, Error :< fs, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable fs) => Assignment.Assignment ast grammar (Term (Sum fs) (Record Location))
|
||||
parseError :: (HasCallStack, Error :< syntaxes, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location))
|
||||
parseError = makeTerm <$> Assignment.token maxBound <*> pure (Error (ErrorStack (getCallStack (freezeCallStack callStack))) [] (Just "ParseError") [])
|
||||
|
||||
|
||||
-- | Match context terms before a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.
|
||||
contextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
|
||||
=> m (Term (Sum fs) a)
|
||||
-> m (Term (Sum fs) a)
|
||||
-> m (Term (Sum fs) a)
|
||||
contextualize :: (HasCallStack, Context :< syntaxes, Alternative m, Semigroup ann, Apply Foldable syntaxes)
|
||||
=> m (Term (Sum syntaxes) ann)
|
||||
-> m (Term (Sum syntaxes) ann)
|
||||
-> m (Term (Sum syntaxes) ann)
|
||||
contextualize context rule = make <$> Assignment.manyThrough context rule
|
||||
where make (cs, node) = case nonEmpty cs of
|
||||
Just cs -> makeTerm1 (Context cs node)
|
||||
_ -> node
|
||||
|
||||
-- | Match context terms after a subject term and before a delimiter, returning the delimiter paired with a Context term if any context terms matched, or the subject term otherwise.
|
||||
postContextualizeThrough :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
|
||||
=> m (Term (Sum fs) a)
|
||||
-> m (Term (Sum fs) a)
|
||||
-> m b
|
||||
-> m (Term (Sum fs) a, b)
|
||||
postContextualizeThrough :: (HasCallStack, Context :< syntaxes, Alternative m, Semigroup ann, Apply Foldable syntaxes)
|
||||
=> m (Term (Sum syntaxes) ann)
|
||||
-> m (Term (Sum syntaxes) ann)
|
||||
-> m delimiter
|
||||
-> m (Term (Sum syntaxes) ann, delimiter)
|
||||
postContextualizeThrough context rule end = make <$> rule <*> Assignment.manyThrough context end
|
||||
where make node (cs, end) = case nonEmpty cs of
|
||||
Just cs -> (makeTerm1 (Context cs node), end)
|
||||
_ -> (node, end)
|
||||
|
||||
-- | Match context terms after a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.
|
||||
postContextualize :: (HasCallStack, Context :< fs, Alternative m, Semigroup a, Apply Foldable fs)
|
||||
=> m (Term (Sum fs) a)
|
||||
-> m (Term (Sum fs) a)
|
||||
-> m (Term (Sum fs) a)
|
||||
postContextualize :: (HasCallStack, Context :< syntaxes, Alternative m, Semigroup ann, Apply Foldable syntaxes)
|
||||
=> m (Term (Sum syntaxes) ann)
|
||||
-> m (Term (Sum syntaxes) ann)
|
||||
-> m (Term (Sum syntaxes) ann)
|
||||
postContextualize context rule = make <$> rule <*> many context
|
||||
where make node cs = case nonEmpty cs of
|
||||
Just cs -> makeTerm1 (Context cs node)
|
||||
_ -> node
|
||||
|
||||
-- | Match infix terms separated by any of a list of operators, with optional context terms following each operand.
|
||||
infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack, Apply Foldable fs)
|
||||
=> m (Term (Sum fs) a)
|
||||
-> m (Term (Sum fs) a)
|
||||
-> m (Term (Sum fs) a)
|
||||
-> [m (Term (Sum fs) a -> Term (Sum fs) a -> Sum fs (Term (Sum fs) a))]
|
||||
-> m (Sum fs (Term (Sum fs) a))
|
||||
infixContext :: (Context :< syntaxes, Assignment.Parsing m, Semigroup ann, HasCallStack, Apply Foldable syntaxes)
|
||||
=> m (Term (Sum syntaxes) ann)
|
||||
-> m (Term (Sum syntaxes) ann)
|
||||
-> m (Term (Sum syntaxes) ann)
|
||||
-> [m (Term (Sum syntaxes) ann -> Term (Sum syntaxes) ann -> Sum syntaxes (Term (Sum syntaxes) ann))]
|
||||
-> m (Sum syntaxes (Term (Sum syntaxes) ann))
|
||||
infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right
|
||||
|
||||
instance (Apply Message1 fs, Generate Message1 fs fs, Generate Named1 fs fs) => Message1 (Sum fs) where
|
||||
|
||||
@ -101,7 +101,7 @@ instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable VariableDeclaration where
|
||||
eval (VariableDeclaration []) = rvalBox unit
|
||||
eval (VariableDeclaration decs) = rvalBox =<< (multiple <$> traverse subtermValue decs)
|
||||
eval (VariableDeclaration decs) = rvalBox =<< tuple =<< traverse subtermAddress decs
|
||||
|
||||
instance Declarations a => Declarations (VariableDeclaration a) where
|
||||
declaredName (VariableDeclaration vars) = case vars of
|
||||
|
||||
@ -215,7 +215,7 @@ instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
|
||||
-- TODO: Finish Eval instance for Subscript
|
||||
-- TODO return a special LvalSubscript instance here
|
||||
instance Evaluatable Subscript where
|
||||
eval (Subscript l [r]) = rvalBox =<< join (index <$> subtermValue l <*> subtermValue r)
|
||||
eval (Subscript l [r]) = Rval <$> join (index <$> subtermValue l <*> subtermValue r)
|
||||
eval (Subscript _ _) = rvalBox =<< throwResumable (Unspecialized "Eval unspecialized for subscript with slices")
|
||||
eval (Member _ _) = rvalBox =<< throwResumable (Unspecialized "Eval unspecialized for member access")
|
||||
|
||||
|
||||
@ -169,7 +169,7 @@ instance Ord1 Array where liftCompare = genericLiftCompare
|
||||
instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Array where
|
||||
eval (Array a) = rvalBox =<< (array =<< traverse subtermValue a)
|
||||
eval (Array a) = rvalBox =<< array =<< traverse subtermAddress a
|
||||
|
||||
newtype Hash a = Hash { hashElements :: [a] }
|
||||
deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1)
|
||||
@ -200,7 +200,7 @@ instance Ord1 Tuple where liftCompare = genericLiftCompare
|
||||
instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Tuple where
|
||||
eval (Tuple cs) = rvalBox =<< (multiple <$> traverse subtermValue cs)
|
||||
eval (Tuple cs) = rvalBox =<< tuple =<< traverse subtermAddress cs
|
||||
|
||||
newtype Set a = Set { setElements :: [a] }
|
||||
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
|
||||
|
||||
@ -103,7 +103,7 @@ type Syntax =
|
||||
]
|
||||
|
||||
type Term = Term.Term (Sum Syntax) (Record Location)
|
||||
type Assignment = HasCallStack => Assignment.Assignment [] Grammar Term
|
||||
type Assignment = Assignment.Assignment [] Grammar Term
|
||||
|
||||
-- | Assignment from AST in Java's grammar onto a program in Java's syntax.
|
||||
assignment :: Assignment
|
||||
@ -215,9 +215,9 @@ variableDeclaratorId = symbol VariableDeclaratorId *> children identifier
|
||||
|
||||
-- Literals
|
||||
boolean :: Assignment
|
||||
boolean = makeTerm <$> symbol BooleanLiteral <*> children
|
||||
(token Grammar.True $> Literal.true
|
||||
<|> token Grammar.False $> Literal.false)
|
||||
boolean = toTerm (branchNode BooleanLiteral
|
||||
( leafNode Grammar.True $> Literal.true
|
||||
<|> leafNode Grammar.False $> Literal.false))
|
||||
|
||||
null' :: Assignment
|
||||
null' = makeTerm <$> symbol NullLiteral <*> (Literal.Null <$ source)
|
||||
@ -288,7 +288,7 @@ explicitConstructorInvocation = makeTerm <$> symbol ExplicitConstructorInvocatio
|
||||
callFunction a Nothing = ([], a)
|
||||
|
||||
module' :: Assignment
|
||||
module' = makeTerm <$> symbol ModuleDeclaration <*> children (Java.Syntax.Module <$> expression <*> many expression)
|
||||
module' = toTerm (branchNode ModuleDeclaration (Java.Syntax.Module <$> expression <*> many expression))
|
||||
|
||||
import' :: Assignment
|
||||
import' = makeTerm <$> symbol ImportDeclaration <*> children (Java.Syntax.Import <$> someTerm (expression <|> asterisk))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user