mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Add ingSyntaxGraphtoDrawing, and add case for NestedApplyNode to nodeToIcon.
This commit is contained in:
parent
deb999a71b
commit
69f6a6c4f2
@ -21,7 +21,8 @@ module TranslateCore(
|
||||
nTupleString,
|
||||
nListString,
|
||||
syntaxGraphToDrawing,
|
||||
syntaxGraphToFglGraph
|
||||
syntaxGraphToFglGraph,
|
||||
ingSyntaxGraphToDrawing
|
||||
) where
|
||||
|
||||
import Data.Semigroup(Semigroup, (<>))
|
||||
@ -30,11 +31,13 @@ import Control.Monad.State(State)
|
||||
import Data.Either(partitionEithers)
|
||||
import Control.Arrow(second)
|
||||
import Data.Graph.Inductive.PatriciaTree as FGR
|
||||
import qualified Data.Graph.Inductive as ING
|
||||
import Diagrams.TwoD.GraphViz as DiaGV
|
||||
import Data.List(find)
|
||||
|
||||
import Types(Icon, SyntaxNode(..), Edge(..), EdgeOption(..), Drawing(..),
|
||||
NameAndPort(..), IDState, getId, SgNamedNode)
|
||||
import Util(noEnds, nameAndPort, makeSimpleEdge, justName, fromMaybeError)
|
||||
NameAndPort(..), IDState, getId, SgNamedNode, IngSyntaxGraph)
|
||||
import Util(noEnds, nameAndPort, makeSimpleEdge, justName, fromMaybeError, maybeBoolToBool)
|
||||
import Icons(Icon(..))
|
||||
|
||||
-- OVERVIEW --
|
||||
@ -173,6 +176,7 @@ nListString n = '[' : replicate (n -1) ',' ++ "]"
|
||||
|
||||
nodeToIcon :: SyntaxNode -> Icon
|
||||
nodeToIcon (ApplyNode n) = ApplyAIcon n
|
||||
nodeToIcon (NestedApplyNode x edges) = nestedApplySyntaxNodeToIcon x edges
|
||||
nodeToIcon (PatternApplyNode s n) = PAppIcon n s
|
||||
nodeToIcon (NameNode s) = TextBoxIcon s
|
||||
nodeToIcon (LiteralNode s) = TextBoxIcon s
|
||||
@ -182,6 +186,21 @@ nodeToIcon (CaseNode n) = CaseIcon n
|
||||
nodeToIcon BranchNode = BranchIcon
|
||||
nodeToIcon CaseResultNode = CaseResultIcon
|
||||
|
||||
nestedApplySyntaxNodeToIcon :: Int -> [(SgNamedNode, Edge)] -> Icon
|
||||
nestedApplySyntaxNodeToIcon numArgs args = NestedApply argList where
|
||||
-- argList should be of length numArgs + 1, since argList includes the function expression
|
||||
-- port 0 is the function, ports 2..(numArgs+1) are the arguments
|
||||
argList = fmap makeArg (0:[2..numArgs + 1])
|
||||
makeArg port = case find (findArg port) args of
|
||||
Nothing -> Nothing
|
||||
Just ((argName, argSyntaxNode), _) -> Just (argName, nodeToIcon argSyntaxNode)
|
||||
|
||||
findArg :: Int -> (SgNamedNode, Edge) -> Bool
|
||||
findArg currentPort ((argName, _), Edge _ _ (NameAndPort fromName fromPort, NameAndPort toName toPort))
|
||||
| argName == fromName = maybeBoolToBool $ fmap (== currentPort) toPort
|
||||
| argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort
|
||||
| otherwise = False -- This case should never happen
|
||||
|
||||
syntaxGraphToFglGraph :: SyntaxGraph -> FGR.Gr SgNamedNode Edge
|
||||
syntaxGraphToFglGraph (SyntaxGraph nodes edges _ _) =
|
||||
DiaGV.mkGraph nodes labeledEdges where
|
||||
@ -199,4 +218,7 @@ syntaxGraphToDrawing (SyntaxGraph nodes edges sources sinks) =
|
||||
Drawing icons edges [] where
|
||||
icons = fmap (second nodeToIcon) nodes
|
||||
|
||||
-- TODO Add ingSyntaxGraphToDrawing :: IngSyntaxGraph gr -> Drawing
|
||||
ingSyntaxGraphToDrawing :: ING.Graph gr => IngSyntaxGraph gr -> Drawing
|
||||
ingSyntaxGraphToDrawing syntaxGraph = Drawing icons edges [] where
|
||||
icons = ((second nodeToIcon) . snd) <$> ING.labNodes syntaxGraph
|
||||
edges = ING.edgeLabel <$> ING.labEdges syntaxGraph
|
||||
|
@ -15,7 +15,8 @@ module Util (
|
||||
fromMaybeError,
|
||||
mapFst,
|
||||
printSelf,
|
||||
eitherToMaybes
|
||||
eitherToMaybes,
|
||||
maybeBoolToBool
|
||||
)where
|
||||
|
||||
import Control.Arrow(first)
|
||||
@ -74,3 +75,7 @@ printSelf a = Debug.Trace.trace (show a ++ "\n\n") a
|
||||
eitherToMaybes :: Either a b -> (Maybe a, Maybe b)
|
||||
eitherToMaybes (Left x) = (Just x, Nothing)
|
||||
eitherToMaybes (Right y) = (Nothing, Just y)
|
||||
|
||||
-- | (Just True) = True, Nothing = False
|
||||
maybeBoolToBool :: Maybe Bool -> Bool
|
||||
maybeBoolToBool = or
|
||||
|
Loading…
Reference in New Issue
Block a user