{-# LANGUAGE ViewPatterns      #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.CSL.Input.Name
-- Copyright   :  (c) John MacFarlane
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  John MacFarlane <fiddlosopher@gmail.com>
-- Stability   :  unstable
-- Portability :  portable
--
-----------------------------------------------------------------------------

module Text.Pandoc.Citeproc.Name
    ( toName
    , NameOpts(..)
    , emptyName
    )
    where

import Text.Pandoc.Definition
import Text.Pandoc.Shared (stringify)
import Citeproc.Types
import Citeproc.Pandoc ()
import Text.Pandoc.Citeproc.Util (splitStrWhen)
import qualified Data.Text              as T
import           Data.List.Split        (splitWhen, wordsBy)
import Data.Char (isUpper, isDigit)
import Data.List (foldl')

emptyName :: Name
emptyName :: Name
emptyName =
    Name {  nameFamily :: Maybe Text
nameFamily              = Maybe Text
forall a. Maybe a
Nothing
          , nameGiven :: Maybe Text
nameGiven               = Maybe Text
forall a. Maybe a
Nothing
          , nameDroppingParticle :: Maybe Text
nameDroppingParticle    = Maybe Text
forall a. Maybe a
Nothing
          , nameNonDroppingParticle :: Maybe Text
nameNonDroppingParticle = Maybe Text
forall a. Maybe a
Nothing
          , nameSuffix :: Maybe Text
nameSuffix              = Maybe Text
forall a. Maybe a
Nothing
          , nameLiteral :: Maybe Text
nameLiteral             = Maybe Text
forall a. Maybe a
Nothing
          , nameCommaSuffix :: Bool
nameCommaSuffix         = Bool
False
          , nameStaticOrdering :: Bool
nameStaticOrdering      = Bool
False
          }

-- | Options for 'toName'.
data NameOpts =
  NameOpts
    { NameOpts -> Bool
nameOptsPrefixIsNonDroppingParticle :: Bool
        -- ^ Treat a prefix on the last name as a non-dropping particle
        -- (default is to treat it as a dropping particle). This corresponds
        -- to the biblatex option @useprefix@.
    , NameOpts -> Bool
nameOptsUseJuniorComma              :: Bool
        -- ^ Put a comma before a suffix like "Jr." This corresponds to the
        -- biblatex option @juniorcomma@.
    } deriving (Int -> NameOpts -> ShowS
[NameOpts] -> ShowS
NameOpts -> String
(Int -> NameOpts -> ShowS)
-> (NameOpts -> String) -> ([NameOpts] -> ShowS) -> Show NameOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NameOpts -> ShowS
showsPrec :: Int -> NameOpts -> ShowS
$cshow :: NameOpts -> String
show :: NameOpts -> String
$cshowList :: [NameOpts] -> ShowS
showList :: [NameOpts] -> ShowS
Show)

-- | Parse a list of 'Inline's into a citeproc 'Name', identifying
-- first and last name, particles, suffixes.
toName :: Monad m => NameOpts -> [Inline] -> m Name
toName :: forall (m :: * -> *). Monad m => NameOpts -> [Inline] -> m Name
toName NameOpts
_ [Str Text
"others"] =
  Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
emptyName{ nameLiteral = Just "others" }
toName NameOpts
_ [Span (Text
"",[],[]) [Inline]
ils] = -- corporate author
  Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
emptyName{ nameLiteral = Just $ stringify ils }
-- extended BibLaTeX name format - see #266
toName NameOpts
_ ils :: [Inline]
ils@(Str Text
ys:[Inline]
_) | (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=') Text
ys = do
  let commaParts :: [[Inline]]
commaParts = (Inline -> Bool) -> [Inline] -> [[Inline]]
forall a. (a -> Bool) -> [a] -> [[a]]
splitWhen (Inline -> Inline -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Inline
Str Text
",")
                   ([Inline] -> [[Inline]])
-> ([Inline] -> [Inline]) -> [Inline] -> [[Inline]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Inline] -> [Inline]
splitStrWhen (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\160')
                   ([Inline] -> [[Inline]]) -> [Inline] -> [[Inline]]
forall a b. (a -> b) -> a -> b
$ [Inline]
ils
  let addPart :: Name -> [Inline] -> Name
addPart Name
ag (Str Text
"given" : Str Text
"=" : [Inline]
xs) =
        Name
ag{ nameGiven = case nameGiven ag of
                          Maybe Text
Nothing -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify [Inline]
xs
                          Just Text
t  -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify [Inline]
xs }
      addPart Name
ag (Str Text
"family" : Str Text
"=" : [Inline]
xs) =
        Name
ag{ nameFamily = Just $ stringify xs }
      addPart Name
ag (Str Text
"prefix" : Str Text
"=" : [Inline]
xs) =
        Name
ag{ nameDroppingParticle =  Just $ stringify xs }
      addPart Name
ag (Str Text
"useprefix" : Str Text
"=" : Str Text
"true" : [Inline]
_) =
        Name
ag{ nameNonDroppingParticle = nameDroppingParticle ag
          , nameDroppingParticle    = Nothing }
      addPart Name
ag (Str Text
"suffix" : Str Text
"=" : [Inline]
xs) =
        Name
ag{ nameSuffix = Just $ stringify xs }
      addPart Name
ag (Inline
Space : [Inline]
xs) = Name -> [Inline] -> Name
addPart Name
ag [Inline]
xs
      addPart Name
ag [Inline]
_ = Name
ag
  Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> m Name) -> Name -> m Name
forall a b. (a -> b) -> a -> b
$ (Name -> [Inline] -> Name) -> Name -> [[Inline]] -> Name
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Name -> [Inline] -> Name
addPart Name
emptyName [[Inline]]
commaParts
-- First von Last
-- von Last, First
-- von Last, Jr ,First
-- NOTE: biblatex and bibtex differ on:
-- Drummond de Andrade, Carlos
-- bibtex takes "Drummond de" as the von;
-- biblatex takes the whole as a last name.
-- See https://github.com/plk/biblatex/issues/236
-- Here we implement the more sensible biblatex behavior.
toName NameOpts
opts [Inline]
ils = do
  let words' :: [Inline] -> [[Inline]]
words' = (Inline -> Bool) -> [Inline] -> [[Inline]]
forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (\Inline
x -> Inline
x Inline -> Inline -> Bool
forall a. Eq a => a -> a -> Bool
== Inline
Space Bool -> Bool -> Bool
|| Inline
x Inline -> Inline -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Inline
Str Text
"\160")
  let commaParts :: [[[Inline]]]
commaParts = ([Inline] -> [[Inline]]) -> [[Inline]] -> [[[Inline]]]
forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> [[Inline]]
words' ([[Inline]] -> [[[Inline]]]) -> [[Inline]] -> [[[Inline]]]
forall a b. (a -> b) -> a -> b
$ (Inline -> Bool) -> [Inline] -> [[Inline]]
forall a. (a -> Bool) -> [a] -> [[a]]
splitWhen (Inline -> Inline -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Inline
Str Text
",")
                              ([Inline] -> [[Inline]]) -> [Inline] -> [[Inline]]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> [Inline] -> [Inline]
splitStrWhen
                                   (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\160') [Inline]
ils
  let ([[Inline]]
first, [[Inline]]
vonlast, [[Inline]]
jr) =
          case [[[Inline]]]
commaParts of
               --- First is the longest sequence of white-space separated
               -- words starting with an uppercase and that is not the
               -- whole string. von is the longest sequence of whitespace
               -- separated words whose last word starts with lower case
               -- and that is not the whole string.
               [[[Inline]]
fvl]      -> let ([[Inline]]
caps', [[Inline]]
rest') = ([Inline] -> Bool) -> [[Inline]] -> ([[Inline]], [[Inline]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span [Inline] -> Bool
isCapitalized [[Inline]]
fvl
                             in  if [[Inline]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Inline]]
rest' Bool -> Bool -> Bool
&& Bool -> Bool
not ([[Inline]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Inline]]
caps')
                                 then ([[Inline]] -> [[Inline]]
forall a. HasCallStack => [a] -> [a]
init [[Inline]]
caps', [[[Inline]] -> [Inline]
forall a. HasCallStack => [a] -> a
last [[Inline]]
caps'], [])
                                 else ([[Inline]]
caps', [[Inline]]
rest', [])
               [[[Inline]]
vl,[[Inline]]
f]     -> ([[Inline]]
f, [[Inline]]
vl, [])
               ([[Inline]]
vl:[[Inline]]
j:[[Inline]]
f:[[[Inline]]]
_) -> ([[Inline]]
f, [[Inline]]
vl, [[Inline]]
j )
               []         -> ([], [], [])

  let ([[Inline]]
von, [[Inline]]
lastname) =
                 case ([Inline] -> Bool) -> [[Inline]] -> ([[Inline]], [[Inline]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break [Inline] -> Bool
isCapitalized [[Inline]]
vonlast of
                        (vs :: [[Inline]]
vs@([Inline]
_:[[Inline]]
_), []) -> ([[Inline]] -> [[Inline]]
forall a. HasCallStack => [a] -> [a]
init [[Inline]]
vs, [[[Inline]] -> [Inline]
forall a. HasCallStack => [a] -> a
last [[Inline]]
vs])
                        ([[Inline]]
vs, [[Inline]]
ws)       -> ([[Inline]]
vs, [[Inline]]
ws)
  let prefix :: Text
prefix = [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ([Inline] -> Text) -> [[Inline]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify [[Inline]]
von
  let family :: Text
family = [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ([Inline] -> Text) -> [[Inline]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify [[Inline]]
lastname
  let suffix :: Text
suffix = [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ([Inline] -> Text) -> [[Inline]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify [[Inline]]
jr
  let given :: Text
given = [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ([Inline] -> Text) -> [[Inline]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify [[Inline]]
first
  Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    Name {  nameFamily :: Maybe Text
nameFamily              = if Text -> Bool
T.null Text
family
                                         then Maybe Text
forall a. Maybe a
Nothing
                                         else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
family
          , nameGiven :: Maybe Text
nameGiven               = if Text -> Bool
T.null Text
given
                                         then Maybe Text
forall a. Maybe a
Nothing
                                         else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
given
          , nameDroppingParticle :: Maybe Text
nameDroppingParticle    = if NameOpts -> Bool
nameOptsPrefixIsNonDroppingParticle NameOpts
opts Bool -> Bool -> Bool
||
                                          Text -> Bool
T.null Text
prefix
                                         then Maybe Text
forall a. Maybe a
Nothing
                                         else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
prefix
          , nameNonDroppingParticle :: Maybe Text
nameNonDroppingParticle = if NameOpts -> Bool
nameOptsPrefixIsNonDroppingParticle NameOpts
opts Bool -> Bool -> Bool
&&
                                          Bool -> Bool
not (Text -> Bool
T.null Text
prefix)
                                         then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
prefix
                                         else Maybe Text
forall a. Maybe a
Nothing
          , nameSuffix :: Maybe Text
nameSuffix              = if Text -> Bool
T.null Text
suffix
                                         then Maybe Text
forall a. Maybe a
Nothing
                                         else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
suffix
          , nameLiteral :: Maybe Text
nameLiteral             = Maybe Text
forall a. Maybe a
Nothing
          , nameCommaSuffix :: Bool
nameCommaSuffix         = NameOpts -> Bool
nameOptsUseJuniorComma NameOpts
opts
          , nameStaticOrdering :: Bool
nameStaticOrdering      = Bool
False
          }

isCapitalized :: [Inline] -> Bool
isCapitalized :: [Inline] -> Bool
isCapitalized (Str (Text -> Maybe (Char, Text)
T.uncons -> Just (Char
c,Text
cs)) : [Inline]
rest)
  | Char -> Bool
isUpper Char
c = Bool
True
  | Char -> Bool
isDigit Char
c = [Inline] -> Bool
isCapitalized (Text -> Inline
Str Text
cs Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
rest)
  | Bool
otherwise = Bool
False
isCapitalized (Inline
_:[Inline]
rest) = [Inline] -> Bool
isCapitalized [Inline]
rest
isCapitalized [] = Bool
True