mirror of
https://github.com/github/semantic.git
synced 2024-12-24 07:25:44 +03:00
Merge branch 'master' into index-calls
This commit is contained in:
commit
ec76510534
@ -54,6 +54,7 @@ common dependencies
|
|||||||
, network
|
, network
|
||||||
, recursion-schemes
|
, recursion-schemes
|
||||||
, scientific
|
, scientific
|
||||||
|
, safe-exceptions
|
||||||
, semilattices
|
, semilattices
|
||||||
, text
|
, text
|
||||||
, these
|
, these
|
||||||
|
@ -45,9 +45,9 @@ defineBuiltIn declaration rel accessControl value = withCurrentCallStack callSta
|
|||||||
-- TODO: This span is still wrong.
|
-- TODO: This span is still wrong.
|
||||||
declare declaration rel accessControl emptySpan ScopeGraph.Unknown (Just associatedScope)
|
declare declaration rel accessControl emptySpan ScopeGraph.Unknown (Just associatedScope)
|
||||||
|
|
||||||
param <- gensym
|
|
||||||
withScope associatedScope $ do
|
withScope associatedScope $ do
|
||||||
declare (Declaration param) rel accessControl emptySpan ScopeGraph.Unknown Nothing
|
param <- gensym
|
||||||
|
declare (Declaration param) ScopeGraph.Gensym accessControl emptySpan ScopeGraph.Unknown Nothing
|
||||||
|
|
||||||
slot <- lookupSlot declaration
|
slot <- lookupSlot declaration
|
||||||
value <- builtIn associatedScope value
|
value <- builtIn associatedScope value
|
||||||
|
@ -3,6 +3,7 @@
|
|||||||
module Control.Abstract.ScopeGraph
|
module Control.Abstract.ScopeGraph
|
||||||
( lookup
|
( lookup
|
||||||
, declare
|
, declare
|
||||||
|
, declareMaybeName
|
||||||
, reference
|
, reference
|
||||||
, newScope
|
, newScope
|
||||||
, newPreludeScope
|
, newPreludeScope
|
||||||
@ -79,6 +80,27 @@ declare decl rel accessControl span kind scope = do
|
|||||||
moduleInfo <- ask @ModuleInfo
|
moduleInfo <- ask @ModuleInfo
|
||||||
modify (fst . ScopeGraph.declare decl moduleInfo rel accessControl span kind scope currentAddress)
|
modify (fst . ScopeGraph.declare decl moduleInfo rel accessControl span kind scope currentAddress)
|
||||||
|
|
||||||
|
-- | If the provided name is 'Nothing' we want to reflect that the declaration's name was a generated name (gensym).
|
||||||
|
-- We use the 'Gensym' relation to indicate that. Otherwise, we use the provided 'relation'.
|
||||||
|
declareMaybeName :: ( Carrier sig m
|
||||||
|
, Member (State (ScopeGraph address)) sig
|
||||||
|
, Member (Reader (CurrentScope address)) sig
|
||||||
|
, Member (Reader ModuleInfo) sig
|
||||||
|
, Member Fresh sig
|
||||||
|
, Ord address
|
||||||
|
)
|
||||||
|
=> Maybe Name
|
||||||
|
-> Relation
|
||||||
|
-> AccessControl
|
||||||
|
-> Span
|
||||||
|
-> Kind
|
||||||
|
-> Maybe address
|
||||||
|
-> Evaluator term address value m Name
|
||||||
|
declareMaybeName maybeName relation ac span kind scope = do
|
||||||
|
case maybeName of
|
||||||
|
Just name -> declare (Declaration name) relation ac span kind scope >> pure name
|
||||||
|
_ -> gensym >>= \name -> declare (Declaration name) Gensym ac span kind scope >> pure name
|
||||||
|
|
||||||
putDeclarationScope :: ( Ord address
|
putDeclarationScope :: ( Ord address
|
||||||
, Member (Reader (CurrentScope address)) sig
|
, Member (Reader (CurrentScope address)) sig
|
||||||
, Member (State (ScopeGraph address)) sig
|
, Member (State (ScopeGraph address)) sig
|
||||||
|
@ -6,6 +6,7 @@
|
|||||||
module Control.Effect.Catch
|
module Control.Effect.Catch
|
||||||
( Catch (..)
|
( Catch (..)
|
||||||
, catch
|
, catch
|
||||||
|
, catchSync
|
||||||
, runCatch
|
, runCatch
|
||||||
, CatchC (..)
|
, CatchC (..)
|
||||||
) where
|
) where
|
||||||
@ -14,6 +15,7 @@ import Control.Effect.Carrier
|
|||||||
import Control.Effect.Reader
|
import Control.Effect.Reader
|
||||||
import Control.Effect.Sum
|
import Control.Effect.Sum
|
||||||
import qualified Control.Exception as Exc
|
import qualified Control.Exception as Exc
|
||||||
|
import Control.Exception.Safe (isSyncException)
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
|
||||||
data Catch m k
|
data Catch m k
|
||||||
@ -39,6 +41,16 @@ catch :: (Member Catch sig, Carrier sig m, Exc.Exception e)
|
|||||||
-> m a
|
-> m a
|
||||||
catch go cleanup = send (CatchIO go cleanup pure)
|
catch go cleanup = send (CatchIO go cleanup pure)
|
||||||
|
|
||||||
|
catchSync :: (Member Catch sig, Carrier sig m, Exc.Exception e, MonadIO m)
|
||||||
|
=> m a
|
||||||
|
-> (e -> m a)
|
||||||
|
-> m a
|
||||||
|
catchSync f g = f `catch` \e ->
|
||||||
|
if isSyncException e
|
||||||
|
then g e
|
||||||
|
-- intentionally rethrowing an async exception synchronously,
|
||||||
|
-- since we want to preserve async behavior
|
||||||
|
else liftIO (Exc.throw e)
|
||||||
|
|
||||||
-- | Evaulate a 'Catch' effect.
|
-- | Evaulate a 'Catch' effect.
|
||||||
runCatch :: (forall x . m x -> IO x)
|
runCatch :: (forall x . m x -> IO x)
|
||||||
|
@ -192,7 +192,7 @@ defineSelf :: ( Carrier sig m
|
|||||||
=> Evaluator term address value m ()
|
=> Evaluator term address value m ()
|
||||||
defineSelf = do
|
defineSelf = do
|
||||||
let self = Declaration X.__self
|
let self = Declaration X.__self
|
||||||
declare self Default Public emptySpan ScopeGraph.Unknown Nothing
|
declare self ScopeGraph.Gensym Public emptySpan ScopeGraph.Unknown Nothing
|
||||||
slot <- lookupSlot self
|
slot <- lookupSlot self
|
||||||
assign slot =<< object =<< currentFrame
|
assign slot =<< object =<< currentFrame
|
||||||
|
|
||||||
|
@ -86,7 +86,7 @@ instance Ord AccessControl where
|
|||||||
(<=) Public _ = False
|
(<=) Public _ = False
|
||||||
|
|
||||||
|
|
||||||
data Relation = Default | Instance | Prelude
|
data Relation = Default | Instance | Prelude | Gensym
|
||||||
deriving (Eq, Show, Ord, Generic, NFData)
|
deriving (Eq, Show, Ord, Generic, NFData)
|
||||||
|
|
||||||
instance Lower Relation where
|
instance Lower Relation where
|
||||||
|
@ -28,15 +28,10 @@ instance Diffable Function where
|
|||||||
|
|
||||||
instance Evaluatable Function where
|
instance Evaluatable Function where
|
||||||
eval _ _ Function{..} = do
|
eval _ _ Function{..} = do
|
||||||
name <- maybeM (throwNoNameError functionName) (declaredName functionName)
|
|
||||||
span <- ask @Span
|
span <- ask @Span
|
||||||
associatedScope <- declareFunction name ScopeGraph.Public span ScopeGraph.Function
|
(name, associatedScope) <- declareFunction (declaredName functionName) ScopeGraph.Public span ScopeGraph.Function
|
||||||
|
|
||||||
params <- withScope associatedScope . for functionParameters $ \paramNode -> do
|
params <- withScope associatedScope . for functionParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (getSpan paramNode) ScopeGraph.Parameter Nothing
|
||||||
param <- maybeM (throwNoNameError paramNode) (declaredName paramNode)
|
|
||||||
|
|
||||||
let paramSpan = getSpan paramNode
|
|
||||||
param <$ declare (Declaration param) Default ScopeGraph.Public paramSpan ScopeGraph.Parameter Nothing
|
|
||||||
|
|
||||||
addr <- lookupSlot (Declaration name)
|
addr <- lookupSlot (Declaration name)
|
||||||
v <- function name params functionBody associatedScope
|
v <- function name params functionBody associatedScope
|
||||||
@ -50,17 +45,17 @@ declareFunction :: ( Carrier sig m
|
|||||||
, Member Fresh sig
|
, Member Fresh sig
|
||||||
, Ord address
|
, Ord address
|
||||||
)
|
)
|
||||||
=> Name
|
=> Maybe Name
|
||||||
-> ScopeGraph.AccessControl
|
-> ScopeGraph.AccessControl
|
||||||
-> Span
|
-> Span
|
||||||
-> ScopeGraph.Kind
|
-> ScopeGraph.Kind
|
||||||
-> Evaluator term address value m address
|
-> Evaluator term address value m (Name, address)
|
||||||
declareFunction name accessControl span kind = do
|
declareFunction name accessControl span kind = do
|
||||||
currentScope' <- currentScope
|
currentScope' <- currentScope
|
||||||
let lexicalEdges = Map.singleton Lexical [ currentScope' ]
|
let lexicalEdges = Map.singleton Lexical [ currentScope' ]
|
||||||
associatedScope <- newScope lexicalEdges
|
associatedScope <- newScope lexicalEdges
|
||||||
declare (Declaration name) Default accessControl span kind (Just associatedScope)
|
name' <- declareMaybeName name Default accessControl span kind (Just associatedScope)
|
||||||
pure associatedScope
|
pure (name', associatedScope)
|
||||||
|
|
||||||
instance Tokenize Function where
|
instance Tokenize Function where
|
||||||
tokenize Function{..} = within' Scope.Function $ do
|
tokenize Function{..} = within' Scope.Function $ do
|
||||||
@ -92,16 +87,13 @@ instance Diffable Method where
|
|||||||
-- local environment.
|
-- local environment.
|
||||||
instance Evaluatable Method where
|
instance Evaluatable Method where
|
||||||
eval _ _ Method{..} = do
|
eval _ _ Method{..} = do
|
||||||
name <- maybeM (throwNoNameError methodName) (declaredName methodName)
|
|
||||||
span <- ask @Span
|
span <- ask @Span
|
||||||
associatedScope <- declareFunction name methodAccessControl span ScopeGraph.Method
|
(name, associatedScope) <- declareFunction (declaredName methodName) methodAccessControl span ScopeGraph.Method
|
||||||
|
|
||||||
params <- withScope associatedScope $ do
|
params <- withScope associatedScope $ do
|
||||||
-- TODO: Should we give `self` a special Relation?
|
-- TODO: Should we give `self` a special Relation?
|
||||||
declare (Declaration __self) Prelude ScopeGraph.Public emptySpan ScopeGraph.Unknown Nothing
|
declare (Declaration __self) ScopeGraph.Prelude ScopeGraph.Public emptySpan ScopeGraph.Unknown Nothing
|
||||||
for methodParameters $ \paramNode -> do
|
for methodParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (getSpan paramNode) ScopeGraph.Parameter Nothing
|
||||||
param <- maybeM (throwNoNameError paramNode) (declaredName paramNode)
|
|
||||||
param <$ declare (Declaration param) Default ScopeGraph.Public span ScopeGraph.Parameter Nothing
|
|
||||||
|
|
||||||
addr <- lookupSlot (Declaration name)
|
addr <- lookupSlot (Declaration name)
|
||||||
v <- function name params methodBody associatedScope
|
v <- function name params methodBody associatedScope
|
||||||
@ -144,9 +136,8 @@ instance Declarations1 RequiredParameter where
|
|||||||
-- TODO: Implement Eval instance for RequiredParameter
|
-- TODO: Implement Eval instance for RequiredParameter
|
||||||
instance Evaluatable RequiredParameter where
|
instance Evaluatable RequiredParameter where
|
||||||
eval _ _ RequiredParameter{..} = do
|
eval _ _ RequiredParameter{..} = do
|
||||||
name <- maybeM (throwNoNameError requiredParameter) (declaredName requiredParameter)
|
|
||||||
span <- ask @Span
|
span <- ask @Span
|
||||||
declare (Declaration name) Default ScopeGraph.Public span ScopeGraph.RequiredParameter Nothing
|
_ <- declareMaybeName (declaredName requiredParameter) Default ScopeGraph.Public span ScopeGraph.RequiredParameter Nothing
|
||||||
unit
|
unit
|
||||||
|
|
||||||
|
|
||||||
@ -170,9 +161,8 @@ instance Evaluatable VariableDeclaration where
|
|||||||
eval _ _ (VariableDeclaration []) = unit
|
eval _ _ (VariableDeclaration []) = unit
|
||||||
eval eval _ (VariableDeclaration decs) = do
|
eval eval _ (VariableDeclaration decs) = do
|
||||||
for_ decs $ \declaration -> do
|
for_ decs $ \declaration -> do
|
||||||
name <- maybeM (throwNoNameError declaration) (declaredName declaration)
|
let span = getSpan declaration
|
||||||
let declarationSpan = getSpan declaration
|
_ <- declareMaybeName (declaredName declaration) Default ScopeGraph.Public span ScopeGraph.VariableDeclaration Nothing
|
||||||
declare (Declaration name) Default ScopeGraph.Public declarationSpan ScopeGraph.VariableDeclaration Nothing
|
|
||||||
eval declaration
|
eval declaration
|
||||||
unit
|
unit
|
||||||
|
|
||||||
@ -209,10 +199,8 @@ data PublicFieldDefinition a = PublicFieldDefinition
|
|||||||
instance Evaluatable PublicFieldDefinition where
|
instance Evaluatable PublicFieldDefinition where
|
||||||
eval eval _ PublicFieldDefinition{..} = do
|
eval eval _ PublicFieldDefinition{..} = do
|
||||||
span <- ask @Span
|
span <- ask @Span
|
||||||
propertyName <- maybeM (throwNoNameError publicFieldPropertyName) (declaredName publicFieldPropertyName)
|
name <- declareMaybeName (declaredName publicFieldPropertyName) Instance publicFieldAccessControl span ScopeGraph.PublicField Nothing
|
||||||
|
slot <- lookupSlot (Declaration name)
|
||||||
declare (Declaration propertyName) Instance publicFieldAccessControl span ScopeGraph.PublicField Nothing
|
|
||||||
slot <- lookupSlot (Declaration propertyName)
|
|
||||||
value <- eval publicFieldValue
|
value <- eval publicFieldValue
|
||||||
assign slot value
|
assign slot value
|
||||||
unit
|
unit
|
||||||
@ -236,12 +224,13 @@ instance Diffable Class where
|
|||||||
|
|
||||||
instance Evaluatable Class where
|
instance Evaluatable Class where
|
||||||
eval eval _ Class{..} = do
|
eval eval _ Class{..} = do
|
||||||
name <- maybeM (throwNoNameError classIdentifier) (declaredName classIdentifier)
|
|
||||||
span <- ask @Span
|
span <- ask @Span
|
||||||
currentScope' <- currentScope
|
currentScope' <- currentScope
|
||||||
|
|
||||||
superScopes <- for classSuperclasses $ \superclass -> do
|
superScopes <- for classSuperclasses $ \superclass -> do
|
||||||
name <- maybeM (throwNoNameError superclass) (declaredName superclass)
|
name <- case declaredName superclass of
|
||||||
|
Just name -> pure name
|
||||||
|
Nothing -> gensym
|
||||||
scope <- associatedScope (Declaration name)
|
scope <- associatedScope (Declaration name)
|
||||||
slot <- lookupSlot (Declaration name)
|
slot <- lookupSlot (Declaration name)
|
||||||
superclassFrame <- scopedEnvironment =<< deref slot
|
superclassFrame <- scopedEnvironment =<< deref slot
|
||||||
@ -253,7 +242,7 @@ instance Evaluatable Class where
|
|||||||
current = (Lexical, ) <$> pure (pure currentScope')
|
current = (Lexical, ) <$> pure (pure currentScope')
|
||||||
edges = Map.fromList (superclassEdges <> current)
|
edges = Map.fromList (superclassEdges <> current)
|
||||||
classScope <- newScope edges
|
classScope <- newScope edges
|
||||||
declare (Declaration name) Default ScopeGraph.Public span ScopeGraph.Class (Just classScope)
|
name <- declareMaybeName (declaredName classIdentifier) Default ScopeGraph.Public span ScopeGraph.Class (Just classScope)
|
||||||
|
|
||||||
let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes))
|
let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes))
|
||||||
classFrame <- newFrame classScope frameEdges
|
classFrame <- newFrame classScope frameEdges
|
||||||
@ -323,13 +312,11 @@ data TypeAlias a = TypeAlias { typeAliasContext :: ![a], typeAliasIdentifier ::
|
|||||||
|
|
||||||
instance Evaluatable TypeAlias where
|
instance Evaluatable TypeAlias where
|
||||||
eval _ _ TypeAlias{..} = do
|
eval _ _ TypeAlias{..} = do
|
||||||
name <- maybeM (throwNoNameError typeAliasIdentifier) (declaredName typeAliasIdentifier)
|
-- This use of `throwNoNameError` is good -- we aren't declaring something new so `declareMaybeName` is not useful here.
|
||||||
kindName <- maybeM (throwNoNameError typeAliasKind) (declaredName typeAliasKind)
|
kindName <- maybeM (throwNoNameError typeAliasKind) (declaredName typeAliasKind)
|
||||||
|
|
||||||
span <- ask @Span
|
span <- ask @Span
|
||||||
assocScope <- associatedScope (Declaration kindName)
|
assocScope <- associatedScope (Declaration kindName)
|
||||||
-- TODO: Should we consider a special Relation for `TypeAlias`?
|
name <- declareMaybeName (declaredName typeAliasIdentifier) Default ScopeGraph.Public span ScopeGraph.TypeAlias assocScope
|
||||||
declare (Declaration name) Default ScopeGraph.Public span ScopeGraph.TypeAlias assocScope
|
|
||||||
|
|
||||||
slot <- lookupSlot (Declaration name)
|
slot <- lookupSlot (Declaration name)
|
||||||
kindSlot <- lookupSlot (Declaration kindName)
|
kindSlot <- lookupSlot (Declaration kindName)
|
||||||
|
@ -427,6 +427,7 @@ instance Evaluatable MemberAccess where
|
|||||||
let lhsAccessControl = fromMaybe Public (termToAccessControl lhs)
|
let lhsAccessControl = fromMaybe Public (termToAccessControl lhs)
|
||||||
infos <- declarationsByAccessControl rhsScope lhsAccessControl
|
infos <- declarationsByAccessControl rhsScope lhsAccessControl
|
||||||
|
|
||||||
|
-- This means we always throw an 'AccessControlError' whenever we have a rhs term whose 'declaredName' is 'Nothing'.
|
||||||
rhsName <- maybeM (throwNoNameError rhs) (declaredName rhs)
|
rhsName <- maybeM (throwNoNameError rhs) (declaredName rhs)
|
||||||
rhsValue' <- case find (\Info{..} -> Declaration rhsName == infoDeclaration) infos of
|
rhsValue' <- case find (\Info{..} -> Declaration rhsName == infoDeclaration) infos of
|
||||||
Just _ -> pure rhsValue
|
Just _ -> pure rhsValue
|
||||||
|
@ -121,13 +121,13 @@ data Let a = Let { letVariable :: !a, letValue :: !a, letBody :: !a }
|
|||||||
|
|
||||||
instance Evaluatable Let where
|
instance Evaluatable Let where
|
||||||
eval eval _ Let{..} = do
|
eval eval _ Let{..} = do
|
||||||
name <- maybeM (throwNoNameError letVariable) (declaredName letVariable)
|
-- This use of 'throwNoNameError' is okay until we have a better way of mapping gensym names to terms in the scope graph.
|
||||||
letSpan <- ask @Span
|
|
||||||
valueName <- maybeM (throwNoNameError letValue) (declaredName letValue)
|
valueName <- maybeM (throwNoNameError letValue) (declaredName letValue)
|
||||||
assocScope <- associatedScope (Declaration valueName)
|
assocScope <- associatedScope (Declaration valueName)
|
||||||
|
|
||||||
_ <- withLexicalScopeAndFrame $ do
|
_ <- withLexicalScopeAndFrame $ do
|
||||||
declare (Declaration name) Default Public letSpan ScopeGraph.Let assocScope
|
letSpan <- ask @Span
|
||||||
|
name <- declareMaybeName (declaredName letVariable) Default Public letSpan ScopeGraph.Let assocScope
|
||||||
letVal <- eval letValue
|
letVal <- eval letValue
|
||||||
slot <- lookupSlot (Declaration name)
|
slot <- lookupSlot (Declaration name)
|
||||||
assign slot letVal
|
assign slot letVal
|
||||||
|
@ -75,11 +75,10 @@ data QualifiedImport a = QualifiedImport { qualifiedImportFrom :: !ImportPath, q
|
|||||||
instance Evaluatable QualifiedImport where
|
instance Evaluatable QualifiedImport where
|
||||||
eval _ _ (QualifiedImport importPath aliasTerm) = do
|
eval _ _ (QualifiedImport importPath aliasTerm) = do
|
||||||
paths <- resolveGoImport importPath
|
paths <- resolveGoImport importPath
|
||||||
alias <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm)
|
|
||||||
span <- ask @Span
|
span <- ask @Span
|
||||||
scopeAddress <- newScope mempty
|
scopeAddress <- newScope mempty
|
||||||
declare (Declaration alias) Default Public span ScopeGraph.QualifiedImport (Just scopeAddress)
|
name <- declareMaybeName (declaredName aliasTerm) Default Public span ScopeGraph.QualifiedImport (Just scopeAddress)
|
||||||
aliasSlot <- lookupSlot (Declaration alias)
|
aliasSlot <- lookupSlot (Declaration name)
|
||||||
|
|
||||||
withScope scopeAddress $ do
|
withScope scopeAddress $ do
|
||||||
let
|
let
|
||||||
|
@ -172,6 +172,7 @@ data QualifiedName a = QualifiedName { name :: a, identifier :: a }
|
|||||||
|
|
||||||
instance Evaluatable QualifiedName where
|
instance Evaluatable QualifiedName where
|
||||||
eval _ _ (QualifiedName obj iden) = do
|
eval _ _ (QualifiedName obj iden) = do
|
||||||
|
-- TODO: Consider gensym'ed names used for References.
|
||||||
name <- maybeM (throwNoNameError obj) (declaredName obj)
|
name <- maybeM (throwNoNameError obj) (declaredName obj)
|
||||||
let objSpan = getSpan obj
|
let objSpan = getSpan obj
|
||||||
reference (Reference name) objSpan ScopeGraph.Identifier (Declaration name)
|
reference (Reference name) objSpan ScopeGraph.Identifier (Declaration name)
|
||||||
|
@ -187,6 +187,7 @@ newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: NonEmpty a
|
|||||||
-- import a.b.c
|
-- import a.b.c
|
||||||
instance Evaluatable QualifiedImport where
|
instance Evaluatable QualifiedImport where
|
||||||
eval _ _ (QualifiedImport qualifiedNames) = do
|
eval _ _ (QualifiedImport qualifiedNames) = do
|
||||||
|
-- TODO: Consider gensym'ed names for imports.
|
||||||
qualifiedName <- fmap (T.unpack . formatName) <$> traverse (\term -> maybeM (throwNoNameError term) (declaredName term)) qualifiedNames
|
qualifiedName <- fmap (T.unpack . formatName) <$> traverse (\term -> maybeM (throwNoNameError term) (declaredName term)) qualifiedNames
|
||||||
modulePaths <- resolvePythonModules (QualifiedName qualifiedName)
|
modulePaths <- resolvePythonModules (QualifiedName qualifiedName)
|
||||||
let namesAndPaths = toList (NonEmpty.zip (NonEmpty.zip qualifiedNames (Data.Abstract.Evaluatable.name . T.pack <$> qualifiedName)) modulePaths)
|
let namesAndPaths = toList (NonEmpty.zip (NonEmpty.zip qualifiedNames (Data.Abstract.Evaluatable.name . T.pack <$> qualifiedName)) modulePaths)
|
||||||
|
@ -181,7 +181,9 @@ instance Diffable Class where
|
|||||||
|
|
||||||
instance Evaluatable Class where
|
instance Evaluatable Class where
|
||||||
eval eval _ Class{..} = do
|
eval eval _ Class{..} = do
|
||||||
name <- maybeM (throwNoNameError classIdentifier) (declaredName classIdentifier)
|
(name, relation) <- case declaredName classIdentifier of
|
||||||
|
Just name -> pure (name, Default)
|
||||||
|
_ -> gensym >>= \name -> pure (name, Gensym)
|
||||||
span <- ask @Span
|
span <- ask @Span
|
||||||
currentScope' <- currentScope
|
currentScope' <- currentScope
|
||||||
|
|
||||||
@ -210,7 +212,7 @@ instance Evaluatable Class where
|
|||||||
current = (Lexical, ) <$> pure (pure currentScope')
|
current = (Lexical, ) <$> pure (pure currentScope')
|
||||||
edges = Map.fromList (superclassEdges <> current)
|
edges = Map.fromList (superclassEdges <> current)
|
||||||
classScope <- newScope edges
|
classScope <- newScope edges
|
||||||
declare (Declaration name) Default Public span ScopeGraph.Class (Just classScope)
|
declare (Declaration name) relation Public span ScopeGraph.Class (Just classScope)
|
||||||
|
|
||||||
let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes))
|
let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes))
|
||||||
childFrame <- newFrame classScope frameEdges
|
childFrame <- newFrame classScope frameEdges
|
||||||
@ -241,7 +243,9 @@ data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
|
|||||||
|
|
||||||
instance Evaluatable Module where
|
instance Evaluatable Module where
|
||||||
eval eval _ Module{..} = do
|
eval eval _ Module{..} = do
|
||||||
name <- maybeM (throwNoNameError moduleIdentifier) (declaredName moduleIdentifier)
|
(name, relation) <- case declaredName moduleIdentifier of
|
||||||
|
Just name -> pure (name, Default)
|
||||||
|
_ -> gensym >>= \name -> pure (name, Gensym)
|
||||||
span <- ask @Span
|
span <- ask @Span
|
||||||
currentScope' <- currentScope
|
currentScope' <- currentScope
|
||||||
|
|
||||||
@ -260,7 +264,7 @@ instance Evaluatable Module where
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
let edges = Map.singleton Lexical [ currentScope' ]
|
let edges = Map.singleton Lexical [ currentScope' ]
|
||||||
classScope <- newScope edges
|
classScope <- newScope edges
|
||||||
declare (Declaration name) Default Public span ScopeGraph.Module (Just classScope)
|
declare (Declaration name) relation Public span ScopeGraph.Module (Just classScope)
|
||||||
|
|
||||||
currentFrame' <- currentFrame
|
currentFrame' <- currentFrame
|
||||||
let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
|
let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
|
||||||
@ -323,10 +327,12 @@ instance Declarations1 Assignment where
|
|||||||
|
|
||||||
instance Evaluatable Assignment where
|
instance Evaluatable Assignment where
|
||||||
eval eval ref Assignment{..} = do
|
eval eval ref Assignment{..} = do
|
||||||
lhsName <- maybeM (throwNoNameError assignmentTarget) (declaredName assignmentTarget)
|
(lhsName, relation) <- case declaredName assignmentTarget of
|
||||||
|
Just name -> pure (name, Default)
|
||||||
|
_ -> gensym >>= \name -> pure (name, Gensym)
|
||||||
maybeSlot <- maybeLookupDeclaration (Declaration lhsName)
|
maybeSlot <- maybeLookupDeclaration (Declaration lhsName)
|
||||||
assignmentSpan <- ask @Span
|
assignmentSpan <- ask @Span
|
||||||
maybe (declare (Declaration lhsName) Default Public assignmentSpan ScopeGraph.Assignment Nothing) (const (pure ())) maybeSlot
|
maybe (declare (Declaration lhsName) relation Public assignmentSpan ScopeGraph.Assignment Nothing) (const (pure ())) maybeSlot
|
||||||
|
|
||||||
lhs <- ref assignmentTarget
|
lhs <- ref assignmentTarget
|
||||||
rhs <- eval assignmentValue
|
rhs <- eval assignmentValue
|
||||||
|
@ -58,10 +58,8 @@ instance Evaluatable QualifiedAliasedImport where
|
|||||||
importScope <- newScope (Map.singleton ScopeGraph.Import [ moduleScope ])
|
importScope <- newScope (Map.singleton ScopeGraph.Import [ moduleScope ])
|
||||||
let scopeMap = Map.singleton moduleScope moduleFrame
|
let scopeMap = Map.singleton moduleScope moduleFrame
|
||||||
aliasFrame <- newFrame importScope (Map.singleton ScopeGraph.Import scopeMap)
|
aliasFrame <- newFrame importScope (Map.singleton ScopeGraph.Import scopeMap)
|
||||||
|
name <- declareMaybeName (declaredName aliasTerm) Default Public span ScopeGraph.QualifiedAliasedImport (Just importScope)
|
||||||
alias <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm)
|
aliasSlot <- lookupSlot (Declaration name)
|
||||||
declare (Declaration alias) Default Public span ScopeGraph.QualifiedAliasedImport (Just importScope)
|
|
||||||
aliasSlot <- lookupSlot (Declaration alias)
|
|
||||||
assign aliasSlot =<< object aliasFrame
|
assign aliasSlot =<< object aliasFrame
|
||||||
|
|
||||||
unit
|
unit
|
||||||
|
@ -76,9 +76,8 @@ instance Declarations1 RequiredParameter where
|
|||||||
|
|
||||||
instance Evaluatable RequiredParameter where
|
instance Evaluatable RequiredParameter where
|
||||||
eval eval ref RequiredParameter{..} = do
|
eval eval ref RequiredParameter{..} = do
|
||||||
name <- maybeM (throwNoNameError requiredParameterSubject) (declaredName requiredParameterSubject)
|
|
||||||
span <- ask @Span
|
span <- ask @Span
|
||||||
declare (Declaration name) Default Public span ScopeGraph.RequiredParameter Nothing
|
_ <- declareMaybeName (declaredName requiredParameterSubject) Default Public span ScopeGraph.RequiredParameter Nothing
|
||||||
|
|
||||||
lhs <- ref requiredParameterSubject
|
lhs <- ref requiredParameterSubject
|
||||||
rhs <- eval requiredParameterValue
|
rhs <- eval requiredParameterValue
|
||||||
|
@ -193,7 +193,9 @@ declareModule :: ( AbstractValue term address value m
|
|||||||
-> [term]
|
-> [term]
|
||||||
-> Evaluator term address value m value
|
-> Evaluator term address value m value
|
||||||
declareModule eval identifier statements = do
|
declareModule eval identifier statements = do
|
||||||
name <- maybeM (throwNoNameError identifier) (declaredName identifier)
|
(name, relation) <- case declaredName identifier of
|
||||||
|
Just name -> pure (name, Default)
|
||||||
|
_ -> gensym >>= \name -> pure (name, Gensym)
|
||||||
span <- ask @Span
|
span <- ask @Span
|
||||||
currentScope' <- currentScope
|
currentScope' <- currentScope
|
||||||
|
|
||||||
@ -212,7 +214,7 @@ declareModule eval identifier statements = do
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
let edges = Map.singleton Lexical [ currentScope' ]
|
let edges = Map.singleton Lexical [ currentScope' ]
|
||||||
childScope <- newScope edges
|
childScope <- newScope edges
|
||||||
declare (Declaration name) Default Public span ScopeGraph.Module (Just childScope)
|
declare (Declaration name) relation Public span ScopeGraph.Module (Just childScope)
|
||||||
|
|
||||||
currentFrame' <- currentFrame
|
currentFrame' <- currentFrame
|
||||||
let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
|
let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
|
||||||
@ -257,7 +259,6 @@ instance Declarations a => Declarations (AbstractClass a) where
|
|||||||
|
|
||||||
instance Evaluatable AbstractClass where
|
instance Evaluatable AbstractClass where
|
||||||
eval eval _ AbstractClass{..} = do
|
eval eval _ AbstractClass{..} = do
|
||||||
name <- maybeM (throwNoNameError abstractClassIdentifier) (declaredName abstractClassIdentifier)
|
|
||||||
span <- ask @Span
|
span <- ask @Span
|
||||||
currentScope' <- currentScope
|
currentScope' <- currentScope
|
||||||
|
|
||||||
@ -274,7 +275,7 @@ instance Evaluatable AbstractClass where
|
|||||||
current = (Lexical, ) <$> pure (pure currentScope')
|
current = (Lexical, ) <$> pure (pure currentScope')
|
||||||
edges = Map.fromList (superclassEdges <> current)
|
edges = Map.fromList (superclassEdges <> current)
|
||||||
classScope <- newScope edges
|
classScope <- newScope edges
|
||||||
declare (Declaration name) Default Public span ScopeGraph.AbstractClass (Just classScope)
|
name <- declareMaybeName (declaredName abstractClassIdentifier) Default Public span ScopeGraph.AbstractClass (Just classScope)
|
||||||
|
|
||||||
let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes))
|
let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes))
|
||||||
childFrame <- newFrame classScope frameEdges
|
childFrame <- newFrame classScope frameEdges
|
||||||
|
@ -1,15 +1,63 @@
|
|||||||
{-# LANGUAGE DeriveAnyClass #-}
|
-- Code generated by protoc-gen-haskell 0.1.0, DO NOT EDIT.
|
||||||
|
{-# LANGUAGE DerivingVia, DeriveAnyClass, DuplicateRecordFields #-}
|
||||||
module Proto3.Google.Timestamp (Timestamp (..)) where
|
{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists #-}
|
||||||
|
|
||||||
import Prologue
|
|
||||||
|
|
||||||
import Data.Aeson
|
|
||||||
import Proto3.Suite
|
|
||||||
|
|
||||||
-- | Predefined timestamp message provided by Google. The schema can be found
|
-- | Predefined timestamp message provided by Google. The schema can be found
|
||||||
-- <https://github.com/protocolbuffers/protobuf/blob/master/src/google/protobuf/timestamp.proto here>.
|
-- <https://github.com/protocolbuffers/protobuf/blob/master/src/google/protobuf/timestamp.proto here>.
|
||||||
|
module Proto3.Google.Timestamp (Timestamp (..)) where
|
||||||
|
|
||||||
|
import Control.DeepSeq
|
||||||
|
import Control.Monad (msum)
|
||||||
|
import qualified Data.Aeson as A
|
||||||
|
import qualified Data.Aeson.Encoding as E
|
||||||
|
import Data.ByteString (ByteString)
|
||||||
|
import Data.Int
|
||||||
|
import Data.Text (Text)
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import Data.Vector (Vector)
|
||||||
|
import Data.Word
|
||||||
|
import GHC.Generics
|
||||||
|
import Proto3.Suite (decodeMessageField, encodeMessageField, nestedvec, packedvec)
|
||||||
|
import qualified Proto3.Suite as Proto3
|
||||||
|
import Proto3.Suite.JSONPB as JSONPB
|
||||||
|
import Proto3.Wire (at, oneof)
|
||||||
|
|
||||||
data Timestamp = Timestamp
|
data Timestamp = Timestamp
|
||||||
{ timestampSeconds :: Int64
|
{ seconds :: Int64
|
||||||
, timestampNanos :: Int32
|
, nanos :: Int32
|
||||||
} deriving (Eq, Ord, Show, Generic, Message, Named, NFData, FromJSON, ToJSON)
|
} deriving stock (Eq, Ord, Show, Generic)
|
||||||
|
deriving anyclass (Proto3.Named, NFData)
|
||||||
|
|
||||||
|
instance FromJSONPB Timestamp where
|
||||||
|
parseJSONPB = A.withObject "Timestamp" $ \obj -> Timestamp
|
||||||
|
<$> obj .: "seconds"
|
||||||
|
<*> obj .: "nanos"
|
||||||
|
|
||||||
|
instance ToJSONPB Timestamp where
|
||||||
|
toJSONPB Timestamp{..} = object
|
||||||
|
[
|
||||||
|
"seconds" .= seconds
|
||||||
|
, "nanos" .= nanos
|
||||||
|
]
|
||||||
|
toEncodingPB Timestamp{..} = pairs
|
||||||
|
[
|
||||||
|
"seconds" .= seconds
|
||||||
|
, "nanos" .= nanos
|
||||||
|
]
|
||||||
|
|
||||||
|
instance FromJSON Timestamp where
|
||||||
|
parseJSON = parseJSONPB
|
||||||
|
|
||||||
|
instance ToJSON Timestamp where
|
||||||
|
toJSON = toAesonValue
|
||||||
|
toEncoding = toAesonEncoding
|
||||||
|
|
||||||
|
instance Proto3.Message Timestamp where
|
||||||
|
encodeMessage _ Timestamp{..} = mconcat
|
||||||
|
[
|
||||||
|
encodeMessageField 1 seconds
|
||||||
|
, encodeMessageField 2 nanos
|
||||||
|
]
|
||||||
|
decodeMessage _ = Timestamp
|
||||||
|
<$> at decodeMessageField 1
|
||||||
|
<*> at decodeMessageField 2
|
||||||
|
dotProto = undefined
|
||||||
|
@ -6,7 +6,10 @@ module Proto3.Google.Wrapped
|
|||||||
|
|
||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
|
import qualified Data.Aeson as A
|
||||||
|
|
||||||
import Proto3.Suite
|
import Proto3.Suite
|
||||||
|
import Proto3.Suite.JSONPB as JSONPB
|
||||||
|
|
||||||
-- | Because protobuf primitive types (string, int32, etc.) are not nullable, Google provides a set of standard
|
-- | Because protobuf primitive types (string, int32, etc.) are not nullable, Google provides a set of standard
|
||||||
-- <https://github.com/protocolbuffers/protobuf/blob/master/src/google/protobuf/wrappers.proto wrappers>
|
-- <https://github.com/protocolbuffers/protobuf/blob/master/src/google/protobuf/wrappers.proto wrappers>
|
||||||
@ -16,6 +19,27 @@ import Proto3.Suite
|
|||||||
newtype Wrapped a = Wrapped { value :: a }
|
newtype Wrapped a = Wrapped { value :: a }
|
||||||
deriving (Eq, Show, Ord, Generic, NFData)
|
deriving (Eq, Show, Ord, Generic, NFData)
|
||||||
|
|
||||||
|
instance (HasDefault a, FromJSONPB a) => FromJSONPB (Wrapped a) where
|
||||||
|
parseJSONPB = A.withObject "Value" $ \obj -> Wrapped
|
||||||
|
<$> obj .: "value"
|
||||||
|
|
||||||
|
instance (HasDefault a, ToJSONPB a) => ToJSONPB (Wrapped a) where
|
||||||
|
toJSONPB Wrapped{..} = object
|
||||||
|
[
|
||||||
|
"value" .= value
|
||||||
|
]
|
||||||
|
toEncodingPB Wrapped{..} = pairs
|
||||||
|
[
|
||||||
|
"value" .= value
|
||||||
|
]
|
||||||
|
|
||||||
|
instance (HasDefault a, FromJSONPB a) => FromJSON (Wrapped a) where
|
||||||
|
parseJSON = parseJSONPB
|
||||||
|
|
||||||
|
instance (HasDefault a, ToJSONPB a) => ToJSON (Wrapped a) where
|
||||||
|
toJSON = toAesonValue
|
||||||
|
toEncoding = toAesonEncoding
|
||||||
|
|
||||||
instance Named (Wrapped Text) where nameOf _ = "StringValue"
|
instance Named (Wrapped Text) where nameOf _ = "StringValue"
|
||||||
instance Named (Wrapped ByteString) where nameOf _ = "BytesValue"
|
instance Named (Wrapped ByteString) where nameOf _ = "BytesValue"
|
||||||
instance Named (Wrapped Double) where nameOf _ = "DoubleValue"
|
instance Named (Wrapped Double) where nameOf _ = "DoubleValue"
|
||||||
|
Loading…
Reference in New Issue
Block a user