diff --git a/Entry.hs b/Entry.hs --- a/Entry.hs +++ b/Entry.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Entry --- Copyright : (C) Peter Robinson 2010-2012 +-- Copyright : (C) Peter Robinson 2010-2013 -- License : GPL-2 -- -- Maintainer : Peter Robinson @@ -18,7 +18,7 @@ data Entry = Entry { entryName :: Text - , entryGraduationInfo :: Maybe GraduationInfo + , entryGraduationInfo :: [GraduationInfo] , entryAdvisors :: [(Text,Text)] } deriving(Ord,Eq) @@ -34,10 +34,16 @@ } deriving(Ord,Eq) +entryToText :: Entry -> Text +entryToText e = + entryName e `T.append` (T.concat $ map graduationInfoToText (entryGraduationInfo e)) + `T.append` (T.concat $ map fst (entryAdvisors e)) instance Show Entry where - show e = T.unpack (entryName e) - ++ maybeShow (entryGraduationInfo e) + show e = + let ginfos = concatMap show (entryGraduationInfo e) in + T.unpack (entryName e) + ++ if ginfos /= [] then "\n" ++ ginfos else "" where maybeShow (Just g) = "\\n" ++ show g maybeShow Nothing = "" @@ -50,8 +56,19 @@ maybeShow (Just gi) = T.unpack gi maybeShow Nothing = "" +graduationInfoToText :: GraduationInfo -> Text +graduationInfoToText g = + let ls = catMaybes [gradDegree g, gradUniversity g, gradYear g] in + T.intercalate (T.pack ", ") ls `T.append` (T.pack "\\n") `T.append` (maybeText (gradThesis g)) + where + maybeText (Just gi) = gi + maybeText Nothing = T.pack "" + + removeThesis :: Entry -> Entry -removeThesis e = e{ entryGraduationInfo = case entryGraduationInfo e of - Nothing -> Nothing - Just g -> Just g{gradThesis = Nothing}} +removeThesis e = + e{ entryGraduationInfo = map (\g -> g{ gradThesis = Nothing }) $ entryGraduationInfo e } +-- e{ entryGraduationInfo = case entryGraduationInfo e of +-- Nothing -> Nothing +-- Just g -> Just g{gradThesis = Nothing}} diff --git a/Extract.hs b/Extract.hs --- a/Extract.hs +++ b/Extract.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Extract --- Copyright : (C) Peter Robinson 2010-2012 +-- Copyright : (C) Peter Robinson 2010-2013 -- License : GPL-2 -- -- Maintainer : Peter Robinson @@ -31,76 +31,69 @@ openURL x = return . T.pack =<< getResponseBody =<< simpleHTTP (getRequest x) + getTags :: Text -> IO [Tag Text] getTags url = parseTags <$> openURL (T.unpack url) + parseEntry :: [Tag Text] -> Maybe Entry -parseEntry tags = - let msc = scientist tags in - case msc of - Nothing -> Nothing - Just sc -> Just $ - Entry sc (graduationInfo tags) (advisors tags) +parseEntry tags = do + sc <- scientist tags + return $ Entry sc (graduationInfos tags) (advisors tags) + scientist :: [Tag Text] -> Maybe Text -scientist tags = +scientist tags = do let t = removeClutter <$> do r <- headMay (sections (~== "

Just $ decodeUtf8 $ B.pack $ T.unpack sc - Nothing -> Nothing + TagText sc <- t + return $ decodeUtf8 $ B.pack $ T.unpack sc -graduationInfo :: [Tag Text] -> Maybe GraduationInfo -graduationInfo tags = - let offset = head $ sections (~== "") tags - getTag i = notEmptyMaybeTagText $ removeClutter $ offset !! i - degree = getTag 1 - univ = getTag 3 - year = getTag 5 - diss = getTag 18 - in matchLen offset degree univ year diss - where - matchLen offset degree univ year diss - | length offset >= 19 = Just $ GraduationInfo degree univ year diss - | length offset >= 6 = Just $ GraduationInfo degree univ year Nothing - | length offset >= 4 = Just $ GraduationInfo degree univ Nothing Nothing - | length offset >= 2 = Just $ GraduationInfo degree Nothing Nothing Nothing - | otherwise = Nothing +graduationInfos :: [Tag Text] -> [GraduationInfo] +graduationInfos tags = + let suffixes = sections (~== "") tags in + map (graduationInfo tags) suffixes + where + graduationInfo tags suffix = + let getTag i = notEmptyMaybeTagText $ removeClutter $ suffix !! i + degree = getTag 1 + univ = getTag 3 + year = getTag 5 + diss = getTag 18 + in matchLen suffix degree univ year diss + where + matchLen s degree univ year diss + | length s >= 19 = GraduationInfo degree univ year diss + | length s >= 6 = GraduationInfo degree univ year Nothing + | length s >= 4 = GraduationInfo degree univ Nothing Nothing + | length s >= 2 = GraduationInfo degree Nothing Nothing Nothing + advisors :: [Tag Text] -> [(Text,Text)] advisors tags = - let offset = sections (~== "

") tags - offset2 = sections (~== "

") - tags - getTag :: Int -> [[Tag Text]] -> Maybe Text - getTag _ [] = Nothing - getTag i off = - let tag = removeClutter $ flip (!!) i $ head off in - case tag of - TagText t -> maybeAdv $ notEmptyMaybeTagText $ - TagText (decodeUtf8 $ B.pack $ T.unpack t) - _ -> Nothing - - getLink :: Int -> [[Tag Text]] -> Maybe Text - getLink _ [] = Nothing - getLink i off = maybeLink $ flip (!!) (i-1) $ head off - in - (catMaybes' - (if null offset2 then [(getTag 1 offset, getLink 1 offset)] else - [(getTag i offset2, getLink i offset2) | i <- [3, 8]])) --- if null offset2 --- then catMaybes' [(getTag 1 offset,getLink 1 offset)] --- else catMaybes' [ (getTag i offset2,getLink i offset2) | i <- [3,8] ] + let offset = sections (~== "

") tags + offset2 = sections (~== "

") + tags + getTag :: Int -> [Tag Text] -> Maybe Text + getTag _ [] = Nothing + getTag i suff = + let tag = removeClutter $ flip (!!) i $ suff in + case tag of + TagText t -> maybeAdv $ notEmptyMaybeTagText $ + TagText (decodeUtf8 $ B.pack $ T.unpack t) + _ -> Nothing + + getLink :: Int -> [Tag Text] -> Maybe Text + getLink _ [] = Nothing + getLink i suff = maybeLink $ flip (!!) (i-1) suff + in + if null offset2 + then concatMap (\off -> catMaybes' $ [(getTag 1 off, getLink 1 off)]) offset + else concatMap (\off2 -> catMaybes' $ [(getTag i off2, getLink i off2) | i <- [3, 8]]) offset2 where -- TODO: rewrite catMaybes' :: [(Maybe a,Maybe b)] -> [(a,b)] @@ -122,9 +115,10 @@ notEmptyMaybeTagText :: Tag Text -> Maybe Text notEmptyMaybeTagText (TagText t) | all isSpace (T.unpack t) = Nothing - | T.null t = Nothing + | T.null t = Nothing | otherwise = Just t notEmptyMaybeTagText _ = Nothing + -- | Removes preceding, trailing and multiple inter-word spaces: removeClutter :: Tag Text -> Tag Text diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Main --- Copyright : (C) Peter Robinson 2010-2012 +-- Copyright : (C) Peter Robinson 2010-2013 -- License : GPL-2 -- -- Maintainer : Peter Robinson @@ -25,6 +25,7 @@ import System.Directory import Data.Maybe import Data.Text.Lazy(Text) +import qualified Data.Text.Lazy.IO as TI import Data.Text.Lazy.Encoding import qualified Data.Text.Lazy as T import System.Console.CmdArgs @@ -57,7 +58,7 @@ , keepDotFile :: Bool , graphvizArgs :: String , onlyDotFile :: Bool - , verbose :: Bool +-- , verbose :: Bool , includeTheses:: Bool , startURL :: String , outputFile :: OutputFile @@ -71,7 +72,7 @@ -- , graphvizArgs = " -Tpdf -Gcharset=utf8 " &= typ "" &= opt " -Tpdf -Gcharset=utf8 " , graphvizArgs = " -Gcharset=utf8 " &= typ "" -- &= opt " -Gcharset=utf8 " , onlyDotFile = False &= help "Only create the GraphViz '.dot' file" - , verbose = False &= help "Print data to terminal." +-- , verbose = False &= help "Print data to terminal." , includeTheses= False &= help "Include PhD thesis in output" , outputFile = enum [ FilePDF &= help "create PDF file (default)" , FilePNG &= help "create PNG file" @@ -104,26 +105,26 @@ args <- cmdArgs mathGenealogy let targs = args when (null $ startURL args) $ - throw (userError "Missing start-URL. Run 'mathgenealogy --help' for help.") + throw (AssertionFailed "Missing start-URL.\nTry 'mathgenealogy --help' for more information.") gvExecutable <- (do m <- findExecutable "dot" if m == Nothing - then throw $ userError "Error - Couldn't find 'dot' program. Did you install graphviz?" + then throw $ AssertionFailed "Error - Couldn't find 'dot' program. Did you install graphviz?" else return (fromJust m)) let traverseEntries :: [Text] -> IO [Entry] - traverseEntries = traverseEntries' 0 [] [] + traverseEntries = traverseEntries' 1 [] [] where 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 print e - else do - putStr $ show c ++ " " - hFlush stdout +-- 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) @@ -151,7 +152,7 @@ result <- system command when (isExitFailure result) $ do print $ "Error running the graphviz (dot) program. I tried: " ++ command - throw $ userError "Existing." + throw $ AssertionFailed "Exiting." putStrLn "done. :)" unless (keepDotFile args) $ removeFile dotFileName where @@ -163,6 +164,6 @@ downloadEntry t = do res <- parseEntry <$> getTags t case res of - Nothing -> throw $ userError "Error parsing fetched data. Did you provide a valid URL to an existing math-genealogy entry?" + Nothing -> throw $ AssertionFailed "Error parsing fetched data. Did you provide a valid URL to an existing math-genealogy entry?" Just r -> return r diff --git a/mathgenealogy.cabal b/mathgenealogy.cabal --- a/mathgenealogy.cabal +++ b/mathgenealogy.cabal @@ -1,6 +1,6 @@ Name: mathgenealogy -Version: 1.1.1 +Version: 1.2.0 Synopsis: Discover your (academic) ancestors! @@ -20,22 +20,26 @@ > mathgenealogy --help . for more options. Requires GraphViz (in particular the /dot/ program) to run. + . + /Changes in 1.2.0:/ + . + * Correct handling of entries with multiple PhDs (reported by Dima Pasechnik) . /Changes in 1.1.1:/ . - * provide error message when given invalid start URL + * Provide error message when given invalid start URL . - * documentation and code cleanup + * Documentation and code cleanup . /Changes in 1.0.0:/ . - * choice between PDF and PNG output + * Choice between PDF and PNG output . - * optional inclusion of PhD theses in output + * Optional inclusion of PhD theses in output . /Changes in 0.0.2:/ . - * fixed bug regarding trailing commas (thanks to A. Koessler) + * Fixed bug regarding trailing commas (reported by Alexander Koessler) -- Homepage: http://darcs.monoid.at/mathgenealogy @@ -49,7 +53,7 @@ Maintainer: Peter Robinson -Copyright: (C) 2010-2012 Peter Robinson +Copyright: (C) 2010-2013 Peter Robinson Category: Web