module Language.Clafer.Generator.Graph (genSimpleGraph, genCVLGraph, traceAstModule, traceIrModule) where
import Language.Clafer.Common(fst3,snd3,trd3)
import Language.Clafer.Front.AbsClafer
import Language.Clafer.Intermediate.Tracing
import Language.Clafer.Intermediate.Intclafer
import Language.Clafer.Generator.Html(genTooltip)
import Control.Applicative ((<$>))
import qualified Data.Map as Map
import Data.Maybe
import Prelude hiding (exp)
genSimpleGraph :: Module -> IModule -> String -> Bool -> String
genSimpleGraph m ir name showRefs = cleanOutput $ "digraph \"" ++ name ++ "\"\n{\n\nrankdir=BT;\nranksep=0.3;\nnodesep=0.1;\ngraph [fontname=Sans fontsize=11];\nnode [shape=box color=lightgray fontname=Sans fontsize=11 margin=\"0.02,0.02\" height=0.2 ];\nedge [fontname=Sans fontsize=11];\n" ++ b ++ "}"
where b = graphSimpleModule m (traceIrModule ir) showRefs
genCVLGraph :: Module -> IModule -> String -> String
genCVLGraph m ir name = cleanOutput $ "digraph \"" ++ name ++ "\"\n{\nrankdir=BT;\nranksep=0.1;\nnodesep=0.1;\nnode [shape=box margin=\"0.025,0.025\"];\nedge [arrowhead=none];\n" ++ b ++ "}"
where b = graphCVLModule m $ traceIrModule ir
graphSimpleModule :: Module -> Map.Map Span [Ir] -> Bool -> String
graphSimpleModule (Module _ []) _ _ = ""
graphSimpleModule (Module s (x:xs)) irMap showRefs = graphSimpleDeclaration x (True, Nothing, Nothing) irMap showRefs ++ graphSimpleModule (Module s xs) irMap showRefs
graphSimpleDeclaration :: Declaration
-> (Bool, Maybe String, Maybe String)
-> Map.Map Span [Ir]
-> Bool
-> String
graphSimpleDeclaration (ElementDecl _ element) topLevel irMap showRefs = graphSimpleElement element topLevel irMap showRefs
graphSimpleDeclaration _ _ _ _ = ""
graphSimpleElement :: Element
-> (Bool, Maybe String, Maybe String)
-> Map.Map Span [Ir]
-> Bool
-> String
graphSimpleElement (Subclafer _ clafer) topLevel irMap showRefs = graphSimpleClafer clafer topLevel irMap showRefs
graphSimpleElement (ClaferUse s _ _ _) topLevel irMap _ = if snd3 topLevel == Nothing then "" else "\"" ++ fromJust (snd3 topLevel) ++ "\" -> \"" ++ getUseId s irMap ++ "\" [arrowhead=vee arrowtail=diamond dir=both style=solid constraint=true weight=5 minlen=2 arrowsize=0.6 penwidth=0.5 ];\n"
graphSimpleElement _ _ _ _ = ""
graphSimpleElements :: Elements
-> (Bool, Maybe String, Maybe String)
-> Map.Map Span [Ir]
-> Bool
-> String
graphSimpleElements (ElementsEmpty _) _ _ _ = ""
graphSimpleElements (ElementsList _ es) topLevel irMap showRefs = concatMap (\x -> graphSimpleElement x topLevel irMap showRefs ++ "\n") es
graphSimpleClafer :: Clafer
-> (Bool, Maybe String, Maybe String)
-> Map.Map Span [Ir]
-> Bool
-> String
graphSimpleClafer (Clafer s abstract gCard id' super' reference' crd init' es) (True, _, _) irMap showRefs =
let
tooltip = genTooltip (Module s [ElementDecl s (Subclafer s (Clafer s abstract gCard id' super' reference' crd init' es))]) irMap
uid' = getDivId s irMap
in
"\"" ++
uid' ++
"\" [label=\"" ++
(head $ lines tooltip) ++
"\" URL=\"#" ++
uid' ++
"\" tooltip=\"" ++
htmlChars tooltip ++
"\"];\n" ++
graphSimpleSuper super' (True, Just uid', Just uid') irMap showRefs ++
graphSimpleReference reference' (True, Just uid', Just uid') irMap showRefs ++
graphSimpleElements es (False, Just uid', Just uid') irMap showRefs
graphSimpleClafer (Clafer s abstract@(Abstract _) gCard id' super' reference' crd init' es) (False, _, _) irMap showRefs =
let
tooltip = genTooltip (Module s [ElementDecl s (Subclafer s (Clafer s abstract gCard id' super' reference' crd init' es))]) irMap
uid' = getDivId s irMap
in
"\"" ++
uid' ++
"\" [label=\"" ++
(head $ lines tooltip) ++
"\" URL=\"#" ++
uid' ++
"\" tooltip=\"" ++
htmlChars tooltip ++
"\"];\n" ++
graphSimpleSuper super' (False, Just uid', Just uid') irMap showRefs ++
graphSimpleReference reference' (False, Just uid', Just uid') irMap showRefs ++
graphSimpleElements es (False, Just uid', Just uid') irMap showRefs
graphSimpleClafer (Clafer _ _ _ id' super' reference' _ _ es) topLevel irMap showRefs =
let
(PosIdent (_,ident')) = id'
in
graphSimpleSuper super' (fst3 topLevel, snd3 topLevel, Just ident') irMap showRefs ++
graphSimpleReference reference' (fst3 topLevel, snd3 topLevel, Just ident') irMap showRefs ++
graphSimpleElements es (fst3 topLevel, snd3 topLevel, Just ident') irMap showRefs
graphSimpleSuper :: Super
-> (Bool, Maybe String, Maybe String)
-> Map.Map Span [Ir]
-> Bool
-> String
parent :: [String] -> String
parent [] = "error"
parent (uid'@('c':xs):xss) = if '_' `elem` xs then uid' else parent xss
parent (_:xss) = parent xss
graphSimpleSuper (SuperEmpty _) _ _ _ = ""
graphSimpleSuper (SuperSome _ setExp) topLevel irMap _ =
let
super' = parent $ graphSimpleSetExp setExp topLevel irMap
in
if super' == "error"
then ""
else "\"" ++
fromJust (snd3 topLevel) ++
"\" -> \"" ++
parent (graphSimpleSetExp setExp topLevel irMap) ++
"\"" ++
" [" ++ if fst3 topLevel == True
then "arrowhead=onormal constraint=true weight=100];\n"
else "arrowhead=vee arrowtail=diamond dir=both style=solid weight=10 color=gray arrowsize=0.6 minlen=2 penwidth=0.5 constraint=true];\n"
graphSimpleReference :: Reference -> (Bool, Maybe String, Maybe String) -> Map.Map Span [Ir] -> Bool -> String
graphSimpleReference (ReferenceEmpty _) _ _ _ = ""
graphSimpleReference (ReferenceSet _ setExp) topLevel irMap showRefs =
case graphSimpleSetExp setExp topLevel irMap of
["integer"] -> ""
["int"] -> ""
["real"] -> ""
["string"] -> ""
[target] ->
"\"" ++
fromJust (snd3 topLevel) ++
"\" -> \"" ++
target ++
"\"" ++
" [arrowhead=vee arrowsize=0.6 penwidth=0.5 constraint=true weight=10 color=" ++
refColour showRefs ++
" fontcolor=" ++
refColour showRefs ++
(if fst3 topLevel == True then "" else " label=" ++
(fromJust $ trd3 topLevel)) ++
"];\n"
_ -> ""
graphSimpleReference (ReferenceBag _ setExp) topLevel irMap showRefs =
case graphSimpleSetExp setExp topLevel irMap of
["integer"] -> ""
["int"] -> ""
["real"] -> ""
["string"] -> ""
[target] ->
("\"" ++
fromJust (snd3 topLevel) ++
"\" -> \"" ++
target ++
"\"" ++
" [arrowhead=veevee arrowsize=0.6 minlen=1.5 penwidth=0.5 constraint=true weight=10 color=" ++
refColour showRefs ++
" fontcolor=" ++
refColour showRefs ++
(if fst3 topLevel == True then "" else " label=" ++
(fromJust $ trd3 topLevel)) ++ "];\n")
_ -> ""
refColour :: Bool -> String
refColour True = "lightgray"
refColour False = "transparent"
graphSimpleName :: Name -> (Bool, Maybe String, Maybe String) -> Map.Map Span [Ir] -> String
graphSimpleName (Path _ modids) topLevel irMap = unwords $ map (\x -> graphSimpleModId x topLevel irMap) modids
graphSimpleModId :: ModId -> (Bool, Maybe String, Maybe String) -> Map.Map Span [Ir] -> String
graphSimpleModId (ModIdIdent _ posident) _ irMap = graphSimplePosIdent posident irMap
graphSimplePosIdent :: PosIdent -> Map.Map Span [Ir] -> String
graphSimplePosIdent (PosIdent (pos, id')) irMap = getUid (PosIdent (pos, id')) irMap
graphSimpleSetExp :: SetExp -> (Bool, Maybe String, Maybe String) -> Map.Map Span [Ir] -> [String]
graphSimpleSetExp (ClaferId _ name) topLevel irMap = [graphSimpleName name topLevel irMap]
graphSimpleSetExp (Union _ set1 set2) topLevel irMap = graphSimpleSetExp set1 topLevel irMap ++ graphSimpleSetExp set2 topLevel irMap
graphSimpleSetExp (UnionCom _ set1 set2) topLevel irMap = graphSimpleSetExp set1 topLevel irMap ++ graphSimpleSetExp set2 topLevel irMap
graphSimpleSetExp (Difference _ set1 set2) topLevel irMap = graphSimpleSetExp set1 topLevel irMap ++ graphSimpleSetExp set2 topLevel irMap
graphSimpleSetExp (Intersection _ set1 set2) topLevel irMap = graphSimpleSetExp set1 topLevel irMap ++ graphSimpleSetExp set2 topLevel irMap
graphSimpleSetExp (Domain _ set1 set2) topLevel irMap = graphSimpleSetExp set1 topLevel irMap ++ graphSimpleSetExp set2 topLevel irMap
graphSimpleSetExp (Range _ set1 set2) topLevel irMap = graphSimpleSetExp set1 topLevel irMap ++ graphSimpleSetExp set2 topLevel irMap
graphSimpleSetExp (Join _ set1 set2) topLevel irMap = graphSimpleSetExp set1 topLevel irMap ++ graphSimpleSetExp set2 topLevel irMap
graphCVLModule :: Module -> Map.Map Span [Ir] -> String
graphCVLModule (Module _ []) _ = ""
graphCVLModule (Module s (x:xs)) irMap = graphCVLDeclaration x Nothing irMap ++ graphCVLModule (Module s xs) irMap
graphCVLDeclaration :: Declaration -> Maybe String -> Map.Map Span [Ir] -> String
graphCVLDeclaration (ElementDecl _ element) parent' irMap = graphCVLElement element parent' irMap
graphCVLDeclaration _ _ _ = ""
graphCVLElement :: Element -> Maybe String -> Map.Map Span [Ir] -> String
graphCVLElement (Subclafer _ clafer) parent' irMap = graphCVLClafer clafer parent' irMap
graphCVLElement (ClaferUse s _ _ _) parent' irMap = if parent' == Nothing then "" else "?" ++ " -> " ++ getUseId s irMap ++ " [arrowhead = onormal style = dashed constraint = false];\n"
graphCVLElement (Subconstraint _ constraint) parent' irMap = graphCVLConstraint constraint parent' irMap
graphCVLElement (Subgoal _ constraint) parent' irMap = graphCVLGoal constraint parent' irMap
graphCVLElement (Subsoftconstraint _ constraint) parent' irMap = graphCVLSoftConstraint constraint parent' irMap
graphCVLElements :: Elements -> Maybe String -> Map.Map Span [Ir] -> String
graphCVLElements (ElementsEmpty _) _ _ = ""
graphCVLElements (ElementsList _ es) parent' irMap = concatMap (\x -> graphCVLElement x parent' irMap ++ "\n") es
graphCVLClafer :: Clafer -> Maybe String -> Map.Map Span [Ir] -> String
graphCVLClafer (Clafer s _ gCard _ super' reference' crd _ es) parent' irMap
= let {
uid' = getDivId s irMap;
gcrd = graphCVLGCard gCard parent' irMap;
super'' = graphCVLSuper super' parent' irMap;
reference'' = graphCVLReference reference' parent' irMap} in
"\"" ++ uid' ++ "\" [URL=\"#" ++ uid' ++ "\" label=\"" ++ dropUid uid' ++ super'' ++ reference'' ++ (if choiceCard crd then "\" style=rounded" else " [" ++ graphCVLCard crd parent' irMap ++ "]\"")
++ (if super'' == "" then "" else " shape=oval") ++ "];\n"
++ (if gcrd == "" then "" else "g" ++ uid' ++ " [label=\"" ++ gcrd ++ "\" fontsize=10 shape=triangle];\ng" ++ uid' ++ " -> " ++ uid' ++ " [weight=10];\n")
++ (if parent'==Nothing then "" else uid' ++ " -> " ++ fromJust parent' ++ (if lowerCard crd == "0" then " [style=dashed]" else "") ++ ";\n")
++ graphCVLElements es (if gcrd == "" then (Just uid') else (Just $ "g" ++ uid')) irMap
graphCVLSuper :: Super -> Maybe String -> Map.Map Span [Ir] -> String
graphCVLSuper (SuperEmpty _) _ _ = ""
graphCVLSuper (SuperSome _ setExp) parent' irMap = ":" ++ concat (graphCVLSetExp setExp parent' irMap)
graphCVLReference :: Reference -> Maybe String -> Map.Map Span [Ir] -> String
graphCVLReference (ReferenceEmpty _) _ _ = ""
graphCVLReference (ReferenceSet _ setExp) parent' irMap = "->" ++ concat (graphCVLSetExp setExp parent' irMap)
graphCVLReference (ReferenceBag _ setExp) parent' irMap = "->>" ++ concat (graphCVLSetExp setExp parent' irMap)
graphCVLName :: Name -> Maybe String -> Map.Map Span [Ir] -> String
graphCVLName (Path _ modids) parent' irMap = unwords $ map (\x -> graphCVLModId x parent' irMap) modids
graphCVLModId :: ModId -> Maybe String -> Map.Map Span [Ir] -> String
graphCVLModId (ModIdIdent _ posident) _ irMap = graphCVLPosIdent posident irMap
graphCVLPosIdent :: PosIdent -> Map.Map Span [Ir] -> String
graphCVLPosIdent (PosIdent (pos, id')) irMap = getUid (PosIdent (pos, id')) irMap
graphCVLConstraint :: Constraint -> Maybe String -> Map.Map Span [Ir] -> String
graphCVLConstraint (Constraint s exps') parent' irMap = let body' = htmlChars $ genTooltip (Module s [ElementDecl s (Subconstraint s (Constraint s exps'))]) irMap;
uid' = "\"" ++ getExpId s irMap ++ "\""
in uid' ++ " [label=\"" ++ body' ++ "\" shape=parallelogram];\n" ++
if parent' == Nothing then "" else uid' ++ " -> \"" ++ fromJust parent' ++ "\";\n"
graphCVLSoftConstraint :: SoftConstraint -> Maybe String -> Map.Map Span [Ir] -> String
graphCVLSoftConstraint (SoftConstraint s exps') parent' irMap = let body' = htmlChars $ genTooltip (Module s [ElementDecl s (Subsoftconstraint s (SoftConstraint s exps'))]) irMap;
uid' = "\"" ++ getExpId s irMap ++ "\""
in uid' ++ " [label=\"" ++ body' ++ "\" shape=parallelogram];\n" ++
if parent' == Nothing then "" else uid' ++ " -> \"" ++ fromJust parent' ++ "\";\n"
graphCVLGoal :: Goal -> Maybe String -> Map.Map Span [Ir] -> String
graphCVLGoal (Goal s exps') parent' irMap = let body' = htmlChars $ genTooltip (Module s [ElementDecl s (Subgoal s (Goal s exps'))]) irMap;
uid' = "\"" ++ getExpId s irMap ++ "\""
in uid' ++ " [label=\"" ++ body' ++ "\" shape=parallelogram];\n" ++
if parent' == Nothing then "" else uid' ++ " -> \"" ++ fromJust parent' ++ "\";\n"
graphCVLCard :: Card -> Maybe String -> Map.Map Span [Ir] -> String
graphCVLCard (CardEmpty _) _ _ = "1..1"
graphCVLCard (CardLone _) _ _ = "0..1"
graphCVLCard (CardSome _) _ _ = "1..*"
graphCVLCard (CardAny _) _ _ = "0..*"
graphCVLCard (CardNum _ (PosInteger (_, n))) _ _ = n ++ ".." ++ n
graphCVLCard (CardInterval _ ncard) parent' irMap = graphCVLNCard ncard parent' irMap
graphCVLNCard :: NCard -> Maybe String -> Map.Map Span [Ir] -> String
graphCVLNCard (NCard _ (PosInteger (_, num)) exInteger) parent' irMap = num ++ ".." ++ graphCVLExInteger exInteger parent' irMap
graphCVLExInteger :: ExInteger -> Maybe String -> Map.Map Span [Ir] -> String
graphCVLExInteger (ExIntegerAst _) _ _ = "*"
graphCVLExInteger (ExIntegerNum _ (PosInteger(_, num))) _ _ = num
graphCVLGCard :: GCard -> Maybe String -> Map.Map Span [Ir] -> String
graphCVLGCard (GCardInterval _ ncard) parent' irMap = graphCVLNCard ncard parent' irMap
graphCVLGCard (GCardEmpty _) _ _ = ""
graphCVLGCard (GCardXor _) _ _ = "1..1"
graphCVLGCard (GCardOr _) _ _ = "1..*"
graphCVLGCard (GCardMux _) _ _ = "0..1"
graphCVLGCard (GCardOpt _) _ _ = ""
graphCVLSetExp :: SetExp -> Maybe String -> Map.Map Span [Ir] -> [String]
graphCVLSetExp (ClaferId _ name) parent' irMap = [graphCVLName name parent' irMap]
graphCVLSetExp (Union _ set1 set2) parent' irMap = graphCVLSetExp set1 parent' irMap ++ graphCVLSetExp set2 parent' irMap
graphCVLSetExp (UnionCom _ set1 set2) parent' irMap = graphCVLSetExp set1 parent' irMap ++ graphCVLSetExp set2 parent' irMap
graphCVLSetExp (Difference _ set1 set2) parent' irMap = graphCVLSetExp set1 parent' irMap ++ graphCVLSetExp set2 parent' irMap
graphCVLSetExp (Intersection _ set1 set2) parent' irMap = graphCVLSetExp set1 parent' irMap ++ graphCVLSetExp set2 parent' irMap
graphCVLSetExp (Domain _ set1 set2) parent' irMap = graphCVLSetExp set1 parent' irMap ++ graphCVLSetExp set2 parent' irMap
graphCVLSetExp (Range _ set1 set2) parent' irMap = graphCVLSetExp set1 parent' irMap ++ graphCVLSetExp set2 parent' irMap
graphCVLSetExp (Join _ set1 set2) parent' irMap = graphCVLSetExp set1 parent' irMap ++ graphCVLSetExp set2 parent' irMap
choiceCard :: Card -> Bool
choiceCard (CardEmpty _) = True
choiceCard (CardLone _) = True
choiceCard (CardInterval _ (NCard _ (PosInteger (_, low)) exInteger)) = if low == "0" || low == "1"
then case exInteger of
(ExIntegerAst _) -> False
(ExIntegerNum _ (PosInteger (_, high))) -> high == "0" || high == "1"
else False
choiceCard _ = False
lowerCard :: Card -> String
lowerCard crd = takeWhile (/= '.') $ graphCVLCard crd Nothing Map.empty
dropUid :: String -> String
dropUid uid' = let id' = rest $ dropWhile (\x -> x /= '_') uid' in if id' == "" then uid' else id'
rest :: String -> String
rest [] = []
rest (_:xs) = xs
getUid :: PosIdent -> Map.Map Span [Ir] -> String
getUid (PosIdent (pos, id')) irMap = if Map.lookup (getSpan (PosIdent (pos, id'))) irMap == Nothing
then id'
else let IRPExp pexp = head $ fromJust $ Map.lookup (getSpan (PosIdent (pos, id'))) irMap in
findUid id' $ getIdentPExp pexp
where {getIdentPExp (PExp _ _ _ exp') = getIdentIExp exp';
getIdentIExp (IFunExp _ exps') = concatMap getIdentPExp exps';
getIdentIExp (IClaferId _ id'' _ _) = [id''];
getIdentIExp (IDeclPExp _ _ pexp) = getIdentPExp pexp;
getIdentIExp _ = [];
findUid name (x:xs) = if name == dropUid x then x else findUid name xs;
findUid name [] = name}
getDivId :: Span -> Map.Map Span [Ir] -> String
getDivId s irMap = if Map.lookup s irMap == Nothing
then "Uid not Found"
else let IRClafer iClaf = head $ fromJust $ Map.lookup s irMap in
_uid iClaf
getUseId :: Span -> Map.Map Span [Ir] -> String
getUseId s irMap = if Map.lookup s irMap == Nothing
then "Uid not Found"
else let
IRClafer iClaf = head $ fromJust $ Map.lookup s irMap
in
fromMaybe "" $ _sident <$> _exp <$> _super iClaf
getExpId :: Span -> Map.Map Span [Ir] -> String
getExpId s irMap = if Map.lookup s irMap == Nothing
then "Uid not Found"
else let IRPExp pexp = head $ fromJust $ Map.lookup s irMap in _pid pexp
htmlChars :: String -> String
htmlChars "" = ""
htmlChars ('\n':xs) = " " ++ htmlChars xs
htmlChars ('-':'>':'>':xs) = "->>" ++ htmlChars xs
htmlChars ('-':'>':xs) = "->" ++ htmlChars xs
htmlChars (x:xs) = x:htmlChars xs
cleanOutput :: String -> String
cleanOutput "" = ""
cleanOutput (' ':'\n':xs) = cleanOutput $ '\n':xs
cleanOutput ('\n':'\n':xs) = cleanOutput $ '\n':xs
cleanOutput (' ':'<':'b':'r':'>':xs) = "<br>"++cleanOutput xs
cleanOutput (x:xs) = x : cleanOutput xs