module GraphRewrite.Main.Visualize
where

-- TODO: use the graphviz package

import GraphRewrite.Internal.DeltaFunctions
import GraphRewrite.Internal.RewriteTypes

import Text.PrettyPrint
import Data.Supply
import Data.Graph.Inductive.Tree
import qualified Data.Graph.Inductive.Graph as IG
import Data.IntMap hiding (map)
import Data.Maybe
import Prelude hiding (lookup)


gStyle :: String
gStyle = unlines
         [
          "node [fontcolor=\"#1f33b3\", fontsize=12, shape=none, fontname=\"Helvetica\"];"
         ,"edge [color=\"#000000\", style=dotted, fontname=\"Helvetica\", arrowhead=normal, arrowsize=0.3];"
         ]


dQText :: String -> Doc
dQText = doubleQuotes . text . concatMap quoteChar
 where
    quoteChar :: Char -> String
    quoteChar '\"' = "\\\""
    quoteChar c = [c]

lookupName :: RewriteSystem -> Int -> [Char]
lookupName rs i = fromMaybe "UNDEFINED" $ lookup i (names rs)

-- | RewriteSystem needed for identifier names.
genName :: RewriteSystem -> Expr -> String
genName rs = gName (-1)  where

    gName :: Int{-outerPrec-} -> Expr -> String
    gName _ (SCons c) = lookupName rs c
    gName _ (SFun _ f) = lookupName rs f
    gName _ (SHole h) = lookupName rs h
    gName _ (SRef r) = lookupName rs r
    gName _ (SLit l) = l
    gName p e@(SApp _ _) = rearrange ip $ fn : map (gName $ precedence ip) xs  where

      precedence :: Prec -> Int
      precedence (Infixr i) = i
      precedence Prefix = 10

      rearrange Prefix l = addParents (p>9) $ unwords l
      rearrange _ [a,b,c] = addParents (p>9) $ unwords [b,a,c]
      rearrange _ [a,b] = addParents True $ unwords [b,a]
      rearrange _ [a] = addParents True a

      ip = head $ [ip | (ip, n)<-deltaNames, n == fn] ++ [Prefix]
      fn = gName 10 f

      (f, xs) = flattenSApp e

      flattenSApp :: Expr -> (Expr, [Expr])
      flattenSApp (SApp y ys) = (f, xs ++ ys)    where (f, xs) = flattenSApp y
      flattenSApp x = (x, [])

addParents :: Bool -> String -> String
addParents True s = "(" ++ s ++ ")"
addParents False s = s



genID :: Supply Int -> Expr -> Int
genID _ (SCons c) = c
genID _ (SFun _ f) = f
genID _ (SHole h) = h
genID ids _ = supplyValue ids


genLNode :: Supply Int -> RewriteSystem -> Expr -> IG.LNode String
genLNode ids rs e = (genID ids e, genName rs e)

genLEdge :: Supply Int -> Expr -> Expr -> IG.LEdge String
genLEdge ids e f = (genID i e, genID j f, "")
    where
      (i, j) = split2 ids

graphToGr :: Supply Int -> RewriteSystem -> PointedGraph -> Gr String String
graphToGr ids rs (e, g) = insExpr (-1) ids e IG.empty
    where
      insExpr i ids e@(SRef r) gr = let
          refe = fromJust (lookup r g)
          (ids1, ids2) = split2 ids
        in
          if i < 0 then
              let en@(eid, _) = genLNode ids1 rs e in
              IG.insEdge (eid, r, "") $ insExpr r ids2 refe $ IG.insNode en gr
          else
              if IG.gelem i gr then
                  gr
              else
                  IG.insEdge (i, r, "") $ insExpr r ids2 refe $ IG.insNode (i, genName rs e) gr
      insExpr i ids e gr
          | i < 0 = IG.insNode (genLNode ids rs e) gr
          | otherwise = IG.insNode (i, genName rs e) gr

outputDot :: Gr String String -> String -> IO ()
outputDot gr fname = writeFile fname $ render $ ppGr gr --graphviz gr "g" (5,5) (1,1) Portrait

ppGr :: Gr String String -> Doc
ppGr gr = text "digraph g" <+>
          (braces $
                  text gStyle $+$
                  vcat pnodes $+$
                  vcat pedges)
    where
--      f = uncurry (liftM2 (,))
--      (nodes, edges) = (f (labNodes, labEdges)) gr
      (nodes, edges) = (IG.labNodes gr, IG.labEdges gr)
      pnodes = map (\(x,y) -> dQText (show x) <+> (brackets $ text "label =" <+> dQText y)) nodes
      pedges = map (\(x,y,_) -> dQText (show x) <+> text "->" <+> dQText (show y)) edges

{-

insNode (2 SRef 1 $ insNode (1, "b") $ insNode (4, "a") empty

-}