module Text.CSL.Style where
import Data.List ( nubBy, isPrefixOf )
import Data.Generics ( Typeable, Data, everywhere
, everywhere', everything, mkT, mkQ)
import qualified Data.Map as M
import Text.JSON
import Text.Pandoc.Definition ( Inline )
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]
, localeTermMap :: [TermMap]
, localeDate :: [Element]
} deriving ( Show, Read, Eq, Typeable, Data )
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
, localeTermMap = newTermMap x
, localeDate = newDate x
}
newOpt x = nubBy (\a b -> fst a == fst b) (concatMap localeOptions x ++ localeOptions l)
newTermMap x = nubBy (\a b -> fst a == fst b) (concatMap localeTermMap x ++ localeTermMap l)
newDate x = nubBy (\(Date _ a _ _ _ _)
(Date _ b _ _ _ _) -> a == b) (concatMap localeDate x ++ localeDate l)
type Abbrev
= (String, [(String, M.Map String String)])
type TermMap
= ((String,Form),(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
| ShortNames [String] Formatting Delimiter
| 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
('-','-') -> compare y x
('-', _ ) -> LT
(_ ,'-') -> GT
_ -> compare x y
data Form
= Long
| Short
| Count
| Verb
| VerbShort
| Symbol
| NotSet
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 :: Bool
, stripPeriods :: Bool
, noCase :: Bool
, noDecor :: Bool
} deriving ( Read, Eq, Ord, Typeable, Data )
instance Show Formatting where show _ = "emptyFormatting"
emptyFormatting :: Formatting
emptyFormatting
= Formatting [] [] [] [] [] [] [] [] [] [] False 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 /= ak then bk else ak)
(if bl /= al then bl else al)
(if bm /= am then bm else am)
(if bn /= an then bn else 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 )
data FormattedOutput
= FO Formatting [FormattedOutput]
| FN String Formatting
| FS String Formatting
| FUrl String Formatting
| FDel String
| FPan [Inline]
| FNull
deriving ( Eq, Show )
data Output
= ONull
| OSpace
| OPan [Inline]
| ODel String
| OStr String Formatting
| ONum Int Formatting
| OCitNum Int Formatting
| OYear String String Formatting
| OYearSuf String String [Output] Formatting
| OName String [Output] [[Output]] Formatting
| OContrib String String [Output] [Output] [[Output]]
| OUrl String Formatting
| OLoc [Output] Formatting
| Output [Output] Formatting
deriving ( Eq, Ord, Show, Typeable, Data )
data Affix
= PlainText String
| PandocText [Inline]
deriving ( Show, Read, Eq, Ord, Typeable, Data )
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
data CitationGroup = CG [(Cite, Output)] Formatting Delimiter [(Cite, Output)] deriving ( Show, Eq, Typeable, Data )
data BiblioData
= BD
{ citations :: [[FormattedOutput]]
, bibliography :: [[FormattedOutput]]
} deriving ( Show )
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
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
| 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
mapGroupOutput :: (Output -> [a]) -> CitationGroup -> [a]
mapGroupOutput f (CG _ _ _ os) = concatMap f $ map snd os
proc :: (Typeable a, Data b) => (a -> a) -> b -> b
proc f = everywhere (mkT f)
proc' :: (Typeable a, Data b) => (a -> a) -> b -> b
proc' f = everywhere' (mkT f)
query :: (Typeable a, Data b) => (a -> [c]) -> b -> [c]
query f = everything (++) ([] `mkQ` f)
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
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
addYearSuffix :: Output -> Output
addYearSuffix o
| OYear y k f <- o = Output [OYear y k emptyFormatting,OYearSuf [] k [] emptyFormatting] f
| 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