{-# LANGUAGE PatternGuards, DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module : Text.CSL.Style
-- Copyright : (c) Andrea Rossato
-- License : BSD-style (see LICENSE)
--
-- Maintainer : Andrea Rossato <andrea.rossato@unitn.it>
-- Stability : unstable
-- Portability : unportable
--
-- The Style types
--
-----------------------------------------------------------------------------
module Text.CSL.Style where
import Control.Arrow
import Data.List ( nubBy, isPrefixOf, isInfixOf )
import Data.Generics ( Typeable, Data, everywhere
, everywhere', everything, mkT, mkQ )
import Data.Maybe ( listToMaybe )
import qualified Data.Map as M
import Text.JSON
import Text.Pandoc.Definition ( Inline, Target )
#ifdef UNICODE_COLLATION
import qualified Data.Text as T
import qualified Data.Text.ICU as T
#endif
-- | The representation of a parsed CSL style.
data Style
= Style
{ styleVersion :: String
, styleClass :: String
, styleInfo :: Maybe CSInfo
, styleDefaultLocale :: String
, styleLocale :: [Locale]
, styleAbbrevs :: [Abbrev]
, csOptions :: [Option]
, csMacros :: [MacroMap]
, citation :: Citation
, biblio :: Maybe Bibliography
} deriving ( Show, Read, Typeable, Data )
data Locale
= Locale
{ localeVersion :: String
, localeLang :: String
, localeOptions :: [Option]
, localeTerms :: [CslTerm]
, localeDate :: [Element]
} deriving ( Show, Read, Eq, Typeable, Data )
-- | With the 'defaultLocale', the locales-xx-XX.xml loaded file and
-- the parsed 'Style' cs:locale elements, produce the final 'Locale'
-- as the only element of a list, taking into account CSL locale
-- prioritization.
mergeLocales :: String -> Locale -> [Locale] -> [Locale]
mergeLocales s l ls = doMerge list
where
list = filter ((==) s . localeLang) ls ++
filter ((\x -> x /= [] && x `isPrefixOf` s) . localeLang) ls ++
filter ((==) [] . localeLang) ls
doMerge x = return l { localeOptions = newOpt x
, localeTerms = newTerms x
, localeDate = newDate x
}
cht = cslTerm &&& termForm &&& termGenderForm
checkedLoc = if hasOrdinals ls then rmOrdinals (localeTerms l) else localeTerms l
newTerms x = nubBy (\a b -> cht a == cht b) (concatMap localeTerms x ++ checkedLoc)
newOpt x = nubBy (\a b -> fst a == fst b) (concatMap localeOptions x ++ localeOptions l)
newDate x = nubBy (\(Date _ a _ _ _ _)
(Date _ b _ _ _ _) -> a == b) (concatMap localeDate x ++ localeDate l)
data CslTerm
= CT
{ cslTerm :: String
, termForm :: Form
, termGender :: Gender
, termGenderForm :: Gender
, termSingular :: String
, termPlural :: String
, termMatch :: String
} deriving ( Show, Read, Eq, Typeable, Data )
newTerm :: CslTerm
newTerm = CT [] Long Neuter Neuter [] [] []
findTerm :: String -> Form -> [CslTerm] -> Maybe CslTerm
findTerm s f
= listToMaybe . filter (cslTerm &&& termForm >>> (==) (s, f))
findTerm' :: String -> Form -> Gender -> [CslTerm] -> Maybe CslTerm
findTerm' s f g
= listToMaybe . filter (cslTerm &&& termForm &&& termGenderForm >>> (==) (s,(f,g)))
hasOrdinals :: Data a => a -> Bool
hasOrdinals = or . query hasOrd
where
hasOrd o
| CT {cslTerm = t} <- o
, "ordinal" `isInfixOf` t = [True]
| otherwise = [False]
rmOrdinals :: Data a => a -> a
rmOrdinals = proc' doRemove
where
doRemove [] = []
doRemove (o:os)
| CT {cslTerm = t} <- o
, "ordinal" `isInfixOf` t = doRemove os
| otherwise = o:doRemove os
type Abbrev
= (String, [(String, M.Map String String)])
type MacroMap
= (String,[Element])
data Citation
= Citation
{ citOptions :: [Option]
, citSort :: [Sort]
, citLayout :: Layout
} deriving ( Show, Read, Typeable, Data )
data Bibliography
= Bibliography
{ bibOptions :: [Option]
, bibSort :: [Sort]
, bibLayout :: Layout
} deriving ( Show, Read, Typeable, Data )
type Option = (String,String)
mergeOptions :: [Option] -> [Option] -> [Option]
mergeOptions os = nubBy (\x y -> fst x == fst y) . (++) os
data Layout
= Layout
{ layFormat :: Formatting
, layDelim :: Delimiter
, elements :: [Element]
} deriving ( Show, Read, Typeable, Data )
data Element
= Choose IfThen [IfThen] [Element]
| Macro String Formatting
| Const String Formatting
| Variable [String] Form Formatting Delimiter
| Term String Form Formatting Bool
| Label String Form Formatting Plural
| Number String NumericForm Formatting
| Names [String] [Name] Formatting Delimiter [Element]
| Substitute [Element]
| Group Formatting Delimiter [Element]
| Date [String] DateForm Formatting Delimiter [DatePart] String
deriving ( Show, Read, Eq, Typeable, Data )
data IfThen
= IfThen Condition Match [Element]
deriving ( Eq, Show, Read, Typeable, Data )
data Condition
= Condition
{ isType :: [String]
, isSet :: [String]
, isNumeric :: [String]
, isUncertainDate :: [String]
, isPosition :: [String]
, disambiguation :: [String]
, isLocator :: [String]
} deriving ( Eq, Show, Read, Typeable, Data )
type Delimiter = String
data Match
= Any
| All
| None
deriving ( Show, Read, Eq, Typeable, Data )
match :: Match -> [Bool] -> Bool
match All = and
match Any = or
match None = and . map not
data DatePart
= DatePart
{ dpName :: String
, dpForm :: String
, dpRangeDelim :: String
, dpFormatting :: Formatting
} deriving ( Show, Read, Eq, Typeable, Data )
defaultDate :: [DatePart]
defaultDate
= [ DatePart "year" "" "-" emptyFormatting
, DatePart "month" "" "-" emptyFormatting
, DatePart "day" "" "-" emptyFormatting]
data Sort
= SortVariable String Sorting
| SortMacro String Sorting Int Int String
deriving ( Eq, Show, Read, Typeable, Data )
data Sorting
= Ascending String
| Descending String
deriving ( Read, Show, Eq, Typeable, Data )
instance Ord Sorting where
compare (Ascending []) (Ascending []) = EQ
compare (Ascending []) (Ascending _) = GT
compare (Ascending _) (Ascending []) = LT
compare (Ascending a) (Ascending b) = compare' a b
compare (Descending []) (Descending []) = EQ
compare (Descending []) (Descending _) = GT
compare (Descending _) (Descending []) = LT
compare (Descending a) (Descending b) = compare' b a
compare _ _ = EQ
compare' :: String -> String -> Ordering
compare' x y
= case (head x, head y) of
('-','-') -> comp y x
('-', _ ) -> LT
(_ ,'-') -> GT
_ -> comp x y
where
#ifdef UNICODE_COLLATION
comp a b = T.collate (T.collator T.Current) (T.pack a) (T.pack b)
#else
comp a b = compare a b
#endif
data Form
= Long
| Short
| Count
| Verb
| VerbShort
| Symbol
| NotSet
deriving ( Eq, Show, Read, Typeable, Data )
data Gender
= Feminine
| Masculine
| Neuter
deriving ( Eq, Show, Read, Typeable, Data )
data NumericForm
= Numeric
| Ordinal
| Roman
| LongOrdinal
deriving ( Eq, Show, Read, Typeable, Data )
data DateForm
= TextDate
| NumericDate
| NoFormDate
deriving ( Eq, Show, Read, Typeable, Data )
data Plural
= Contextual
| Always
| Never
deriving ( Eq, Show, Read, Typeable, Data )
data Name
= Name Form Formatting NameAttrs Delimiter [NamePart]
| NameLabel Form Formatting Plural
| EtAl Formatting String
deriving ( Eq, Show, Read, Typeable, Data )
type NameAttrs = [(String, String)]
data NamePart
= NamePart String Formatting
deriving ( Show, Read, Eq, Typeable, Data )
isPlural :: Plural -> Int -> Bool
isPlural p l
= case p of
Always -> True
Never -> False
Contextual -> l > 1
isName :: Name -> Bool
isName x = case x of Name {} -> True; _ -> False
isNames :: Element -> Bool
isNames x = case x of Names {} -> True; _ -> False
hasEtAl :: [Name] -> Bool
hasEtAl = not . null . query getEtAl
where getEtAl n
| EtAl _ _ <- n = [n]
| otherwise = []
data Formatting
= Formatting
{ prefix :: String
, suffix :: String
, fontFamily :: String
, fontStyle :: String
, fontVariant :: String
, fontWeight :: String
, textDecoration :: String
, verticalAlign :: String
, textCase :: String
, display :: String
, quotes :: Quote
, stripPeriods :: Bool
, noCase :: Bool
, noDecor :: Bool
} deriving ( Read, Eq, Ord, Typeable, Data )
instance Show Formatting where show _ = "emptyFormatting"
rmTitleCase :: Formatting -> Formatting
rmTitleCase f
| Formatting _ _ _ _ _ _ _ _ "title" _ _ _ _ _ <- f = f {textCase = []}
| otherwise = f
data Quote
= NativeQuote
| ParsedQuote
| NoQuote
deriving ( Read, Eq, Ord, Typeable, Data )
emptyFormatting :: Formatting
emptyFormatting
= Formatting [] [] [] [] [] [] [] [] [] [] NoQuote False False False
unsetAffixes :: Formatting -> Formatting
unsetAffixes f = f {prefix = [], suffix = []}
mergeFM :: Formatting -> Formatting -> Formatting
mergeFM (Formatting aa ab ac ad ae af ag ah ai aj ak al am an)
(Formatting ba bb bc bd be bf bg bh bi bj bk bl bm bn) =
Formatting (ba `betterThen` aa)
(bb `betterThen` ab)
(bc `betterThen` ac)
(bd `betterThen` ad)
(be `betterThen` ae)
(bf `betterThen` af)
(bg `betterThen` ag)
(bh `betterThen` ah)
(bi `betterThen` ai)
(bj `betterThen` aj)
(if bk == NoQuote then ak else bk)
(bl || al)
(bm || am)
(bn || an)
data CSInfo
= CSInfo
{ csiTitle :: String
, csiAuthor :: CSAuthor
, csiCategories :: [CSCategory]
, csiId :: String
, csiUpdated :: String
} deriving ( Show, Read, Typeable, Data )
data CSAuthor = CSAuthor String String String deriving ( Show, Read, Eq, Typeable, Data )
data CSCategory = CSCategory String String String deriving ( Show, Read, Eq, Typeable, Data )
-- | The formatted output, produced after post-processing the
-- evaluated citations.
data FormattedOutput
= FO Formatting [FormattedOutput] -- ^ List of 'FormatOutput' items
| FN String Formatting -- ^ Formatted number
| FS String Formatting -- ^ Formatted string
| FErr CiteprocError -- ^ Warning
| FDel String -- ^ Delimeter string
| FUrl Target Formatting -- ^ Formatted URL
| FPan [Inline] -- ^ Pandoc inline elements
| FNull -- ^ Null formatting item
deriving ( Eq, Show )
data CiteprocError
= NoOutput
| ReferenceNotFound String
deriving ( Eq, Ord, Show, Typeable, Data )
-- | The 'Output' generated by the evaluation of a style. Must be
-- further processed for disambiguation and collapsing.
data Output
= ONull
| OSpace
| OPan [Inline]
| ODel String -- ^ A delimiter string.
| OStr String Formatting -- ^ A simple 'String'
| OErr CiteprocError -- ^ Warning message
| OLabel String Formatting -- ^ A label used for roles
| ONum Int Formatting -- ^ A number (used to count contributors)
| OCitNum Int Formatting -- ^ The citation number
| ODate [Output] -- ^ A (possibly) ranged date
| OYear String String Formatting -- ^ The year and the citeId
| OYearSuf String String [Output] Formatting -- ^ The year suffix, the citeId and a holder for collision data
| OName String [Output] [[Output]] Formatting -- ^ A (family) name with the list of given names.
| OContrib String String [Output] [Output] [[Output]] -- ^ The citation key, the role (author, editor, etc.), the contributor(s),
-- the output needed for year suf. disambiguation, and everything used for
-- name disambiguation.
| OUrl Target Formatting -- ^ An URL
| OLoc [Output] Formatting -- ^ The citation's locator
| Output [Output] Formatting -- ^ Some nested 'Output'
deriving ( Eq, Ord, Show, Typeable, Data )
data Affix
= PlainText String
| PandocText [Inline]
deriving ( Show, Read, Eq, Ord, Typeable, Data )
-- | Needed for the test-suite.
instance JSON Affix where
showJSON (PlainText s) = JSString . toJSString $ s
showJSON (PandocText i) = JSString . toJSString $ show i
readJSON jv
| JSString js <- jv
, [(x,"")] <- reads (fromJSString js) = Ok x
| otherwise = Ok $ PlainText []
type Citations = [[Cite]]
data Cite
= Cite
{ citeId :: String
, citePrefix :: Affix
, citeSuffix :: Affix
, citeLabel :: String
, citeLocator :: String
, citeNoteNumber :: String
, citePosition :: String
, nearNote :: Bool
, authorInText :: Bool
, suppressAuthor :: Bool
, citeHash :: Int
} deriving ( Show, Eq, Typeable, Data )
emptyAffix :: Affix
emptyAffix = PlainText []
emptyCite :: Cite
emptyCite = Cite [] emptyAffix emptyAffix [] [] [] [] False False False 0
-- | A citation group: the first list has a single member when the
-- citation group starts with an "author-in-text" cite, the
-- 'Formatting' to be applied, the 'Delimiter' between individual
-- citations and the list of evaluated citations.
data CitationGroup = CG [(Cite, Output)] Formatting Delimiter [(Cite, Output)] deriving ( Show, Eq, Typeable, Data )
data BiblioData
= BD
{ citations :: [[FormattedOutput]]
, bibliography :: [[FormattedOutput]]
} deriving ( Show )
-- | A record with all the data to produce the 'FormattedOutput' of a
-- citation: the citation key, the part of the formatted citation that
-- may be colliding with other citations, the form of the citation
-- when a year suffix is used for disambiguation , the data to
-- disambiguate it (all possible contributors and all possible given
-- names), and, after processing, the disambiguated citation and its
-- year, initially empty.
data CiteData
= CD
{ key :: String
, collision :: [Output]
, disambYS :: [Output]
, disambData :: [[Output]]
, disambed :: [Output]
, sameAs :: [String]
, citYear :: String
} deriving ( Show, Typeable, Data )
instance Eq CiteData where
(==) (CD ka ca _ _ _ _ _)
(CD kb cb _ _ _ _ _) = ka == kb && ca == cb
data NameData
= ND
{ nameKey :: String
, nameCollision :: [Output]
, nameDisambData :: [[Output]]
, nameDataSolved :: [Output]
} deriving ( Show, Typeable, Data )
instance Eq NameData where
(==) (ND ka ca _ _)
(ND kb cb _ _) = ka == kb && ca == cb
formatOutputList :: [Output] -> [FormattedOutput]
formatOutputList = filterUseless . map formatOutput
where
filterUseless [] = []
filterUseless (o:os)
| FO _ [] <- o = filterUseless os
| FO f xs <- o
, isEmpty f = filterUseless xs ++ filterUseless os
| FO f xs <- o = case filterUseless xs of
[] -> filterUseless os
xs' -> FO f xs' : filterUseless os
| FNull <- o = filterUseless os
| otherwise = o : filterUseless os
where
isEmpty f = f == emptyFormatting
-- | Convert evaluated 'Output' into 'FormattedOutput', ready for the
-- output filters.
formatOutput :: Output -> FormattedOutput
formatOutput o
| OSpace <- o = FDel " "
| OPan i <- o = FPan i
| ODel [] <- o = FNull
| ODel s <- o = FDel s
| OStr [] _ <- o = FNull
| OStr s f <- o = FS s f
| OErr e <- o = FErr e
| OLabel [] _ <- o = FNull
| OLabel s f <- o = FS s f
| ODate os <- o = FO emptyFormatting (format os)
| OYear s _ f <- o = FS s f
| OYearSuf s _ _ f <- o = FS s f
| ONum i f <- o = FS (show i) f
| OCitNum i f <- o = FN (add00 i) f
| OUrl s f <- o = FUrl s f
| OName _ s _ f <- o = FO f (format s)
| OContrib _ _ s _ _ <- o = FO emptyFormatting (format s)
| OLoc os f <- o = FO f (format os)
| Output os f <- o = FO f (format os)
| otherwise = FNull
where
format = map formatOutput
add00 = reverse . take 5 . flip (++) (repeat '0') . reverse . show
-- | Map the evaluated output of a citation group.
mapGroupOutput :: (Output -> [a]) -> CitationGroup -> [a]
mapGroupOutput f (CG _ _ _ os) = concatMap f $ map snd os
-- | A generic processing function.
proc :: (Typeable a, Data b) => (a -> a) -> b -> b
proc f = everywhere (mkT f)
-- | A generic processing function: process a data structure in
-- top-down manner.
proc' :: (Typeable a, Data b) => (a -> a) -> b -> b
proc' f = everywhere' (mkT f)
-- | A generic query function.
query :: (Typeable a, Data b) => (a -> [c]) -> b -> [c]
query f = everything (++) ([] `mkQ` f)
-- | Removes all given names form a 'OName' element with 'proc'.
rmGivenNames :: Output -> Output
rmGivenNames o
| OName i s _ f <- o = OName i s [] f
| otherwise = o
rmNameHash :: Output -> Output
rmNameHash o
| OName _ s ss f <- o = OName [] s ss f
| otherwise = o
-- | Add, with 'proc', a give name to the family name. Needed for
-- disambiguation.
addGivenNames :: [Output] -> [Output]
addGivenNames
= addGN True
where
addGN _ [] = []
addGN b (o:os)
| OName i _ xs f <- o
, xs /= [] = if b then OName i (head xs) (tail xs) f : addGN False os else o:os
| otherwise = o : addGN b os
-- | Add the year suffix to the year. Needed for disambiguation.
addYearSuffix :: Output -> Output
addYearSuffix o
| OYear y k f <- o = Output [OYear y k emptyFormatting,OYearSuf [] k [] emptyFormatting] f
| ODate (x:xs) <- o = if or $ map hasYear xs
then Output (x : [addYearSuffix $ ODate xs]) emptyFormatting
else addYearSuffix (Output (x:xs) emptyFormatting)
| Output (x:xs) f <- o = if or $ map hasYearSuf (x : xs)
then Output (x : xs) f
else if hasYear x
then Output (addYearSuffix x : xs) f
else Output (x : [addYearSuffix $ Output xs emptyFormatting]) f
| otherwise = o
hasYear :: Output -> Bool
hasYear = not . null . query getYear
where getYear o
| OYear _ _ _ <- o = [o]
| otherwise = []
hasYearSuf :: Output -> Bool
hasYearSuf = not . null . query getYearSuf
where getYearSuf o
| OYearSuf _ _ _ _ <- o = ["a"]
| otherwise = []
betterThen :: Eq a => [a] -> [a] -> [a]
betterThen a b = if a == [] then b else a