{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards, OverloadedStrings, DeriveDataTypeable, ExistentialQuantification, FlexibleInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving, IncoherentInstances, DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Text.CSL.Reference -- Copyright : (c) Andrea Rossato -- License : BSD-style (see LICENSE) -- -- Maintainer : Andrea Rossato -- Stability : unstable -- Portability : unportable -- -- The Reference type -- ----------------------------------------------------------------------------- module Text.CSL.Reference ( Literal(..) , Value(..) , ReferenceMap , mkRefMap , formatField , fromValue , isValueSet , Empty(..) , RefDate(..) , handleLiteral , toDatePart , setCirca , mkRefDate , RefType(..) , CNum(..) , Reference(..) , emptyReference , numericVars , getReference , processCites , setPageFirst , setNearNote ) where import Data.List ( elemIndex, intercalate ) import Data.List.Split ( splitWhen ) import Data.Maybe ( fromMaybe ) import Data.Generics hiding (Generic) import GHC.Generics (Generic) import Data.Monoid import Data.Aeson hiding (Value) import Data.Aeson.Types (Parser) import Control.Applicative ((<$>), (<*>), (<|>), pure) import qualified Data.Text as T import qualified Data.Vector as V import Data.Char (toLower, isUpper, isLower, isDigit) import Text.CSL.Style hiding (Number) import Text.CSL.Util (parseString, parseInt, parseBool, safeRead, readNum, inlinesToString, capitalize, camelize) import Text.Pandoc (Inline(Str)) import Data.String newtype Literal = Literal { unLiteral :: String } deriving ( Show, Read, Eq, Data, Typeable, Monoid, Generic ) instance FromJSON Literal where parseJSON v = Literal `fmap` parseString v instance ToJSON Literal where toJSON = toJSON . unLiteral instance IsString Literal where fromString = Literal -- | An existential type to wrap the different types a 'Reference' is -- made of. This way we can create a map to make queries easier. data Value = forall a . Data a => Value a -- for debuging instance Show Value where show (Value a) = gshow a type ReferenceMap = [(String, Value)] mkRefMap :: Data a => a -> ReferenceMap mkRefMap a = zip fields (gmapQ Value a) where fields = map formatField . constrFields . toConstr $ a formatField :: String -> String formatField = foldr f [] . g where f x xs = if isUpper x then '-' : toLower x : xs else x : xs g (x:xs) = toLower x : xs g [] = [] fromValue :: Data a => Value -> Maybe a fromValue (Value a) = cast a isValueSet :: Value -> Bool isValueSet val | Just v <- fromValue val :: Maybe Literal = v /= mempty | Just v <- fromValue val :: Maybe String = v /= mempty | Just v <- fromValue val :: Maybe Formatted = v /= mempty | Just v <- fromValue val :: Maybe [Agent] = v /= [] | Just v <- fromValue val :: Maybe [RefDate] = v /= [] | Just v <- fromValue val :: Maybe Int = v /= 0 | Just v <- fromValue val :: Maybe CNum = v /= 0 | Just _ <- fromValue val :: Maybe Empty = True | otherwise = False data Empty = Empty deriving ( Typeable, Data, Generic ) data RefDate = RefDate { year :: Literal , month :: Literal , season :: Literal , day :: Literal , other :: Literal , circa :: Bool } deriving ( Show, Read, Eq, Typeable, Data, Generic ) instance FromJSON RefDate where parseJSON (Array v) = case fromJSON (Array v) of Success [y] -> RefDate <$> parseJSON y <*> pure "" <*> pure "" <*> pure "" <*> pure "" <*> pure False Success [y,m] -> RefDate <$> parseJSON y <*> parseJSON m <*> pure "" <*> pure "" <*> pure "" <*> pure False Success [y,m,d] -> RefDate <$> parseJSON y <*> parseJSON m <*> pure "" <*> parseJSON d <*> pure "" <*> pure False Error e -> fail $ "Could not parse RefDate: " ++ e _ -> fail "Could not parse RefDate" parseJSON (Object v) = RefDate <$> v .:? "year" .!= "" <*> v .:? "month" .!= "" <*> v .:? "season" .!= "" <*> v .:? "day" .!= "" <*> v .:? "literal" .!= "" <*> ((v .: "circa" >>= parseBool) <|> pure False) parseJSON _ = fail "Could not parse RefDate" {- instance ToJSON RefDate where toJSON refdate = object' $ [ "year" .= year refdate , "month" .= month refdate , "season" .= season refdate , "day" .= day refdate , "other" .= other refdate ] ++ [ "circa" .= circa refdate | circa refdate ] -} instance FromJSON [RefDate] where parseJSON (Array xs) = mapM parseJSON $ V.toList xs parseJSON (Object v) = do dateParts <- v .:? "date-parts" circa' <- (v .: "circa" >>= parseBool) <|> pure False case dateParts of Just (Array xs) -> mapM (fmap (setCirca circa') . parseJSON) $ V.toList xs _ -> handleLiteral <$> parseJSON (Object v) parseJSON x = parseJSON x >>= mkRefDate -- Zotero doesn't properly support date ranges, so a common -- workaround is 2005_2007; support this as date range: handleLiteral :: RefDate -> [RefDate] handleLiteral d@(RefDate (Literal "") (Literal "") (Literal "") (Literal "") (Literal xs) b) = case splitWhen (=='_') xs of [x,y] | all isDigit x && all isDigit y && not (null x) && not (null y) -> [RefDate (Literal x) mempty mempty mempty mempty b, RefDate (Literal y) mempty mempty mempty mempty b] _ -> [d] handleLiteral d = [d] toDatePart :: RefDate -> [Int] toDatePart refdate = case (safeRead (unLiteral $ year refdate), safeRead (unLiteral $ month refdate), safeRead (unLiteral $ day refdate)) of (Just (y :: Int), Just (m :: Int), Just (d :: Int)) -> [y, m, d] (Just y, Just m, Nothing) -> [y, m] (Just y, Nothing, Nothing) -> [y] _ -> [] instance ToJSON [RefDate] where toJSON [] = Array V.empty toJSON xs = object' $ case filter (not . null) (map toDatePart xs) of [] -> ["literal" .= intercalate "; " (map (unLiteral . other) xs)] dps -> (["date-parts" .= dps ] ++ ["circa" .= (1 :: Int) | or (map circa xs)] ++ ["season" .= s | s <- map season xs, s /= mempty]) -- instance ToJSON [RefDate] -- toJSON xs = Array (V.fromList $ map toJSON xs) setCirca :: Bool -> RefDate -> RefDate setCirca circa' rd = rd{ circa = circa' } mkRefDate :: Literal -> Parser [RefDate] mkRefDate z@(Literal xs) | all isDigit xs = return [RefDate z mempty mempty mempty mempty False] | otherwise = return [RefDate mempty mempty mempty mempty z False] data RefType = NoType | Article | ArticleMagazine | ArticleNewspaper | ArticleJournal | Bill | Book | Broadcast | Chapter | Dataset | Entry | EntryDictionary | EntryEncyclopedia | Figure | Graphic | Interview | Legislation | LegalCase | Manuscript | Map | MotionPicture | MusicalScore | Pamphlet | PaperConference | Patent | Post | PostWeblog | PersonalCommunication | Report | Review | ReviewBook | Song | Speech | Thesis | Treaty | Webpage deriving ( Read, Eq, Typeable, Data, Generic ) instance Show RefType where show MotionPicture = "motion_picture" show MusicalScore = "musical_score" show PersonalCommunication = "personal_communication" show LegalCase = "legal_case" show x = map toLower . formatField . showConstr . toConstr $ x instance FromJSON RefType where parseJSON (String t) = safeRead (capitalize . camelize . T.unpack $ t) parseJSON v@(Array _) = fmap (capitalize . camelize . inlinesToString) (parseJSON v) >>= safeRead parseJSON _ = fail "Could not parse RefType" instance ToJSON RefType where toJSON reftype = toJSON (uncamelize $ uncapitalize $ show reftype) where uncamelize [] = [] uncamelize (x:y:zs) | isLower x && isUpper y = x:'-':toLower y:uncamelize zs uncamelize (x:xs) = x : uncamelize xs uncapitalize (x:xs) = toLower x : xs uncapitalize [] = [] newtype CNum = CNum { unCNum :: Int } deriving ( Show, Read, Eq, Num, Typeable, Data, Generic ) instance FromJSON CNum where parseJSON x = CNum `fmap` parseInt x instance ToJSON CNum where toJSON (CNum n) = toJSON n -- | The 'Reference' record. data Reference = Reference { refId :: Literal , refType :: RefType , author :: [Agent] , editor :: [Agent] , translator :: [Agent] , recipient :: [Agent] , interviewer :: [Agent] , composer :: [Agent] , director :: [Agent] , illustrator :: [Agent] , originalAuthor :: [Agent] , containerAuthor :: [Agent] , collectionEditor :: [Agent] , editorialDirector :: [Agent] , reviewedAuthor :: [Agent] , issued :: [RefDate] , eventDate :: [RefDate] , accessed :: [RefDate] , container :: [RefDate] , originalDate :: [RefDate] , submitted :: [RefDate] , title :: Formatted , titleShort :: Formatted , reviewedTitle :: Formatted , containerTitle :: Formatted , volumeTitle :: Formatted , collectionTitle :: Formatted , containerTitleShort :: Formatted , collectionNumber :: Formatted --Int , originalTitle :: Formatted , publisher :: Formatted , originalPublisher :: Formatted , publisherPlace :: Formatted , originalPublisherPlace :: Formatted , authority :: Formatted , jurisdiction :: Formatted , archive :: Formatted , archivePlace :: Formatted , archiveLocation :: Formatted , event :: Formatted , eventPlace :: Formatted , page :: Formatted , pageFirst :: Formatted , numberOfPages :: Formatted , version :: Formatted , volume :: Formatted , numberOfVolumes :: Formatted --Int , issue :: Formatted , chapterNumber :: Formatted , medium :: Formatted , status :: Formatted , edition :: Formatted , section :: Formatted , source :: Formatted , genre :: Formatted , note :: Formatted , annote :: Formatted , abstract :: Formatted , keyword :: Formatted , number :: Formatted , references :: Formatted , url :: Literal , doi :: Literal , isbn :: Literal , issn :: Literal , pmcid :: Literal , pmid :: Literal , callNumber :: Literal , dimensions :: Literal , scale :: Literal , categories :: [Literal] , language :: Literal , citationNumber :: CNum , firstReferenceNoteNumber :: Int , citationLabel :: Literal } deriving ( Eq, Show, Read, Typeable, Data, Generic ) instance FromJSON Reference where parseJSON (Object v) = addPageFirst <$> (Reference <$> v .:? "id" .!= "" <*> v .:? "type" .!= NoType <*> v .:? "author" .!= [] <*> v .:? "editor" .!= [] <*> v .:? "translator" .!= [] <*> v .:? "recipient" .!= [] <*> v .:? "interviewer" .!= [] <*> v .:? "composer" .!= [] <*> v .:? "director" .!= [] <*> v .:? "illustrator" .!= [] <*> v .:? "original-author" .!= [] <*> v .:? "container-author" .!= [] <*> v .:? "collection-editor" .!= [] <*> v .:? "editorial-director" .!= [] <*> v .:? "reviewed-author" .!= [] <*> v .:? "issued" .!= [] <*> v .:? "event-date" .!= [] <*> v .:? "accessed" .!= [] <*> v .:? "container" .!= [] <*> v .:? "original-date" .!= [] <*> v .:? "submitted" .!= [] <*> v .:? "title" .!= mempty <*> (v .: "shortTitle" <|> (v .:? "title-short" .!= mempty)) <*> v .:? "reviewed-title" .!= mempty <*> v .:? "container-title" .!= mempty <*> v .:? "volume-title" .!= mempty <*> v .:? "collection-title" .!= mempty <*> (v .: "journalAbbreviation" <|> v .:? "container-title-short" .!= mempty) <*> v .:? "collection-number" .!= mempty <*> v .:? "original-title" .!= mempty <*> v .:? "publisher" .!= mempty <*> v .:? "original-publisher" .!= mempty <*> v .:? "publisher-place" .!= mempty <*> v .:? "original-publisher-place" .!= mempty <*> v .:? "authority" .!= mempty <*> v .:? "jurisdiction" .!= mempty <*> v .:? "archive" .!= mempty <*> v .:? "archive-place" .!= mempty <*> v .:? "archive_location" .!= mempty <*> v .:? "event" .!= mempty <*> v .:? "event-place" .!= mempty <*> v .:? "page" .!= mempty <*> v .:? "page-first" .!= mempty <*> v .:? "number-of-pages" .!= mempty <*> v .:? "version" .!= mempty <*> v .:? "volume" .!= mempty <*> v .:? "number-of-volumes" .!= mempty <*> v .:? "issue" .!= mempty <*> v .:? "chapter-number" .!= mempty <*> v .:? "medium" .!= mempty <*> v .:? "status" .!= mempty <*> v .:? "edition" .!= mempty <*> v .:? "section" .!= mempty <*> v .:? "source" .!= mempty <*> v .:? "genre" .!= mempty <*> v .:? "note" .!= mempty <*> v .:? "annote" .!= mempty <*> v .:? "abstract" .!= mempty <*> v .:? "keyword" .!= mempty <*> v .:? "number" .!= mempty <*> v .:? "references" .!= mempty <*> v .:? "URL" .!= "" <*> v .:? "DOI" .!= "" <*> v .:? "ISBN" .!= "" <*> v .:? "ISSN" .!= "" <*> v .:? "PMCID" .!= "" <*> v .:? "PMID" .!= "" <*> v .:? "call-number" .!= "" <*> v .:? "dimensions" .!= "" <*> v .:? "scale" .!= "" <*> v .:? "categories" .!= [] <*> v .:? "language" .!= "" <*> v .:? "citation-number" .!= CNum 0 <*> ((v .: "first-reference-note-number" >>= parseInt) <|> return 1) <*> v .:? "citation-label" .!= "") where takeFirstNum (Formatted (Str xs : _)) = case takeWhile isDigit xs of [] -> mempty ds -> Formatted [Str ds] takeFirstNum x = x addPageFirst ref = if pageFirst ref == mempty && page ref /= mempty then ref{ pageFirst = takeFirstNum (page ref) } else ref parseJSON _ = fail "Could not parse Reference" instance ToJSON Reference where toJSON ref = object' [ "id" .= refId ref , "type" .= refType ref , "author" .= author ref , "editor" .= editor ref , "translator" .= translator ref , "recipient" .= recipient ref , "interviewer" .= interviewer ref , "composer" .= composer ref , "director" .= director ref , "illustrator" .= illustrator ref , "original-author" .= originalAuthor ref , "container-author" .= containerAuthor ref , "collection-editor" .= collectionEditor ref , "editorial-director" .= editorialDirector ref , "reviewed-author" .= reviewedAuthor ref , "issued" .= issued ref , "event-date" .= eventDate ref , "accessed" .= accessed ref , "container" .= container ref , "original-date" .= originalDate ref , "submitted" .= submitted ref , "title" .= title ref , "title-short" .= titleShort ref , "reviewed-title" .= reviewedTitle ref , "container-title" .= containerTitle ref , "volume-title" .= volumeTitle ref , "collection-title" .= collectionTitle ref , "container-title-short" .= containerTitleShort ref , "collection-number" .= collectionNumber ref , "original-title" .= originalTitle ref , "publisher" .= publisher ref , "original-publisher" .= originalPublisher ref , "publisher-place" .= publisherPlace ref , "original-publisher-place" .= originalPublisherPlace ref , "authority" .= authority ref , "jurisdiction" .= jurisdiction ref , "archive" .= archive ref , "archive-place" .= archivePlace ref , "archive_location" .= archiveLocation ref , "event" .= event ref , "event-place" .= eventPlace ref , "page" .= page ref , "page-first" .= (if page ref == mempty then pageFirst ref else mempty) , "number-of-pages" .= numberOfPages ref , "version" .= version ref , "volume" .= volume ref , "number-of-volumes" .= numberOfVolumes ref , "issue" .= issue ref , "chapter-number" .= chapterNumber ref , "medium" .= medium ref , "status" .= status ref , "edition" .= edition ref , "section" .= section ref , "source" .= source ref , "genre" .= genre ref , "note" .= note ref , "annote" .= annote ref , "abstract" .= abstract ref , "keyword" .= keyword ref , "number" .= number ref , "references" .= references ref , "URL" .= url ref , "DOI" .= doi ref , "ISBN" .= isbn ref , "ISSN" .= issn ref , "PMCID" .= pmcid ref , "PMID" .= pmid ref , "call-number" .= callNumber ref , "dimensions" .= dimensions ref , "scale" .= scale ref , "categories" .= categories ref , "language" .= language ref , "citation-number" .= citationNumber ref , "first-reference-note-number" .= firstReferenceNoteNumber ref , "citation-label" .= citationLabel ref ] emptyReference :: Reference emptyReference = Reference { refId = mempty , refType = NoType , author = [] , editor = [] , translator = [] , recipient = [] , interviewer = [] , composer = [] , director = [] , illustrator = [] , originalAuthor = [] , containerAuthor = [] , collectionEditor = [] , editorialDirector = [] , reviewedAuthor = [] , issued = [] , eventDate = [] , accessed = [] , container = [] , originalDate = [] , submitted = [] , title = mempty , titleShort = mempty , reviewedTitle = mempty , containerTitle = mempty , volumeTitle = mempty , collectionTitle = mempty , containerTitleShort = mempty , collectionNumber = mempty , originalTitle = mempty , publisher = mempty , originalPublisher = mempty , publisherPlace = mempty , originalPublisherPlace = mempty , authority = mempty , jurisdiction = mempty , archive = mempty , archivePlace = mempty , archiveLocation = mempty , event = mempty , eventPlace = mempty , page = mempty , pageFirst = mempty , numberOfPages = mempty , version = mempty , volume = mempty , numberOfVolumes = mempty , issue = mempty , chapterNumber = mempty , medium = mempty , status = mempty , edition = mempty , section = mempty , source = mempty , genre = mempty , note = mempty , annote = mempty , abstract = mempty , keyword = mempty , number = mempty , references = mempty , url = mempty , doi = mempty , isbn = mempty , issn = mempty , pmcid = mempty , pmid = mempty , callNumber = mempty , dimensions = mempty , scale = mempty , categories = mempty , language = mempty , citationNumber = CNum 0 , firstReferenceNoteNumber = 0 , citationLabel = mempty } numericVars :: [String] numericVars = [ "edition", "volume", "number-of-volumes", "number", "issue", "citation-number" , "chapter-number", "collection-number", "number-of-pages"] getReference :: [Reference] -> Cite -> Maybe Reference getReference r c = case citeId c `elemIndex` map (unLiteral . refId) r of Just i -> Just $ setPageFirst $ r !! i Nothing -> Nothing processCites :: [Reference] -> [[Cite]] -> [[(Cite, Reference)]] processCites rs cs = procGr [[]] cs where procRef r = case filter ((==) (unLiteral $ refId r) . citeId) $ concat cs of x:_ -> r { firstReferenceNoteNumber = readNum $ citeNoteNumber x} [] -> r getRef c = case filter ((==) (citeId c) . unLiteral . refId) rs of x:_ -> procRef $ setPageFirst x [] -> emptyReference { title = fromString $ citeId c ++ " not found!" } procGr _ [] = [] procGr a (x:xs) = let (a',res) = procCs a x in res : procGr (a' ++ [[]]) xs procCs a [] = (a,[]) procCs a (c:xs) | isIbid, isLocSet = go "ibid-with-locator" | isIbid = go "ibid" | isElem = go "subsequent" | otherwise = go "first" where go s = let addCite = init a ++ [last a ++ [c]] (a', rest) = procCs addCite xs in (a', (c { citePosition = s}, getRef c) : rest) isElem = citeId c `elem` map citeId (concat a) isIbid = case reverse (last a) of [] -> case reverse (init a) of [] -> False (zs:_) -> not (null zs) && all (== citeId c) (map citeId zs) (x:_) -> citeId c == citeId x isLocSet = citeLocator c /= "" setPageFirst :: Reference -> Reference setPageFirst ref = let Formatted ils = page ref ils' = takeWhile (\i -> i /= Str "–" && i /= Str "-") ils in if ils == ils' then ref else ref{ pageFirst = Formatted ils' } setNearNote :: Style -> [[Cite]] -> [[Cite]] setNearNote s cs = procGr [] cs where near_note = let nn = fromMaybe [] . lookup "near-note-distance" . citOptions . citation $ s in if nn == [] then 5 else readNum nn procGr _ [] = [] procGr a (x:xs) = let (a',res) = procCs a x in res : procGr a' xs procCs a [] = (a,[]) procCs a (c:xs) = (a', c { nearNote = isNear} : rest) where (a', rest) = procCs (c:a) xs isNear = case filter ((==) (citeId c) . citeId) a of x:_ -> citeNoteNumber c /= "0" && citeNoteNumber x /= "0" && readNum (citeNoteNumber c) - readNum (citeNoteNumber x) <= near_note _ -> False