mirror of
https://github.com/github/semantic.git
synced 2024-12-25 07:55:12 +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 :: 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 :: (Has (Sketch Name) sig m) => m Result
|
||||||
sampleGraphThing = do
|
sampleGraphThing = do
|
||||||
@ -62,7 +62,7 @@ main = do
|
|||||||
file <- ByteString.readFile path
|
file <- ByteString.readFile path
|
||||||
tree <- TS.parseByteString @Py.Module @Loc TSP.tree_sitter_python file
|
tree <- TS.parseByteString @Py.Module @Loc TSP.tree_sitter_python file
|
||||||
pyModule <- either die pure tree
|
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
|
let (result, Complete) = runScopeGraph (Path.absRel path) (Source.fromUTF8 file) pyModule
|
||||||
print result
|
print result
|
||||||
assertEqual expecto result
|
assertEqual expecto result
|
||||||
|
@ -7,9 +7,9 @@
|
|||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
|
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
|
||||||
|
|
||||||
module Control.Carrier.Sketch.Fresh
|
module Control.Carrier.Sketch.Fresh
|
||||||
@ -23,27 +23,36 @@ import Control.Carrier.Fresh.Strict
|
|||||||
import Control.Carrier.State.Strict
|
import Control.Carrier.State.Strict
|
||||||
import Control.Effect.Sketch
|
import Control.Effect.Sketch
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
import Data.Bifunctor
|
||||||
import Data.Module
|
import Data.Module
|
||||||
import Data.Name (Name)
|
import Data.Name (Name)
|
||||||
import qualified Data.Name
|
import qualified Data.Name
|
||||||
import Data.Bifunctor
|
|
||||||
import Data.ScopeGraph (ScopeGraph)
|
import Data.ScopeGraph (ScopeGraph)
|
||||||
import qualified Data.ScopeGraph as ScopeGraph
|
import qualified Data.ScopeGraph as ScopeGraph
|
||||||
import Data.Semilattice.Lower
|
import Data.Semilattice.Lower
|
||||||
|
import Source.Span
|
||||||
import qualified System.Path as Path
|
import qualified System.Path as Path
|
||||||
import Source.Span
|
|
||||||
|
|
||||||
newtype Sketchbook address = Sketchbook
|
data Sketchbook address = Sketchbook
|
||||||
{ sGraph :: ScopeGraph address
|
{ sGraph :: ScopeGraph address
|
||||||
} deriving (Eq, Show, Lower)
|
, 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)
|
newtype SketchC address m a = SketchC (StateC (Sketchbook address) (FreshC m) a)
|
||||||
deriving (Applicative, Functor, Monad, MonadIO)
|
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
|
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
|
alg (L (Declare n _props k)) = do
|
||||||
old <- SketchC (gets @(Sketchbook address) sGraph)
|
Sketchbook old current <- SketchC (get @(Sketchbook Name))
|
||||||
addr <- SketchC Data.Name.gensym
|
|
||||||
let (new, _pos) =
|
let (new, _pos) =
|
||||||
ScopeGraph.declare
|
ScopeGraph.declare
|
||||||
(ScopeGraph.Declaration (Data.Name.name n))
|
(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)
|
(lowerBound @Span)
|
||||||
ScopeGraph.Identifier
|
ScopeGraph.Identifier
|
||||||
Nothing
|
Nothing
|
||||||
addr
|
current
|
||||||
old
|
old
|
||||||
SketchC (put (Sketchbook new))
|
SketchC (put @(Sketchbook Name) (Sketchbook new current))
|
||||||
k ()
|
k ()
|
||||||
alg (R other) = SketchC (alg (R (R (handleCoercible other))))
|
alg (R other) = SketchC (alg (R (R (handleCoercible other))))
|
||||||
|
|
||||||
runSketch ::
|
runSketch ::
|
||||||
(Ord address, Functor m)
|
(Functor m)
|
||||||
=> Maybe Path.AbsRelFile
|
=> Maybe Path.AbsRelFile
|
||||||
-> SketchC address m a
|
-> SketchC Name m a
|
||||||
-> m (ScopeGraph address, a)
|
-> m (ScopeGraph Name, a)
|
||||||
runSketch _rootpath (SketchC go)
|
runSketch _rootpath (SketchC go)
|
||||||
= evalFresh 0
|
= evalFresh 0
|
||||||
. fmap (first sGraph)
|
. fmap (first sGraph)
|
||||||
|
@ -274,7 +274,6 @@ declare :: Ord scope
|
|||||||
-> (ScopeGraph scope, Maybe Position)
|
-> (ScopeGraph scope, Maybe Position)
|
||||||
declare decl moduleInfo rel accessControl declSpan kind assocScope currentScope g = fromMaybe (g, Nothing) $ do
|
declare decl moduleInfo rel accessControl declSpan kind assocScope currentScope g = fromMaybe (g, Nothing) $ do
|
||||||
scope <- lookupScope currentScope g
|
scope <- lookupScope currentScope g
|
||||||
|
|
||||||
dataSeq <- ddataOfScope currentScope g
|
dataSeq <- ddataOfScope currentScope g
|
||||||
case Seq.findIndexR (\Info{..} -> decl == infoDeclaration && declSpan == infoSpan && rel == infoRelation) dataSeq of
|
case Seq.findIndexR (\Info{..} -> decl == infoDeclaration && declSpan == infoSpan && rel == infoRelation) dataSeq of
|
||||||
Just index -> pure (g, Just (Position index))
|
Just index -> pure (g, Just (Position index))
|
||||||
|
Loading…
Reference in New Issue
Block a user