-----------------------------------------------------------------------------
-- |
-- Module      :  Main
-- Copyright   :  (C) Peter Robinson 2010-2013
-- License     :  GPL-2
--
-- Maintainer  :  Peter Robinson <thaldyron@gmail.com>
-- Stability   :  experimental
-- Portability :  portable 
--
-----------------------------------------------------------------------------
module Main
where
import Control.Monad
import Control.Applicative
import Control.Concurrent
import Control.Exception
import Prelude hiding(catch)
import Data.Char(toUpper)
import Data.GraphViz
import Data.GraphViz.Attributes.Complete
import qualified Data.GraphViz.Attributes.HTML as GA
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.List as L
import System.Console.CmdArgs hiding (args)
import System.Cmd(system)
import System.IO(hFlush,stdout)
import System.Exit
import System.Directory
import Data.Text.Lazy(Text)
import Data.Text.Lazy.Encoding 
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as TI
import Safe(readDef)
import Data.Binary(encodeFile,decodeFile)
import System.FilePath(pathSeparator)

import CmdParams(mathGenealogy,MathGenealogy(..),outputFileToGraphviz)
import Extract
import Entry
import Graph

main :: IO ()
main = do
  args <- cmdArgs mathGenealogy
  when (null $ startURL args) $ 
    throw (AssertionFailed "Missing start-URL.\nTry 'mathgenealogy --help' for more information.")

  gvExecutable <- findExecutable "dot"  >>=
                      maybe (throw $ AssertionFailed "Error - Couldn't find the 'dot' program. Did you install GraphViz?")
                            return

  let traverseEntries :: [Text] -> IO [Entry]
      traverseEntries = traverseEntries' 1 [] []
        where
          traverseEntries' :: Int -> [Entry] -> [Text] -> [Text] -> IO [Entry]
          traverseEntries' _ acc _        []         = return $ L.nub acc
          traverseEntries' c acc prevUrls (url:urls) = do
            e <- (if includeTheses args then id else removeThesis)
                 `liftM` downloadEntry url
            threadDelay 1000000
            if verbose args then  
                TI.putStrLn $ entryToText e
            else do 
                putStr $ "..."  ++ show c
                hFlush stdout
            let newUrls = urlAdvisors e
            traverseEntries' (c+1) (e:acc) (url:prevUrls) 
                             ((newUrls L.\\ prevUrls) ++ urls)

  appDir   <- getAppUserDataDirectory "mathgenealogy"
  doesDirectoryExist appDir >>= \exAppDir -> 
      unless exAppDir $ createDirectory appDir
  let entryFilename = tail $ L.dropWhile (/='=') $ startURL args
  mEntryFile <- findFile [appDir] entryFilename
  doDownload <- case mEntryFile of
                    Nothing -> return True
                    Just _  -> yesno False "Found locally stored data for this entry. Download new data and overwrite it?"

  let dotFileName = prefix args ++ ".dot"         
  theGraph <- if doDownload then do
                  putStrLn "Fetching entries from http://genealogy.math.ndsu.nodak.edu..."
                  putStrLn "(this might take a few minutes)"
                  putStr "Downloading entry number"
                  entries  <- traverseEntries [T.pack $ startURL args]
                  putStrLn ". Done. :)"
                  encodeFile (appDir ++ [pathSeparator] ++ entryFilename) entries
                  putStr $ "Building DOT-file '" ++ dotFileName ++ "' from downloaded data..."
                  return $ entryGraph entries
              else do
                  (entries::[Entry]) <- decodeFile (appDir ++ [pathSeparator] ++ entryFilename)
                  putStr $ "Building DOT-file '" ++ dotFileName ++ "' from locally stored data..."
                  return $ entryGraph entries

  
  let edgeAtt = const [ Dir Forward
                      , parseColor "Error - Could not parse edge color!" $ edgeColor args
                      ] 
  let bgcolorX11 = parseColorX11 "Error - Could not parse node background color!" $ 
                         nodeBackgroundColor args
  let nodeAtt (num,e) = 
        if not $ oldTextLabels args then
            [ styles [rounded,filled]
            , Shape PlainText
            , parseColor "Error - Could not parse node backgroundcolor!" $ 
                           nodeBackgroundColor args
            , toLabel $ 
                let fshead = if num == 1 then fontSizeFirstHeading args 
                                         else fontSizeHeading args 
                    fs = if num == 1 then fontSizeFirst args 
                                     else fontSize args in
                entryToHtml [ GA.BGColor $ X11Color bgcolorX11
                            , GA.Border 0
                            , GA.CellBorder 0
                            ]
                            [ GA.Face (T.pack $ fontHeading args)
                            , GA.PointSize fshead
                            ]
                            [ GA.Face (T.pack $ font args)
                            , GA.PointSize fs
                            ] e 
            ]
        else
            [ styles [rounded,filled]
            , textLabel $ entryToText e
            , Shape BoxShape
            , FontSize (if num == 1 then fontSizeFirst args else fontSize args)
            , parseColor "Error - Could not parse node background color!" $ 
                         nodeBackgroundColor args
            , FontName (T.pack $ font args) 
            ]
  let output = printDotGraph $ 
                 graphToDot nonClusteredParams{ fmtNode = nodeAtt 
                                              , fmtEdge = edgeAtt
                                              } theGraph
  B.writeFile dotFileName (encodeUtf8 output)
    `catch` (\(e::IOException) -> do { print e ; throw e })
  putStrLn "success! :)"

  putStr $ "Generating graphics file " ++ prefix args ++ show (outputFile args) ++ "..."
  let command = gvExecutable ++ " " ++ outputFileToGraphviz (outputFile args) ++ graphvizArgs args
                             ++ " " ++ dotFileName ++ " > " 
                             ++ prefix args ++ show (outputFile args)
  when (verbose args) $
      print command
  result <- system command
  when (isExitFailure result) $ do
    print $ "Error running the graphviz (dot) program. I tried: " ++ command
    throw $ AssertionFailed "Exiting."
  putStrLn "done. :)"
  unless (keepDotFile args) $ removeFile dotFileName
  where
    isExitFailure (ExitFailure _) = True
    isExitFailure _               = False
  
    parseColor :: String -> String -> Attribute
    parseColor errMsg colStr = 
        let colStr1 = headToUpper colStr in
        color (readDef (throw $ AssertionFailed errMsg) colStr1 :: X11Color)

    parseColorX11 :: String -> String -> X11Color
    parseColorX11 errMsg colStr = 
        let colStr1 = headToUpper colStr in
        readDef (throw $ AssertionFailed errMsg) colStr1 :: X11Color

-- | Conver the first character of the string to upper-case.
headToUpper :: String -> String
headToUpper str = toUpper  (head str) : tail str

    
-- | Download and parse an entry.
downloadEntry :: Text -> IO Entry
downloadEntry t = do 
    res <- parseEntry <$> getTags t
    case res of
        Nothing -> throw $ AssertionFailed "Error - Could not parse fetched data. Did you provide a valid URL to an existing math-genealogy entry?"
        Just r -> return r


yesno :: Bool    -- Set to 'True' iff "y" is the default value.
      -> String  -- Prompt string.
      -> IO Bool -- 'True' if the user answered affirmatively.
yesno defval prompt = do
          putStr $ prompt ++ if defval then " (Y/n) " else " (y/N) "
          hFlush stdout
          str <- getLine
          if null str then
              return defval
          else case headToUpper str of
                "Y" -> return True
                "N" -> return False
                _   -> do
                  putStrLn "Invalid input."
                  yesno defval prompt