module Language.KansasLava.DOT (writeDotCircuit) where
import Language.KansasLava.Types
import Data.Reify.Graph(Unique)
import Text.Dot(Dot,NodeId,showDot, attribute, node,edge')
import Data.List(intercalate)
import Data.Maybe(fromMaybe)
writeDotCircuit :: FilePath
-> KLEG
-> IO ()
writeDotCircuit filename (KLEG nodes circInputs circOutputs) = do
let showP :: (String,Type) -> String
showP (v,ty) = "<" ++ v ++ ">" ++ v ++ "::" ++ show ty
join = intercalate "|"
mkLabel :: String -> [(String,Type)] -> [(String,Type)] -> String
mkLabel nm ins outs =
concatMap addSpecial nm ++ "|{{"
++ join (map showP ins) ++ "}|{"
++ join (map showP outs) ++ "}}"
writeFile filename $ showDot $ do
attribute ("rankdir","LR")
input_bar <- node [ ("label","INPUTS|{{" ++ join [ showP (show o,i) | (o,i) <- circInputs] ++ "}}")
, ("shape","record")
, ("style","filled")
]
nds <- sequence [ do nd <- node [ ("label",mkLabel (show nm)
[ (v,ty) |(v,ty,_) <- ins ]
[ (v,ty) | (v,ty) <- outs] )
, ("shape","record")
, ("style","rounded")
]
return (n,nd)
| (n,Entity nm outs ins) <- nodes ]
output_bar <- node [ ("label","OUTPUTS|{{" ++ join [ showP (show i,ty) | (i,ty,_) <- circOutputs ] ++ "}}")
, ("shape","record")
, ("style","filled")
]
let findNd n = fromMaybe (error $ "strange port: " ++ show (n,nds)) (lookup n nds)
let drawEdge :: Driver Unique -> NodeId -> String -> Dot ()
drawEdge (Port nm' n') n v = edge' (findNd n') (Just (show nm' ++ ":e")) n (Just (show v ++ ":w")) []
drawEdge (Pad v') n v
| v' `elem` map fst circInputs
= edge' input_bar (Just (show (show v') ++ ":e")) n (Just (show v ++ ":w")) []
| otherwise = do nd' <- node [ ("label",show v')]
edge' nd' Nothing n (Just (show v ++ ":w")) []
drawEdge (Lit i) n v = do nd' <- node [("label",show i),("shape","none")]
edge' nd' Nothing n (Just (show v ++ ":w")) []
drawEdge (Generic i) n v = do nd' <- node [("label",show i),("shape","none")]
edge' nd' Nothing n (Just (show v ++ ":w")) []
drawEdge (Error e) n v = do nd' <- node [("label",show e),("shape","none")]
edge' nd' Nothing n (Just (show v ++ ":w")) []
drawEdge (ClkDom nm) n v = do nd' <- node [("label",show nm),("shape","none")]
edge' nd' Nothing n (Just (show v ++ ":w")) []
drawEdge (Lits ls) n v = do let label = intercalate "," $ map show ls
nd' <- node [("label",label),("shape","none")]
edge' nd' Nothing n (Just (show v ++ ":w")) []
sequence_ [ drawEdge dr output_bar (show v)
| (v,_,dr) <- circOutputs
]
sequence_ [ drawEdge dr (findNd n) v
| (n,Entity _ _ ins) <- nodes
, (v,_,dr) <- ins
]
return ()
return ()
addSpecial :: Char -> String
addSpecial '>' = ">";
addSpecial '<' = "<";
addSpecial c = [c]