citation-resolve 0.2.4 → 0.3

raw patch · 9 files changed

+457/−302 lines, 9 filesdep +aesondep +containersdep +data-defaultdep −monad-loggerdep −persistentdep −persistent-sqlitebuild-type:Customsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, containers, data-default, either, lens, mtl, safe, yaml

Dependencies removed: monad-logger, persistent, persistent-sqlite, persistent-template, resourcet

API changes (from Hackage documentation)

Files

• Setup.hs +53/−2
• Text/CSL/Input/Identifier.hs +0/−25
• Text/CSL/Input/Identifier/Internal.hs +0/−225
• citation-resolve.cabal +45/−35
• default.db +51/−0
• isbn2bibtex.xsl +14/−0
• src/Text/CSL/Input/Identifier.hs +54/−0
• src/Text/CSL/Input/Identifier/Internal.hs +198/−0
• test/doctests.hs +42/−15

@@ -1,2 +1,53 @@-import Distribution.Simple-main = defaultMain+#!/usr/bin/runhaskell+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Text ( display )+import Distribution.Verbosity ( Verbosity )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+     buildHook simpleUserHooks pkg lbi hooks flags+  , postHaddock = \args flags pkg lbi -> do+     postHaddock simpleUserHooks args flags pkg lbi+  }++haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath+haddockOutputDir flags pkg = destDir where+  baseDir = case haddockDistPref flags of+    NoFlag -> "."+    Flag x -> x+  destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  withLibLBI pkg lbi $ \_ libcfg -> do+    withTestLBI pkg lbi $ \suite suitecfg -> do+      rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+        [ "module Build_" ++ testName suite ++ " where"+        , "deps :: [String]"+        , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+        ]+  where+    formatdeps = map (formatone . snd)+    formatone p = case packageName p of+      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++

@@ -1,25 +0,0 @@--- | This modules provides a way to convert document identifiers, such---  as DOIs, ISBNs, arXiv IDs to bibliographic references.------  Each type of identifiers will be converted via internet services---  to a bibliographic record of type 'Text.CSL.Reference' , which in---  turn can be rendered in various format using @citeproc-hs@ package---  <hackage.haskell.org/package/citeproc-hs> .------  Moreover, the server responses are cached in a local database,---  making the server load as little as possible.---module Text.CSL.Input.Identifier-       (EReference, readID, readDOI, readArXiv, readBibcode, readISBN )-       where---import qualified Text.CSL-import           Text.CSL.Input.Identifier.Internal----- | EReference is the type returned by the 'Reference' resolver,--- accompanied with possible error message.--type EReference = Either String Text.CSL.Reference

