mathgenealogy 1.1.1 → 1.2.0
raw patch · 4 files changed
+99/−83 lines, 4 files
Files
- Entry.hs +24/−7
- Extract.hs +50/−56
- Main.hs +14/−13
- mathgenealogy.cabal +11/−7
Entry.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Entry--- Copyright : (C) Peter Robinson 2010-2012+-- Copyright : (C) Peter Robinson 2010-2013 -- License : GPL-2 -- -- Maintainer : Peter Robinson <thaldyron@gmail.com>@@ -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}}
Extract.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Extract--- Copyright : (C) Peter Robinson 2010-2012+-- Copyright : (C) Peter Robinson 2010-2013 -- License : GPL-2 -- -- Maintainer : Peter Robinson <thaldyron@gmail.com>@@ -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 (~== "<h2 style") tags) r2 <- tailMay r headMay r2--- let TagText sc = removeClutter $ headMay --- $ tailMay --- $ headMay --- $ sections (~== "<h2 style") tags in---- in- case t of- Just (TagText sc) -> 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 (~== "<span style=\"margin-right: 0.5em\">") 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 (~== "<span style=\"margin-right: 0.5em\">") 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 (~== "<p style=\"text-align: center\">") tags- offset2 = sections (~== "<p style=\"text-align: center; line-height: 2.75ex\">") - 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 (~== "<p style=\"text-align: center\">") tags+ offset2 = sections (~== "<p style=\"text-align: center; line-height: 2.75ex\">") + 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
Main.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Main--- Copyright : (C) Peter Robinson 2010-2012+-- Copyright : (C) Peter Robinson 2010-2013 -- License : GPL-2 -- -- Maintainer : Peter Robinson <thaldyron@gmail.com>@@ -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 "<graphviz parameters>" &= opt " -Tpdf -Gcharset=utf8 " , graphvizArgs = " -Gcharset=utf8 " &= typ "<graphviz parameters>" -- &= 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
mathgenealogy.cabal view
@@ -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 <thaldyron@gmail.com> -Copyright: (C) 2010-2012 Peter Robinson+Copyright: (C) 2010-2013 Peter Robinson Category: Web