{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}

module Graphviz (graphviz) where

import Types
import Hash

import Data.Aeson
import Data.Char
import Data.Word
import Data.Either
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 :: FilePath -> IO ()
graphviz logfile = do
	parsed <- parseLog <$> L.readFile logfile
	case lefts parsed of
		[] -> do
			let g = genGraph (rights parsed)
			f <- createImage logfile Png g
			putStrLn ("Generated " ++ f)
		errs -> error $ unlines errs

parseLog :: L.ByteString -> [Either String ActivityLog]
parseLog = map eitherDecode' 
	. filter (not . L.null)
	. L.split nl


nl :: Word8
nl = fromIntegral (ord '\n')

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

genGraph :: [ActivityLog] -> G.DotGraph T.Text
genGraph ls = digraph (Str "debug-me") $ do
	nodeAttrs [style filled]
	forM_ ls $
		showactivity [ xcolor Green ]
  where
	showactivity s (ActivitySeen { activitySeen = (a, h) }) = do
		node (display h) $ s ++
			[ textLabel $ display $ activity a
			, shape BoxShape
			]
		case activity a of
			Rejected ar -> do
				let hr = hash ar
				let rejstyle =
					[ xcolor Red
					, Style [dashed, filled]
					]
				showactivity rejstyle $
					ActivityEntered (ar, hr)
				link hr h rejstyle
			_ -> return ()
		linkprev s a h
	showactivity s (ActivityEntered { activityEntered = (a, h) }) = do
			node (display h) $ s ++
				[ textLabel $ display $ activity a
				, shape Circle
				]
			linkprev s a h
	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 ++
		[ textLabel (shorthash a)
		]
	shorthash h = display $ Val $ B.take 5 $ val $ hashValue h

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

class Display t where
	display :: t -> T.Text

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

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)