content: {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {- |
     Module      : Text.Pandoc.Readers.Docx.Lists
     Copyright   : Copyright (C) 2014-2020 Jesse Rosenthal
     License     : GNU GPL, version 2 or above
  
     Maintainer  : Jesse Rosenthal <jrosenthal@jhu.edu>
     Stability   : alpha
     Portability : portable
  
  Functions for converting flat docx paragraphs into nested lists.
  -}
  
  module Text.Pandoc.Readers.Docx.Lists ( blocksToBullets
                                        , blocksToDefinitions
                                        , listParagraphDivs
                                        , listParagraphStyles
                                        ) where
  
  import Data.List
  import Data.Char (isDigit)
  import Data.Maybe
  import Data.String (fromString)
  import qualified Data.Text as T
  import Text.Pandoc.Walk (walk)
  import Text.Pandoc.JSON
  import Text.Pandoc.Readers.Docx.Parse (ParaStyleName)
  import Text.Pandoc.Shared (trim, safeRead)
  
  isListItem :: Block -> Bool
  isListItem (Div (_, classes, _) _) | "list-item" `elem` classes = True
  isListItem _                       = False
  
  getLevel :: Block -> Maybe Integer
  getLevel (Div (_, _, kvs) _) =  lookup "level" kvs >>= safeRead
  getLevel _                   = Nothing
  
  getLevelN :: Block -> Integer
  getLevelN b = fromMaybe (-1) (getLevel b)
  
  getNumId :: Block -> Maybe Integer
  getNumId (Div (_, _, kvs) _) =  lookup "num-id" kvs >>= safeRead
  getNumId _                   = Nothing
  
  getNumIdN :: Block -> Integer
  getNumIdN b = fromMaybe (-1) (getNumId b)
  
  getText :: Block -> Maybe T.Text
  getText (Div (_, _, kvs) _) = lookup "text" kvs
  getText _                   = Nothing
  
  data ListType = Itemized | Enumerated ListAttributes
  
  listStyleMap :: [(T.Text, ListNumberStyle)]
  listStyleMap = [("upperLetter", UpperAlpha),
                  ("lowerLetter", LowerAlpha),
                  ("upperRoman", UpperRoman),
                  ("lowerRoman", LowerRoman),
                  ("decimal", Decimal)]
  
  listDelimMap :: [(T.Text, ListNumberDelim)]
  listDelimMap = [("%)", OneParen),
                  ("(%)", TwoParens),
                  ("%.", Period)]
  
  getListType :: Block -> Maybe ListType
  getListType b@(Div (_, _, kvs) _) | isListItem b =
    let
      start = lookup "start" kvs
      frmt = lookup "format" kvs
      txt  = lookup "text" kvs
    in
     case frmt of
       Just "bullet" -> Just Itemized
       Just f        ->
         case T.filter (not . isDigit) <$> txt of
           Just t -> Just $ Enumerated (
                    fromMaybe 1 (start >>= safeRead) :: Int,
                    fromMaybe DefaultStyle (lookup f listStyleMap),
                    fromMaybe DefaultDelim (lookup t listDelimMap))
           Nothing -> Nothing
       _ -> Nothing
  getListType _ = Nothing
  
  listParagraphDivs :: [T.Text]
  listParagraphDivs = ["list-paragraph"]
  
  listParagraphStyles :: [ParaStyleName]
  listParagraphStyles = map (fromString . T.unpack) listParagraphDivs
  
  -- This is a first stab at going through and attaching meaning to list
  -- paragraphs, without an item marker, following a list item. We
  -- assume that these are paragraphs in the same item.
  
  handleListParagraphs :: [Block] -> [Block]
  handleListParagraphs [] = []
  handleListParagraphs (
    Div attr1@(_, classes1, _) blks1 :
    Div (ident2, classes2, kvs2) blks2 :
    blks
    ) | "list-item" `elem` classes1 &&
      notElem "list-item" classes2 &&
      (not . null) (listParagraphDivs `intersect` classes2) =
        -- We don't want to keep this indent.
        let newDiv2 =
              Div (ident2, classes2, filter (\kv -> fst kv /= "indent") kvs2) blks2
        in
         handleListParagraphs (Div attr1 (blks1 ++ [newDiv2]) : blks)
  handleListParagraphs (blk:blks) = blk : handleListParagraphs blks
  
  separateBlocks' :: Block -> [[Block]] -> [[Block]]
  separateBlocks' blk [[]] = [[blk]]
  separateBlocks' b@(BulletList _) acc = init acc ++ [last acc ++ [b]]
  separateBlocks' b@(OrderedList _ _) acc = init acc ++ [last acc ++ [b]]
  -- The following is for the invisible bullet lists. This is how
  -- pandoc-generated ooxml does multiparagraph item lists.
  separateBlocks' b acc | fmap trim (getText b) == Just "" =
    init acc ++ [last acc ++ [b]]
  separateBlocks' b acc = acc ++ [[b]]
  
  separateBlocks :: [Block] -> [[Block]]
  separateBlocks blks = foldr separateBlocks' [[]] (reverse blks)
  
  flatToBullets' :: Integer -> [Block] -> [Block]
  flatToBullets' _ [] = []
  flatToBullets' num xs@(b : elems) =
    if getLevelN b == num
       then (case bCheckmark of
               Just checked -> addCheckmark checked b
               Nothing -> b) : flatToBullets' num elems
       else case getListType b of
              Just (Enumerated attr) ->
                OrderedList attr (separateBlocks $ flatToBullets' bLevel children) :
                flatToBullets' num remaining
              _ ->
                BulletList (separateBlocks $ flatToBullets' bLevel children) :
                flatToBullets' num remaining
   where
    bNumId = getNumIdN b
    bLevel = getLevelN b
    isCheckmark (Just "\9744") = Just False
    isCheckmark (Just "\9746") = Just True
    isCheckmark _ = Nothing
    bCheckmark =
      case getListType b of
        Just Itemized -> isCheckmark (getText b)
        _ -> Nothing
    addCheckmark checked (Div attrs [Para ils]) =
      Div attrs [Para (Str (if checked then "\9746" else "\9744") : Space : ils)]
    addCheckmark checked (Div attrs [Plain ils]) =
      Div attrs [Plain (Str (if checked then "\9746" else "\9744") : Space : ils)]
    addCheckmark _ x = x
    (children, remaining) =
      span
      (\b' ->
        getLevelN b' > bLevel ||
         (getLevelN b' == bLevel &&
            (getNumIdN b' == bNumId ||
              (case bCheckmark of
                 Just _ ->
                   case getText b' of
                     Just "" -> True
                     Just " " -> True
                     Just x -> isJust (isCheckmark (Just x))
                     Nothing -> False
                 Nothing -> False))))
      xs
  
  flatToBullets :: [Block] -> [Block]
  flatToBullets elems = flatToBullets' (-1) elems
  
  singleItemHeaderToHeader :: Block -> Block
  singleItemHeaderToHeader (OrderedList _ [[h@Header{}]]) = h
  singleItemHeaderToHeader blk                            = blk
  
  
  blocksToBullets :: [Block] -> [Block]
  blocksToBullets blks =
    map singleItemHeaderToHeader $
    walk removeListDivs $ flatToBullets (handleListParagraphs blks)
  
  plainParaInlines :: Block -> [Inline]
  plainParaInlines (Plain ils) = ils
  plainParaInlines (Para ils)  = ils
  plainParaInlines _           = []
  
  blocksToDefinitions' :: [([Inline], [[Block]])] -> [Block] -> [Block] -> [Block]
  blocksToDefinitions' []     acc [] = reverse acc
  blocksToDefinitions' defAcc acc [] =
    reverse $ DefinitionList (reverse defAcc) : acc
  blocksToDefinitions' defAcc acc
    (Div (_, classes1, _) blks1 : Div (ident2, classes2, kvs2) blks2 : blks)
    | "Definition-Term" `elem` classes1 && "Definition"  `elem` classes2 =
      let remainingAttr2 = (ident2, delete "Definition" classes2, kvs2)
          pair = if remainingAttr2 == ("", [], []) then (concatMap plainParaInlines blks1, [blks2]) else (concatMap plainParaInlines blks1, [[Div remainingAttr2 blks2]])
      in
       blocksToDefinitions' (pair : defAcc) acc blks
  blocksToDefinitions' ((defTerm, defItems):defs) acc
    (Div (ident2, classes2, kvs2) blks2 : blks)
    | "Definition"  `elem` classes2 =
      let remainingAttr2 = (ident2, delete "Definition" classes2, kvs2)
          defItems2 = if remainingAttr2 == ("", [], [])
            then blks2
            else [Div remainingAttr2 blks2]
          defAcc' = if null defItems
            then (defTerm, [defItems2]) : defs
            else (defTerm, init defItems ++ [last defItems ++ defItems2]) : defs
      in
       blocksToDefinitions' defAcc' acc blks
  blocksToDefinitions' [] acc (b:blks) =
    blocksToDefinitions' [] (b:acc) blks
  blocksToDefinitions' defAcc acc (b:blks) =
    blocksToDefinitions' [] (b : DefinitionList (reverse defAcc) : acc) blks
  
  removeListDivs' :: Block -> [Block]
  removeListDivs' (Div (ident, classes, kvs) blks)
    | "list-item" `elem` classes =
      case delete "list-item" classes of
        []       -> blks
        classes' -> [Div (ident, classes', kvs) blks]
  removeListDivs' (Div (ident, classes, kvs) blks)
    | not $ null $ listParagraphDivs `intersect` classes =
      case classes \\ listParagraphDivs of
        []       -> blks
        classes' -> [Div (ident, classes', kvs) blks]
  removeListDivs' blk = [blk]
  
  removeListDivs :: [Block] -> [Block]
  removeListDivs = concatMap removeListDivs'
  
  blocksToDefinitions :: [Block] -> [Block]
  blocksToDefinitions = blocksToDefinitions' [] []
  