{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Pandoc.Citeproc.Locator
  ( parseLocator
  , toLocatorMap
  , LocatorInfo(..)
  , LocatorMap(..) )
where
import Citeproc.Types
import Text.Pandoc.Citeproc.Util (splitStrWhen)
import Data.Text (Text)
import qualified Data.Text as T
import Data.List (foldl')
import Text.Pandoc.Definition
import Text.Pandoc.Parsing
import Text.Pandoc.Shared (stringify)
import Control.Monad (mzero)
import qualified Data.Map as M
import Data.Char (isSpace, isPunctuation, isDigit)


data LocatorInfo =
  LocatorInfo{ LocatorInfo -> Text
locatorRaw :: Text
             , LocatorInfo -> Text
locatorLabel :: Text
             , LocatorInfo -> Text
locatorLoc :: Text
             }
  deriving (Int -> LocatorInfo -> ShowS
[LocatorInfo] -> ShowS
LocatorInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LocatorInfo] -> ShowS
$cshowList :: [LocatorInfo] -> ShowS
show :: LocatorInfo -> String
$cshow :: LocatorInfo -> String
showsPrec :: Int -> LocatorInfo -> ShowS
$cshowsPrec :: Int -> LocatorInfo -> ShowS
Show)

parseLocator :: LocatorMap -> [Inline] -> (Maybe LocatorInfo, [Inline])
parseLocator :: LocatorMap -> [Inline] -> (Maybe LocatorInfo, [Inline])
parseLocator LocatorMap
locmap [Inline]
inp =
  case forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (LocatorMap -> LocatorParser (Maybe LocatorInfo, [Inline])
pLocatorWords LocatorMap
locmap) String
"suffix" forall a b. (a -> b) -> a -> b
$ [Inline] -> [Inline]
splitInp [Inline]
inp of
       Right (Maybe LocatorInfo, [Inline])
r -> (Maybe LocatorInfo, [Inline])
r
       Left ParseError
_  -> (forall a. Maybe a
Nothing, [Inline] -> [Inline]
maybeAddComma [Inline]
inp)

splitInp :: [Inline] -> [Inline]
splitInp :: [Inline] -> [Inline]
splitInp = (Char -> Bool) -> [Inline] -> [Inline]
splitStrWhen (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| (Char -> Bool
isPunctuation Char
c Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
':'))

--
-- Locator parsing
--

type LocatorParser = Parsec [Inline] ()

pLocatorWords :: LocatorMap
              -> LocatorParser (Maybe LocatorInfo, [Inline])
pLocatorWords :: LocatorMap -> LocatorParser (Maybe LocatorInfo, [Inline])
pLocatorWords LocatorMap
locMap = do
  forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional forall a b. (a -> b) -> a -> b
$ String -> (Char -> Bool) -> LocatorParser Inline
pMatchChar String
"," (forall a. Eq a => a -> a -> Bool
== Char
',')
  forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional LocatorParser Inline
pSpace
  LocatorInfo
info <- LocatorMap -> ParsecT [Inline] () Identity LocatorInfo
pLocatorDelimited LocatorMap
locMap forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> LocatorMap -> ParsecT [Inline] () Identity LocatorInfo
pLocatorIntegrated LocatorMap
locMap
  [Inline]
s <- forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput -- rest is suffix
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    if Text -> Bool
T.null (LocatorInfo -> Text
locatorLabel LocatorInfo
info) Bool -> Bool -> Bool
&& Text -> Bool
T.null (LocatorInfo -> Text
locatorLoc LocatorInfo
info)
       then (forall a. Maybe a
Nothing, [Inline] -> [Inline]
maybeAddComma [Inline]
s)
       else (forall a. a -> Maybe a
Just LocatorInfo
info, [Inline]
s)

maybeAddComma :: [Inline] -> [Inline]
maybeAddComma :: [Inline] -> [Inline]
maybeAddComma [] = []
maybeAddComma ils :: [Inline]
ils@(Inline
Space : [Inline]
_) = [Inline]
ils
maybeAddComma ils :: [Inline]
ils@(Str Text
t : [Inline]
_)
  | Just (Char
c, Text
_) <- Text -> Maybe (Char, Text)
T.uncons Text
t
  , Char -> Bool
isPunctuation Char
c = [Inline]
ils
maybeAddComma [Inline]
ils = Text -> Inline
Str Text
"," forall a. a -> [a] -> [a]
: Inline
Space forall a. a -> [a] -> [a]
: [Inline]
ils

pLocatorDelimited :: LocatorMap -> LocatorParser LocatorInfo
pLocatorDelimited :: LocatorMap -> ParsecT [Inline] () Identity LocatorInfo
pLocatorDelimited LocatorMap
locMap = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
  Inline
_ <- String -> (Char -> Bool) -> LocatorParser Inline
pMatchChar String
"{" (forall a. Eq a => a -> a -> Bool
== Char
'{')
  forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany LocatorParser Inline
pSpace -- gobble pre-spaces so label doesn't try to include them
  (Text
rawlab, Text
la, Bool
_) <- LocatorMap -> LocatorParser (Text, Text, Bool)
pLocatorLabelDelimited LocatorMap
locMap
  -- we only care about balancing {} and [] (because of the outer [] scope);
  -- the rest can be anything
  let inner :: ParsecT [Inline] u Identity (Bool, Text)
inner = do { Inline
t <- forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m t
anyToken; forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, forall a. Walkable Inline a => a -> Text
stringify Inline
t) }
  [(Bool, Text)]
