-----------------------------------------------------------------------------
-- |
-- 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