@@ -1,225 +0,0 @@-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}--module Text.CSL.Input.Identifier.Internal where--import           Control.Applicative ((<$>))-import           Control.Monad.IO.Class (liftIO)-import           Control.Monad.Logger (runNoLoggingT)-import           Control.Monad.Trans.Resource (runResourceT)-import qualified Data.ByteString.Char8 as BS-import           Data.Char (toLower)-import           Data.List (span)-import qualified Data.Text as Text-import qualified Data.String.Utils as String (replace)-import           Database.Persist-import           Database.Persist.TH-import           Database.Persist.Sqlite-import           Network.Curl.Download (openURIWithOpts)-import           Network.Curl.Opts (CurlOption(CurlFollowLocation, CurlHttpHeaders))-import           System.Directory (createDirectoryIfMissing)-import           System.Process (runInteractiveCommand, system)-import           System.IO (hGetContents, hClose)-import           Text.CSL (Reference, readBiblioString, BibFormat(Bibtex, Json))-import           Text.Printf--import qualified Paths_citation_resolve as Paths------ $setup--- >>> import Control.Applicative((<$>), (<*>))--- >>> import Data.Either.Utils(forceEither)--- >>> import Text.CSL------- | data structure for accessing the reference cache database.-share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|-WebCache-  url     String-  content BS.ByteString-  deriving Show-|]---- | 'Resolver' is a function that converts a 'String' key to some--- value @a@, which may fail with an error message.-type Resolver a = String -> IO (Either String a)---- | Take a resolver, and make it cached.-cached :: Resolver BS.ByteString -> Resolver BS.ByteString-cached resolver0 url = do-  dbfn <- getDataFileName "reference.db3"--  runNoLoggingT $ runResourceT $  withSqlitePool (Text.pack dbfn) 1 $ \pool -> do-      flip runSqlPool pool $ runMigration migrateAll-      mx <- flip runSqlPool pool $ do-        selectFirst [WebCacheUrl ==. url] []-      case mx of-        Just x  -> do-          return $ Right $ webCacheContent $ entityVal x--        Nothing -> do-          ret <- liftIO $ resolver0 url-          case ret of-            Right content0 -> do-              flip runSqlPool pool $ do-                insert $ WebCache-                   url content0-              return ()-            Left _ -> return ()-          return ret------- | parse a Bibtex entry obtained in various ways.-resolveBibtex :: String -> Resolver Reference-resolveBibtex src str = do-  rs <- readBiblioString Bibtex str-  case rs of-    [r] -> return $ Right r-    []  -> return $ Left $ src ++ " returned no reference."-    _   -> return $ Left $ src ++ " returned multiple references."----- | Multi-purpose reference ID resolver. Resolve 'String' starting--- with "arXiv:", "isbn:", "doi:" to 'Reference' .------ >>> (==) <$> readArXiv "1204.4779" <*>  readID "arXiv:1204.4779"--- True--- >>> (==) <$> readDOI "10.1088/1749-4699/5/1/015003" <*> readID "doi:10.1088/1749-4699/5/1/015003"--- True--- >>> (==) <$> readISBN "9780199233212" <*> readID "isbn:9780199233212"--- True----readID :: Resolver Reference-readID str-  | idId == "arxiv"   = readArXiv addr-  | idId == "bibcode" = readBibcode addr-  | idId == "doi"     = readDOI addr-  | idId == "isbn"    = readISBN addr-  | otherwise         = return $ Left $ "Unknown identifier type: " ++ str-  where-    (h,t) = span (/=':') str-    idId = map toLower h-    addr = drop 1 t------- | resolve a DOI to a 'Reference'.------ >>> ref <- forceEither <$> readDOI "10.1088/1749-4699/5/1/015003"--- >>> title ref--- "Paraiso: an automated tuning framework for explicit solvers of partial differential equations"--- >>> putStrLn $ url ref--- http://dx.doi.org/10.1088/1749-4699/5/1/015003----readDOI :: Resolver Reference-readDOI doi = do-  let-      opts = [ CurlFollowLocation True-             , CurlHttpHeaders ["Accept: text/bibliography; style=bibtex"]-             ]-      url = "http://dx.doi.org/" ++ doi-  res <- cached (openURIWithOpts opts) url-  case res of-    Left msg -> return $ Left msg-    Right bs -> resolveBibtex url $ BS.unpack bs---- | resolve an arXiv ID to a 'Reference'. If it's a referred journal paper, it can also resolve---   the refereed version of the paper.------ >>>  ref <- forceEither <$> readArXiv "1204.4779"--- >>> title ref--- "Paraiso: an automated tuning framework for explicit solvers of partial differential equations"--- >>> containerTitle ref--- "Computational Science and Discovery"--readArXiv :: Resolver Reference-readArXiv arXiv = do-  let-      opts = [ CurlFollowLocation True]-      url = "http://adsabs.harvard.edu/cgi-bin/bib_query?data_type=BIBTEX&arXiv:" ++ arXiv-  res <- cached (openURIWithOpts opts) url-  case res of-    Left msg -> return $ Left msg-    Right bs -> resolveBibtex url $-       String.replace "adsurl" "url" $-       BS.unpack bs------ | resolve an Bibcode ID to a 'Reference'.------ >>>  ref <- forceEither <$> readBibcode " 2012CS&D....5a5003M"--- >>> title ref--- "Paraiso: an automated tuning framework for explicit solvers of partial differential equations"--- >>> containerTitle ref--- "Computational Science and Discovery"--readBibcode :: Resolver Reference-readBibcode idstr = do-  let-      opts = [ CurlFollowLocation True]-      url = "http://adsabs.harvard.edu/cgi-bin/bib_query?data_type=BIBTEX&bibcode=" ++ idstr-  res <- cached (openURIWithOpts opts) url-  case res of-    Left msg -> return $ Left msg-    Right bs -> resolveBibtex url $-       String.replace "adsurl" "url" $-       BS.unpack bs---------- | resolve an ISBN to a 'Reference'.------ >>> ref <- forceEither <$> readISBN "9780199233212"--- >>> title ref--- "The nature of computation"--readISBN :: Resolver Reference-readISBN isbn = do-  let-      opts = [ CurlFollowLocation True ]-      url = printf "http://xisbn.worldcat.org/webservices/xid/isbn/%s?method=getMetadata&format=xml&fl=*"-            isbn-  res <- cached (openURIWithOpts opts) url-  case res of-    Left msg -> return $ Left msg-    Right bs -> do-      xsltfn <- getDataFileName "isbn2bibtex.xsl"-      writeFile xsltfn xsl-      (hIn,hOut,_,_) <- runInteractiveCommand $ printf "xsltproc %s -" xsltfn-      BS.hPutStr hIn bs-      hClose hIn-      str <- hGetContents hOut-      resolveBibtex url str--  where-    xsl = "<?xml version=\"1.0\"?>\n<xsl:stylesheet xmlns:xsl=\"http://www.w3.org/1999/XSL/Transform\" xmlns:wc=\"http://worldcat.org/xid/isbn/\" version=\"1.0\">\n    <xsl:output method=\"text\" omit-xml-declaration=\"yes\" indent=\"no\"/>\n    <xsl:template match=\"wc:isbn\">\n        <code>\n    @BOOK{CiteKeyGoesHere,\n        AUTHOR = \"<xsl:value-of select=\"@author\"/>\",\n        TITLE = \"<xsl:value-of select=\"@title\"/>\",\n        PUBLISHER = \"<xsl:value-of select=\"@publisher\"/>\",\n        ADDRESS = \"<xsl:value-of select=\"@city\"/>\",\n        YEAR =\"<xsl:value-of select=\"@year\"/>\"}\n</code>\n    </xsl:template>\n</xsl:stylesheet>\n"----- | a safer way to get data file name.-getDataFileName :: String -> IO String-getDataFileName fn = do-  dd <- Paths.getDataDir-  createDirectoryIfMissing True dd-  Paths.getDataFileName fn--- >>> take 7 $ title ref--- "Paraiso"

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                citation-resolve-version:             0.2.4+version:             0.3 synopsis:            convert document IDs such as DOI, ISBN, arXiv ID to bibliographic reference. description:            This modules provides a way to convert document identifiers, such@@ -29,45 +29,55 @@ maintainer:          muranushi@gmail.com -- copyright:            category:            Text-build-type:          Simple+build-type:          Custom cabal-version:       >=1.8 -Data-Files:          bibtex.csl+Data-Files:          bibtex.csl, isbn2bibtex.xsl, default.db  library-  exposed-modules:     Text.CSL.Input.Identifier-                       Text.CSL.Input.Identifier.Internal+  exposed-modules:  +    Text.CSL.Input.Identifier+    Text.CSL.Input.Identifier.Internal -  other-modules:       Paths_citation_resolve+  other-modules:   +    Paths_citation_resolve -  build-depends:       base >=4.5 &&  <5-                     , bytestring >= 0.9.2.1-                     , citeproc-hs >= 0.3.7-                     , curl >= 1.3.8-                     , directory >= 1.2-                     , download-curl >= 0.1.4 -                     , MissingH >= 1.1-                     , monad-logger >= 0.3.1.1---                   , hxt >= 9.3.1       -- TODO: treat xsl more properly ---                   , hxt-xslt >= 9.1.1  -- using these libraries.-                     , persistent >= 1.2.0.2-                     , persistent-template >= 1.1.2-                     , persistent-sqlite >= 1.1.2-                     , process >= 1.1-                     , resourcet >= 0.4.4-                     , text >= 0.11-                     , transformers >= 0.3+  Hs-Source-Dirs: src -Test-Suite doctest+  build-depends:     +      base >=4.5 &&  <5+    , aeson >= 0.6.1+    , bytestring >= 0.9.2.1+    , citeproc-hs >= 0.3.7+    , containers >= 0.5+    , curl >= 1.3.8+    , data-default+    , directory >= 1.2    +    , download-curl >= 0.1.4 +    , either >= 3.4.1+    , lens >= 3.9.0.2+    , MissingH >= 1.1+    , mtl >= 2.1.2+--  , hxt >= 9.3.1       -- TODO: treat xsl more properly +--  , hxt-xslt >= 9.1.1  -- using these libraries.+    , process >= 1.1+    , safe+    , text >= 0.11+    , transformers >= 0.3+    , yaml >= 0.8.4++Test-Suite doctests   Type: exitcode-stdio-1.0   HS-Source-Dirs: test-  Ghc-Options: -threaded -Wall+  Ghc-Options: -Wall -threaded    Main-Is: doctests.hs-  Build-Depends: base-                  , directory >= 1.1-                  , filepath >= 1.2-                  , MissingH >= 1.1-                  , doctest >= 0.9.3+  +  Build-Depends:+      base+    , directory >= 1.1+    , filepath >= 1.2+    , MissingH >= 1.1+    , doctest >= 0.9.3  Test-Suite spec   Type: exitcode-stdio-1.0@@ -76,11 +86,11 @@   Main-Is: Spec.hs   Other-Modules:                      -  Build-Depends: base >=4.5 && < 5-                  , binary-search--                  , hspec >= 1.3-                  , QuickCheck >= 2.5+  Build-Depends: +      base >=4.5 && < 5+    , binary-search+    , hspec >= 1.3+    , QuickCheck >= 2.5  Source-Repository head   Type:                 git

