1
1
mirror of https://github.com/github/semantic.git synced 2024-12-25 07:55:12 +03:00

it works!

This commit is contained in:
Patrick Thomson 2020-01-14 14:44:08 -05:00
parent e9247ab8a8
commit 90ca2c8b3f
3 changed files with 24 additions and 16 deletions

View File

@ -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

View File

@ -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)

View File

@ -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))