{-# 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              = forall a. Maybe a
Nothing
          , nameGiven :: Maybe Text
nameGiven               = forall a. Maybe a
Nothing
          , nameDroppingParticle :: Maybe Text
nameDroppingParticle    = forall a. Maybe a
Nothing
          , nameNonDroppingParticle :: Maybe Text
nameNonDroppingParticle = forall a. Maybe a
Nothing
          , nameSuffix :: Maybe Text
nameSuffix              = forall a. Maybe a
Nothing
          , nameLiteral :: Maybe Text
nameLiteral             = 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NameOpts] -> ShowS
$cshowList :: [NameOpts] -> ShowS
show :: NameOpts -> String
$cshow :: NameOpts -> String
showsPrec :: Int -> NameOpts -> ShowS
$cshowsPrec :: Int -> 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"] =
  forall (m :: * -> *) a. Monad m => a -> m a
return Name
emptyName{ nameLiteral :: Maybe Text
nameLiteral = forall a. a -> Maybe a
Just Text
"others" }
toName NameOpts
_ [Span (Text
"",[],[]) [Inline]
ils] = -- corporate author
  forall (m :: * -> *) a. Monad m => a -> m a
return Name
emptyName{ nameLiteral :: Maybe Text
nameLiteral = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Walkable Inline a => a -> Text
stringify [Inline]
ils }
-- extended BibLaTeX name format - see #266
toName NameOpts
_ ils :: [Inline]
ils@(Str Text
ys:[Inline]
_) | (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
'=') Text
ys = do
  let commaParts :: [[Inline]]
commaParts = forall a. (a -> Bool) -> [a] -> [[a]]
splitWhen (forall a. Eq a => a -> a -> Bool
== Text -> Inline
Str Text
",")
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Inline] -> [Inline]
splitStrWhen (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'=' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\160')
                   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 :: Maybe Text
nameGiven = case Name -> Maybe Text
nameGiven Name
ag of
                          Maybe Text
Nothing -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Walkable Inline a => a -> Text
stringify [Inline]
xs
                          Just Text
t  -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
t forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Walkable Inline a => a -> Text
stringify [Inline]
xs }
      addPart Name
ag (Str Text
"family" : Str Text
"=" : [Inline]
xs) =
        Name
ag{ nameFamily :: Maybe Text
nameFamily = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Walkable Inline a => a -> Text
stringify [Inline]
xs }
      addPart Name
ag (Str Text
"prefix" : Str Text
"=" : [Inline]
xs) =
        Name
ag{ nameDroppingParticle :: Maybe Text
nameDroppingParticle =  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Walkable Inline a => a -> Text
stringify [Inline]
xs }
      addPart Name
ag (Str Text
"useprefix" : Str Text
"=" : Str Text
"true" : [Inline]
_) =
        Name
ag{ nameNonDroppingParticle :: Maybe Text
nameNonDroppingParticle = Name -> Maybe Text
nameDroppingParticle Name
ag
          , nameDroppingParticle :: Maybe Text
nameDroppingParticle    = forall a. Maybe a
Nothing }
      addPart Name
ag (Str Text
"suffix" : Str Text
"=" : [Inline]
xs) =
        Name
ag{ nameSuffix :: Maybe Text
nameSuffix = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Walkable Inline a => a -> Text
stringify [Inline]
xs }
      addPart Name
ag (Inline
Space : [Inline]
xs) = Name -> [Inline] -> Name
addPart Name
ag [Inline]
xs
      addPart Name
ag [Inline]
_ = Name
ag
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> 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' = forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (\Inline
x -> Inline
x forall a. Eq a => a -> a -> Bool
== Inline
Space Bool -> Bool -> Bool
|| Inline
x forall a. Eq a => a -> a -> Bool
== Text -> Inline
Str Text
"\160")
  let commaParts :: [[[Inline]]]
commaParts = forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> [[Inline]]
words' forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [[a]]
splitWhen (forall a. Eq a => a -> a -> Bool
== Text -> Inline
Str Text
",")
                              forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> [Inline] -> [Inline]
splitStrWhen
                                   (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Char
c 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') = forall a. (a -> Bool) -> [a] -> ([a], [a])
span [Inline] -> Bool
isCapitalized [[Inline]]
fvl
                             in  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Inline]]
rest' Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Inline]]
caps')
                                 then (forall a. [a] -> [a]
init [[Inline]]
caps', [forall a. [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 forall a. (a -> Bool) -> [a] -> ([a], [a])
break [Inline] -> Bool
isCapitalized [[Inline]]
vonlast of
                        (vs :: [[Inline]]
vs@([Inline]
_:[[Inline]]
_), []) -> (forall a. [a] -> [a]
init [[Inline]]
vs, [forall a. [a] -> a
last [[Inline]]
vs])
                        ([[Inline]]
vs, [[Inline]]
ws)       -> ([[Inline]]
vs, [[Inline]]
ws)
  let prefix :: Text
prefix = [Text] -> Text
T.unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Walkable Inline a => a -> Text
stringify [[Inline]]
von
  let family :: Text
family = [Text] -> Text
T.unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Walkable Inline a => a -> Text
stringify [[Inline]]
lastname
  let suffix :: Text
suffix = [Text] -> Text
T.unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Walkable Inline a => a -> Text
stringify [[Inline]]
jr
  let given :: Text
given = [Text] -> Text
T.unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Walkable Inline a => a -> Text
stringify [[Inline]]
first
  forall (m :: * -> *) a. Monad m => a -> m a
return
    Name {  nameFamily :: Maybe Text
nameFamily              = if Text -> Bool
T.null Text
family
                                         then forall a. Maybe a
Nothing
                                         else forall a. a -> Maybe a
Just Text
family
          , nameGiven :: Maybe Text
nameGiven               = if Text -> Bool
T.null Text
given
                                         then forall a. Maybe a
Nothing
                                         else 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 forall a. Maybe a
Nothing
                                         else 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 forall a. a -> Maybe a
Just Text
prefix
                                         else forall a. Maybe a
Nothing
          , nameSuffix :: Maybe Text
nameSuffix              = if Text -> Bool
T.null Text
suffix
                                         then forall a. Maybe a
Nothing
                                         else forall a. a -> Maybe a
Just Text
suffix
          , nameLiteral :: Maybe Text
nameLiteral             = 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 forall a. a -> [a] -> [a]
: [Inline]
rest)
  | Bool
otherwise = Bool
False
isCapitalized (Inline
_:[Inline]
rest) = [Inline] -> Bool
isCapitalized [Inline]
rest
isCapitalized [] = Bool
True