gs <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ([(Char, Char)]
-> LocatorParser (Bool, Text) -> LocatorParser (Bool, Text)
pBalancedBraces [(Char
'{',Char
'}'), (Char
'[',Char
']')] forall {u}. ParsecT [Inline] u Identity (Bool, Text)
inner)
  Inline
_ <- String -> (Char -> Bool) -> LocatorParser Inline
pMatchChar String
"}" (forall a. Eq a => a -> a -> Bool
== Char
'}')
  let lo :: Text
lo = [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, Text)]
gs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LocatorInfo{ locatorLoc :: Text
locatorLoc = Text
lo,
                        locatorLabel :: Text
locatorLabel = Text
la,
                        locatorRaw :: Text
locatorRaw = Text
rawlab forall a. Semigroup a => a -> a -> a
<> Text
"{" forall a. Semigroup a => a -> a -> a
<> Text
lo forall a. Semigroup a => a -> a -> a
<> Text
"}" }

pLocatorLabelDelimited :: LocatorMap -> LocatorParser (Text, Text, Bool)
pLocatorLabelDelimited :: LocatorMap -> LocatorParser (Text, Text, Bool)
pLocatorLabelDelimited LocatorMap
locMap
  = LocatorMap
-> LocatorParser Text -> LocatorParser (Text, Text, Bool)
pLocatorLabel' LocatorMap
locMap (forall a. Walkable Inline a => a -> Text
stringify forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m t
anyToken)
      forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ((Text
"", Text
"page", Bool
True) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (String -> (Char -> Bool) -> LocatorParser Inline
pMatchChar String
"digit" Char -> Bool
isDigit))
      forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"", Text
"", Bool
True))

pLocatorIntegrated :: LocatorMap -> LocatorParser LocatorInfo
pLocatorIntegrated :: LocatorMap -> ParsecT [Inline] () Identity LocatorInfo
pLocatorIntegrated LocatorMap
locMap = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
  (Text
rawlab, Text
la, Bool
wasImplicit) <- LocatorMap -> LocatorParser (Text, Text, Bool)
pLocatorLabelIntegrated LocatorMap
locMap
  -- if we got the label implicitly, we have presupposed the first one is
  -- going to have a digit, so guarantee that. You _can_ have p. (a)
  -- because you specified it.
  let modifier :: (Bool, Text) -> LocatorParser Text
modifier = if Bool
wasImplicit
                    then (Bool, Text) -> LocatorParser Text
requireDigits
                    else (Bool, Text) -> LocatorParser Text
requireRomansOrDigits
  Text
g <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ Bool -> LocatorParser (Bool, Text)
pLocatorWordIntegrated (Bool -> Bool
not Bool
wasImplicit) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool, Text) -> LocatorParser Text
modifier
  [Text]
