imbib 1.0.0 → 1.2.5
raw patch · 17 files changed
+897/−1043 lines, 17 filesdep +groomdep +imbibdep +optparse-applicativedep −curldep −download-curldep −glibdep ~ConfigFiledep ~basedep ~bibtex
Dependencies added: groom, imbib, optparse-applicative, parsek, text
Dependencies removed: curl, download-curl, glib, gnomevfs, gtk, utf8-string
Dependency ranges changed: ConfigFile, base, bibtex, bytestring, containers, directory, filepath, mtl, parsec, process, split
Files
- .imbib +2/−6
- Batch.hs +99/−70
- BibAttach.hs +0/−50
- BibDB.hs +0/−41
- BibFile.hs +0/−39
- Config.hs +0/−38
- Diff.hs +62/−0
- Imbibed.hs +0/−296
- MaybeIO.hs +11/−5
- SuffixTreeCluster.hs +0/−301
- TypedBibData.hs +0/−155
- imbib.cabal +80/−42
- lib/BibAttach.hs +53/−0
- lib/BibDB.hs +31/−0
- lib/Config.hs +61/−0
- lib/SuffixTreeCluster.hs +301/−0
- lib/TypedBibData.hs +197/−0
.imbib view
@@ -1,6 +1,2 @@-watched = %(home)s/Downloads-archive = %(home)s/Papers-library = %(home)s/library.bib--viewer = /usr/bin/evince-editor = /usr/bin/emacs+library = %(home)s/path-to-bib-file.bib+editor = /usr/bin/emacsclient
Batch.hs view
@@ -1,60 +1,57 @@ {-# LANGUAGE RecordWildCards, TupleSections #-} -import Control.Applicative hiding ((<|>),many)-import Control.Monad-import Control.Monad.Trans-import qualified Data.ByteString.Lazy as BS-import Data.Char import Data.List-import Data.Maybe-import Data.Tree-import Data.Traversable import System.FilePath-import System.Process-import Text.BibTeX.Entry as Entry-import Text.BibTeX.Parse-import Data.Function-import System.Environment import qualified Data.Map as M import Config+import Options.Applicative import TypedBibData import BibDB import BibAttach import qualified SuffixTreeCluster as SC--- import Text.Groom import MaybeIO-+import Diff+import Data.Function (on) ------------------------------------------------------------------------- -- CheckDuplicates, method 1 +pairs :: [t] -> [(t, t)] pairs (x:xs) = map (x,) xs ++ pairs xs pairs _ = [] -checkDup bib = do+dist :: String -> String -> Int+dist x y = length $ filter (/= B) $ map fst $ diff' (project x) (project y)++checkDup :: InitFile -> [Entry] -> MaybeIO ()+checkDup cfg bib' = do -- mapM_ putString $ [ groom $ (map findTitle es, shared) | (es,shared) <- common ]- putString "Possible duplicates:"- mapM_ putString $ map (show . map findTitle) dups- saveBib $ uniqDups ++ (bib \\ uniqDups) -- clump together the duplicates- where- uniqDups = nub $ concat $ dups- trueDups es = filter (\e -> any (not . (areRelated e)) es) es- dups = [ es | (es0,shared) <- common, - let es = trueDups es0, - not (null es),- sum (map length shared) >= threshold (minimum (map (length . project . findTitle) es))]- threshold x = (9 * x) `div` 10- -- SC.printTree $ SC.select ("", clusterTree)- common = M.toList $ SC.commonStrings info- clusterTree = SC.construct info- info = [(project $ findTitle e,[e]) | e <- bib]- + putString ("Removing exact duplicates:" ++ show (length bib' - length bib))+ -- putString ("Candidate duplicate groups:\n" ++ (groom $ [(shared,map findTitle es) | (es,shared) <- dupGroups]))+ uncheckedHarmless $ mapM_ print [(findTitle e1,findTitle e2) | (e1,e2) <- dups]+ sortBib cfg $ bib -- (uniqDups ++ (bib \\ uniqDups))+ where dups = [(e1,e2) |+ (es,_) <- dupGroups,+ (e1,e2) <- pairs $ es,+ not (areRelated e1 e2), -- no "see also" field+ dist (findTitle e1) (findTitle e2) <= 10 -- edit distance+ ]+ dupGroups = [(es,shared) | (es,shared) <- common,+ -- a sufficently long substring is shared+ maximum (map length shared) >= threshold (minimum (map (length . project . findTitle) es))]+ threshold x = (9 * x) `div` 10+ -- SC.printTree $ SC.select ("", clusterTree)+ common = M.toList $ SC.commonStrings info+ -- clusterTree = SC.construct info+ info = [(project $ findTitle e,[e]) | e <- bib]+ bib = nub bib'+ ------------------------------------------------------------------------- -- Auto-renaming of attachments rename :: (String -> String) -> (String,String) -> MaybeIO (String,String) -rename new (oldfname,typ) +rename new (oldfname,typ) | oldfname == newfname = bail | otherwise = do oex <- doesFileExist oldfname@@ -65,87 +62,119 @@ (False,_) -> putString ("old does not exist: " ++ oldfname) >> bail (_,True) -> putString ("new already exists: " ++ newfname) >> bail -- (_,True) -> do removeFile oldfname >> return (newfname,typ)- where newfname = new typ bail = return (oldfname,typ) -renamer :: Entry -> MaybeIO Entry-renamer t@Entry{..} = do - files <- traverse (rename (findAttachName t)) files+renamer :: InitFile -> Entry -> MaybeIO Entry+renamer cfg t@Entry{..} = do+ files <- traverse (rename (findAttachName cfg t)) files return $ Entry{..} -renameAttachments bib = do - bib' <- traverse renamer bib- saveBib bib'+renameAttachments :: InitFile -> [Entry] -> MaybeIO ()+renameAttachments cfg bib = do + bib' <- traverse (renamer cfg) bib+ saveBib cfg bib' ------------------------------------------------------------------------ -- Check for orphans check :: (String,String) -> MaybeIO () -check (fname,typ) = do+check (fname,_typ) = do ex <- doesFileExist fname if (not ex) then putString $ "missing: " ++ fname else return () +checker :: Entry -> MaybeIO () checker Entry{..} = mapM_ check files +getDirectoryContents' :: FilePath -> MaybeIO [FilePath] getDirectoryContents' d = map (d </>) <$> getDirectoryContents d -checkAttachments bib = do- fnames <- getDirectoryContents' "/home/bernardy/Papers"- let attachments = [ f | e <- bib, (f,t) <- files e] - +checkAttachments :: InitFile -> [Entry] -> MaybeIO ()+checkAttachments cfg bib = do+ fnames <- getDirectoryContents' (attachmentsRoot cfg)+ let attachments = [ f | e <- bib, (f,_t) <- files e] + mapM_ putString (fnames \\ attachments) ---------------------------------------------------------------------- -- Merge another bibtex file -mergeIn bib fname = do- bib2 <- uncheckedHarmless $ rightOrDie <$> loadBibliographyFrom fname- checkDup $ bib2 ++ bib+cleanImported :: Entry -> Entry+cleanImported Entry {..} = Entry {files=[],..}++mergeIn :: InitFile -> [Entry] -> String -> MaybeIO ()+mergeIn cfg bib fname = do+ bib2 <- uncheckedHarmless (rightOrDie =<< loadBibliographyFrom fname)+ + saveBib cfg $ map cleanImported bib2 ++ bib return () {--mergeBibs bib1 bib2 = +mergeBibs bib1 bib2 = where bibM1 = M.fromList [(project $ findTitle e, e) | e <- bib1]--} +-} ----------------------------------------------------------------------- -- Harvest Downloads -harvest bib = do- contents <- getDirectoryContents' downloadsDirectory+harvest :: InitFile -> [Entry] -> MaybeIO ()+harvest cfg bib = do+ contents <- getDirectoryContents' (downloadsDirectory cfg) let oldFiles = concatMap (map snd . files) bib- newFiles = contents \\ oldFiles - papers = [Entry {kind = "download", + newFiles = contents \\ oldFiles+ papers = [Entry {kind = "download", seeAlso = [], authors = [],- files = [(fname,guessType fname BS.empty)],+ files = [(fname,guessTypeByName fname)], otherFields = [("title",fname),("date","2010")] } | fname <- newFiles, takeExtension fname `elem` [".pdf",".ps"]]- saveBib $ papers ++ bib+ saveBib cfg $ papers ++ bib + ------------------------------------------------------------------------ -- Driver -saveBib b = safely "Saving bibfile" $ saveBibliography b+sortBib :: InitFile -> [Entry] -> MaybeIO ()+sortBib cfg b = saveBib cfg (sortBy (compare `on` \x -> (findFirstAuthor x,findYear x,findTitle x)) b) +saveBib :: InitFile -> [Entry] -> MaybeIO ()+saveBib cfg b = safely "Saving bibfile" $ saveBibliography cfg b -go (command: ~(arg1:_)) = do - bib <- uncheckedHarmless $ (rightOrDie <$> loadBibliography)- case command of- "check" -> checkAttachments bib- "rename" -> renameAttachments bib- "merge" -> mergeIn bib arg1- "harvest" -> harvest bib- "dup" -> checkDup bib+withInfo :: Parser a -> String -> ParserInfo a+withInfo opts desc = info (helper <*> opts) $ progDesc desc +parseCommand :: InitFile -> [Entry] -> Parser (MaybeIO ())+parseCommand cfg bib = subparser $+ command "check" ((pure (checkAttachments cfg bib) `withInfo` "check that attachment exist")) <>+ command "rename" ((pure (renameAttachments cfg bib) `withInfo` "rename/move atachments to where they belong")) <>+ command "import" ((mergeIn cfg bib <$> (argument str (metavar "FILE")) `withInfo` "merge a bibfile into the database")) <>+ command "harvest" ((pure (harvest cfg bib) `withInfo` "harvest attachments (???)")) <>+ command "dup" ((pure (checkDup cfg bib) `withInfo` "check for duplicates")) <>+ command "cleanup" ((pure (saveBib cfg bib) `withInfo` "cleanup keys etc.")) <>+ command "sort" ((pure (sortBib cfg bib) `withInfo` "sort entries by key"))++main :: IO ()+main = do+ cfg <- loadConfiguration+ bib <- rightOrDie =<< loadBibliography cfg+ let options :: ParserInfo (Bool, MaybeIO ())+ options =+ (((,) <$> + switch (short 'd' <> long "dry-run" <> help "don't perform any change (dry run)") <*>+ parseCommand cfg bib+ ) `withInfo` "batch handling of bib db")+ (dry,cmd) <- execParser options+ run dry cmd++dryRun :: MaybeIO a -> IO a dryRun = run True++trueRun :: MaybeIO a -> IO a trueRun = run False -main = do - args <- getArgs- case args of- ("dry":args) -> dryRun $ go args- _ -> trueRun $ go args++-- Local Variables:+-- dante-target: "imbibatch"+-- End:
− BibAttach.hs
@@ -1,50 +0,0 @@-module BibAttach where--import Control.Applicative hiding ((<|>),many)-import Control.Monad-import Control.Monad.Trans-import qualified Data.ByteString.Lazy as BS-import Data.Char-import Data.List-import Data.List.Split-import Data.Maybe-import Data.Tree-import System.Directory-import System.FilePath-import System.Process-import Data.Function-import System.FilePath--import TypedBibData-import Config------------------------------------------- Attachment manipulation--sanitize = filter (\c -> c`notElem` ";:{}/\\" && ord c < 128) --- there seems to be a problem with big chars in filenames at the moment.--- see http://hackage.haskell.org/trac/ghc/ticket/3307---- save a (binary) file, safely-saveFile name contents = do- putStrLn $ "Creating directory for " ++ name- createDirectoryIfMissing True (dropFileName name)- putStrLn $ "Writing..."- BS.writeFile name contents- return name--findAttachName entry ext = attachmentsRoot </> (sanitize $ findTitle entry ++ "-" ++ findYear entry ++ "." ++ ext)---guessType :: FilePath -> BS.ByteString -> String-guessType fname contents - | BS.head contents == ord' '@' = "bib"- | magic == pdfMagic = "pdf"- | magic == psMagic = "ps"- | otherwise = drop 1 $ takeExtension fname- where magic = BS.take 4 contents- - pdfMagic = BS.pack $ map ord' "%PDF"- psMagic = BS.pack $ map ord' "%!PS"- ord' = fromIntegral . ord -
− BibDB.hs
@@ -1,41 +0,0 @@-module BibDB where---import Control.Applicative hiding ((<|>),many)-import Control.Monad-import Control.Monad.Trans-import qualified Data.ByteString -import Data.Char-import Data.List-import Data.List.Split-import Data.Maybe-import Data.Tree-import System.Directory-import System.FilePath-import Data.Function--import Text.ParserCombinators.Parsec (parseFromFile)-import TypedBibData-import Config----------------- DB---loadBibliography = loadBibliographyFrom bibfile--loadBibliographyFrom fileName = do- mBib <- fmap bibToForest <$> parseFromFile parseBib fileName - case mBib of- Left err -> return (Left err)- Right bib -> do putStrLn $ show (length $ bib) ++ " entries loaded." -- force it right here- return (Right bib)--formatBib = concatMap formatEntry . map treeToEntry--saveBibliography :: [TypedBibData.Entry] -> IO ()-saveBibliography bib = do- writeFile bibfile (formatBib bib)- putStrLn $ show (length bib) ++ " entries saved to " ++ bibfile--
− BibFile.hs
@@ -1,39 +0,0 @@-module BibFile where--import Control.Applicative hiding ((<|>),many)-import Control.Monad-import Control.Monad.Trans-import qualified Data.ByteString -import Data.Char-import Data.List-import Data.List.Split-import Data.Maybe-import Data.Tree-import System.Directory-import System.FilePath-import Data.Function--import Text.ParserCombinators.Parsec (parseFromFile)-import BibData-------------------------------------------- Bib file manipulation--bibfile = "/home/bernardy/project/gitroot/bibtex/jp.bib"--loadBibliography = loadBibliographyFrom bibfile--loadBibliographyFrom fname = do- mBib <- fmap bibToForest <$> parseFromFile parseBib bibfile - case mBib of- Left err -> do print "Failed to load library"- print err- return []- Right bib -> do putStrLn $ show (length $ bib) ++ " entries loaded." -- force it right here- -- print $ last bib -- really force closing the file... ?- return bib--saveBibliography bib = do- writeFile bibfile (concatMap formatEntry $ map treeToEntry bib)- putStrLn $ show (length bib) ++ " entries saved to " ++ bibfile
− Config.hs
@@ -1,38 +0,0 @@-module Config where- -import Paths_imbib-import System.IO.Unsafe-import System.FilePath-import System.Process-import System.Directory-import Data.ConfigFile-import Control.Applicative--rightOrDie (Left err) = error (show err)-rightOrDie (Right x) = x--startConfig = rightOrDie $ - set (emptyCP {accessfunc = interpolatingAccess 10}) "DEFAULT" "home" homeDirectory--configFileName = ".imbib"--configuration = unsafePerformIO $ do- c0f <- getDataFileName configFileName - c0 <- rightOrDie <$> readfile startConfig c0f- let user = homeDirectory </> configFileName- ex <- doesFileExist user- if ex then rightOrDie <$> readfile c0 user else return c0- -getOption = rightOrDie . get configuration "DEFAULT"--downloadsDirectory = getOption "watched"-attachmentsRoot = getOption "archive"-bibfile = getOption "library"-runEditor lineNumber file = runProcess' (getOption "editor") ['+':show lineNumber,file]-runViewer file = runProcess' (getOption "viewer") [file] ---- The following should probably not change-homeDirectory = unsafePerformIO $ getHomeDirectory-iconFile = unsafePerformIO $ getDataFileName "icon.svg"--runProcess' = \bin args -> runProcess bin args Nothing Nothing Nothing Nothing Nothing
+ Diff.hs view
@@ -0,0 +1,62 @@+module Diff where++-- A diff algorithm adapted from a edit-distance algorithm.++import Data.List+import Data.Function+data Source = L | R | B+ deriving (Show, Eq)++type Choice a = (Source, a)++type Diff a = [Choice a]++weight0 :: Num t => Source -> t+weight0 B = 0+weight0 _ = 1++weight :: [(Source, b)] -> Int+weight = sum . map (weight0 . fst)++diff' :: Eq a => [a] -> [a] -> Diff a+diff' = diff (==) (const)++diff :: (a -> a -> Bool) -- ^ compare two values+ -> (a -> a -> a) -- ^ merge two values in the same equivalent class+ -> [a] -> [a] -> Diff a+diff (=?=) (=+=) a b = + tail $ reverse $ + last (if lab == 0 then mainDiag+ else if lab > 0 then lowers !! (lab - 1)+ else{- < 0 -} uppers !! (-1 - lab))+ where mainDiag = oneDiag L R (error "diff: head element should not be forced") a b (head uppers) ([] : head lowers)+ uppers = eachDiag L R a b (mainDiag : uppers) -- upper diagonals+ lowers = eachDiag R L b a (mainDiag : lowers) -- lower diagonals+ eachDiag centerSrc edgeSrc a [] diags = []+ eachDiag centerSrc edgeSrc a (bch0:bs) (lastDiag:diags) = oneDiag centerSrc edgeSrc bch0 a bs nextDiag lastDiag + : eachDiag centerSrc edgeSrc a bs diags+ where nextDiag = head (tail diags)+ oneDiag centerSrc edgeSrc f a b diagAbove diagBelow = thisdiag+ where doDiag [] b nw n w = []+ doDiag a [] nw n w = []+ doDiag (ach:as) (bch:bs) nw n w = me : (doDiag as bs me (tail n) (tail w))+ where me = if ach =?= bch then (B,ach =+= bch) : nw+ else minBy weight ((edgeSrc,bch) : head w) ((centerSrc,ach) : head n)+ firstelt = (edgeSrc,f) : head diagBelow+ thisdiag = firstelt : doDiag a b firstelt diagAbove (tail diagBelow)+ lab = length a - length b++minBy :: Ord a => (t -> a) -> t -> t -> t+minBy f x y = if (f x) < (f y) then x else y++simplify :: Diff a -> Diff [a]+simplify = map simplOne . groupBy ((==) `on` fst)+ where simplOne l@((src,_):_) = (src,map snd l)++diffS :: Eq a => [a] -> [a] -> Diff a+diffS = diff (==) (const)++-- >>> simplify (diffS "test me" "tes me")+-- [(B,"tes"),(L,"t"),(B," me")]++
− Imbibed.hs
@@ -1,296 +0,0 @@-{-# LANGUAGE RecordWildCards, TupleSections #-}--{---TODO:-if URI is bib, use as such-Search google on title-merge other bibtex(s); duplicate detection--}--import Control.Applicative hiding ((<|>),many)-import Control.Monad-import Control.Monad.Trans-import qualified Data.ByteString -import qualified Data.ByteString.Lazy.UTF8 as UTF8 (toString)-import Data.Char-import Data.List-import Data.Maybe-import Graphics.UI.Gtk hiding (on, Entry)-import qualified Graphics.UI.Gtk as Gtk -import Graphics.UI.Gtk.ModelView as New-import Graphics.UI.Gtk.ModelView.ListStore-import Network.Curl.Download.Lazy-import Network.Curl.Opts-import System.Directory-import System.FilePath-import Text.BibTeX.Entry as Entry-import Text.BibTeX.Parse-import Data.Function-import System.Gnome.VFS.Monitor-import qualified System.Gnome.VFS.Init as VFS-import System.Glib.GError-import Text.ParserCombinators.Parsec (parse, parseFromFile)--import TypedBibData-import BibDB-import BibAttach-import Config---{--import Text.ParserCombinators.Parsec as Parsec hiding ...--instance Alternative (GenParser Char ()) where- (<|>) = (Parsec.<|>)- ...--}--------------------------- GUI--main = do- bib <- rightOrDie <$> loadBibliography- - VFS.init- initGUI-- win <- windowNew-- model <- listStoreNewDND bib - (Just (DragSourceIface draggable dataGet dataDelete)) - (Just (DragDestIface possible recieved))-- onDestroy win $ do- saveStore model - VFS.shutdown- mainQuit-- monitorAdd ("file://" ++ bibfile) (toEnum 0) $ \handle monitored changed evType -> do- -- ugh: toEnum 0 == MonitorFile- putStrLn $ "Bibfile changed; reloading " ++ show evType- mBib <- loadBibliography- case mBib of- Left err -> putStr $ show err- Right bib -> do oldBib <- listStoreToList model- when (bib /= oldBib) $ do- listStoreClear model- forM_ bib (listStoreAppend model)-- searchBox <- entryNew-- filt <- treeModelFilterNew model []- treeModelFilterSetVisibleFunc filt $ Just $ \iter -> do- needle <- get searchBox entryText- let idx = listStoreIterToIndex iter- e <- listStoreGetValue model idx- return $ e `matchSearch` needle-- - onEditableChanged searchBox $ treeModelFilterRefilter filt-- view <- New.treeViewNewWithModel filt-- New.treeViewSetHeadersVisible view True-- -- columns- [col0,col1,col2] <- forM ["⎙","Cit","Title"] $ \h -> do - c <- New.treeViewColumnNew- New.treeViewColumnSetTitle c h- return c- - treeViewColumnSetResizable col1 True- treeViewColumnSetResizable col2 True-- [renderer0,renderer1,renderer2] <- forM [0..2] $ \_ -> New.cellRendererTextNew-- New.cellLayoutPackStart col0 renderer0 True- New.cellLayoutPackStart col1 renderer1 True- New.cellLayoutPackStart col2 renderer2 True-- Gtk.set col1 [treeViewColumnMinWidth := 180]-- forM [renderer1,renderer2] $ \r -> set r [ cellTextEllipsizeSet := True , cellTextEllipsize := EllipsizeEnd ]-- New.cellLayoutSetAttributes col0 renderer0 model $ \row -> [ New.cellText := if null $ findFullText row then "" else "✓"]- New.cellLayoutSetAttributes col1 renderer1 model $ \row -> [ New.cellText := findCite row ]- New.cellLayoutSetAttributes col2 renderer2 model $ \row -> [ New.cellText := renderTex $ findTitle row ]-- {-- Gtk.on renderer2 edited $ \path@(i:_) newText -> do- (k,v) <- listStoreGetValue model path- listStoreSetValue model path (k,newText)- -}-- New.treeViewAppendColumn view col0- New.treeViewAppendColumn view col1- New.treeViewAppendColumn view col2 - - -- enable interactive search- treeViewSetEnableSearch view True- treeViewSetSearchEqualFunc view $ Just $ \str iter -> do- p0 <- treeModelGetPath filt iter - [i] <- treeModelFilterConvertPathToChildPath filt p0- entry <- listStoreGetValue model i- return $ entry `matchSearch` str-- -- make the widget a drag source- tl <- targetListNew- targetListAddTextTargets tl 0- treeViewEnableModelDragSource view [Button1] tl [ActionCopy]-- -- make the widget a drag destination- tl <- targetListNew- targetListAddUriTargets tl 0- targetListAddTextTargets tl 1- treeViewEnableModelDragDest view tl [ActionCopy]-- -- See the discussion on the gtk2hs-users list: - -- Drag and drop support in filtered TreeView- -- (July 2010)- Gtk.on view dragDrop $ \ context point time -> do- putStrLn $ "dragDrop"- signalStopEmission view "drag_drop"- Just target <- dragDestFindTarget view context (Just tl)- -- print target- dragStatus context Nothing time - -- not so important as we do not need the data for motion: we never check this status.- dragGetData view context target time- return True-- Gtk.on view dragDataReceived $ \ context pt infoId time -> do- liftIO $ putStrLn $ "dragData"- liftIO $ signalStopEmission view "drag_data_received"- pt' <- liftIO $ treeViewConvertWidgetToBinWindowCoords view pt- mPath <- liftIO $ treeViewGetPathAtPos view pt'- done <- case mPath of- Nothing -> return False- Just (p0,_,_) -> do- p1 <- liftIO $ treeModelFilterConvertPathToChildPath filt p0- recieved model p1 -- normally we'd call "possible" upon motion; but it's always possible.- liftIO $ dragFinish context done False time-- let entryFromPath p0 = do- [i] <- treeModelFilterConvertPathToChildPath filt p0- listStoreGetValue model i--- -- Handle "return"- afterRowActivated view $ \path col -> do- openFullText =<< entryFromPath path- - -- Handle clicks- Gtk.on view buttonPressEvent $ do - b <- eventButton- c <- eventClick- (x,y) <- eventCoordinates - let pt = (round x, round y)- mPath <- liftIO $ treeViewGetPathAtPos view pt- case mPath of- Nothing -> return False- Just (p0,_,_) -> liftIO $ do- case (b,c) of- (LeftButton,DoubleClick) -> do- openFullText =<< entryFromPath p0- return True- (RightButton,DoubleClick) -> do- -- Open emacs at the adequate line to edit.- [i] <- treeModelFilterConvertPathToChildPath filt p0- saveStore model- before <- take i <$> listStoreToList model- let lineNumber = length $ lines $ formatBib before- runEditor lineNumber bibfile - return True- _ -> return False-- layout <- vBoxNew False 0- scr <- scrolledWindowNew Nothing Nothing - containerAdd scr view- boxPackStart layout searchBox PackNatural 0 - boxPackStart layout scr PackGrow 0- containerAdd win layout-- catchGError (windowSetIconFromFile win iconFile) $ \(GError dom code msg) -> do- putStrLn $ "Could not load icon file: " ++ msg- windowSetDefaultSize win 640 360- widgetShowAll win- mainGUI --openFullText :: Entry -> IO ()-openFullText t = do- let file = findFullText t- case file of - [] -> putStrLn "no pdf found!"- (f:_) -> do putStrLn $ "Opening " ++ f- runViewer f - return ()---draggable store [_] = return True-draggable store _ = return False--dataGet store [p] = do- t <- liftIO $ listStoreGetValue store p- let k = findNiceKey t- selectionDataSetText $ "\\cite{" ++ k ++ "}"--dataDelete _ _ = return True--receivedBib store text = do- putStrLn $ "Got bib: "- forM_ (lines text) putStrLn- let mBib = parse parseBib "dropped text" text- case mBib of- Left err -> print err >> return False- Right bib -> do print bib- mapM_ (listStorePrepend store) (bibToForest bib) - -- saveStore store- return True--recievedFile i store uri = do- putStrLn $ "Downloading " ++ uri- mFile <- openLazyURIWithOpts [CurlFollowLocation True] uri- case mFile of- Left err -> putStrLn err >> return False- Right file -> do - putStrLn "Success!"- let fileType = guessType uri file- if fileType == "bib" then receivedBib store (UTF8.toString file) else do- entry <- listStoreGetValue store i- putStrLn "Saving..."- fname <- saveFile (findAttachName entry fileType) file- putStrLn "Updating store"- storeModify store i (addFile (fname, fileType))- -- saveStore store- return True--recieved store path@(i:_) = do- liftIO $ putStrLn "recieved!"- mURI <- selectionDataGetURIs- case mURI :: Maybe [String] of- -- Accept URI as download to link to the library- -- Normally this stuff should be done in the background.- -- I don't care.- Just [uri] -> liftIO $ recievedFile i store uri- _ -> do- -- Accept drop of text as bibtex- mText <- selectionDataGetText- case mText :: Maybe String of- Just text -> liftIO $ receivedBib store text- _ -> return False--possible store path = do - liftIO $ putStrLn "Possible?"- return True -- accept all text & URI, a priori.------------------------------------------- Store--storeModify store i f = do- a <- listStoreGetValue store i- listStoreSetValue store i (f a)--saveStore store = do- putStrLn "Syncing on disk"- bib <- listStoreToList store- saveBibliography bib-
MaybeIO.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-} module MaybeIO ( MaybeIO, doesFileExist,@@ -11,8 +13,7 @@ import qualified System.Directory as R import Prelude hiding (putStrLn) import qualified Prelude as R-import Control.Monad (ap,liftM)-import Control.Applicative+import Control.Monad (ap,liftM,unless) data MaybeIO a where Return :: a -> MaybeIO a@@ -35,20 +36,26 @@ run' (a :>>= b) = do x <- run' a run' (b x) run' (Safe i) = i- run' (Harmful msg i) = if dry then R.putStrLn ('|':msg) else i+ run' (Harmful msg i) = R.putStrLn ('|':msg) >> (unless dry i) instance Monad MaybeIO where (>>=) = (:>>=)- return = Return + return = pure +uncheckedHarmless :: IO a -> MaybeIO a uncheckedHarmless = Safe++safely :: String -> IO () -> MaybeIO () safely = Harmful +doesFileExist :: FilePath -> MaybeIO Bool doesFileExist f = uncheckedHarmless $ R.doesFileExist f +putString :: String -> MaybeIO () putString = uncheckedHarmless . R.putStrLn +getDirectoryContents :: FilePath -> MaybeIO [FilePath] getDirectoryContents = uncheckedHarmless . R.getDirectoryContents renameFile :: String -> String -> MaybeIO ()@@ -56,7 +63,6 @@ safely ("RENAME: " ++ old ++ " TO " ++ new) (R.renameFile old new) - removeFile :: String -> MaybeIO () removeFile f = do safely ("DELETE: " ++ f) (R.removeFile f)
− SuffixTreeCluster.hs
@@ -1,301 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.SuffixTreeCluster--- Copyright : (c) Bryan O'Sullivan 2007, JP Bernardy 2010--- License : BSD-style--- Maintainer : nobody--- Stability : experimental--- Portability : portable------ A suffix tree cluster implementation.------ Since many function names (but not the type name) clash with--- "Prelude" names, this module is usually imported @qualified@, e.g.------ > import Data.SuffixTreeCluster (STree)--- > import qualified Data.SuffixTreeCluster as T------ This implementation constructs the suffix tree lazily, so subtrees--- are not created until they are traversed. ------ Estimates are given for performance. The value /k/ is a constant;--- /n/ is the length of a query string; and /t/ is the number of--- elements (nodes and leaves) in a suffix tree.--module SuffixTreeCluster- (- -- * Types- Alphabet- , Edge- , Prefix- , STree(..)-- -- * Construction- , construct-- -- * Querying- , elem- , findEdge- , findTree- , findPath-- -- * Other useful functions- , mkPrefix- , prefix- , suffixes- , select- , commonStrings-- -- * Debug- , printTree- ) where- -import Prelude hiding (elem, foldl, foldr)-import qualified Data.Map as M-import Control.Arrow (second)-import qualified Data.ByteString as SB-import qualified Data.ByteString.Lazy as LB-import qualified Data.List as L-import Data.Maybe (listToMaybe, mapMaybe, catMaybes)-import Data.Monoid hiding (Sum)--- import Text.Groom-import Data.Function (on)-import qualified Data.Tree as T---- | The length of a prefix list. This type is formulated to do cheap--- work eagerly (to avoid constructing a pile of deferred thunks),--- while deferring potentially expensive work (computing the length of--- a list).-data Length a = Exactly {-# UNPACK #-} !Int- | Sum {-# UNPACK #-} !Int [a]- deriving (Show)---- | The list of symbols that 'constructWith' can possibly see in its--- input.-type Alphabet a = [a]---- | The prefix string associated with an 'Edge'. Use 'mkPrefix' to--- create a value of this type, and 'prefix' to deconstruct one.-newtype Prefix a = Prefix ([a], Length a)--instance (Eq a) => Eq (Prefix a) where- a == b = prefix a == prefix b--instance (Ord a) => Ord (Prefix a) where- compare a b = compare (prefix a) (prefix b)--instance (Show a) => Show (Prefix a) where- show a = "mkPrefix " ++ show (prefix a)---- | An edge in the suffix tree.-type Edge a b = (Prefix a, STree a b)---- | /O(1)/. Construct a 'Prefix' value.-mkPrefix :: [a] -> Prefix a-mkPrefix xs = Prefix (xs, Sum 0 xs)--pmap :: (a -> b) -> Prefix a -> Prefix b-pmap f = mkPrefix . map f . prefix--instance Functor Prefix where- fmap = pmap---- | The suffix tree type. The implementation is exposed to ease the--- development of custom traversal functions. Note that @('Prefix' a,--- 'STree' a b)@ pairs are not stored in any order.-data STree a b = Node b [Edge a b]- deriving (Show)--smap :: (a -> b) -> STree a c -> STree b c-smap f (Node b es) = Node b (map (\(p, t) -> (fmap f p, smap f t)) es)--lmap :: (a -> b) -> STree c a -> STree c b-lmap f (Node b es) = Node (f b) (map (second (lmap f)) es)--instance Functor (STree a) where- fmap = lmap---- | /O(n)/. Obtain the list stored in a 'Prefix'.-prefix :: Prefix a -> [a]-prefix (Prefix (ys, Exactly n)) = take n ys-prefix (Prefix (ys, Sum n xs)) = tk n ys- where tk 0 ys = zipWith (const id) xs ys- tk n (y:ys) = y : tk (n-1) ys------ | Increments the length of a prefix.-inc :: Length a -> Length a-inc (Exactly n) = Exactly (n+1)-inc (Sum n xs) = Sum (n+1) xs---- | /O(n)/. Returns all non-empty suffixes of the argument, longest--- first. Behaves as follows:------ >suffixes xs == init (tails xs)-suffixes :: [a] -> [[a]]-suffixes (xs@(_:xs')) = (xs) : suffixes (xs')-suffixes _ = []--constr :: (Eq b, Monoid b, Ord a) => [(b,[[a]])] -> STree a b-constr is = Node label (suf xs)- where xs = filter (not . null . snd) $ map (second (filter (not . null))) is- label = (mconcat $ map fst is)--construct :: (Eq b, Monoid b, Ord a) => [([a],b)] -> STree a b-construct is = constr [(b,L.tails a) | (a,b) <- is]--suf :: (Eq b, Monoid b, Ord a) => [(b,[[a]])] -> [Edge a b]-suf ss = [(Prefix (a:sa, inc cpl), constr ssr)- | (a, n@((_,sa:_):_)) <- suffixMap ss,- let (cpl,ssr) = cst n]--regroup :: (Eq b) => [(b, a)] -> [(b, [a])]-regroup xs = [(b,map snd as) | as@((b,_):_) <- L.groupBy ((==) `on` fst) xs]---- --suffixMap :: (Eq b, Ord a) => [(b,[[a]])] -> [(a, [(b, [[a]])])]-suffixMap sss = map (second (regroup . reverse)) .- M.toList . L.foldl' step M.empty $ [(b,s) | (b,ss) <- sss, s <- ss]- where step m (b,x:xs) = M.alter (f (b,xs)) x m- step m _ = m- f x Nothing = Just [x]- f x (Just xs) = Just (x:xs)--cst :: (Monoid b, Eq b, Eq a) => [(b, [[a]])] -> (Length a, [(b, [[a]])])--cst bss | or [null s | (_,ss) <- bss, s <- ss] = (Exactly 0, bss)-cst ss0@((_,[s]):ss) | all ((== [s]) . snd) ss = (Sum 0 s, [(b, []) | (b,_) <- ss0])-cst awss@((_,(a:w):_):ss)- | null [c | (_,x) <- ss, (c:_) <- x, a /= c] - = let cpl' = inc cpl- in seq cpl' (cpl', rss)- | otherwise = (Exactly 0, awss)- where (cpl, rss) = cst $ map (second (map tail')) awss- tail' (_:t) = t -- so we see the pattern fail here instead of a generic tail.---suffix :: (Eq a) => [a] -> [a] -> Maybe [a]-suffix (p:ps) (x:xs) | p == x = suffix ps xs- | otherwise = Nothing-suffix _ xs = Just xs--{-# SPECIALISE elem :: [Char] -> STree Char b -> Bool #-}-{-# SPECIALISE elem :: [[Char]] -> STree [Char] b -> Bool #-}-{-# SPECIALISE elem :: [SB.ByteString] -> STree SB.ByteString b -> Bool #-}-{-# SPECIALISE elem :: [LB.ByteString] -> STree LB.ByteString b -> Bool #-}-{-# SPECIALISE elem :: (Eq a) => [[a]] -> STree [a] b -> Bool #-}---- | /O(n)/. Indicates whether the suffix tree contains the given--- sublist. Performance is linear in the length /n/ of the--- sublist.-elem :: (Eq a) => [a] -> STree a b -> Bool-elem [] _ = True-elem xs (Node mb es) = any pfx es- where pfx (e, t) = maybe False (`elem` t) (suffix (prefix e) xs)--lkup :: (Monoid b, Eq a) => [a] -> STree a b -> b-lkup [] (Node b es) = b-lkup xs (Node _ es) = mconcat $ map pfx es- where pfx (e, t) = maybe mempty (`lkup` t) (suffix (prefix e) xs)--{-# SPECIALISE findEdge :: [Char] -> STree Char b- -> Maybe (Edge Char b, Int) #-}-{-# SPECIALISE findEdge :: [String] -> STree String b- -> Maybe (Edge String b, Int) #-}-{-# SPECIALISE findEdge :: [SB.ByteString] -> STree SB.ByteString b- -> Maybe (Edge SB.ByteString b, Int) #-}-{-# SPECIALISE findEdge :: [ LB.ByteString] -> STree LB.ByteString b- -> Maybe (Edge LB.ByteString b, Int) #-}-{-# SPECIALISE findEdge :: (Eq a) => [[a]] -> STree [a] b- -> Maybe (Edge [a] b, Int) #-}---- | /O(n)/. Finds the given subsequence in the suffix tree. On--- failure, returns 'Nothing'. On success, returns the 'Edge' in the--- suffix tree at which the subsequence ends, along with the number of--- elements to drop from the prefix of the 'Edge' to get the \"real\"--- remaining prefix.------ Here is an example:------ >> find "ssip" (construct "mississippi")--- >Just ((mkPrefix "ppi",Leaf),1)------ This indicates that the edge @('mkPrefix' \"ppi\",'Leaf')@ matches,--- and that we must strip 1 character from the string @\"ppi\"@ to get--- the remaining prefix string @\"pi\"@.------ Performance is linear in the length /n/ of the query list.-findEdge :: (Eq a) => [a] -> STree a b -> Maybe (Edge a b, Int)-findEdge xs (Node mb es) = listToMaybe (mapMaybe pfx es)- where pfx e@(p, t) = let p' = prefix p- in suffix p' xs >>= \suf ->- case suf of- [] -> return (e, length (zipWith const xs p'))- s -> findEdge s t---- | /O(n)/. Finds the subtree rooted at the end of the given query--- sequence. On failure, returns 'Nothing'.------ Performance is linear in the length /n/ of the query list.-findTree :: (Eq a) => [a] -> STree a b -> Maybe (STree a b)-findTree s t = (snd . fst) `fmap` findEdge s t---- | /O(n)/. Returns the path from the 'Edge' in the suffix tree at--- which the given subsequence ends, up to the root of the tree. If--- the subsequence is not found, returns the empty list.------ Performance is linear in the length of the query list.-findPath :: (Eq a) => [a] -> STree a b -> [Edge a b]-findPath = go []- where go me xs (Node mb es) = pfx me es- where pfx _ [] = []- pfx me (e@(p, t):es) =- case suffix (prefix p) xs of- Nothing -> pfx me es- Just [] -> e:me- Just s -> go (e:me) s t----- select :: SC.STree a b -> Tree Int-selectPairs (p0,Node entries sub) = T.Node (p0,entries) $- [select (p0 ++ prefix p,n) | (p,n) <- sub, isRelevantNode n]--selectLen (T.Node (shared,entries) sub) = T.Node here (map selectLen sub)- where here | length shared < 7 = ([],mempty) - | otherwise = (shared,entries)---selectLongest (T.Node (shared,entries) sub) = T.Node here (map selectLongest sub)- where here | subsumed = ([],[]) - | otherwise = (shared,entries)- subsumed = all (`L.elem` (concatMap (snd . T.rootLabel) sub)) entries - --select :: Eq b => ([a],STree a [b]) -> T.Tree ([a],[b])-select = selectLongest . selectLen . selectPairs--buildMap :: (Eq a, Ord b) => T.Tree ([a],[b]) -> M.Map [b] [[a]]-buildMap t = L.foldl' step M.empty $ filter (not . null . snd) $ T.flatten t- where step m (x,bs) = M.alter (lub x) bs m--commonStrings :: (Eq b, Ord a, Ord b) => [([a],[b])] -> M.Map [b] [[a]]-commonStrings xs = buildMap $ select ([],construct xs)--lub y Nothing = Just [y]-lub y (Just xs)- | (y `L.isSuffixOf`) `any` xs = Just xs- | otherwise = Just (y : filter (not . (`L.isSuffixOf` y)) xs)--printTree :: Show a => T.Tree a -> IO ()-printTree = putStrLn . T.drawTree . fmap show--isRelevant [] = False-isRelevant [_] = False-isRelevant _ = True--isRelevantNode (Node e _) = isRelevant e--emptyPrefix :: Prefix a-emptyPrefix = mkPrefix []
− TypedBibData.hs
@@ -1,155 +0,0 @@-{-# LANGUAGE RecordWildCards, TupleSections #-}--module TypedBibData where--import Control.Applicative hiding ((<|>),many)-import Control.Monad-import Control.Monad.Trans-import Data.Char-import Data.List-import Data.List.Split-import Data.Maybe-import Data.Tree-import Text.BibTeX.Entry as Entry-import Text.BibTeX.Parse-import Data.Function-import Text.ParserCombinators.Parsec as Parsec------------------------------------------- Bib Data manipulation--data Entry = Entry {- kind :: String,- authors :: [(String,String)],- files :: [(String,String)], -- ^ name, type- seeAlso :: [(String,String)],- otherFields :: [(String,String)]- } deriving (Show, Eq, Ord)---renderTex = filter (`notElem` "{}")--sanitizeIdent = filter (\c -> (c >= 'a' && c <= 'z') || isDigit c || c `elem` ".-_?+") . - map ((\c -> if isSpace c then '_' else c) . toLower)---parseBib = skippingSpace $ skippingLeadingSpace Text.BibTeX.Parse.file--pAuth :: Parser (String, String)-pAuth = do- many Parsec.space- p1 <- pAuthNamePart `Parsec.sepBy` (many Parsec.space)- do Parsec.char ','- many Parsec.space- first <- pAuthName- return (first, intercalate " " p1)- <|> let (first,[last]) = splitAt (length p1 - 1) p1 in- return (intercalate " " first, last)- -pAuthName = concat <$> many (pAuthBlock True)-pAuthNamePart = concat <$> many1 (pAuthBlock False)--pAuthBlock :: Bool -> Parser String-pAuthBlock spaceOk =- liftM3 (\open body close -> open : body ++ close : [])- (Parsec.char '{') pAuthName (Parsec.char '}') <|>- sequence- [Parsec.char '\\',- Parsec.oneOf "{}'`^&%\".,~# " <|> Parsec.letter] <|>- fmap (:[]) (Parsec.noneOf $ [' ' | not spaceOk] ++ "},")----- When searching ignore special characters-project = map toLower . filter isAlphaNum---- | Does a node contain a string (for search)-contains :: Entry -> String -> Bool-contains t needle = or [needle `isInfixOf` project txt | txt <- findTitle t : map snd (authors t)]--matchSearch entry pattern = all (contains entry) (map project $ words pattern) --findCiteAuth :: Entry -> String-findCiteAuth Entry {..} = renderTex $ case map snd authors of- [] -> "????"- [a] -> a- [a,b] -> a ++ " and " ++ b- [a,b,c] -> a ++ ", " ++ b ++ " and " ++ c- (a:_) -> a ++ " et al."--findYear :: Entry -> String-findYear = findField "year" --findTitle :: Entry -> String-findTitle = findField "title"--findField :: String -> Entry -> String-findField f t = findField' f t ?? "????"--findField' f Entry {..} = map snd (filter ((== f) . fst) otherFields)--findFirstAuthor :: Entry -> String-findFirstAuthor Entry{..} = map snd authors ?? "????"--findCite t = findCiteAuth t ++ " " ++ findYear t-findNiceKey t = findField' "forcedkey" t ?? - (intercalate "_" $ map sanitizeIdent $ [findFirstAuthor t, title, findYear t])- where title = ((filter ((> 1) . length) . map sanitizeIdent . words . findTitle $ t) - \\ ["for","le","an","to","be","on","make","the","how","why","its","from","towards"])- ?? "????"--findFullText Entry {..} = map fst . filter ((`elem` ["pdf","ps"]) . snd) $ files--addFile f (Entry {..})= Entry {files = f:files,..}--partitions :: [a -> Bool] -> [a] -> [[a]]-partitions [] l = [l]-partitions (x:xs) l = yes : partitions xs no- where (yes,no) = partition x l--entryToTree :: Entry.T -> Entry-entryToTree Entry.Cons{..} = Entry {..}- where- [auths,fils,seeAlsos,otherFields] = partitions (map (\k -> (k ==) . fst) ["author","file","see"]) fields- kind = entryType- authors = [authorToTree a | (_,as) <- auths, a <- splitOn " and " as]- ident = identifier- files = [fileToTree f | (_,fs) <- fils, f <- splitOn ";" fs]- seeAlso = [seeAlsoToTree r | (_,rs) <- seeAlsos, not $ null rs, r <- splitOn ";" rs ]--treeToEntry :: Entry -> Entry.T-treeToEntry t@Entry {..} = Entry.Cons{..}- where fields = ("author", intercalate " and " [first ++ " " ++ last | (first,last) <- authors]) :- [("file",intercalate ";" [":" ++ f ++ ":" ++ t | (f,t) <- files]) | not $ null files] ++- otherFields ++- [("see",intercalate ";" [how ++ ":" ++ what | (how,what) <- seeAlso]) | not $ null seeAlso]- entryType = kind- identifier = findNiceKey t --fileToTree (':':fs) = (f, t) - where (f,':':t) = break (== ':') fs--authorToTree :: String -> (String,String)-authorToTree s = case parse pAuth ("in " ++ s) s of- Left err -> error $ show err- Right r -> r--seeAlsoToTree r = (how,what)- where (how,':':what) = break (== ':') r--l ?? b = head $ l ++ [b]--bibToForest = map entryToTree --formatEntry :: Entry.T -> String-formatEntry (Entry.Cons entryType bibId items) =- let formatItem (name, value) =- "\t"++name++" = {"++value++"}"- in "@" ++ entryType ++ "{" ++ bibId ++ ",\n" ++- intercalate ",\n" (map formatItem items) ++- "\n},\n\n"---e1 `isSeeAlso` e2 = findNiceKey e1 `elem` (map snd (seeAlso e2))--areRelated e1 e2 = e1 == e2 || e1 `isSeeAlso` e2 || e2 `isSeeAlso` e1
imbib.cabal view
@@ -1,61 +1,99 @@ name: imbib-version: 1.0.0+version: 1.2.5 category: Text-synopsis: Minimalistic reference manager.-description: - The tool to facilitates the workflow: webbrowser -> bibtex file -> directory of .pdfs. The design is minimalistic (eg. no editor is included; emacs can be fired up by double right-clicking an entry).+synopsis: Minimalistic .bib reference manager.+description: The package has three parts:+ .+ 1. A very minimial gui [currently not buildable], featuring:+ .+ - Drop of bibtex snippets to add a reference to your bibtex.+ - Drop of pdf to save a fulltext version and a link in the bibtex.+ - Double click on entry to open fulltex.+ - Double right-click to open the entry in editor.+ - Search box (author/title).+ .+ A simplistic configuration file is given in ~/.imbib; an example file+ is bundled with the package.+ .+ 2. A library to manipulate bib files and do related management tasks.+ .+ The package contains some helper functions to manipultate .bib files+ en masse. For example one function can help detecting duplicates in+ the bibtex file.+ .+ 3. A batch processor for bib files.+ .+ A simplistic CLI for the above library.+ license: GPL license-file: LICENSE author: Jean-Philippe Bernardy maintainer: jeanphilippe.bernardy@gmail.com-Cabal-Version: >= 1.8-tested-with: GHC==6.12.2+Cabal-Version: >= 1.10+tested-with: GHC==6.12.3 build-type: Simple data-files: icon.svg .imbib -executable imbib- main-is: Imbibed.hs- extensions: TypeSynonymInstances, RecordWildCards, FlexibleInstances- build-depends: base==4.*- build-depends: mtl==1.1.*- build-depends: parsec==2.1.*- build-depends: process==1.0.*- build-depends: filepath==1.1.*- build-depends: directory==1.0.*- build-depends: containers==0.*- build-depends: bibtex==0.*- build-depends: split==0.*- build-depends: gtk==0.11.*- build-depends: glib==0.11.*- build-depends: download-curl==0.*- build-depends: curl==1.3.*- build-depends: bytestring==0.*- build-depends: gnomevfs==0.11.*- build-depends: utf8-string==0.3.*- build-depends: ConfigFile==1.0.*- - other-modules: - BibDB Config MaybeIO TypedBibData BibAttach BibFile SuffixTreeCluster+library+ default-language: Haskell2010+ hs-source-dirs: lib+ default-extensions: TypeSynonymInstances, RecordWildCards, FlexibleInstances+ exposed-modules:+ Config+ TypedBibData+ BibDB+ BibAttach+ SuffixTreeCluster+ other-modules:+ Paths_imbib+ build-depends: base>=4&& < 666+ build-depends: bibtex>=0.1&& < 666+ build-depends: mtl>=2.1&& < 666+ build-depends: ConfigFile>=1&& < 666+ build-depends: directory>=1.2&& < 666+ build-depends: process>=1.1&& < 666+ build-depends: filepath>=1.3&& < 666+ build-depends: parsek>0 && < 666+ build-depends: parsec>=3.1&& < 666+ build-depends: containers >= 0.4&& < 666+ build-depends: split>=0.1&& < 666+ build-depends: text>=0.11&& < 666+ build-depends: bytestring>=0.9&& < 666 +-- executable imbib+-- main-is: Imbibed.hs+-- extensions: TypeSynonymInstances, RecordWildCards, FlexibleInstances+-- build-depends: imbib+-- build-depends: mtl>=2.1+-- build-depends: base>=4+-- build-depends: gtk+-- build-depends: glib>=0.12+-- build-depends: download-curl+-- build-depends: curl>=1.3+-- build-depends: bytestring>=0.9+-- build-depends: gio>=0.12+-- build-depends: parsec>=3.1+-- build-depends: text>=0.11 && <1+-- -- build-depends: hinotify >=0.3 && <1 executable imbibatch+ default-language: Haskell2010 main-is: Batch.hs- extensions: TypeSynonymInstances, RecordWildCards, FlexibleInstances, RankNTypes, GADTs- build-depends: base==4.*- build-depends: mtl==1.1.*- build-depends: parsec==2.1.*- build-depends: process==1.0.*- build-depends: filepath==1.1.*- build-depends: directory==1.0.*- build-depends: containers==0.*- build-depends: bibtex==0.*- build-depends: split==0.*- build-depends: bytestring==0.*- build-depends: ConfigFile==1.0.*- + default-extensions: TypeSynonymInstances, RecordWildCards, FlexibleInstances, RankNTypes, GADTs+ build-depends: imbib+ build-depends: base>=4&& < 666+ build-depends: directory>=1.2&& < 666+ build-depends: containers >=0.4&& < 666+ build-depends: filepath>=1.3&& < 666+ build-depends: text>=0.11&& < 666+ build-depends: optparse-applicative>=0.15&& < 666+ build-depends: groom>0&& < 666 + other-modules:+ MaybeIO+ Diff
+ lib/BibAttach.hs view
@@ -0,0 +1,53 @@+module BibAttach where++import Control.Applicative hiding ((<|>),many)+import Control.Monad+import Control.Monad.Trans+import qualified Data.ByteString.Lazy as BS+import Data.Char+import Data.List+import Data.List.Split+import Data.Maybe+import Data.Tree+import System.Directory+import System.FilePath+import System.Process+import Data.Function+import System.FilePath++import TypedBibData+import Config++--------------------------------------+-- Attachment manipulation++sanitize = filter (\c -> c`notElem` ";:{}/\\" && ord c < 128) +-- there seems to be a problem with big chars in filenames at the moment.+-- see http://hackage.haskell.org/trac/ghc/ticket/3307++-- save a (binary) file, safely+saveFile name contents = do+ putStrLn $ "Creating directory for " ++ name+ createDirectoryIfMissing True (dropFileName name)+ putStrLn $ "Writing..."+ BS.writeFile name contents+ return name+++findAttachName cfg entry ext = attachmentsRoot cfg </> (sanitize $ findTitle entry ++ "-" ++ findYear entry ++ "." ++ ext)+++guessTypeByName fname = drop 1 $ takeExtension fname+++guessType :: FilePath -> BS.ByteString -> String+guessType fname contents + | BS.head contents == ord' '@' = "bib"+ | magic == pdfMagic = "pdf"+ | magic == psMagic = "ps"+ | otherwise = guessTypeByName fname+ where magic = BS.take 4 contents+ pdfMagic = BS.pack $ map ord' "%PDF"+ psMagic = BS.pack $ map ord' "%!PS"+ ord' = fromIntegral . ord +
+ lib/BibDB.hs view
@@ -0,0 +1,31 @@+module BibDB where++import Text.ParserCombinators.Parsec (parseFromFile)+import TypedBibData+import Config+import Control.Monad++------------+-- DB+++loadBibliography cfg = loadBibliographyFrom (bibfile cfg)++loadBibliographyFrom fileName = do+ putStrLn ("Loading " ++ fileName)+ mBib <- fmap bibToForest <$> parseFromFile parseBib fileName+ case join (either (Left . show) Right $ mBib) of+ Left err -> return (Left err)+ Right bib -> do putStrLn $ show (length $ bib) ++ " entries loaded."+ return (Right bib)++formatBib :: [Entry] -> [Char]+formatBib = concatMap formatEntry . map treeToEntry++saveBibliography :: InitFile -> [Entry] -> IO ()+saveBibliography cfg bib = do+ let formatted = formatBib bib+ writeFile (bibfile cfg) formatted + putStrLn $ show (length bib) ++ " entries saved to " ++ (bibfile cfg)++
+ lib/Config.hs view
@@ -0,0 +1,61 @@+module Config where++import System.FilePath+import System.Process+import System.Directory+import Data.ConfigFile++rightOrDie :: Show a => Either a p -> IO p+rightOrDie (Left err) = fail (show err)+rightOrDie (Right x) = return x+++configFileName :: [Char]+configFileName = ".imbib"++getConfiguration :: IO ConfigParser+getConfiguration = do+ homeDirectory <- getHomeDirectory+ let startConfig = rightOrDie $ set (emptyCP {accessfunc = interpolatingAccess 10}) "DEFAULT" "home" homeDirectory+ c0 <- rightOrDie =<< (flip readstring dflt <$> startConfig)+ let user = homeDirectory </> configFileName+ ex <- doesFileExist user+ if ex then rightOrDie =<< readfile c0 user else return c0++++data InitFile = InitFile+ {+ attachmentsRoot, downloadsDirectory, bibfile :: FilePath,+ runViewer :: String -> IO ProcessHandle,+ runEditor :: Int -> String -> IO ProcessHandle + }++dflt :: String+dflt = "\+ \watched = %(home)s/Downloads\n\+ \archive = %(home)s/Papers\n\+ \library = %(home)s/library.bib\n\+ \viewer = /usr/bin/evince\n\+ \editor = /usr/bin/emacs\n\+ \"++loadConfiguration :: IO InitFile+loadConfiguration = do+ cfg <- getConfiguration+ let getOption = get cfg "DEFAULT"+ rightOrDie $ do+ downloadsDirectory <- getOption "watched"+ attachmentsRoot <- getOption "archive"+ bibfile <- getOption "library"+ editor <- getOption "editor"+ viewer <- getOption "viewer"+ let runEditor lineNumber file = runProcess' editor ['+':show lineNumber,file]+ runViewer file = runProcess' viewer [file]+ return InitFile{..}++-- The following should probably not change+-- iconFile = unsafePerformIO $ getDataFileName "icon.svg"++runProcess' :: FilePath -> [String] -> IO ProcessHandle+runProcess' = \bin args -> runProcess bin args Nothing Nothing Nothing Nothing Nothing
+ lib/SuffixTreeCluster.hs view
@@ -0,0 +1,301 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.SuffixTreeCluster+-- Copyright : (c) Bryan O'Sullivan 2007, JP Bernardy 2010+-- License : BSD-style+-- Maintainer : nobody+-- Stability : experimental+-- Portability : portable+--+-- A suffix tree cluster implementation.+--+-- Since many function names (but not the type name) clash with+-- "Prelude" names, this module is usually imported @qualified@, e.g.+--+-- > import Data.SuffixTreeCluster (STree)+-- > import qualified Data.SuffixTreeCluster as T+--+-- This implementation constructs the suffix tree lazily, so subtrees+-- are not created until they are traversed. +--+-- Estimates are given for performance. The value /k/ is a constant;+-- /n/ is the length of a query string; and /t/ is the number of+-- elements (nodes and leaves) in a suffix tree.++module SuffixTreeCluster+ (+ -- * Types+ Alphabet+ , Edge+ , Prefix+ , STree(..)++ -- * Construction+ , construct++ -- * Querying+ , elem+ , findEdge+ , findTree+ , findPath++ -- * Other useful functions+ , mkPrefix+ , prefix+ , suffixes+ , select+ , commonStrings++ -- * Debug+ , printTree+ ) where+ +import Prelude hiding (elem, foldl, foldr)+import qualified Data.Map as M+import Control.Arrow (second)+import qualified Data.Text as SB+import qualified Data.Text.Lazy as LB+import qualified Data.List as L+import Data.Maybe (listToMaybe, mapMaybe, catMaybes)+import Data.Monoid hiding (Sum)+-- import Text.Groom+import Data.Function (on)+import qualified Data.Tree as T++-- | The length of a prefix list. This type is formulated to do cheap+-- work eagerly (to avoid constructing a pile of deferred thunks),+-- while deferring potentially expensive work (computing the length of+-- a list).+data Length a = Exactly {-# UNPACK #-} !Int+ | Sum {-# UNPACK #-} !Int [a]+ deriving (Show)++-- | The list of symbols that 'constructWith' can possibly see in its+-- input.+type Alphabet a = [a]++-- | The prefix string associated with an 'Edge'. Use 'mkPrefix' to+-- create a value of this type, and 'prefix' to deconstruct one.+newtype Prefix a = Prefix ([a], Length a)++instance (Eq a) => Eq (Prefix a) where+ a == b = prefix a == prefix b++instance (Ord a) => Ord (Prefix a) where+ compare a b = compare (prefix a) (prefix b)++instance (Show a) => Show (Prefix a) where+ show a = "mkPrefix " ++ show (prefix a)++-- | An edge in the suffix tree.+type Edge a b = (Prefix a, STree a b)++-- | /O(1)/. Construct a 'Prefix' value.+mkPrefix :: [a] -> Prefix a+mkPrefix xs = Prefix (xs, Sum 0 xs)++pmap :: (a -> b) -> Prefix a -> Prefix b+pmap f = mkPrefix . map f . prefix++instance Functor Prefix where+ fmap = pmap++-- | The suffix tree type. The implementation is exposed to ease the+-- development of custom traversal functions. Note that @('Prefix' a,+-- 'STree' a b)@ pairs are not stored in any order.+data STree a b = Node b [Edge a b]+ deriving (Show)++smap :: (a -> b) -> STree a c -> STree b c+smap f (Node b es) = Node b (map (\(p, t) -> (fmap f p, smap f t)) es)++lmap :: (a -> b) -> STree c a -> STree c b+lmap f (Node b es) = Node (f b) (map (second (lmap f)) es)++instance Functor (STree a) where+ fmap = lmap++-- | /O(n)/. Obtain the list stored in a 'Prefix'.+prefix :: Prefix a -> [a]+prefix (Prefix (ys, Exactly n)) = take n ys+prefix (Prefix (ys, Sum n xs)) = tk n ys+ where tk 0 ys = zipWith (const id) xs ys+ tk n (y:ys) = y : tk (n-1) ys++++-- | Increments the length of a prefix.+inc :: Length a -> Length a+inc (Exactly n) = Exactly (n+1)+inc (Sum n xs) = Sum (n+1) xs++-- | /O(n)/. Returns all non-empty suffixes of the argument, longest+-- first. Behaves as follows:+--+-- >suffixes xs == init (tails xs)+suffixes :: [a] -> [[a]]+suffixes (xs@(_:xs')) = (xs) : suffixes (xs')+suffixes _ = []++constr :: (Eq b, Monoid b, Ord a) => [(b,[[a]])] -> STree a b+constr is = Node label (suf xs)+ where xs = filter (not . null . snd) $ map (second (filter (not . null))) is+ label = (mconcat $ map fst is)++construct :: (Eq b, Monoid b, Ord a) => [([a],b)] -> STree a b+construct is = constr [(b,L.tails a) | (a,b) <- is]++suf :: (Eq b, Monoid b, Ord a) => [(b,[[a]])] -> [Edge a b]+suf ss = [(Prefix (a:sa, inc cpl), constr ssr)+ | (a, n@((_,sa:_):_)) <- suffixMap ss,+ let (cpl,ssr) = cst n]++regroup :: (Eq b) => [(b, a)] -> [(b, [a])]+regroup xs = [(b,map snd as) | as@((b,_):_) <- L.groupBy ((==) `on` fst) xs]++-- ++suffixMap :: (Eq b, Ord a) => [(b,[[a]])] -> [(a, [(b, [[a]])])]+suffixMap sss = map (second (regroup . reverse)) .+ M.toList . L.foldl' step M.empty $ [(b,s) | (b,ss) <- sss, s <- ss]+ where step m (b,x:xs) = M.alter (f (b,xs)) x m+ step m _ = m+ f x Nothing = Just [x]+ f x (Just xs) = Just (x:xs)++cst :: (Monoid b, Eq b, Eq a) => [(b, [[a]])] -> (Length a, [(b, [[a]])])++cst bss | or [null s | (_,ss) <- bss, s <- ss] = (Exactly 0, bss)+cst ss0@((_,[s]):ss) | all ((== [s]) . snd) ss = (Sum 0 s, [(b, []) | (b,_) <- ss0])+cst awss@((_,(a:w):_):ss)+ | null [c | (_,x) <- ss, (c:_) <- x, a /= c] + = let cpl' = inc cpl+ in seq cpl' (cpl', rss)+ | otherwise = (Exactly 0, awss)+ where (cpl, rss) = cst $ map (second (map tail')) awss+ tail' (_:t) = t -- so we see the pattern fail here instead of a generic tail.+++suffix :: (Eq a) => [a] -> [a] -> Maybe [a]+suffix (p:ps) (x:xs) | p == x = suffix ps xs+ | otherwise = Nothing+suffix _ xs = Just xs++{-# SPECIALISE elem :: [Char] -> STree Char b -> Bool #-}+{-# SPECIALISE elem :: [[Char]] -> STree [Char] b -> Bool #-}+{-# SPECIALISE elem :: [SB.Text] -> STree SB.Text b -> Bool #-}+{-# SPECIALISE elem :: [LB.Text] -> STree LB.Text b -> Bool #-}+{-# SPECIALISE elem :: (Eq a) => [[a]] -> STree [a] b -> Bool #-}++-- | /O(n)/. Indicates whether the suffix tree contains the given+-- sublist. Performance is linear in the length /n/ of the+-- sublist.+elem :: (Eq a) => [a] -> STree a b -> Bool+elem [] _ = True+elem xs (Node mb es) = any pfx es+ where pfx (e, t) = maybe False (`elem` t) (suffix (prefix e) xs)++lkup :: (Monoid b, Eq a) => [a] -> STree a b -> b+lkup [] (Node b es) = b+lkup xs (Node _ es) = mconcat $ map pfx es+ where pfx (e, t) = maybe mempty (`lkup` t) (suffix (prefix e) xs)++{-# SPECIALISE findEdge :: [Char] -> STree Char b+ -> Maybe (Edge Char b, Int) #-}+{-# SPECIALISE findEdge :: [String] -> STree String b+ -> Maybe (Edge String b, Int) #-}+{-# SPECIALISE findEdge :: [SB.Text] -> STree SB.Text b+ -> Maybe (Edge SB.Text b, Int) #-}+{-# SPECIALISE findEdge :: [ LB.Text] -> STree LB.Text b+ -> Maybe (Edge LB.Text b, Int) #-}+{-# SPECIALISE findEdge :: (Eq a) => [[a]] -> STree [a] b+ -> Maybe (Edge [a] b, Int) #-}++-- | /O(n)/. Finds the given subsequence in the suffix tree. On+-- failure, returns 'Nothing'. On success, returns the 'Edge' in the+-- suffix tree at which the subsequence ends, along with the number of+-- elements to drop from the prefix of the 'Edge' to get the \"real\"+-- remaining prefix.+--+-- Here is an example:+--+-- >> find "ssip" (construct "mississippi")+-- >Just ((mkPrefix "ppi",Leaf),1)+--+-- This indicates that the edge @('mkPrefix' \"ppi\",'Leaf')@ matches,+-- and that we must strip 1 character from the string @\"ppi\"@ to get+-- the remaining prefix string @\"pi\"@.+--+-- Performance is linear in the length /n/ of the query list.+findEdge :: (Eq a) => [a] -> STree a b -> Maybe (Edge a b, Int)+findEdge xs (Node mb es) = listToMaybe (mapMaybe pfx es)+ where pfx e@(p, t) = let p' = prefix p+ in suffix p' xs >>= \suf ->+ case suf of+ [] -> return (e, length (zipWith const xs p'))+ s -> findEdge s t++-- | /O(n)/. Finds the subtree rooted at the end of the given query+-- sequence. On failure, returns 'Nothing'.+--+-- Performance is linear in the length /n/ of the query list.+findTree :: (Eq a) => [a] -> STree a b -> Maybe (STree a b)+findTree s t = (snd . fst) `fmap` findEdge s t++-- | /O(n)/. Returns the path from the 'Edge' in the suffix tree at+-- which the given subsequence ends, up to the root of the tree. If+-- the subsequence is not found, returns the empty list.+--+-- Performance is linear in the length of the query list.+findPath :: (Eq a) => [a] -> STree a b -> [Edge a b]+findPath = go []+ where go me xs (Node mb es) = pfx me es+ where pfx _ [] = []+ pfx me (e@(p, t):es) =+ case suffix (prefix p) xs of+ Nothing -> pfx me es+ Just [] -> e:me+ Just s -> go (e:me) s t+++-- select :: SC.STree a b -> Tree Int+selectPairs (p0,Node entries sub) = T.Node (p0,entries) $+ [select (p0 ++ prefix p,n) | (p,n) <- sub, isRelevantNode n]++selectLen (T.Node (shared,entries) sub) = T.Node here (map selectLen sub)+ where here | length shared < 7 = ([],mempty) + | otherwise = (shared,entries)+++selectLongest (T.Node (shared,entries) sub) = T.Node here (map selectLongest sub)+ where here | subsumed = ([],[]) + | otherwise = (shared,entries)+ subsumed = all (`L.elem` (concatMap (snd . T.rootLabel) sub)) entries + ++select :: Eq b => ([a],STree a [b]) -> T.Tree ([a],[b])+select = selectLongest . selectLen . selectPairs++buildMap :: (Eq a, Ord b) => T.Tree ([a],[b]) -> M.Map [b] [[a]]+buildMap t = L.foldl' step M.empty $ filter (not . null . snd) $ T.flatten t+ where step m (x,bs) = M.alter (lub x) bs m++commonStrings :: (Eq b, Ord a, Ord b) => [([a],[b])] -> M.Map [b] [[a]]+commonStrings xs = buildMap $ select ([],construct xs)++lub y Nothing = Just [y]+lub y (Just xs)+ | (y `L.isSuffixOf`) `any` xs = Just xs+ | otherwise = Just (y : filter (not . (`L.isSuffixOf` y)) xs)++printTree :: Show a => T.Tree a -> IO ()+printTree = putStrLn . T.drawTree . fmap show++isRelevant [] = False+isRelevant [_] = False+isRelevant _ = True++isRelevantNode (Node e _) = isRelevant e++emptyPrefix :: Prefix a+emptyPrefix = mkPrefix []
+ lib/TypedBibData.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards, TupleSections #-}++module TypedBibData where++import Control.Applicative hiding ((<|>),many)+import Control.Monad+import Control.Monad.Trans+import Data.Char+import Data.List+import Data.List.Split+import Data.Maybe+import Data.Tree+import Text.BibTeX.Entry as Entry+import Text.BibTeX.Parse+import Data.Function+import Text.ParserCombinators.Parsek as Parsek+++-------------------------------------+-- Bib Data manipulation++data Entry = Entry {+ kind :: String,+ authors :: [(String,String)],+ files :: [(String,String)], -- ^ name, type+ seeAlso :: [(String,String)],+ otherFields :: [(String,String)]+ } deriving (Show, Eq, Ord)+++renderTex = filter (`notElem` "{}")++sanitizeIdent = filter (\c -> (c >= 'a' && c <= 'z') || isDigit c || c `elem` ".-_?+") . + map ((\c -> if isSpace c then '_' else c) . toLower)+++parseBib = skippingSpace $ skippingLeadingSpace Text.BibTeX.Parse.file++-- >>> test+-- Left [([("\"{\"",Just '\n')],"satisfy"),([("\"\\\\\"",Just '\n')],"satisfy"),([],"satisfy"),([("\"}\"",Just '\n')],"satisfy")]++test = parse (pAuthBlock True) longestResult+ "{students of the\nUtrecht University Generic Programming class}"+ -- "Ba, Jimmy"+++pAuthLastFirst = do+ lst <- pAuthName+ spaces+ _ <- string ","+ spaces+ frst <- pAuthName+ return (frst,lst)++pAuthFirstLast = do+ frst <- pAuthName+ _ <- some space+ lst <- pAuthNamePart+ return (frst,lst)++pAuthLastOnly = do+ lst <- pAuthNamePart+ return ("",lst)++pAuth :: Parser Char ([Char], [Char])+pAuth = pAuthFirstLast <|> pAuthLastFirst <|> pAuthLastOnly++pAuthors :: Parser Char [([Char], [Char])]+pAuthors = pAuth `Parsek.sepBy1` (some space >> string "and" >> some space)+ <|> return [("","UnknownAuthor")]+++pAuthName :: Parser Char [Char]+pAuthName = intercalate " " <$> (pAuthNamePart `sepBy1` some space)++pAuthNamePart :: Parser Char [Char]+pAuthNamePart =+ do n <- concat <$> some (pAuthBlock False)+ when (n == "and") (fail "and is not a name")+ return n++pAuthBlock :: Bool -> Parser Char String+pAuthBlock allowSpace =+ (\open body close -> open : body ++ close : []) <$> (Parsek.char '{') <*> (concat <$> many (pAuthBlock True)) <*> (Parsek.char '}') <|>+ sequence+ [Parsek.char '\\',+ Parsek.oneOf "{}'`^&%\".,~# " <|> Parsek.letter] <|>+ munch1 (not . (`elem` ((if allowSpace then "" else "\n\t " ) ++ "{},")))+++-- | When searching ignore special characters+project :: String -> String+project = map toLower . filter isAlphaNum++-- | Does a node contain a string (for search)+contains :: Entry -> String -> Bool+contains t needle = or [needle `isInfixOf` project txt | txt <- findTitle t : map snd (authors t)]++matchSearch :: Entry -> String -> Bool+matchSearch entry pattern = all (contains entry) (map project $ words pattern) ++findCiteAuth :: Entry -> String+findCiteAuth Entry {..} = renderTex $ case map snd authors of+ [] -> "????"+ [a] -> a+ [a,b] -> a ++ " and " ++ b+ [a,b,c] -> a ++ ", " ++ b ++ " and " ++ c+ (a:_) -> a ++ " et al."++findYear :: Entry -> String+findYear = findField "year" ++findTitle :: Entry -> String+findTitle = findField "title"++findField :: String -> Entry -> String+findField f t = findField' f t ?? "????"++eqField :: [Char] -> [Char] -> Bool+eqField = (==) `on` (map toLower)++findField' :: String -> Entry -> [String]+findField' f Entry {..} = map snd (filter ((eqField f) . fst) otherFields)++findFirstAuthor :: Entry -> String+findFirstAuthor Entry{..} = map snd authors ?? "UnknownAuthor"++findCite t = findCiteAuth t ++ " " ++ findYear t+findNiceKey t = findField' "forcedkey" t ?? + (intercalate "_" $ map sanitizeIdent $ [findFirstAuthor t, title, findYear t])+ where title = ((filter ((> 2) . length) . map sanitizeIdent . words . findTitle $ t) + \\ ["de","am","for","le","an","to","be","on","make","the","how","why","its","from","towards","does"])+ ?? "????"++findFullText Entry {..} = map fst . filter ((`elem` ["pdf","ps"]) . snd) $ files++addFile f (Entry {..})= Entry {files = f:files,..}++partitions :: [a -> Bool] -> [a] -> [[a]]+partitions [] l = [l]+partitions (x:xs) l = yes : partitions xs no+ where (yes,no) = partition x l++entryToTree :: Entry.T -> Either String Entry+entryToTree Entry.Cons{..} =+ do authors <- authorsToTree (concatMap snd auths)+ return Entry {..}+ where+ [auths,fils,seeAlsos,otherFields] = partitions (map (\k -> (eqField k) . fst) ["author","file","see"]) fields+ kind = entryType+ ident = identifier+ files = [fileToTree f | (_,fs) <- fils, f <- splitOn ";" fs]+ seeAlso = [seeAlsoToTree r | (_,rs) <- seeAlsos, not $ null rs, r <- splitOn ";" rs ]++treeToEntry :: Entry -> Entry.T+treeToEntry t@Entry {..} = Entry.Cons{..}+ where fields = ("author", intercalate " and " [first ++ " " ++ last | (first,last) <- authors]) :+ [("file",intercalate ";" [":" ++ f ++ ":" ++ t | (f,t) <- files]) | not $ null files] +++ otherFields +++ [("see",intercalate ";" [how ++ ":" ++ what | (how,what) <- seeAlso]) | not $ null seeAlso]+ entryType = kind+ identifier = findNiceKey t ++fileToTree :: [Char] -> ([Char], [Char])+fileToTree = \case+ (':':fs) -> (f, t)+ where (f,':':t) = break (== ':') fs+ other -> (error $ "fileToTree: unexpected: " ++ show (take 10 other))++authorsToTree :: String -> Either String [(String,String)]+authorsToTree s = case parse (pAuthors <* spaces) longestResultWithLeftover s of+ Right (r,[]) -> Right r+ _ -> Left ("parse error in authors name: " ++ s)++seeAlsoToTree r = (how,what)+ where (how,':':what) = break (== ':') r++l ?? b = head $ l ++ [b]++bibToForest :: [T] -> Either String [Entry]+bibToForest xs = mapM entryToTree xs++formatEntry :: Entry.T -> String+formatEntry (Entry.Cons entryType bibId items) =+ let formatItem (name, value) =+ "\t"++name++" = {"++value++"}"+ in "@" ++ entryType ++ "{" ++ bibId ++ ",\n" +++ intercalate ",\n" (map formatItem items) +++ "\n}\n\n"+++e1 `isSeeAlso` e2 = findNiceKey e1 `elem` (map snd (seeAlso e2))++areRelated e1 e2 = e1 `isSeeAlso` e2 || e2 `isSeeAlso` e1++