{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}

module Graphviz (graphviz) where

import Types
import Hash
import CmdLine
import Log

import Data.Char
import Data.Monoid
import Data.GraphViz
import Data.GraphViz.Attributes.Complete
import Data.GraphViz.Types.Generalised as G
import Data.GraphViz.Types.Monadic
import Control.Monad
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as T
import Data.Text.Encoding.Error

graphviz :: GraphvizOpts -> IO ()
graphviz opts = do
	l <- loadLog (graphvizLogFile opts)
	let g = genGraph opts l
	f <- createImage (graphvizLogFile opts) Png g
	putStrLn ("Generated " ++ f)

createImage :: PrintDotRepr dg n => FilePath -> GraphvizOutput -> dg n -> IO FilePath
createImage f o g = Data.GraphViz.addExtension (runGraphvizCommand Dot g) o f

genGraph :: GraphvizOpts -> [ActivityLog] -> G.DotGraph T.Text
genGraph opts ls = digraph (Str "debug-me") $ do
	nodeAttrs [style filled]
	forM_ ls $
		showactivity [ xcolor Green ]
  where
	showactivity s l = case loggedActivity l of
		ActivitySeen a -> do
			node (display h) $ s ++
				[ textLabel $ prettyDisplay $ activity a
				, shape BoxShape
				]
			case activity a of
				Rejected ar -> do
					let hr = hash ar
					let rejstyle =
						[ xcolor Red
						, Style [dashed, filled]
						]
					showactivity rejstyle $
						ActivityLog
							{ loggedActivity = ActivityEntered ar
							, loggedHash = hr
							, loggedTimestamp = loggedTimestamp l
							}
					link hr h rejstyle
				_ -> return ()
			linkprev s a h
		ActivityEntered a -> do
			node (display h) $ s ++
				[ textLabel $ prettyDisplay $ activity a
				, shape Circle
				]
			linkprev s a h
	  where
		h = loggedHash l
	linkprev s a h = case prevActivity a of
		Nothing -> return ()
		Just p -> link p h s
	link a b s = edge (display a) (display b) $ s ++
		if graphvizShowHashes opts
			then [ textLabel (prettyDisplay a) ]
			else []

xcolor :: X11Color -> Attribute
xcolor c = Color [toWC $ X11Color c]

class Display t where
	-- Display more or less as-is, for graphviz.
	display :: t -> T.Text
	-- Prettified display for user-visible labels etc.
	prettyDisplay :: t -> T.Text
	prettyDisplay = prettyDisplay . display

instance Display T.Text where
	display = id
	prettyDisplay t
		| all visible s = t
		| all isPrint s && not (leadingws s) && not (leadingws (reverse s)) = t
		| otherwise = T.pack (show s)
	  where
		s = T.unpack t
		visible c = isPrint c && not (isSpace c)
		leadingws (c:_) = isSpace c
		leadingws _ = False

instance Display Val where
	display (Val b) = T.decodeUtf8With lenientDecode (L.fromStrict b)

instance Display Hash where
	display (Hash m h) = T.pack (show m) <> display h
	-- Use short hash for pretty display.
	-- The "h:" prefix is to work around this bug:
	-- https://github.com/ivan-m/graphviz/issues/16
	prettyDisplay h = display $ Val $ "h:" <> (B.take 5 $ val $ hashValue h)

instance Display Seen where
	display = display . seenData

instance Display Entered where
	display v 
		| B.null (val $ echoData v) = display $ enteredData v
		| otherwise = "[" <> display (echoData v) <> "] " <> display (enteredData v)

instance Display a => Display (Proto a) where
	display (Proto a) = display a
	display (Rejected a) = "Rejected: " <> display (activity a)