@@ -0,0 +1,51 @@+- - arXiv:1204.4779+  - - ! '@ARTICLE{2012CS&D....5a5003M,'+    - ! '   author = {{Muranushi}, T.},'+    - ! '    title = "{Paraiso: an automated tuning framework for explicit solvers+      of partial differential equations}",'+    - ! '  journal = {Computational Science and Discovery},'+    - archivePrefix = "arXiv",+    - ! '   eprint = {1204.4779},'+    - ! ' primaryClass = "astro-ph.IM",'+    - ! '     year = 2012,'+    - ! '    month = jan,'+    - ! '   volume = 5,'+    - ! '   number = 1,'+    - ! '      eid = {015003},'+    - ! '    pages = {015003},'+    - ! '      doi = {10.1088/1749-4699/5/1/015003},'+    - ! '   url = {http://adsabs.harvard.edu/abs/2012CS%26D....5a5003M},'+    - ! '  adsnote = {Provided by the SAO/NASA Astrophysics Data System}'+    - ! '}'+- - bibcode:2012CS&D....5a5003M+  - - ! '@ARTICLE{2012CS&D....5a5003M,'+    - ! '   author = {{Muranushi}, T.},'+    - ! '    title = "{Paraiso: an automated tuning framework for explicit solvers+      of partial differential equations}",'+    - ! '  journal = {Computational Science and Discovery},'+    - archivePrefix = "arXiv",+    - ! '   eprint = {1204.4779},'+    - ! ' primaryClass = "astro-ph.IM",'+    - ! '     year = 2012,'+    - ! '    month = jan,'+    - ! '   volume = 5,'+    - ! '   number = 1,'+    - ! '      eid = {015003},'+    - ! '    pages = {015003},'+    - ! '      doi = {10.1088/1749-4699/5/1/015003},'+    - ! '   url = {http://adsabs.harvard.edu/abs/2012CS%26D....5a5003M},'+    - ! '  adsnote = {Provided by the SAO/NASA Astrophysics Data System}'+    - ! '}'+- - doi:10.1088/1749-4699/5/1/015003+  - - ! '@article{Muranushi_2012, title={Paraiso: an automated tuning framework for+      explicit solvers of partial differential equations}, volume={5}, url={http://dx.doi.org/10.1088/1749-4699/5/1/015003},+      DOI={10.1088/1749-4699/5/1/015003}, number={1}, journal={Computational Science+      & Discovery}, publisher={IOP Publishing}, author={Muranushi, Takayuki}, year={2012},+      month={Jan}, pages={015003}}'+- - isbn:9784274068850+  - - ! '    @BOOK{CiteKeyGoesHere,'+    - ! '        AUTHOR = "Lipovaca Miran;Tanaka Hideyuki;Muranushi Takayuki.",'+    - ! "        TITLE = \"Sugoi hasukeru tanoshiku manab\u014D\","+    - ! "        PUBLISHER = \"\u014Cmusha\","+    - ! "        ADDRESS = \"T\u014Dky\u014D\","+    - ! '        YEAR =""}'

