mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Add NameAndPort data type. Translate works with simple functions.
This commit is contained in:
parent
d3b38bb491
commit
009f7b0b30
@ -240,8 +240,9 @@ main2 = mainWith ((apply0NDia 3 # bgFrame 0.1 black) :: Diagram B)
|
||||
main3 :: IO ()
|
||||
main3 = do
|
||||
let
|
||||
(drawing, decl) = translateString "y2 = x1"
|
||||
(drawing, decl) = translateString "y2 = f x1 x2 x3 x4"
|
||||
print decl
|
||||
print drawing
|
||||
placedNodes <- renderDrawing drawing
|
||||
mainWith ((placedNodes # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)
|
||||
|
||||
|
@ -21,7 +21,7 @@ import Data.Graph.Inductive.PatriciaTree (Gr)
|
||||
import Data.Typeable(Typeable)
|
||||
|
||||
import Icons(colorScheme, Icon(..), iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..))
|
||||
import Types(Edge(..), Connection, Drawing(..), EdgeEnd(..))
|
||||
import Types(Edge(..), Connection, Drawing(..), EdgeEnd(..), NameAndPort(..))
|
||||
|
||||
-- If the inferred types for these functions becomes unweildy,
|
||||
-- try using PartialTypeSignitures.
|
||||
@ -45,10 +45,10 @@ makeNamedMap subDiagramMap =
|
||||
map (\(name, icon) -> (name, iconToDiagram icon subDiagramMap # nameDiagram name))
|
||||
|
||||
-- | Make an inductive Graph from a list of node names, and a list of Connections.
|
||||
edgesToGraph :: (Ord v) => [v] -> [(v, t, v , t1)] -> Gr v ()
|
||||
edgesToGraph :: [Name] -> [(NameAndPort, NameAndPort)] -> Gr Name ()
|
||||
edgesToGraph iconNames edges = mkGraph iconNames simpleEdges
|
||||
where
|
||||
simpleEdges = map (\(a, _, c, _) -> (a, c, ())) edges
|
||||
simpleEdges = map (\(NameAndPort a _, NameAndPort c _) -> (a, c, ())) edges
|
||||
|
||||
-- | Custom arrow tail for the arg1 result circle.
|
||||
-- The ArrowHT type does not seem to be documented.
|
||||
@ -87,16 +87,16 @@ getArrowOpts (t, h) = arrowOptions
|
||||
connectMaybePorts ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
|
||||
Edge -> QDiagram b V2 n Any -> QDiagram b V2 n Any
|
||||
connectMaybePorts (Edge (icon0, Just port0, icon1, Just port1) ends) =
|
||||
connectMaybePorts (Edge (NameAndPort icon0 (Just port0), NameAndPort icon1 (Just port1)) ends) =
|
||||
connect'
|
||||
(getArrowOpts ends)
|
||||
(icon0 .> port0)
|
||||
(icon1 .> port1)
|
||||
connectMaybePorts (Edge (icon0, Nothing, icon1, Just port1) ends) =
|
||||
connectMaybePorts (Edge (NameAndPort icon0 Nothing, NameAndPort icon1 (Just port1)) ends) =
|
||||
connectOutside' (getArrowOpts ends) icon0 (icon1 .> port1)
|
||||
connectMaybePorts (Edge (icon0, Just port0, icon1, Nothing) ends) =
|
||||
connectMaybePorts (Edge (NameAndPort icon0 (Just port0), NameAndPort icon1 Nothing) ends) =
|
||||
connectOutside' (getArrowOpts ends) (icon0 .> port0) icon1
|
||||
connectMaybePorts (Edge (icon0, Nothing, icon1, Nothing) ends) =
|
||||
connectMaybePorts (Edge (NameAndPort icon0 Nothing, NameAndPort icon1 Nothing) ends) =
|
||||
connectOutside' (getArrowOpts ends) icon0 icon1
|
||||
|
||||
makeConnections ::
|
||||
@ -152,8 +152,8 @@ connectedPorts :: [Connection] -> Name -> [(Int, Name, Maybe Int)]
|
||||
connectedPorts edges name = map edgeToPort $ filter nameInEdge edges
|
||||
where
|
||||
isPort = isJust
|
||||
nameInEdge (name1, port1, name2, port2) = (name == name1 && isPort port1) || (name == name2 && isPort port2)
|
||||
edgeToPort (name1, port1, name2, port2) =
|
||||
nameInEdge (NameAndPort name1 port1, NameAndPort name2 port2) = (name == name1 && isPort port1) || (name == name2 && isPort port2)
|
||||
edgeToPort (NameAndPort name1 port1, NameAndPort name2 port2) =
|
||||
if name == name1
|
||||
then (fromMaybeError "connectedPorts: port is Nothing" port1, name2, port2)
|
||||
else (fromMaybeError "connectedPorts: port is Nothing" port2, name1, port1)
|
||||
|
@ -4,48 +4,86 @@ module Translate(
|
||||
) where
|
||||
|
||||
import qualified Diagrams.Prelude as DIA
|
||||
import Diagrams.Prelude((<>))
|
||||
|
||||
import Language.Haskell.Exts(Match(..), Decl(..), parseDecl, ParseResult(..),
|
||||
import Language.Haskell.Exts(Decl(..), parseDecl,
|
||||
Name(..), Pat(..), Rhs(..), Exp(..), QName(..), fromParseResult) --(parseFile, parse, ParseResult, Module)
|
||||
|
||||
import Types(Icon, Edge, Drawing(..))
|
||||
import Util(toNames, iconToIcon)
|
||||
import Types(Icon, Edge(..), Drawing(..), NameAndPort)
|
||||
import Util(toNames, noEnds, nameAndPort, justName)
|
||||
import Icons(Icon(..))
|
||||
|
||||
data IconGraph = IconGraph [(DIA.Name, Icon)] [Edge]
|
||||
|
||||
instance DIA.Semigroup IconGraph where
|
||||
(IconGraph x1 y1) <> (IconGraph x2 y2) = IconGraph (x1 <> x2) (y1 <> y2)
|
||||
|
||||
instance Monoid IconGraph where
|
||||
mempty = IconGraph [] []
|
||||
mappend = (<>)
|
||||
|
||||
--instance
|
||||
|
||||
nameToString :: Language.Haskell.Exts.Name -> String
|
||||
nameToString (Ident s) = s
|
||||
nameToString (Symbol s) = s
|
||||
|
||||
evalPattern :: Pat -> String
|
||||
evalPattern p = case p of
|
||||
PVar n -> nameToString n
|
||||
-- TODO other cases
|
||||
|
||||
evalMatch (Match _ name patterns _ _ _) = res where
|
||||
patternStrings = map evalPattern patterns
|
||||
matchName = nameToString name
|
||||
res = (matchName, patternStrings)
|
||||
-- evalMatch :: Match -> (String, [String])
|
||||
-- evalMatch (Match _ name patterns _ _ _) = res where
|
||||
-- patternStrings = map evalPattern patterns
|
||||
-- matchName = nameToString name
|
||||
-- res = (matchName, patternStrings)
|
||||
|
||||
evalQName (UnQual n) = nameToString n
|
||||
evalQName :: QName -> (IconGraph, NameAndPort)
|
||||
evalQName (UnQual n) = (graph, justName nameString) where
|
||||
nameString = nameToString n
|
||||
graph = IconGraph [(DIA.toName nameString, TextBoxIcon nameString)] []
|
||||
-- TODO other cases
|
||||
|
||||
evalVar x = case x of
|
||||
evalApp :: Int -> (IconGraph, NameAndPort) -> (IconGraph, NameAndPort) -> (IconGraph, NameAndPort)
|
||||
evalApp uniqueInt (funGr, funNamePort) (argGr, argNamePort) =
|
||||
(newGraph <> funGr <> argGr, nameAndPort applyIconName 2)
|
||||
where
|
||||
newGraph = IconGraph icons edges
|
||||
-- TODO figure out unique names for the apply icons
|
||||
applyIconString = "app0" ++ show uniqueInt
|
||||
applyIconName = DIA.toName applyIconString
|
||||
icons = [(applyIconName, Apply0Icon)]
|
||||
edges = [
|
||||
Edge (funNamePort, nameAndPort applyIconName 0) noEnds,
|
||||
Edge (argNamePort, nameAndPort applyIconName 1) noEnds
|
||||
]
|
||||
|
||||
evalExp :: Int -> Exp -> (IconGraph, NameAndPort)
|
||||
evalExp uniqueInt x = case x of
|
||||
Var n -> evalQName n
|
||||
App exp1 exp2 -> evalApp uniqueInt (evalExp (uniqueInt + 1) exp1) (evalExp 0 exp2)
|
||||
-- TODO other cases
|
||||
|
||||
evalRhs (UnGuardedRhs e) = evalVar e
|
||||
evalRhs :: Rhs -> (IconGraph, NameAndPort)
|
||||
evalRhs (UnGuardedRhs e) = evalExp 0 e
|
||||
evalRhs (GuardedRhss _) = error "GuardedRhss not implemented"
|
||||
|
||||
evalPatBind :: Decl -> ([(DIA.Name, Icon)], [Edge])
|
||||
evalPatBind (PatBind _ pat rhs binds) = (icons, edges) where
|
||||
evalPatBind :: Decl -> IconGraph
|
||||
evalPatBind (PatBind _ pat rhs binds) = graph <> rhsGraph where
|
||||
patName = evalPattern pat
|
||||
rhsName = evalRhs rhs
|
||||
(rhsGraph, rhsNamePort) = evalRhs rhs
|
||||
icons = toNames [
|
||||
(patName, TextBoxIcon patName),
|
||||
(rhsName, TextBoxIcon rhsName)
|
||||
(patName, TextBoxIcon patName)
|
||||
--(rhsName, TextBoxIcon rhsName)
|
||||
]
|
||||
edges = [
|
||||
iconToIcon patName rhsName
|
||||
]
|
||||
-- TODO use port here
|
||||
Edge (justName patName, rhsNamePort) noEnds
|
||||
]
|
||||
graph = IconGraph icons edges
|
||||
|
||||
evalDecl :: Decl -> IconGraph
|
||||
evalDecl d = case d of
|
||||
pat@PatBind{} -> evalPatBind pat
|
||||
-- TODO other cases
|
||||
@ -54,5 +92,5 @@ translateString :: String -> (Drawing, Decl)
|
||||
translateString s = (drawing, decl) where
|
||||
parseResult = parseDecl s -- :: ParseResult Module
|
||||
decl = fromParseResult parseResult
|
||||
(icons, edges) = evalDecl decl
|
||||
IconGraph icons edges = evalDecl decl
|
||||
drawing = Drawing icons edges []
|
||||
|
10
app/Types.hs
10
app/Types.hs
@ -12,15 +12,19 @@ import Diagrams.Prelude(Name)
|
||||
-- subdrawing.
|
||||
data Icon = Apply0Icon | ResultIcon | BranchIcon | TextBoxIcon String | GuardIcon Int
|
||||
| LambdaRegionIcon Int Name | Apply0NIcon Int
|
||||
deriving (Show)
|
||||
|
||||
type Connection = (Name, Maybe Int, Name, Maybe Int)
|
||||
data NameAndPort = NameAndPort Name (Maybe Int) deriving (Show)
|
||||
|
||||
type Connection = (NameAndPort, NameAndPort)
|
||||
|
||||
-- | An Edge has an name of the source icon, and its optional port number,
|
||||
-- and the name of the destination icon, and its optional port number.
|
||||
data Edge = Edge {edgeConnection :: Connection, edgeEnds :: (EdgeEnd, EdgeEnd)}
|
||||
deriving (Show)
|
||||
|
||||
data EdgeEnd = EndAp1Result | EndAp1Arg | EndNone
|
||||
data EdgeEnd = EndAp1Result | EndAp1Arg | EndNone deriving (Show)
|
||||
|
||||
-- | A drawing is a map from names to Icons, a list of edges,
|
||||
-- and a map of names to subDrawings
|
||||
data Drawing = Drawing [(Name, Icon)] [Edge] [(Name, Drawing)]
|
||||
data Drawing = Drawing [(Name, Icon)] [Edge] [(Name, Drawing)] deriving (Show)
|
||||
|
29
app/Util.hs
29
app/Util.hs
@ -5,15 +5,18 @@ module Util (
|
||||
iconToPort,
|
||||
iconToIcon,
|
||||
iconToIconEnds,
|
||||
iconHeadToPort,
|
||||
--iconHeadToPort,
|
||||
iconTailToPort,
|
||||
toNames
|
||||
toNames,
|
||||
noEnds,
|
||||
nameAndPort,
|
||||
justName
|
||||
)where
|
||||
|
||||
import Control.Arrow(first)
|
||||
import Diagrams.Prelude(IsName, toName, Name)
|
||||
|
||||
import Types(EdgeEnd(..), Edge(..))
|
||||
import Types(EdgeEnd(..), Edge(..), NameAndPort(..))
|
||||
|
||||
mapFst :: (a -> b) -> [(a, c)] -> [(b, c)]
|
||||
mapFst f = map (first f)
|
||||
@ -24,24 +27,30 @@ toNames = mapFst toName
|
||||
noEnds :: (EdgeEnd, EdgeEnd)
|
||||
noEnds = (EndNone, EndNone)
|
||||
|
||||
nameAndPort :: IsName a => a -> Int -> NameAndPort
|
||||
nameAndPort n p = NameAndPort (toName n) (Just p)
|
||||
|
||||
justName :: IsName a => a -> NameAndPort
|
||||
justName n = NameAndPort (toName n) Nothing
|
||||
|
||||
-- Edge constructors --
|
||||
portToPort :: (IsName a, IsName b) => a -> Int -> b -> Int -> Edge
|
||||
portToPort a b c d = Edge (toName a, Just b, toName c, Just d) noEnds
|
||||
portToPort a b c d = Edge (nameAndPort a b, nameAndPort c d) noEnds
|
||||
|
||||
iconToPort :: (IsName a, IsName b) => a -> b -> Int -> Edge
|
||||
iconToPort a c d = Edge (toName a, Nothing, toName c, Just d) noEnds
|
||||
iconToPort a c d = Edge (justName a, nameAndPort c d) noEnds
|
||||
|
||||
iconToIcon :: (IsName a, IsName b) => a -> b -> Edge
|
||||
iconToIcon a c = Edge (toName a, Nothing, toName c, Nothing) noEnds
|
||||
iconToIcon a c = Edge (justName a, justName c) noEnds
|
||||
|
||||
|
||||
-- If there are gaps between the arrow and the icon, try switching the first two arguments
|
||||
-- with the last two arguments
|
||||
iconToIconEnds :: (IsName a, IsName b) => a -> EdgeEnd -> b -> EdgeEnd -> Edge
|
||||
iconToIconEnds a b c d = Edge (toName a, Nothing, toName c, Nothing) (b, d)
|
||||
iconToIconEnds a b c d = Edge (justName a, justName c) (b, d)
|
||||
|
||||
iconHeadToPort :: (IsName a, IsName b) => a -> EdgeEnd -> b -> Int -> Edge
|
||||
iconHeadToPort a endHead c d = Edge (toName a, Nothing, toName c, Just d) (EndNone, endHead)
|
||||
-- iconHeadToPort :: (IsName a, IsName b) => a -> EdgeEnd -> b -> Int -> Edge
|
||||
-- iconHeadToPort a endHead c d = Edge (justName a, nameAndPort c d) (EndNone, endHead)
|
||||
|
||||
iconTailToPort :: (IsName a, IsName b) => a -> EdgeEnd -> b -> Int -> Edge
|
||||
iconTailToPort a endTail c d = Edge (toName a, Nothing, toName c, Just d) (endTail, EndNone)
|
||||
iconTailToPort a endTail c d = Edge (justName a, nameAndPort c d) (endTail, EndNone)
|
||||
|
Loading…
Reference in New Issue
Block a user