gs <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ Bool -> LocatorParser (Bool, Text)
pLocatorWordIntegrated Bool
False forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool, Text) -> LocatorParser Text
modifier)
  let lo :: Text
lo = [Text] -> Text
T.concat (Text
gforall a. a -> [a] -> [a]
:[Text]
gs)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LocatorInfo{ locatorLabel :: Text
locatorLabel = Text
la,
                        locatorLoc :: Text
locatorLoc = Text
lo,
                        locatorRaw :: Text
locatorRaw = Text
rawlab forall a. Semigroup a => a -> a -> a
<> Text
lo }

pLocatorLabelIntegrated :: LocatorMap -> LocatorParser (Text, Text, Bool)
pLocatorLabelIntegrated :: LocatorMap -> LocatorParser (Text, Text, Bool)
pLocatorLabelIntegrated LocatorMap
locMap
  = LocatorMap
-> LocatorParser Text -> LocatorParser (Text, Text, Bool)
pLocatorLabel' LocatorMap
locMap LocatorParser Text
lim forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
     (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead LocatorParser Text
digital forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"", Text
"page", Bool
True))
    where
      lim :: LocatorParser Text
lim = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ Bool -> LocatorParser (Bool, Text)
pLocatorWordIntegrated Bool
True forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool, Text) -> LocatorParser Text
requireRomansOrDigits
      digital :: LocatorParser Text
digital = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ Bool -> LocatorParser (Bool, Text)
pLocatorWordIntegrated Bool
True forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool, Text) -> LocatorParser Text
requireDigits

pLocatorLabel' :: LocatorMap -> LocatorParser Text
               -> LocatorParser (Text, Text, Bool)
pLocatorLabel' :: LocatorMap
-> LocatorParser Text -> LocatorParser (Text, Text, Bool)
pLocatorLabel' LocatorMap
locMap LocatorParser Text
lim = Text -> LocatorParser (Text, Text, Bool)
go Text
""
    where
      -- grow the match string until we hit the end
      -- trying to find the largest match for a label
      go :: Text -> LocatorParser (Text, Text, Bool)
go Text
acc = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
          -- advance at least one token each time
          -- the pathological case is "p.3"
          Inline
t <- forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m t
anyToken
          [Inline]
ts <- forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m t
anyToken (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead LocatorParser Text
lim)
          let s :: Text
s = Text
acc forall a. Semigroup a => a -> a -> a
<> forall a. Walkable Inline a => a -> Text
stringify (Inline
tforall a. a -> [a] -> [a]
:[Inline]
ts)
          case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> Text
T.toCaseFold forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
s) (LocatorMap -> Map Text Text
unLocatorMap LocatorMap
locMap) of
            -- try to find a longer one, or return this one
            Just Text
l -> Text -> LocatorParser (Text, Text, Bool)
go Text
s forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (Text
s, Text
l, Bool
False)
            Maybe Text
Nothing -> Text -> LocatorParser (Text, Text, Bool)
go Text
s

-- hard requirement for a locator to have some real digits in it
requireDigits :: (Bool, Text) -> LocatorParser Text
requireDigits :: (Bool, Text) -> LocatorParser Text
requireDigits (Bool
_, Text
s) = if Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
T.any Char -> Bool
isDigit Text
s)
                          then forall (m :: * -> *) a. MonadFail m => String -> m a
Prelude.fail String
"requireDigits"
                          else forall (m :: * -> *) a. Monad m => a -> m a
return Text
s

-- soft requirement for a sequence with some roman or arabic parts
-- (a)(iv) -- because iv is roman
-- 1(a)  -- because 1 is an actual digit
-- NOT: a, (a)-(b), hello, (some text in brackets)
requireRomansOrDigits :: (Bool, Text) -> LocatorParser Text
requireRomansOrDigits :: (Bool, Text) -> LocatorParser Text
requireRomansOrDigits (Bool
d, Text
s) = if Bool -> Bool
not Bool
d
                                  then forall (m :: * -> *) a. MonadFail m => String -> m a
Prelude.fail String
"requireRomansOrDigits"
                                  else forall (m :: * -> *) a. Monad m => a -> m a
