mirror of
https://github.com/github/semantic.git
synced 2024-11-28 10:15:55 +03:00
Merge remote-tracking branch 'origin/master' into import-graph-mk2
This commit is contained in:
Patrick Thomson
commit
80aac54baa
@ -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.
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
|
||||
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeOperators #-}
|
||||
module Control.Abstract.Evaluator
|
||||
( Evaluator(..)
|
||||
-- * Effects
|
||||
@ -37,49 +37,46 @@ deriving instance Member NonDet effects => Alternative (Evaluator address value
|
||||
-- Effects
|
||||
|
||||
-- | An effect for explicitly returning out of a function/method body.
|
||||
data Return address value resume where
|
||||
Return :: address -> Return address value address
|
||||
data Return address resume where
|
||||
Return :: address -> Return address address
|
||||
|
||||
deriving instance (Eq address, Eq value) => Eq (Return address value a)
|
||||
deriving instance (Show address, Eq value) => Show (Return address value a)
|
||||
deriving instance Eq address => Eq (Return address a)
|
||||
deriving instance Show address => Show (Return address a)
|
||||
|
||||
earlyReturn :: forall address value effects
|
||||
. Member (Return address value) effects
|
||||
earlyReturn :: Member (Return address) effects
|
||||
=> address
|
||||
-> Evaluator address value effects address
|
||||
earlyReturn = send . Return @address @value
|
||||
earlyReturn = send . Return
|
||||
|
||||
catchReturn :: Member (Return address value) effects => Evaluator address value effects a -> (forall x . Return address value x -> Evaluator address value effects a) -> Evaluator address value effects a
|
||||
catchReturn :: Member (Return address) effects => Evaluator address value effects a -> (forall x . Return address x -> Evaluator address value effects a) -> Evaluator address value effects a
|
||||
catchReturn action handler = interpose pure (\ ret _ -> handler ret) action
|
||||
|
||||
runReturn :: Effectful (m address value) => m address value (Return address value ': effects) address -> m address value effects address
|
||||
runReturn :: Effectful (m address value) => m address value (Return address ': effects) address -> m address value effects address
|
||||
runReturn = raiseHandler (relay pure (\ (Return value) _ -> pure value))
|
||||
|
||||
|
||||
-- | Effects for control flow around loops (breaking and continuing).
|
||||
data LoopControl address value resume where
|
||||
Break :: address -> LoopControl address value address
|
||||
Continue :: address -> LoopControl address value address
|
||||
data LoopControl address resume where
|
||||
Break :: address -> LoopControl address address
|
||||
Continue :: address -> LoopControl address address
|
||||
|
||||
deriving instance (Eq address, Eq value) => Eq (LoopControl address value a)
|
||||
deriving instance (Show address, Show value) => Show (LoopControl address value a)
|
||||
deriving instance Eq address => Eq (LoopControl address a)
|
||||
deriving instance Show address => Show (LoopControl address a)
|
||||
|
||||
throwBreak :: forall address value effects
|
||||
. Member (LoopControl address value) effects
|
||||
throwBreak :: Member (LoopControl address) effects
|
||||
=> address
|
||||
-> Evaluator address value effects address
|
||||
throwBreak = send . Break @address @value
|
||||
throwBreak = send . Break
|
||||
|
||||
throwContinue :: forall address value effects
|
||||
. Member (LoopControl address value) effects
|
||||
throwContinue :: Member (LoopControl address) effects
|
||||
=> address
|
||||
-> Evaluator address value effects address
|
||||
throwContinue = send . Continue @address @value
|
||||
throwContinue = send . Continue
|
||||
|
||||
catchLoopControl :: Member (LoopControl address value) effects => Evaluator address value effects a -> (forall x . LoopControl address value x -> Evaluator address value effects a) -> Evaluator address value effects a
|
||||
catchLoopControl :: Member (LoopControl address) effects => Evaluator address value effects a -> (forall x . LoopControl address x -> Evaluator address value effects a) -> Evaluator address value effects a
|
||||
catchLoopControl action handler = interpose pure (\ control _ -> handler control) action
|
||||
|
||||
runLoopControl :: Effectful (m address value) => m address value (LoopControl address value ': effects) address -> m address value effects address
|
||||
runLoopControl :: Effectful (m address value) => m address value (LoopControl address ': effects) address -> m address value effects address
|
||||
runLoopControl = raiseHandler (relay pure (\ eff _ -> case eff of
|
||||
Break value -> pure value
|
||||
Continue value -> pure value))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -46,7 +46,7 @@ class Show1 constr => Evaluatable constr where
|
||||
, FreeVariables term
|
||||
, Member (Allocator address value) effects
|
||||
, Member (Env address) effects
|
||||
, Member (LoopControl address value) effects
|
||||
, Member (LoopControl address) effects
|
||||
, Member (Modules address value) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader PackageInfo) effects
|
||||
@ -55,7 +55,7 @@ class Show1 constr => Evaluatable constr where
|
||||
, Member (Resumable EvalError) effects
|
||||
, Member (Resumable ResolutionError) effects
|
||||
, Member (Resumable (Unspecialized value)) effects
|
||||
, Member (Return address value) effects
|
||||
, Member (Return address) effects
|
||||
, Member Trace effects
|
||||
)
|
||||
=> SubtermAlgebra constr term (Evaluator address value effects (ValueRef address))
|
||||
@ -84,7 +84,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer
|
||||
, Recursive term
|
||||
, Reducer value (Cell address value)
|
||||
, ValueRoots address value
|
||||
, inner ~ (LoopControl address value ': Return address value ': Env address ': Allocator address value ': inner')
|
||||
, inner ~ (LoopControl address ': Return address ': Env address ': Allocator address value ': inner')
|
||||
, inner' ~ (Reader ModuleInfo ': inner'')
|
||||
, inner'' ~ (Modules address value ': Reader Span ': Reader PackageInfo ': outer)
|
||||
)
|
||||
|
||||
@ -108,7 +108,6 @@ instance AbstractIntro Type where
|
||||
float _ = Float
|
||||
symbol _ = Symbol
|
||||
rational _ = Rational
|
||||
multiple = zeroOrMoreProduct
|
||||
hash = Hash
|
||||
kvPair k v = k :* v
|
||||
|
||||
@ -119,7 +118,7 @@ instance ( Member (Allocator address Type) effects
|
||||
, Member (Env address) effects
|
||||
, Member Fresh effects
|
||||
, Member (Resumable TypeError) effects
|
||||
, Member (Return address Type) effects
|
||||
, Member (Return address) effects
|
||||
)
|
||||
=> AbstractFunction address Type effects where
|
||||
closure names _ body = do
|
||||
@ -146,12 +145,15 @@ instance ( Member (Allocator address Type) effects
|
||||
, Member Fresh effects
|
||||
, Member NonDet effects
|
||||
, Member (Resumable TypeError) effects
|
||||
, Member (Return address Type) effects
|
||||
, Member (Return address) 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)
|
||||
@ -60,7 +60,7 @@ instance ( Coercible body (Eff effects)
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader PackageInfo) effects
|
||||
, Member (Resumable (ValueError address body)) effects
|
||||
, Member (Return address (Value address body)) effects
|
||||
, Member (Return address) effects
|
||||
, Show address
|
||||
)
|
||||
=> AbstractFunction address (Value address body) effects where
|
||||
@ -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)
|
||||
|
||||
@ -105,11 +103,11 @@ instance ( Coercible body (Eff effects)
|
||||
, Member (Allocator address (Value address body)) effects
|
||||
, Member (Env address) effects
|
||||
, Member Fresh effects
|
||||
, Member (LoopControl address (Value address body)) effects
|
||||
, Member (LoopControl address) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader PackageInfo) effects
|
||||
, Member (Resumable (ValueError address body)) effects
|
||||
, Member (Return address (Value address body)) effects
|
||||
, Member (Return address) effects
|
||||
, Show address
|
||||
)
|
||||
=> AbstractValue address (Value address body) effects where
|
||||
@ -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))
|
||||
|
||||
@ -4,6 +4,7 @@ module Semantic.Graph
|
||||
, GraphType(..)
|
||||
, Graph
|
||||
, Vertex
|
||||
, GraphEff(..)
|
||||
, style
|
||||
, parsePackage
|
||||
, withTermSpans
|
||||
@ -65,9 +66,34 @@ runGraph graphType includePackages project
|
||||
. resumingResolutionError
|
||||
. resumingAddressError
|
||||
. resumingValueError
|
||||
. runTermEvaluator @_ @_ @(Value (Hole (Located Precise)) (Eff _))
|
||||
. runTermEvaluator @_ @_ @(Value (Hole (Located Precise)) (GraphEff _))
|
||||
. graphing
|
||||
|
||||
-- | The full list of effects in flight during the evaluation of terms. This, and other @newtype@s like it, are necessary to type 'Value', since the bodies of closures embed evaluators. This would otherwise require cycles in the effect list (i.e. references to @effects@ within @effects@ itself), which the typechecker forbids.
|
||||
newtype GraphEff address a = GraphEff
|
||||
{ runGraphEff :: Eff '[ LoopControl address
|
||||
, Return address
|
||||
, Env address
|
||||
, Allocator address (Value address (GraphEff address))
|
||||
, Reader ModuleInfo
|
||||
, Modules address (Value address (GraphEff address))
|
||||
, Reader Span
|
||||
, Reader PackageInfo
|
||||
, State (Graph Vertex)
|
||||
, Resumable (ValueError address (GraphEff address))
|
||||
, Resumable (AddressError address (Value address (GraphEff address)))
|
||||
, Resumable ResolutionError
|
||||
, Resumable EvalError
|
||||
, Resumable (EnvironmentError address)
|
||||
, Resumable (Unspecialized (Value address (GraphEff address)))
|
||||
, Resumable (LoadError address (Value address (GraphEff address)))
|
||||
, Trace
|
||||
, Fresh
|
||||
, State (Heap address Latest (Value address (GraphEff address)))
|
||||
, State (ModuleTable (Maybe (address, Environment address)))
|
||||
] a
|
||||
}
|
||||
|
||||
-- | Parse a list of files into a 'Package'.
|
||||
parsePackage :: (Member (Exc SomeException) effs, Member (Distribute WrappedTask) effs, Member Resolution effs, Member Task effs, Member Trace effs)
|
||||
=> Parser term -- ^ A parser.
|
||||
|
||||
@ -44,9 +44,33 @@ justEvaluating
|
||||
. runEnvironmentError
|
||||
. runEvalError
|
||||
. runAddressError
|
||||
. runTermEvaluator @_ @Precise @(Value Precise (Eff _))
|
||||
. runTermEvaluator @_ @Precise @(Value Precise (UtilEff _))
|
||||
. runValueError
|
||||
|
||||
newtype UtilEff address a = UtilEff
|
||||
{ runUtilEff :: Eff '[ LoopControl address
|
||||
, Return address
|
||||
, Env address
|
||||
, Allocator address (Value address (UtilEff address))
|
||||
, Reader ModuleInfo
|
||||
, Modules address (Value address (UtilEff address))
|
||||
, Reader Span
|
||||
, Reader PackageInfo
|
||||
, Resumable (ValueError address (UtilEff address))
|
||||
, Resumable (AddressError address (Value address (UtilEff address)))
|
||||
, Resumable EvalError
|
||||
, Resumable (EnvironmentError address)
|
||||
, Resumable ResolutionError
|
||||
, Resumable (Unspecialized (Value address (UtilEff address)))
|
||||
, Resumable (LoadError address (Value address (UtilEff address)))
|
||||
, Trace
|
||||
, Fresh
|
||||
, State (Heap address Latest (Value address (UtilEff address)))
|
||||
, State (ModuleTable (Maybe (address, Environment address)))
|
||||
, IO
|
||||
] a
|
||||
}
|
||||
|
||||
checking
|
||||
= runM @_ @IO
|
||||
. evaluating
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Control.Abstract.Evaluator.Spec
|
||||
( spec
|
||||
, SpecEff(..)
|
||||
) where
|
||||
|
||||
import Analysis.Abstract.Evaluating (evaluating)
|
||||
@ -30,7 +31,7 @@ spec = parallel $ do
|
||||
|
||||
evaluate
|
||||
= runM
|
||||
. evaluating @Precise @(Value Precise (Eff _))
|
||||
. evaluating @Precise @Val
|
||||
. runReader (PackageInfo (name "test") Nothing mempty)
|
||||
. runReader (ModuleInfo "test/Control/Abstract/Evaluator/Spec.hs")
|
||||
. fmap reassociate
|
||||
@ -45,3 +46,21 @@ evaluate
|
||||
|
||||
reassociate :: Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc3) result)) -> Either (SomeExc (Sum '[exc3, exc2, exc1])) result
|
||||
reassociate = mergeExcs . mergeExcs . mergeExcs . Right
|
||||
|
||||
type Val = Value Precise SpecEff
|
||||
newtype SpecEff a = SpecEff
|
||||
{ runSpecEff :: Eff '[ LoopControl Precise
|
||||
, Return Precise
|
||||
, Env Precise
|
||||
, Allocator Precise Val
|
||||
, Resumable (AddressError Precise Val)
|
||||
, Resumable (EnvironmentError Precise)
|
||||
, Resumable (ValueError Precise SpecEff)
|
||||
, Reader ModuleInfo
|
||||
, Reader PackageInfo
|
||||
, Fresh
|
||||
, State (Heap Precise Latest Val)
|
||||
, State (ModuleTable (Maybe (Precise, Environment Precise)))
|
||||
, IO
|
||||
] a
|
||||
}
|
||||
|
||||
@ -9,6 +9,7 @@ module SpecHelpers
|
||||
, derefQName
|
||||
, verbatim
|
||||
, TermEvaluator(..)
|
||||
, TestEff(..)
|
||||
, Verbatim(..)
|
||||
) where
|
||||
|
||||
@ -79,15 +80,15 @@ readFilePair paths = let paths' = fmap file paths in
|
||||
runBothWith IO.readFilePair paths'
|
||||
|
||||
testEvaluating :: TermEvaluator term Precise
|
||||
(Value Precise (Eff effects))
|
||||
'[ Resumable (ValueError Precise (Eff effects))
|
||||
, Resumable (AddressError Precise (Value Precise (Eff effects)))
|
||||
Val
|
||||
'[ Resumable (ValueError Precise TestEff)
|
||||
, Resumable (AddressError Precise Val)
|
||||
, Resumable EvalError, Resumable (EnvironmentError Precise)
|
||||
, Resumable ResolutionError
|
||||
, Resumable (Unspecialized (Value Precise (Eff effects)))
|
||||
, Resumable (LoadError Precise (Value Precise (Eff effects)))
|
||||
, Resumable (Unspecialized Val)
|
||||
, Resumable (LoadError Precise Val)
|
||||
, Fresh
|
||||
, State (Heap Precise Latest (Value Precise (Eff effects)))
|
||||
, State (Heap Precise Latest Val)
|
||||
, State (ModuleTable (Maybe (Precise, Environment Precise)))
|
||||
, Trace
|
||||
]
|
||||
@ -95,16 +96,16 @@ testEvaluating :: TermEvaluator term Precise
|
||||
-> ((Either
|
||||
(SomeExc
|
||||
(Data.Sum.Sum
|
||||
'[ ValueError Precise (Eff effects)
|
||||
, AddressError Precise (Value Precise (Eff effects))
|
||||
'[ ValueError Precise TestEff
|
||||
, AddressError Precise Val
|
||||
, EvalError
|
||||
, EnvironmentError Precise
|
||||
, ResolutionError
|
||||
, Unspecialized (Value Precise (Eff effects))
|
||||
, LoadError Precise (Value Precise (Eff effects))
|
||||
, Unspecialized Val
|
||||
, LoadError Precise Val
|
||||
]))
|
||||
[(Value Precise (Eff effects), Environment Precise)],
|
||||
EvaluatingState Precise (Value Precise (Eff effects))),
|
||||
[(Value Precise TestEff, Environment Precise)],
|
||||
EvaluatingState Precise Val),
|
||||
[String])
|
||||
testEvaluating
|
||||
= run
|
||||
@ -118,8 +119,32 @@ testEvaluating
|
||||
. runEvalError
|
||||
. runAddressError
|
||||
. runValueError
|
||||
. (>>= (traverse deref1))
|
||||
. runTermEvaluator @_ @_ @(Value Precise (Eff _))
|
||||
. (>>= traverse deref1)
|
||||
. runTermEvaluator @_ @_ @Val
|
||||
|
||||
type Val = Value Precise TestEff
|
||||
newtype TestEff a = TestEff
|
||||
{ runTestEff :: Eff '[ LoopControl Precise
|
||||
, Return Precise
|
||||
, Env Precise
|
||||
, Allocator Precise Val
|
||||
, Reader ModuleInfo
|
||||
, Modules Precise Val
|
||||
, Reader Span
|
||||
, Reader PackageInfo
|
||||
, Resumable (ValueError Precise TestEff)
|
||||
, Resumable (AddressError Precise Val)
|
||||
, Resumable EvalError
|
||||
, Resumable (EnvironmentError Precise)
|
||||
, Resumable ResolutionError
|
||||
, Resumable (Unspecialized Val)
|
||||
, Resumable (LoadError Precise Val)
|
||||
, Fresh
|
||||
, State (Heap Precise Latest Val)
|
||||
, State (ModuleTable (Maybe (Precise, Environment Precise)))
|
||||
, Trace
|
||||
] a
|
||||
}
|
||||
|
||||
deref1 (ptr, env) = runAllocator $ do
|
||||
val <- deref ptr
|
||||
|
||||
2
vendor/effects
vendored
2
vendor/effects
vendored
@ -1 +1 @@
|
||||
Subproject commit adec65af304cc31681ce02111985aa73e1f11cf5
|
||||
Subproject commit 5db3a4f18ee8a2bf97762a9846b76ca21383126e
|
||||
Loading…
Reference in New Issue
Block a user