@@ -0,0 +1,14 @@+<?xml version="1.0"?>+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" xmlns:wc="http://worldcat.org/xid/isbn/" version="1.0">+    <xsl:output method="text" omit-xml-declaration="yes" indent="no"/>+    <xsl:template match="wc:isbn">+        <code>+    @BOOK{CiteKeyGoesHere,+        AUTHOR = "<xsl:value-of select="@author"/>",+        TITLE = "<xsl:value-of select="@title"/>",+        PUBLISHER = "<xsl:value-of select="@publisher"/>",+        ADDRESS = "<xsl:value-of select="@city"/>",+        YEAR ="<xsl:value-of select="@year"/>"}+</code>+    </xsl:template>+</xsl:stylesheet>

@@ -0,0 +1,54 @@+{-# LANGUAGE FlexibleContexts #-}+-- | This modules provides a way to convert document identifiers, such+--  as DOIs, ISBNs, arXiv IDs to bibliographic references.+--+--  Each type of identifiers will be converted via internet services+--  to a bibliographic record of type 'Text.CSL.Reference' , which in+--  turn can be rendered in various format using @citeproc-hs@ package+--  <hackage.haskell.org/package/citeproc-hs> .+--+--  Moreover, the server responses are cached in a local database,+--  making the server load as little as possible.++module Text.CSL.Input.Identifier+       (resolveEither, resolve)+       where++import           Control.Monad.IO.Class+import           Control.Monad.State as State+import           Control.Monad.Trans.Either+import           Data.Default+import           Text.CSL.Reference (emptyReference, Reference)+import           Text.CSL.Input.Identifier.Internal++-- $setup+-- >>> import Control.Applicative((<$>), (<*>))+-- >>> import Data.Either.Utils(forceEither)+-- >>> import Text.CSL++++-- | Resolve a document url to a 'Reference'. returns an empty reference when someting fails. +--   prefix the document ID with one of "arXiv:", "doi:", "bibcode:" or "isbn:" .+-- +--+-- >>> do { ref <- resolveDef "arXiv:1204.4779" ; putStrLn $ title ref }+-- Paraiso: an automated tuning framework for explicit solvers of partial differential equations+-- >>> do { ref <- resolveDef "doi:10.1088/1749-4699/5/1/015003" ; print $ author ref }+-- [Takayuki Muranushi]+-- >>> do { ref <- resolveDef "bibcode:2012CS&D....5a5003M" ; putStrLn $ containerTitle ref }+-- Computational Science and Discovery+-- >>> do { ref <- resolveDef "isbn:9784274068850" ; putStrLn $ title ref }+-- Sugoi hasukeru tanoshiku manabō+++resolve :: (MonadIO m, MonadState DB m) => String -> m Reference+resolve = liftM (either (const emptyReference) id) . runEitherT . resolveEither ++-- | Resolve the document id using the default database.++resolveDef :: String -> IO Reference+resolveDef url = do+  fn <- getDataFileName "default.db"             +  let go = withDBFile fn $ resolve url+  State.evalStateT go def

@@ -0,0 +1,198 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Text.CSL.Input.Identifier.Internal where++import           Control.Applicative ((<$>))+import           Control.Lens (_2, Iso, iso, over,  Simple, to, use, (%=))+import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.State as State+import           Control.Monad.Trans.Either+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Generic as AG+import qualified Data.ByteString.Char8 as BS+import           Data.Char (toLower, isSpace)+import           Data.Default(Default(..))+import           Data.List (span)+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import qualified Data.String.Utils as String (replace)+import qualified Data.Yaml as Yaml+import           Network.Curl.Download (openURIWithOpts)+import           Network.Curl.Opts (CurlOption(CurlFollowLocation, CurlHttpHeaders))+import           Safe (headMay)+import           System.Directory (createDirectoryIfMissing, doesFileExist)+import           System.Process (runInteractiveCommand, system)+import           System.IO (hGetContents, hClose, hPutStrLn, stderr)+import           Text.CSL (Reference, readBiblioString, BibFormat(Bibtex, Json))+import           Text.Printf++import qualified Paths_citation_resolve as Paths++++-- | The data structure that carries the resolved references.+newtype DB = DB { unDB :: Map.Map String String}++-- | The lens for accessing the map within the DB.+db :: Simple Iso DB (Map.Map String String)+db = iso unDB DB++instance Default DB where def = DB Map.empty++instance Yaml.FromJSON DB where+  parseJSON x0 = do+    x1 <- Yaml.parseJSON x0+    let x1' :: [(String, [String])]+        x1' = x1+    return $ DB $ Map.fromList $ map (over _2 unlines) x1'++instance Yaml.ToJSON DB where+  toJSON = Yaml.toJSON . map (over _2 lines) . Map.toList . unDB+++++withDBFile :: (MonadIO m, MonadState DB m) => FilePath -> m a -> m a+withDBFile fn prog = do+  x <- liftIO $ doesFileExist fn+  initState <- case x of+    False -> return def+    True -> do+      con <- liftIO $ BS.readFile fn+      case Yaml.decode con of+        Just st -> return st+        Nothing -> do+          liftIO $ hPutStrLn stderr $ "cannot read/parse DB file: " ++ fn+          return def+  State.put initState+  ret <- prog+  finalState <- State.get+  liftIO $ BS.writeFile fn $ Yaml.encode (finalState :: DB)+  return ret+++-- | Resolver Monad is a function that converts a key of type @a@ to some+-- other type @b@, which may fail with an error message.+type RM m a b = a -> EitherT String m b++-- | Perform possibly failing IO within a monad++liftIOE :: MonadIO m => IO (Either a b) -> EitherT a m b+liftIOE = (>>= hoistEither) . liftIO++-- | parse a Bibtex entry that contains single reference.+resolveBibtex :: MonadIO m => String -> RM m String Reference+resolveBibtex url str = do+  rs <- liftIO $ readBiblioString Bibtex str+  case rs of+    [r] -> right r+    []  -> left $ url ++ " returned no parsable reference."+    _   -> left $ url ++ " returned multiple references."++++-- | resolve a document url to a 'Reference', or emits a error+--   message with reason why it fails.+resolveEither :: forall m. (MonadIO m, MonadState DB m) => String -> EitherT String m Reference+resolveEither url = do+  val <- use $ db . to (Map.lookup url)+  case val of+    Just bibtexStr -> resolveBibtex url bibtexStr+    Nothing -> do+      reader <- hoistEither selectResolver+      bibtexStr <- reader addr+      ret <- resolveBibtex url bibtexStr+      db %= Map.insert url bibtexStr+      return ret+++   where+     (h,t) = span (/=':') url+     idId = map toLower h+     addr = drop 1 t++     selectResolver :: Either String (RM m String String)+     selectResolver =+       maybe (Left $ "Unknown identifier type: " ++ idId) (Right . snd) $+       headMay $+       filter ((==idId) . fst) specialResolverTbl++     specialResolverTbl =+       [ ("arxiv"   , resolveArXiv   )+       , ("bibcode" , resolveBibcode )+       , ("doi"     , resolveDOI     )+       , ("isbn"    , resolveISBN    ) ]+++-- resolvers for specific document IDs.++resolveDOI :: MonadIO m => RM m String String+resolveDOI docIDStr = do+  let+      opts = [ CurlFollowLocation True+             , CurlHttpHeaders ["Accept: text/bibliography; style=bibtex"]+             ]+      url = "http://dx.doi.org/" ++ docIDStr+  bs <- liftIOE $ openURIWithOpts opts url+  return $ BS.unpack bs++resolveArXiv :: MonadIO m => RM m String String+resolveArXiv docIDStr = do+  let+      opts = [ CurlFollowLocation True]+      url = "http://adsabs.harvard.edu/cgi-bin/bib_query?data_type=BIBTEX&arXiv:" ++ docIDStr+  bs <- liftIOE $ openURIWithOpts opts url+  return $+    unlines . drop 2 . filter (any (not . isSpace)) . lines $+    String.replace "adsurl" "url" $+    BS.unpack bs++resolveBibcode :: MonadIO m => RM m String String+resolveBibcode docIDStr = do+  let+      opts = [ CurlFollowLocation True]+      url = "http://adsabs.harvard.edu/cgi-bin/bib_query?data_type=BIBTEX&bibcode=" ++ docIDStr+  bs <- liftIOE $ openURIWithOpts opts url+  return $+    unlines . drop 2 . filter (any (not . isSpace)) . lines $+    String.replace "adsurl" "url" $ BS.unpack bs++resolveISBN :: MonadIO m => RM m String String+resolveISBN docIDStr = do+  let+      opts = [ CurlFollowLocation True ]+      url = printf "http://xisbn.worldcat.org/webservices/xid/isbn/%s?method=getMetadata&format=xml&fl=*"+            docIDStr+  bs <- liftIOE $ openURIWithOpts opts url+  str <- liftIO $ do+    xsltfn <- getDataFileName "isbn2bibtex.xsl"+    writeFile xsltfn xsl+    (hIn,hOut,_,_) <- runInteractiveCommand $ printf "xsltproc %s -" xsltfn+    BS.hPutStr hIn bs+    hClose hIn+    hGetContents hOut+  return $ unlines . filter (any (not . isSpace)) . lines $ str++  where+    -- we must dynamically generate this file because it does not+    -- exist at the test timing.++    xsl = "<?xml version=\"1.0\"?>\n<xsl:stylesheet xmlns:xsl=\"http://www.w3.org/1999/XSL/Transform\" xmlns:wc=\"http://worldcat.org/xid/isbn/\" version=\"1.0\">\n    <xsl:output method=\"text\" omit-xml-declaration=\"yes\" indent=\"no\"/>\n    <xsl:template match=\"wc:isbn\">\n        <code>\n    @BOOK{CiteKeyGoesHere,\n        AUTHOR = \"<xsl:value-of select=\"@author\"/>\",\n        TITLE = \"<xsl:value-of select=\"@title\"/>\",\n        PUBLISHER = \"<xsl:value-of select=\"@publisher\"/>\",\n        ADDRESS = \"<xsl:value-of select=\"@city\"/>\",\n        YEAR =\"<xsl:value-of select=\"@year\"/>\"}\n</code>\n    </xsl:template>\n</xsl:stylesheet>\n"+++-- | a safer way to get data file name.+getDataFileName :: String -> IO String+getDataFileName fn = do+  dd <- Paths.getDataDir+  createDirectoryIfMissing True dd+  Paths.getDataFileName fn

@@ -1,24 +1,51 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (doctests)+-- Copyright   :  (C) 2012-13 Edward Kmett+-- License     :  BSD-style (see the file LICENSE.doctests)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- This module provides doctests for a project based on the actual versions+-- of the packages it was built with. It requires a corresponding Setup.lhs+-- to be added to the project+----------------------------------------------------------------------------- module Main where +import Build_doctests (deps) import Control.Applicative import Control.Monad-import Test.DocTest+import Data.List import System.Directory import System.FilePath+import Test.DocTest -findHs :: FilePath -> IO [FilePath]-findHs dir = do-  fs <- map (dir </>) <$>-    filter (`notElem` ["..","."]) <$>-    getDirectoryContents dir-  subDirs <- filterM doesDirectoryExist fs-  files1 <- filter ((`elem` [".hs", ".lhs"]) . takeExtension) <$>-    filterM doesFileExist fs-  files2 <- concat <$> mapM findHs subDirs-  return $ files1 ++ files2 +-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+withUnicode m = m++ main :: IO ()-main = do-  files <- findHs "Text"-  putStrLn $ "testing: " ++ unwords files-  doctest $ ["-idist/build/autogen"] ++ files+main = withUnicode $ getSources >>= \sources -> doctest $+    "-isrc"+  : "-idist/build/autogen"+  : "-optP-include"+  : "-optPdist/build/autogen/cabal_macros.h"+  : "-hide-all-packages"+  : map ("-package="++) deps ++ sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+  where+    go dir = do+      (dirs, files) <- getFilesAndDirectories dir+      (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c