return Text
s

pLocatorWordIntegrated :: Bool -> LocatorParser (Bool, Text)
pLocatorWordIntegrated :: Bool -> LocatorParser (Bool, Text)
pLocatorWordIntegrated Bool
isFirst = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
  Text
punct <- if Bool
isFirst
              then forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
              else (forall a. Walkable Inline a => a -> Text
stringify forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocatorParser Inline
pLocatorSep) forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
  Text
sp <- forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Text
"" (LocatorParser Inline
pSpace forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Text
" ")
  (Bool
dig, Text
s) <- [(Char, Char)]
-> LocatorParser (Bool, Text) -> LocatorParser (Bool, Text)
pBalancedBraces [(Char
'(',Char
')'), (Char
'[',Char
']'), (Char
'{',Char
'}')] LocatorParser (Bool, Text)
pPageSeq
  forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
dig, Text
punct forall a. Semigroup a => a -> a -> a
<> Text
sp forall a. Semigroup a => a -> a -> a
<> Text
s)

-- we want to capture:  123, 123A, C22, XVII, 33-44, 22-33; 22-11
--                      34(1), 34A(A), 34(1)(i)(i), (1)(a)
--                      [17], [17]-[18], '591 [84]'
--                      (because CSL cannot pull out individual pages/sections
--                      to wrap in braces on a per-style basis)
pBalancedBraces :: [(Char, Char)]
                -> LocatorParser (Bool, Text)
                -> LocatorParser (Bool, Text)
pBalancedBraces :: [(Char, Char)]
-> LocatorParser (Bool, Text) -> LocatorParser (Bool, Text)
pBalancedBraces [(Char, Char)]
braces LocatorParser (Bool, Text)
p = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
  [(Bool, Text)]
ss <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 LocatorParser (Bool, Text)
surround
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(Bool, Text)] -> (Bool, Text)
anyWereDigitLike [(Bool, Text)]
ss
  where
      except :: LocatorParser (Bool, Text)
except = forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy LocatorParser Inline
pBraces forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LocatorParser (Bool, Text)
p
      -- outer and inner
      surround :: LocatorParser (Bool, Text)
surround = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\LocatorParser (Bool, Text)
a (Char
open, Char
close) -> Char
-> Char -> LocatorParser (Bool, Text) -> LocatorParser (Bool, Text)
sur Char
open Char
close LocatorParser (Bool, Text)
except forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> LocatorParser (Bool, Text)
a)
                       LocatorParser (Bool, Text)
except
                       [(Char, Char)]
braces

      isc :: Char -> LocatorParser Text
isc Char
c = forall a. Walkable Inline a => a -> Text
stringify forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> (Char -> Bool) -> LocatorParser Inline
pMatchChar [Char
c] (forall a. Eq a => a -> a -> Bool
== Char
c)

      sur :: Char
-> Char -> LocatorParser (Bool, Text) -> LocatorParser (Bool, Text)
sur Char
c Char
c' LocatorParser (Bool, Text)
m = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
          (Bool
d, Text
mid) <- Char -> LocatorParser Text
isc Char
c forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option (Bool
False, Text
"") LocatorParser (Bool, Text)
m forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> LocatorParser Text
isc Char
c'
          forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
d, Char -> Text -> Text
T.cons Char
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Char -> Text
T.snoc Char
c' forall a b. (a -> b) -> a -> b
$  Text
mid)

      flattened :: String
flattened = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Char
o, Char
c) -> [Char
o, Char
c]) [(Char, Char)]
braces
      pBraces :: LocatorParser Inline
pBraces = String -> (Char -> Bool) -> LocatorParser Inline
pMatchChar String
"braces" (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
flattened)


-- YES 1, 1.2, 1.2.3
-- NO  1., 1.2. a.6
-- can't use sepBy because we want to leave trailing .s
pPageSeq :: LocatorParser (Bool, Text)
pPageSeq :: LocatorParser (Bool, Text)
pPageSeq = LocatorParser (Bool, Text)
oneDotTwo forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> LocatorParser (Bool, Text)
withPeriod
  where
      oneDotTwo :: LocatorParser (Bool, Text)
