8000 Implement concatenation algorithm for paths. · github/semantic@87ec75b · GitHub
[go: up one dir, main page]
Skip to content
This repository was archived by the owner on Apr 1, 2025. It is now read-only.

Commit 87ec75b

Browse files
author
Patrick Thomson
committed
Implement concatenation algorithm for paths.
1 parent 15e982d commit 87ec75b

File tree

2 files changed

+115
-4
lines changed

2 files changed

+115
-4
lines changed

‎semantic-scope-graph/src/Data/Functor/Tagged.hs

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@ module Data.Functor.Tagged
1313
-- * Monadic creation functions
1414
, taggedM
1515
, taggedIO
16+
, unsafeTagged
1617
-- * Reexports
1718
, extract
1819
) where
@@ -21,6 +22,7 @@ import Control.Comonad
2122
import Control.Effect.Fresh
2223
import Control.Lens.Getter
2324
import Control.Lens.Lens
25+
import System.IO.Unsafe
2426
import Data.Function
2527
import Data.Generics.Product
2628
import Data.Unique
@@ -63,3 +65,7 @@ taggedM a = (a :#) <$> fresh
6365
-- ordered, but are guaranteed to be unique throughout the life of the program.
6466
taggedIO :: a -> IO (Tagged a)
6567
taggedIO a = (a :#) . hashUnique <$> newUnique
68+
69+
-- This is bad. Don't use it.
70+
unsafeTagged :: a -> Tagged a
71+
unsafeTagged = unsafePerformIO . taggedIO

‎semantic-scope-graph/src/Stack/Path.hs

Lines changed: 109 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,14 @@
1+
{-# LANGUAGE DeriveGeneric #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE TypeApplications #-}
14
{-# LANGUAGE NamedFieldPuns #-}
25
{-# LANGUAGE OverloadedLists #-}
6+
{-# LANGUAGE OverloadedStrings #-}
37
module Stack.Path
48
( Path (..)
9+
, Compatibility (..)
10+
, compatibility
11+
, concatenate
512
, Edge (..)
613
, StartingSize (..)
714
, PathInvariantError (..)
@@ -12,15 +19,20 @@ module Stack.Path
1219
, Completion (..)
1320
, completion
1421
, isIncremental
22+
1523
) where
1624

1725

1826
import Data.Functor.Tagged
1927
import Data.Monoid
2028
import Data.Semigroup (sconcat)
21-
import Data.Sequence (Seq (..))
29+
import Data.Sequence (Seq (..), (|>))
2230
import Data.Text (Text)
2331
import Stack.Graph (Node (..), Symbol)
32+
import Data.Generics.Product
33+
import Control.Lens ((^.), Lens')
34+
import GHC.Generics
35+
import Data.List (isPrefixOf)
2436

2537
-- | A partial path through a stack graph. These will be generated
2638
-- from walks through the stack graph, and can be thought of as
@@ -34,7 +46,15 @@ data Path = Path
3446
, endingSymbolStack :: [Symbol]
3547
, startingScopeStackSize :: StartingSize
3648
, endingScopeStack :: [Tag]
37-
} deriving (Eq, Show)
49+
} deriving (Eq, Show, Generic)
50+
51+
startingNode_, endingNode_ :: Lens' Path (Tagged Node)
52+
startingNode_ = field @"startingNode"
53+
endingNode_ = field @"endingNode"
54+
55+
startingSymbolStack_, endingSymbolStack_ :: Lens' Path [Symbol]
56+
startingSymbolStack_ = field @"startingSymbolStack"
57+
endingSymbolStack_ = field @"endingSymbolStack"
3858

3959
data Edge = Edge
4060
{ sourceNode :: Tagged Node
@@ -45,7 +65,7 @@ data Edge = Edge
4565
data StartingSize
4666
= Zero
4767
| One
48-
deriving (Eq, Show)
68+
deriving (Eq, Show, Ord, Enum)
4969

5070
data PathInvariantError
5171
= ExpectedEqual (Tagged Node) (Tagged Node)
@@ -120,7 +140,10 @@ validity p = sconcat [vStart, vEnd, vSize]
120140
(One, _) -> Invalid
121141
_otherwise -> Valid
122142

123-
data Completion = Partial | Complete
143+
data Completion
144+
= Partial
145+
| Complete
146+
deriving (Eq, Show)
124147

125148
-- | A path is complete if its starting node is a reference node and its ending node is a definition node. Otherwise it is partial.
126149
completion :: Path -> Completion
@@ -130,3 +153,85 @@ completion _
130153
-- | A path is incremental if the source node and sink node of every edge in the path belongs to the same file.
131154
isIncremental :: Path -> Bool
132155
isIncremental = error "TODO: need file support to implement this"
156+
157+
data Compatibility
158+
= Compatible
159+
| Incompatible
160+
deriving (Eq, Show)
161+
162+
compatibility :: Path -> Path -> Compatibility
163+
compatibility left right
164+
-- Two paths 'left' and 'right' are compatible with each other if all the following are true:
165+
| and @[] [nodesCompatible, stackPrefix, hasElements] = Compatible
166+
| otherwise = Incompatible
167+
where
168+
-- Any of the following are true:
169+
nodesCompatible =
170+
-- The ending node of 'left' and the starting node of 'right' are both the root node.
171+
let bothRootNode = left ^. endingNode_.contents == Root && right ^. startingNode_.contents == Root
172+
-- The ending node of 'left' and the starting node of 'right' are both scope references, and both refer to the same scope
173+
bothSameScope = case (left ^. endingNode_, right ^. startingNode_) of
174+
-- TODO: determining "same scope" by symbol comparison is rough
175+
(Scope s1 :# _, Scope s2 :# _) -> s1 == s2
176+
_ -> False
177+
in bothRootNode || bothSameScope
178+
-- The starting symbol stack of 'right' is a prefix of the ending symbol stack of 'left'.
179+
stackPrefix = (right ^. startingSymbolStack_) `isPrefixOf` (left ^. endingSymbolStack_)
180+
-- The ending scope stack of 'left' has at least as many elements as the starting scope stack size of 'right'.
181+
hasElements = (length (endingScopeStack left)) >= fromEnum (startingScopeStackSize right)
182+
183+
concatenate :: Path -> Path -> Maybe Path
184+
concatenate left right
185+
-- Incompatible paths cannot be concatenated.
186+
| compatibility left right == Incompatible = Nothing
187+
-- If left and right are compatible with each other, you can concatenate them together, yielding a new path:
188+
| otherwise =
189+
-- The new path's starting node, starting symbol stack, and starting scope stack size are the same as left.
190+
let (newStartingNode, newStartingSymbolStack, newStartingScopeStackSize) = (startingNode left, startingSymbolStack left, startingScopeStackSize left)
191+
-- The new path's edge list is the concatenation of left's and right's edge lists.
192+
allEdges = edges left <> edges right
193+
-- The new path's ending symbol stack is the value of new symbol stack after doing the following:
194+
newEndingSymbolStack =
195+
-- Let new symbol stack be a copy of left's ending symbol stack.
196+
let newSymbolStack = endingSymbolStack left
197+
-- Remove right's starting symbol stack from the beginning of new symbol stack. (This must succeed because the two input paths are compatible.)
198+
withoutRight = drop (length (startingSymbolStack right)) newSymbolStack
199+
in -- Prepend a copy of right's ending symbol stack to the beginning of new symbol stack.
200+
endingSymbolStack right <> withoutRight
201+
-- The new path's ending scope stack is the value of new scope stack after doing the following:
202+
newEndingScopeStack =
203+
-- Let new scope stack be a copy of left's ending scope stack.
204+
let newScopeStack = endingScopeStack left
205+
-- If right's starting scope stack size is 1, pop resolved scope identifier from the beginning of new scope stack.
206+
popped = if startingScopeStackSize right == One then drop 1 newScopeStack else newScopeStack
207+
in -- Prepend a copy of right's ending scope stack to the beginning of new scope stack.
208+
endingScopeStack right <> popped
209+
-- The new path's ending node is the same as right's.
210+
newEndingNode = endingNode right
211+
newEdges = case newEndingNode of
212+
-- If right's ending node is a jump to scope node node, then:
213+
JumpToScope :# _ ->
214+
-- Let jump edge be a new edge whose:
215+
let jumpEdge =
216+
Edge
217+
{ sourceNode = newEndingNode, -- source node is node
218+
-- sink node is an exported scope node whose scope identifier is resolved scope identifier
219+
-- PT TODO: we don't appear to have scope identifiers attached to exported scope nodes
220+
sinkNode = unsafeTagged ExportedScope,
221+
-- label is `jump``
222+
label = "jump"
223+
}
224+
in -- Append jump edge to the new path.
225+
(allEdges |> jumpEdge)
226+
-- Otherwise, do nothing
227+
_ -> allEdges
228+
in pure
229+
Path
230+
{ startingNode = newStartingNode,
231+
endingNode = newEndingNode,
232+
edges = newEdges,
233+
startingSymbolStack = newStartingSymbolStack,
234+
endingSymbolStack = newEndingSymbolStack,
235+
startingScopeStackSize = newStartingScopeStackSize,
236+
endingScopeStack = newEndingScopeStack
237+
}

0 commit comments

Comments
 (0)
0