----------------------------------------------------------------------------- -- | -- Module : Main -- Copyright : (C) Peter Robinson 2010-2012 -- License : GPL-2 -- -- Maintainer : Peter Robinson -- 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.Cmd(system) -- import System.IO.Error import System.Exit 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 data OutputType = PDF | PNG deriving(Eq,Data,Typeable) instance Show OutputType where show PDF = ".pdf" show PNG = ".png" outputTypeToGraphviz :: OutputType -> String outputTypeToGraphviz PDF = " -Tpdf " outputTypeToGraphviz PNG = " -Tpng " instance Default OutputType where def = PNG -- command line arguments: data MathGenealogy = MathGenealogy { filePrefix :: String , keepDotFile :: Bool , graphvizArgs :: String , onlyDotFile :: Bool , verbose :: Bool , includeTheses:: Bool , startURL :: String , outputType :: OutputType } deriving(Eq,Data,Typeable,Show) mathGenealogy = MathGenealogy { startURL = def &= args &= typ "URL" , filePrefix = "output" &= typ "PREFIX" , keepDotFile = False -- , graphvizArgs = " -Tpdf -Gcharset=utf8 " &= typ "" &= opt " -Tpdf -Gcharset=utf8 " , graphvizArgs = " -Gcharset=utf8 " &= typ "" -- &= opt " -Gcharset=utf8 " , onlyDotFile = False &= help "Only create .dot file" , verbose = False &= help "Print data to terminal." , includeTheses= False &= help "Include PhD thesis in output" , outputType = enum [PNG &= help "create PNG file",PDF &= help "create PDF file"] } &= 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 args <- cmdArgs mathGenealogy let targs = args when (null $ startURL args) $ 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. Did you install graphviz?") else return (fromJust m)) let traverseEntries :: [Text] -> IO [Entry] traverseEntries = traverseEntries' [] [] where traverseEntries' acc _ [] = return $ L.nub acc traverseEntries' acc prevUrls (url:urls) = do e <- (if includeTheses args then id else removeThesis) `liftM` downloadEntry url threadDelay 1000000 when (verbose args) $ print e let newUrls = urlAdvisors e traverseEntries' (e:acc) (url:prevUrls) ((newUrls L.\\ prevUrls) ++ urls) putStrLn "Downloading data..." theGraph <- entryGraph <$> traverseEntries [T.pack $ startURL args] putStrLn "done. :)" let dotFileName = filePrefix args ++ ".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 (onlyDotFile args) $ do putStr "Generating graphics file..." let command = gvExecutable ++ " " ++ outputTypeToGraphviz (outputType args) ++ graphvizArgs args ++ " " ++ dotFileName ++ " > " ++ filePrefix args ++ show (outputType args) 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 args) $ removeFile dotFileName where isExitFailure (ExitFailure _) = True isExitFailure _ = False downloadEntry :: Text -> IO Entry downloadEntry = liftM parseEntry . getTags