mirror of
https://github.com/github/semantic.git
synced 2024-12-24 23:42:31 +03:00
it works!
This commit is contained in:
parent
e9247ab8a8
commit
90ca2c8b3f
@ -44,7 +44,7 @@ The graph should be
|
||||
|
||||
|
||||
runScopeGraph :: ToScopeGraph t => Path.AbsRelFile -> Source.Source -> t Loc -> (ScopeGraph.ScopeGraph Name, Result)
|
||||
runScopeGraph p _src item = run . runSketch @Name (Just p) $ scopeGraph item
|
||||
runScopeGraph p _src item = run . runSketch (Just p) $ scopeGraph item
|
||||
|
||||
sampleGraphThing :: (Has (Sketch Name) sig m) => m Result
|
||||
sampleGraphThing = do
|
||||
@ -62,7 +62,7 @@ main = do
|
||||
file <- ByteString.readFile path
|
||||
tree <- TS.parseByteString @Py.Module @Loc TSP.tree_sitter_python file
|
||||
pyModule <- either die pure tree
|
||||
let (expecto, Complete) = run $ runSketch @Name Nothing sampleGraphThing
|
||||
let (expecto, Complete) = run $ runSketch Nothing sampleGraphThing
|
||||
let (result, Complete) = runScopeGraph (Path.absRel path) (Source.fromUTF8 file) pyModule
|
||||
print result
|
||||
assertEqual expecto result
|
||||
|
@ -7,9 +7,9 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
|
||||
|
||||
module Control.Carrier.Sketch.Fresh
|
||||
@ -23,27 +23,36 @@ import Control.Carrier.Fresh.Strict
|
||||
import Control.Carrier.State.Strict
|
||||
import Control.Effect.Sketch
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Bifunctor
|
||||
import Data.Module
|
||||
import Data.Name (Name)
|
||||
import qualified Data.Name
|
||||
import Data.Bifunctor
|
||||
import Data.ScopeGraph (ScopeGraph)
|
||||
import qualified Data.ScopeGraph as ScopeGraph
|
||||
import Data.Semilattice.Lower
|
||||
import Source.Span
|
||||
import qualified System.Path as Path
|
||||
import Source.Span
|
||||
|
||||
newtype Sketchbook address = Sketchbook
|
||||
{ sGraph :: ScopeGraph address
|
||||
} deriving (Eq, Show, Lower)
|
||||
data Sketchbook address = Sketchbook
|
||||
{ sGraph :: ScopeGraph address
|
||||
, sCurrentScope :: address
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance Lower (Sketchbook Name) where
|
||||
lowerBound =
|
||||
let
|
||||
initialGraph = ScopeGraph.insertScope n initialScope lowerBound
|
||||
initialScope = ScopeGraph.Scope mempty mempty mempty
|
||||
n = Data.Name.nameI 0
|
||||
in
|
||||
Sketchbook initialGraph n
|
||||
|
||||
newtype SketchC address m a = SketchC (StateC (Sketchbook address) (FreshC m) a)
|
||||
deriving (Applicative, Functor, Monad, MonadIO)
|
||||
|
||||
instance forall address sig m . (address ~ Name, Effect sig, Algebra sig m) => Algebra (Sketch Name :+: sig) (SketchC Name m) where
|
||||
alg (L (Declare n _props k)) = do
|
||||
old <- SketchC (gets @(Sketchbook address) sGraph)
|
||||
addr <- SketchC Data.Name.gensym
|
||||
Sketchbook old current <- SketchC (get @(Sketchbook Name))
|
||||
let (new, _pos) =
|
||||
ScopeGraph.declare
|
||||
(ScopeGraph.Declaration (Data.Name.name n))
|
||||
@ -53,17 +62,17 @@ instance forall address sig m . (address ~ Name, Effect sig, Algebra sig m) => A
|
||||
(lowerBound @Span)
|
||||
ScopeGraph.Identifier
|
||||
Nothing
|
||||
addr
|
||||
current
|
||||
old
|
||||
SketchC (put (Sketchbook new))
|
||||
SketchC (put @(Sketchbook Name) (Sketchbook new current))
|
||||
k ()
|
||||
alg (R other) = SketchC (alg (R (R (handleCoercible other))))
|
||||
|
||||
runSketch ::
|
||||
(Ord address, Functor m)
|
||||
(Functor m)
|
||||
=> Maybe Path.AbsRelFile
|
||||
-> SketchC address m a
|
||||
-> m (ScopeGraph address, a)
|
||||
-> SketchC Name m a
|
||||
-> m (ScopeGraph Name, a)
|
||||
runSketch _rootpath (SketchC go)
|
||||
= evalFresh 0
|
||||
. fmap (first sGraph)
|
||||
|
@ -274,7 +274,6 @@ declare :: Ord scope
|
||||
-> (ScopeGraph scope, Maybe Position)
|
||||
declare decl moduleInfo rel accessControl declSpan kind assocScope currentScope g = fromMaybe (g, Nothing) $ do
|
||||
scope <- lookupScope currentScope g
|
||||
|
||||
dataSeq <- ddataOfScope currentScope g
|
||||
case Seq.findIndexR (\Info{..} -> decl == infoDeclaration && declSpan == infoSpan && rel == infoRelation) dataSeq of
|
||||
Just index -> pure (g, Just (Position index))
|
||||
|
Loading…
Reference in New Issue
Block a user