oneDotTwo = do
          (Bool, Text)
u <- LocatorParser (Bool, Text)
pPageUnit
          [(Bool, Text)]
us <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many LocatorParser (Bool, Text)
withPeriod
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(Bool, Text)] -> (Bool, Text)
anyWereDigitLike ((Bool, Text)
uforall a. a -> [a] -> [a]
:[(Bool, Text)]
us)
      withPeriod :: LocatorParser (Bool, Text)
withPeriod = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
          -- .2
          Inline
p <- String -> (Char -> Bool) -> LocatorParser Inline
pMatchChar String
"." (forall a. Eq a => a -> a -> Bool
== Char
'.')
          (Bool, Text)
u <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try LocatorParser (Bool, Text)
pPageUnit
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a, b) -> a
fst (Bool, Text)
u, forall a. Walkable Inline a => a -> Text
stringify Inline
p forall a. Semigroup a => a -> a -> a
<> forall a b. (a, b) -> b
snd (Bool, Text)
u)

anyWereDigitLike :: [(Bool, Text)] -> (Bool, Text)
anyWereDigitLike :: [(Bool, Text)] -> (Bool, Text)
anyWereDigitLike [(Bool, Text)]
as = (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a b. (a, b) -> a
fst [(Bool, Text)]
as, [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, Text)]
as)

pPageUnit :: LocatorParser (Bool, Text)
pPageUnit :: LocatorParser (Bool, Text)
pPageUnit = LocatorParser (Bool, Text)
roman forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> LocatorParser (Bool, Text)
plainUnit
  where
      -- roman is a 'digit'
      roman :: LocatorParser (Bool, Text)
roman = (Bool
True,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocatorParser Text
pRoman
      plainUnit :: LocatorParser (Bool, Text)
plainUnit = do
          [Inline]
ts <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy LocatorParser Inline
pSpace forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                       forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy LocatorParser Inline
pLocatorPunct forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                       forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy LocatorParser Inline
pMath forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                       forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m t
anyToken)
          let s :: Text
s = forall a. Walkable Inline a => a -> Text
stringify [Inline]
ts
          -- otherwise look for actual digits or -s
          forall (m :: * -> *) a. Monad m => a -> m a
return ((Char -> Bool) -> Text -> Bool
T.any Char -> Bool
isDigit Text
s, Text
s)

pRoman :: LocatorParser Text
pRoman :: LocatorParser Text
pRoman = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
  Inline
tok <- forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m t
anyToken
  case Inline
tok of
       Str Text
t -> case forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (forall s (m :: * -> *) st.
(Stream s m Char, UpdateSourcePos s Char) =>
Bool -> ParsecT s st m Int
romanNumeral Bool
True forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof)
                   String
"roman numeral" (Text -> Text
T.toUpper Text
t) of
                      Left ParseError
_    -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
                      Right ()  -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
       Inline
_      -> forall (m :: * -> *) a. MonadPlus m => m a
mzero

pLocatorPunct :: LocatorParser Inline
pLocatorPunct :: LocatorParser Inline
pLocatorPunct = String -> (Char -> Bool) -> LocatorParser Inline
pMatchChar String
"punctuation" Char -> Bool
isLocatorPunct

pLocatorSep :: LocatorParser Inline
pLocatorSep :: LocatorParser Inline
pLocatorSep = String -> (Char -> Bool) -> LocatorParser Inline
pMatchChar String
"locator separator" Char -> Bool
isLocatorSep

pMatchChar :: String -> (Char -> Bool) -> LocatorParser Inline
pMatchChar :: String -> (Char -> Bool) -> LocatorParser Inline
pMatchChar String
msg Char -> Bool
f = (Inline -> Bool) -> LocatorParser Inline
satisfyTok Inline -> Bool
f' forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
msg
    where
        f' :: Inline -> Bool
f' (Str (Text -> String
T.unpack -> [Char
c])) = Char -> Bool
f Char
c
        f' Inline
_                       = Bool
False

