{-# LANGUAGE OverloadedStrings #-}
module Poseidon.BibFile (dummyBibEntry, readBibTeXFile, writeBibTeXFile, BibTeX, BibEntry(..)) where

import           Poseidon.Utils                     (PoseidonException (..),
                                                     showParsecErr)

import           Control.Exception                  (throwIO)
import           Control.Monad                      (forM_, liftM2, liftM3)
import           System.IO                          (IOMode (..), hPutStrLn,
                                                     withFile)
import           Text.Parsec                        (between, char, many, many1,
                                                     noneOf, oneOf, sepEndBy,
                                                     try, (<|>))
import           Text.Parsec.Char                   (alphaNum, digit, letter)
import           Text.Parsec.Language               (emptyDef)
import           Text.Parsec.String                 (Parser, parseFromFile)
import qualified Text.Parsec.Token                  as T
import           Text.ParserCombinators.Parsec.Char (CharParser)

data BibEntry = BibEntry
    { BibEntry -> String
bibEntryType   :: String
    , BibEntry -> String
bibEntryId     :: String
    , BibEntry -> [(String, String)]
bibEntryFields :: [(String, String)]
    }
    deriving (Int -> BibEntry -> ShowS
[BibEntry] -> ShowS
BibEntry -> String
(Int -> BibEntry -> ShowS)
-> (BibEntry -> String) -> ([BibEntry] -> ShowS) -> Show BibEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BibEntry -> ShowS
showsPrec :: Int -> BibEntry -> ShowS
$cshow :: BibEntry -> String
show :: BibEntry -> String
$cshowList :: [BibEntry] -> ShowS
showList :: [BibEntry] -> ShowS
Show)

instance Eq BibEntry where
    (BibEntry String
t1 String
i1 [(String, String)]
_) == :: BibEntry -> BibEntry -> Bool
== (BibEntry String
t2 String
i2 [(String, String)]
_) = (String
t1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
t2) Bool -> Bool -> Bool
&& (String
i1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
i2)

instance Ord BibEntry where
    (BibEntry String
_ String
i1 [(String, String)]
_) compare :: BibEntry -> BibEntry -> Ordering
`compare` (BibEntry String
_ String
i2 [(String, String)]
_) = String
i1 String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` String
i2

type BibTeX = [BibEntry]

dummyBibEntry :: BibEntry
dummyBibEntry :: BibEntry
dummyBibEntry = BibEntry
    { bibEntryType :: String
bibEntryType   = String
"article"
    , bibEntryId :: String
bibEntryId     = String
"exampleBibtexKey"
    , bibEntryFields :: [(String, String)]
bibEntryFields = [
       (String
"title", String
"Example Paper"),
       (String
"author", String
"Doe, John"),
       (String
"year", String
"2018"),
       (String
"journal", String
"Example Journal"),
       (String
"volume", String
"47"),
       (String
"issue", String
"10"),
       (String
"publisher", String
"The example society for example research"),
       (String
"doi",String
"10.XXXX/ExampleJournal.47.777"),
       (String
"url",String
"https://doi.org/10.XXXX/ExampleJournal.47.777")
      ]
    }

readBibTeXFile :: FilePath -> IO BibTeX
readBibTeXFile :: String -> IO [BibEntry]
readBibTeXFile String
bibPath = do
    Either ParseError [BibEntry]
res <- Parser [BibEntry] -> String -> IO (Either ParseError [BibEntry])
forall a. Parser a -> String -> IO (Either ParseError a)
parseFromFile Parser [BibEntry]
bibFileParser String
bibPath
    case Either ParseError [BibEntry]
res of
        Left ParseError
err   -> PoseidonException -> IO [BibEntry]
forall e a. Exception e => e -> IO a
throwIO (PoseidonException -> IO [BibEntry])
-> PoseidonException -> IO [BibEntry]
forall a b. (a -> b) -> a -> b
$ String -> String -> PoseidonException
PoseidonBibTeXException String
bibPath (String -> PoseidonException) -> String -> PoseidonException
forall a b. (a -> b) -> a -> b
$ ParseError -> String
showParsecErr ParseError
err
        Right [BibEntry]
res_ -> [BibEntry] -> IO [BibEntry]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [BibEntry]
res_

{-
Much of the code below was shamelessly copied from the existing Haskell package "bibtex"
by Henning Thielemann. The package seems to be dead, and I needed to make some changes. So I
copied the relevant code here and modified it as needed.
-}

writeBibTeXFile :: FilePath -> BibTeX -> IO ()
writeBibTeXFile :: String -> [BibEntry] -> IO ()
writeBibTeXFile String
path [BibEntry]
entries = String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
outH -> do
    [BibEntry] -> (BibEntry -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [BibEntry]
entries ((BibEntry -> IO ()) -> IO ()) -> (BibEntry -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \BibEntry
bibEntry -> do
        let entryString :: String
entryString = BibEntry -> String
writeEntry BibEntry
bibEntry
        Handle -> String -> IO ()
hPutStrLn Handle
outH String
entryString
  where
    writeEntry :: BibEntry -> String
    writeEntry :: BibEntry -> String
writeEntry (BibEntry String
entryType String
bibId [(String, String)]
items) =
        let formatItem :: (String, String) -> String
formatItem (String
name, String
value_) =
                String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = {" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
value_ String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"},\n"
        in  String
"@" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
entryType String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
bibId String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
",\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
            ((String, String) -> String) -> [(String, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, String) -> String
formatItem [(String, String)]
items String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}\n"

bibFileParser :: Parser [BibEntry]
bibFileParser :: Parser [BibEntry]
bibFileParser = Parser String
bibCommentParser Parser String -> Parser [BibEntry] -> Parser [BibEntry]
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity BibEntry
-> Parser String -> Parser [BibEntry]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepEndBy ParsecT String () Identity BibEntry
bibEntryParser Parser String
bibCommentParser

bibCommentParser :: Parser String
bibCommentParser :: Parser String
bibCommentParser = ParsecT String () Identity Char -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String () Identity Char -> Parser String)
-> ParsecT String () Identity Char -> Parser String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"@"

bibEntryParser :: Parser BibEntry
bibEntryParser :: ParsecT String () Identity BibEntry
bibEntryParser =
   do String
entryType <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'@' ParsecT String () Identity Char -> Parser String -> Parser String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser String
forall st. CharParser st String
identifier
      ParsecT String () Identity BibEntry
-> ParsecT String () Identity BibEntry
forall st a. CharParser st a -> CharParser st a
braces (ParsecT String () Identity BibEntry
 -> ParsecT String () Identity BibEntry)
-> ParsecT String () Identity BibEntry
-> ParsecT String () Identity BibEntry
forall a b. (a -> b) -> a -> b
$
         (String -> [(String, String)] -> BibEntry)
-> Parser String
-> ParsecT String () Identity [(String, String)]
-> ParsecT String () Identity BibEntry
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (String -> String -> [(String, String)] -> BibEntry
BibEntry String
entryType)
            (Parser String -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser String
bibIdentifier)
            (Parser String
forall st. CharParser st String
comma Parser String
-> ParsecT String () Identity [(String, String)]
-> ParsecT String () Identity [(String, String)]
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity (String, String)
-> Parser String -> ParsecT String () Identity [(String, String)]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepEndBy ParsecT String () Identity (String, String)
assignment Parser String
forall st. CharParser st String
comma)

identifier :: CharParser st String
identifier :: forall st. CharParser st String
identifier = GenTokenParser String st Identity
-> ParsecT String st Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
T.identifier GenTokenParser String st Identity
forall st. TokenParser st
lexer

lexer :: T.TokenParser st
lexer :: forall st. TokenParser st
lexer =
   GenLanguageDef String st Identity
-> GenTokenParser String st Identity
forall s (m :: * -> *) u.
Stream s m Char =>
GenLanguageDef s u m -> GenTokenParser s u m
T.makeTokenParser (GenLanguageDef String st Identity
 -> GenTokenParser String st Identity)
-> GenLanguageDef String st Identity
-> GenTokenParser String st Identity
forall a b. (a -> b) -> a -> b
$ GenLanguageDef String st Identity
forall st. LanguageDef st
emptyDef {
      commentLine :: String
T.commentLine = String
"%",
      identStart :: ParsecT String st Identity Char
T.identStart = ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum,
      identLetter :: ParsecT String st Identity Char
T.identLetter = ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum
   }

braces :: CharParser st a -> CharParser st a
braces :: forall st a. CharParser st a -> CharParser st a
braces = GenTokenParser String st Identity
-> forall a.
   ParsecT String st Identity a -> ParsecT String st Identity a
forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
T.braces GenTokenParser String st Identity
forall st. TokenParser st
lexer

bibIdentifier :: Parser String
bibIdentifier :: Parser String
bibIdentifier = Parser String -> Parser String
forall st a. CharParser st a -> CharParser st a
lexeme (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$
   (Char -> ShowS)
-> ParsecT String () Identity Char
-> Parser String
-> Parser String
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) (ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'_') (ParsecT String () Identity Char -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"&;:-_.?+/"))

lexeme :: CharParser st a -> CharParser st a
lexeme :: forall st a. CharParser st a -> CharParser st a
lexeme = GenTokenParser String st Identity
-> forall a.
   ParsecT String st Identity a -> ParsecT String st Identity a
forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
T.lexeme GenTokenParser String st Identity
forall st. TokenParser st
lexer

assignment :: Parser (String, String)
assignment :: ParsecT String () Identity (String, String)
assignment =
   (String -> String -> (String, String))
-> Parser String
-> Parser String
-> ParsecT String () Identity (String, String)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,)
      Parser String
bibIdentifier
      (Parser String
forall st. CharParser st String
equals Parser String -> Parser String -> Parser String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser String
value)

equals :: CharParser st String
equals :: forall st. CharParser st String
equals = GenTokenParser String st Identity
-> String -> ParsecT String st Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> String -> ParsecT s u m String
T.symbol GenTokenParser String st Identity
forall st. TokenParser st
lexer String
"="

value :: Parser String
value :: Parser String
value =
   Parser String -> Parser String
forall st a. CharParser st a -> CharParser st a
lexeme (ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter) Parser String -> Parser String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> -- for fields like: month = jul
   Parser String -> Parser String
forall st a. CharParser st a -> CharParser st a
lexeme (ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit)  Parser String -> Parser String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> -- for fields like: year = 2010
   Parser String -> Parser String
forall st a. CharParser st a -> CharParser st a
braces (Char -> Parser String
texSequence Char
'}') Parser String -> Parser String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
   Parser String -> Parser String
forall st a. CharParser st a -> CharParser st a
lexeme (ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> Parser String
-> Parser String
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"') (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"') (Char -> Parser String
texSequence Char
'"'))

texSequence :: Char -> Parser String
texSequence :: Char -> Parser String
texSequence Char
closeChar =
   [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ParsecT String () Identity [String] -> Parser String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String -> ParsecT String () Identity [String]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (Char -> Parser String
texBlock Char
closeChar)

texBlock :: Char -> Parser String
texBlock :: Char -> Parser String
texBlock Char
closeChar =
   (Char -> String -> Char -> String)
-> ParsecT String () Identity Char
-> Parser String
-> ParsecT String () Identity Char
-> Parser String
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (\Char
open String
body Char
close -> Char
open Char -> ShowS
forall a. a -> [a] -> [a]
: String
body String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
close])
      (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'{') (Char -> Parser String
texSequence Char
'}') (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'}') Parser String -> Parser String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
   [ParsecT String () Identity Char] -> Parser String
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
      [Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\',
       String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"=\\_{}[]$|'`^&%\".,~# " ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter] Parser String -> Parser String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
   (Char -> String)
-> ParsecT String () Identity Char -> Parser String
forall a b.
(a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> ShowS
forall a. a -> [a] -> [a]
:[]) (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf [Char
closeChar])


comma :: CharParser st String
comma :: forall st. CharParser st String
comma = GenTokenParser String st Identity
-> ParsecT String st Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
T.comma GenTokenParser String st Identity
forall st. TokenParser st
lexer