-----------------------------------------------------------------------------
-- |
-- Module : Main
-- Copyright : (C) Peter Robinson 2010-2012
-- 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 Data.GraphViz
import Data.GraphViz.Attributes.Complete
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.List as L
import System
-- import System.IO.Error
import System.Directory
import Data.Maybe
import Data.Text.Lazy(Text)
import Data.Text.Lazy.Encoding
import qualified Data.Text.Lazy as T
import System.Console.CmdArgs
import Prelude hiding(catch)
import Extract
import Entry
import Graph
-- command line arguments:
data MathGenealogy = MathGenealogy
{ filePrefix :: String
, keepDotFile :: Bool
, graphvizArgs :: String
, noPDF :: Bool
, quiet :: Bool
, startURL :: String
}
deriving(Eq,Data,Typeable,Show)
mathGenealogy = MathGenealogy
{ startURL = def &= args &= typ "URL"
, filePrefix = "output" &= typ "PREFIX"
, keepDotFile = False
, graphvizArgs = " -Tpdf -Gcharset=utf8 " &= typ "<graphviz parameters>" &= opt " -Tpdf -Gcharset=utf8 "
, noPDF = False
, quiet = False
} &= summary "Mathematics Genealogy Visualizer"
&= details[ "Run the program with a start-URL, for example:",
"# mathgenealogy http://genealogy.math.ndsu.nodak.edu/id.php?id=18231"]
-- | GraphViz style attributes for edges and nodes.
-- See: http://hackage.haskell.org/packages/archive/graphviz/2999.12.0.4/doc/html/Data-GraphViz-Attributes.html
-- TODO: figure out if GraphViz supports CSS files or similar.
edgeAtt = const [ Dir Forward
, color LightBlue2
]
nodeAtt (num,e) =
[ textLabel (T.pack (show e))
, Shape BoxShape
, if num == 1 then FontSize 18 else FontSize 14
, styles [rounded,filled,bold]
, color LightYellow1
, FontName (T.pack "ZapfChancery-MediumItalic") -- "Helvetica")
]
main = do
MathGenealogy filePrefix keepDotFile graphvizArgs noPdf quiet startURL
<- cmdArgs mathGenealogy
when (null startURL) $
throw (userError "Missing start-URL. Run 'mathgenealogy --help' for help.")
gvExecutable <- (do m <- findExecutable "dot"
if m == Nothing
then throw (userError "Error - Couldn't find 'dot' program")
else return (fromJust m))
putStrLn "Downloading data..."
theGraph <- entryGraph <$> traverseEntries quiet [T.pack startURL]
putStrLn "done. :)"
let dotFileName = filePrefix ++ ".dot"
putStr $ "Writing DOT-file " ++ dotFileName ++ "..."
let output = printDotGraph $
graphToDot nonClusteredParams{ fmtNode = nodeAtt
, fmtEdge = edgeAtt
} theGraph
B.writeFile dotFileName (encodeUtf8 output)
`catch` (\(e::IOException) -> do { print e ; throw e })
putStrLn "done. :)"
unless noPdf $ do
putStr "Generating graphics file..."
let command = gvExecutable ++ " " ++ graphvizArgs ++ " " ++ dotFileName ++ " > "
++ filePrefix ++ ".pdf"
print command
result <- system command
when (isExitFailure result) $ do
print $ "Error running the graphviz (dot) program. I tried: " ++ command
throw $ userError "Existing."
putStrLn "done. :)"
unless keepDotFile $ removeFile dotFileName
where
isExitFailure (ExitFailure _) = True
isExitFailure _ = False
-- TODO: Build the graph here?
traverseEntries :: Bool -> [Text] -> IO [Entry]
traverseEntries quiet = traverseEntries' [] []
where
traverseEntries' acc _ [] = return $ L.nub acc
traverseEntries' acc prevUrls (url:urls) = do
e <- downloadEntry url
threadDelay 1000000
unless quiet $ print e
let newUrls = urlAdvisors e
traverseEntries' (e:acc) (url:prevUrls) ((newUrls L.\\ prevUrls) ++ urls)
downloadEntry :: Text -> IO Entry
downloadEntry = liftM parseEntry . getTags