pSpace :: LocatorParser Inline
pSpace :: LocatorParser Inline
pSpace = (Inline -> Bool) -> LocatorParser Inline
satisfyTok (\Inline
t -> Inline -> Bool
isSpacey Inline
t Bool -> Bool -> Bool
|| Inline
t forall a. Eq a => a -> a -> Bool
== Text -> Inline
Str Text
"\160") forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"space"

pMath :: LocatorParser Inline
pMath :: LocatorParser Inline
pMath = (Inline -> Bool) -> LocatorParser Inline
satisfyTok Inline -> Bool
isMath
 where
  isMath :: Inline -> Bool
isMath (Math{}) = Bool
True
  isMath Inline
_ = Bool
False

satisfyTok :: (Inline -> Bool) -> LocatorParser Inline
satisfyTok :: (Inline -> Bool) -> LocatorParser Inline
satisfyTok Inline -> Bool
f = forall s (m :: * -> *) t a u.
Stream s m t =>
(t -> String)
-> (SourcePos -> t -> s -> SourcePos)
-> (t -> Maybe a)
-> ParsecT s u m a
tokenPrim forall a. Show a => a -> String
show (\SourcePos
sp Inline
_ [Inline]
_ -> SourcePos
sp) (\Inline
tok -> if Inline -> Bool
f Inline
tok
                                                          then forall a. a -> Maybe a
Just Inline
tok
                                                          else forall a. Maybe a
Nothing)

isSpacey :: Inline -> Bool
isSpacey :: Inline -> Bool
isSpacey Inline
Space     = Bool
True
isSpacey Inline
SoftBreak = Bool
True
isSpacey Inline
_         = Bool
False

isLocatorPunct :: Char -> Bool
isLocatorPunct :: Char -> Bool
isLocatorPunct Char
'-' = Bool
False -- page range
isLocatorPunct Char
'–' = Bool
False -- page range, en dash
isLocatorPunct Char
':' = Bool
False -- vol:page-range hack
isLocatorPunct Char
c   = Char -> Bool
isPunctuation Char
c -- includes [{()}]

isLocatorSep :: Char -> Bool
isLocatorSep :: Char -> Bool
isLocatorSep Char
',' = Bool
True
isLocatorSep Char
';' = Bool
True
isLocatorSep Char
_   = Bool
False

--
-- Locator Map
--

newtype LocatorMap = LocatorMap { LocatorMap -> Map Text Text
unLocatorMap :: M.Map Text Text }
  deriving (Int -> LocatorMap -> ShowS
[LocatorMap] -> ShowS
LocatorMap -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LocatorMap] -> ShowS
$cshowList :: [LocatorMap] -> ShowS
show :: LocatorMap -> String
$cshow :: LocatorMap -> String
showsPrec :: Int -> LocatorMap -> ShowS
$cshowsPrec :: Int -> LocatorMap -> ShowS
Show)

toLocatorMap :: Locale -> LocatorMap
toLocatorMap :: Locale -> LocatorMap
toLocatorMap Locale
locale =
  Map Text Text -> LocatorMap
LocatorMap forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> Map Text Text -> Map Text Text
go forall a. Monoid a => a
mempty [Text]
locatorTerms
 where
  go :: Text -> Map Text Text -> Map Text Text
go Text
tname Map Text Text
locmap =
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
tname (Locale -> Map Text [(Term, Text)]
localeTerms Locale
locale) of
      Maybe [(Term, Text)]
Nothing -> Map Text Text
locmap
      Just [(Term, Text)]
ts -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Term, Text)
x -> forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Text -> Text
T.toCaseFold forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (Term, Text)
x) Text
tname) Map Text Text
locmap [(Term, Text)]
ts
-- we store keys in "case-folded" (lowercase) form, so that both
-- "Chap." and "chap." will match, for example.

locatorTerms :: [Text]
locatorTerms :: [Text]
locatorTerms =
  [ Text
"book"
  , Text
"chapter"
  , Text
"column"
  , Text
"figure"
  , Text
"folio"
  , Text
"issue"
  , Text
"line"
  , Text
"note"
  , Text
"opus"
  , Text
"page"
  , Text
"number-of-pages"
  , Text
"paragraph"
  , Text
"part"
  , Text
"section"
  , Text
"sub-verbo"
  , Text
"verse"
  , Text
"volume" ]