1
1
mirror of https://github.com/github/semantic.git synced 2024-12-30 02:14:20 +03:00

Give a type for importGraphAnalysis.

This commit is contained in:
Rob Rix 2018-05-04 19:41:10 -04:00
parent d31dce7490
commit 8e73d99889

View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators #-}
module Semantic.Graph where
import Analysis.Abstract.BadAddresses
@ -11,21 +11,22 @@ import Analysis.Abstract.Evaluating
import Analysis.Abstract.ImportGraph
import qualified Control.Exception as Exc
import Data.Abstract.Address
import qualified Data.Abstract.Evaluatable as Analysis
import Data.Abstract.Evaluatable
import Data.Abstract.FreeVariables
import Data.Abstract.Located
import Data.Abstract.Module
import Data.Abstract.Package as Package
import Data.Abstract.Value (Value)
import Data.Abstract.Value (Value, ValueError)
import Data.File
import Data.Output
import Data.Semilattice.Lower
import qualified Data.Syntax as Syntax
import Data.Term
import Parsing.Parser
import Prologue hiding (MonadError (..))
import Rendering.Renderer
import Semantic.IO (Files)
import Semantic.Task
import Semantic.Task as Task
graph :: Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs
=> GraphRenderer output
@ -33,7 +34,7 @@ graph :: Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telem
-> Eff effs ByteString
graph renderer project
| SomeAnalysisParser parser prelude <- someAnalysisParser
(Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do
(Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do
parsePackage parser prelude project >>= graphImports >>= case renderer of
JSONGraphRenderer -> pure . toOutput
DOTGraphRenderer -> pure . renderImportGraph
@ -62,9 +63,27 @@ parseModule parser rootDir file = do
moduleForBlob rootDir blob <$> parse parser blob
importGraphAnalysis :: forall location term value syntax ann a
. ( AbstractHole value
, Element Syntax.Identifier syntax
, Lower (Cell location value)
, Show location
, Show value
)
=> Evaluator location term value
( State (ImportGraph (Term (Sum syntax) ann))
': Resumable (AddressError location value)
': Resumable (ResolutionError value)
': Resumable (EvalError value)
': State [Name]
': Resumable (ValueError location value)
': Resumable (Unspecialized value)
': Resumable (LoadError term)
': EvaluatingEffects location term value) a
-> (Either String (Either (SomeExc (LoadError term)) ((a, ImportGraph (Term (Sum syntax) ann)), [Name])), EvaluatingState location term value)
importGraphAnalysis
= evaluating
. erroring @(Analysis.LoadError term)
. erroring @(LoadError term)
. resumingBadSyntax
. resumingBadValues
. resumingBadVariables
@ -75,8 +94,8 @@ importGraphAnalysis
-- | Render the import graph for a given 'Package'.
graphImports :: ( Show ann
, Ord ann
, Apply Analysis.Declarations1 syntax
, Apply Analysis.Evaluatable syntax
, Apply Declarations1 syntax
, Apply Evaluatable syntax
, Apply FreeVariables1 syntax
, Apply Functor syntax
, Apply Ord1 syntax
@ -85,14 +104,10 @@ graphImports :: ( Show ann
, Element Syntax.Identifier syntax
, Members '[Exc SomeException, Task] effs
)
=> Package (Term (Sum syntax) ann) -> Eff effs ImportGraph
graphImports package = analyze (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package) >>= extractGraph
=> Package (Term (Sum syntax) ann)
-> Eff effs (ImportGraph (Term (Sum syntax) ann))
graphImports package = analyze importGraphAnalysis (evaluatePackageWith package) >>= extractGraph
where
asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value
-> Package term
-> ImportGraphAnalysis term effs value
asAnalysisForTypeOfPackage = const
extractGraph result = case result of
(Right (Right ((_, graph), _)), _) -> pure graph
_ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result)))
_ -> Task.throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result)))