1
1
mirror of https://github.com/github/semantic.git synced 2024-12-24 23:42:31 +03:00

Move Edge into Concrete.

This commit is contained in:
Rob Rix 2019-07-23 16:11:04 -04:00
parent 7c24672921
commit a0bf65f43b
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
2 changed files with 10 additions and 11 deletions

View File

@ -59,6 +59,9 @@ newtype Frame = Frame
type Heap = IntMap.IntMap Concrete
data Edge = Lexical | Import
deriving (Eq, Ord, Show)
-- | Concrete evaluation of a term to a value.
--
@ -153,14 +156,14 @@ runHeap = runState mempty
-- > λ let (heap, res) = concrete [ruby]
-- > λ writeFile "/Users/rob/Desktop/heap.dot" (export (addressStyle heap) (heapAddressGraph heap))
-- > λ :!dot -Tsvg < ~/Desktop/heap.dot > ~/Desktop/heap.svg
heapGraph :: (Precise -> Concrete -> a) -> (Either Core.Edge User -> Precise -> G.Graph a) -> Heap -> G.Graph a
heapGraph :: (Precise -> Concrete -> a) -> (Either Edge User -> Precise -> G.Graph a) -> Heap -> G.Graph a
heapGraph vertex edge h = foldr (uncurry graph) G.empty (IntMap.toList h)
where graph k v rest = (G.vertex (vertex k v) `G.connect` outgoing v) `G.overlay` rest
outgoing = \case
Unit -> G.empty
Bool _ -> G.empty
String _ -> G.empty
Closure _ _ _ env -> foldr (G.overlay . edge (Left Core.Lexical)) G.empty env
Closure _ _ _ env -> foldr (G.overlay . edge (Left Lexical)) G.empty env
Record frame -> foldr (G.overlay . uncurry (edge . Right)) G.empty (Map.toList frame)
heapValueGraph :: Heap -> G.Graph Concrete
@ -173,10 +176,10 @@ heapAddressGraph = heapGraph (\ addr v -> (Value v, addr)) (fmap G.vertex . (,)
addressStyle :: Heap -> G.Style (EdgeType, Precise) Text
addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes }
where vertex (_, addr) = pack (show addr) <> " = " <> maybe "?" fromConcrete (IntMap.lookup addr heap)
edgeAttributes _ (Slot name, _) = ["label" G.:= name]
edgeAttributes _ (Edge Core.Import, _) = ["color" G.:= "blue"]
edgeAttributes _ (Edge Core.Lexical, _) = ["color" G.:= "green"]
edgeAttributes _ _ = []
edgeAttributes _ (Slot name, _) = ["label" G.:= name]
edgeAttributes _ (Edge Import, _) = ["color" G.:= "blue"]
edgeAttributes _ (Edge Lexical, _) = ["color" G.:= "green"]
edgeAttributes _ _ = []
fromConcrete = \case
Unit -> "()"
Bool b -> pack $ show b
@ -186,7 +189,7 @@ addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes }
showPos (Pos l c) = pack (show l) <> ":" <> pack (show c)
data EdgeType
= Edge Core.Edge
= Edge Edge
| Slot User
| Value Concrete
deriving (Eq, Ord, Show)

View File

@ -2,7 +2,6 @@
ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Data.Core
( Core(..)
, Edge(..)
, rec
, (>>>)
, unseq
@ -50,9 +49,6 @@ import Data.Text (Text)
import GHC.Generics (Generic1)
import GHC.Stack
data Edge = Lexical | Import
deriving (Eq, Ord, Show)
data Core f a
-- | Recursive local binding of a name in a scope; strict evaluation of the name in the body will diverge.
--