import DaVinciTypes hiding (Edge(..) , Node(..)) import qualified DaVinciTypes (Edge(..) , Node(..)) -- toDV :: NodeMap -> IO () toDV nodes = writeFile "out.daVinci" (show $ map g2n nodes) -- show_gsymbol (HappyTok x) = show x show_gsymbol t = show t g2n (n@(s,e,x), []) = mk_rhombus id (show_gsymbol x ++ show (s,e)) [] where id = show n g2n (n@(s,e,x), [Branch _ bs]) = mk_box id (show_gsymbol x ++ show (s,e)) $ [ DaVinciTypes.R (NodeId $ show j) | j <- bs ] where id = show n g2n (n@(s,e,x), bss) = mk_circle id (show_gsymbol x ++ show (s,e)) $ [ mk_box (id ++ "." ++ show i) (show_gsymbol x ++ show (s,e)) [ DaVinciTypes.R (NodeId $ show j) | j <- js ] | (i,Branch _ js) <- zip [0..] bss ] where id = show n --- mk_box = mk_node box_t mk_circle = mk_node circle_t mk_plain = mk_node text_t mk_rhombus = mk_node rhombus_t mk_node :: Attribute -> String -> String -> [DaVinciTypes.Node] -> DaVinciTypes.Node mk_node a id nm ts = DaVinciTypes.N (NodeId id) (Type "") [a,text nm] $ [ (mk_edge id n) t | (n,t) <- zip [1..] ts ] mk_edge id child_no t@(DaVinciTypes.R (NodeId id2)) = DaVinciTypes.E (EdgeId eId) (Type "") [] t where eId = concat [id,":",id2,"(",show child_no,")"] mk_edge id child_no t@(DaVinciTypes.N (NodeId id2) _ _ _) = DaVinciTypes.E (EdgeId eId) (Type "") [] t where eId = concat [id,":",id2,"(",show child_no,")"] --- nodeStyle = A "_GO" box_t, circle_t, ellipse_t, rhombus_t, text_t, icon_t :: Attribute box_t = nodeStyle "box" circle_t = nodeStyle "circle" ellipse_t = nodeStyle "ellipse" rhombus_t = nodeStyle "rhombus" text_t = nodeStyle "text" icon_t = nodeStyle "icon" text :: String -> Attribute text = A "OBJECT"