{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Internal.CommentTable where

import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as LBC8
import Data.List.Extra (nubOrd)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Lazy (toStrict)
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B
import GHC.Generics (Generic)
import Safe
import Text.XML
import Text.XML.Cursor

import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Comment
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Writer.Internal

newtype CommentTable = CommentTable
    { CommentTable -> Map CellRef Comment
_commentsTable :: Map CellRef Comment }
    deriving (CommentTable -> CommentTable -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommentTable -> CommentTable -> Bool
$c/= :: CommentTable -> CommentTable -> Bool
== :: CommentTable -> CommentTable -> Bool
$c== :: CommentTable -> CommentTable -> Bool
Eq, Int -> CommentTable -> ShowS
[CommentTable] -> ShowS
CommentTable -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommentTable] -> ShowS
$cshowList :: [CommentTable] -> ShowS
show :: CommentTable -> String
$cshow :: CommentTable -> String
showsPrec :: Int -> CommentTable -> ShowS
$cshowsPrec :: Int -> CommentTable -> ShowS
Show, forall x. Rep CommentTable x -> CommentTable
forall x. CommentTable -> Rep CommentTable x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CommentTable x -> CommentTable
$cfrom :: forall x. CommentTable -> Rep CommentTable x
Generic)

tshow :: Show a => a -> Text
tshow :: forall a. Show a => a -> Text
tshow = String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

fromList :: [(CellRef, Comment)] -> CommentTable
fromList :: [(CellRef, Comment)] -> CommentTable
fromList = Map CellRef Comment -> CommentTable
CommentTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList

toList :: CommentTable -> [(CellRef, Comment)]
toList :: CommentTable -> [(CellRef, Comment)]
toList = forall k a. Map k a -> [(k, a)]
M.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommentTable -> Map CellRef Comment
_commentsTable

lookupComment :: CellRef -> CommentTable -> Maybe Comment
lookupComment :: CellRef -> CommentTable -> Maybe Comment
lookupComment CellRef
ref = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup CellRef
ref forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommentTable -> Map CellRef Comment
_commentsTable

instance ToDocument CommentTable where
  toDocument :: CommentTable -> Document
toDocument = Text -> Element -> Document
documentFromElement Text
"Sheet comments generated by xlsx"
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToElement a => Name -> a -> Element
toElement Name
"comments"

instance ToElement CommentTable where
  toElement :: Name -> CommentTable -> Element
toElement Name
nm (CommentTable Map CellRef Comment
m) = Element
      { elementName :: Name
elementName       = Name
nm
      , elementAttributes :: Map Name Text
elementAttributes = forall k a. Map k a
M.empty
      , elementNodes :: [Node]
elementNodes      = [ Element -> Node
NodeElement forall a b. (a -> b) -> a -> b
$ Name -> [Element] -> Element
elementListSimple Name
"authors" [Element]
authorNodes
                            , Element -> Node
NodeElement forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Element] -> Element
elementListSimple Name
"commentList" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. ToAttrVal a => (a, Comment) -> Element
commentToEl (forall k a. Map k a -> [(k, a)]
M.toList Map CellRef Comment
m) ]
      }
    where
      commentToEl :: (a, Comment) -> Element
commentToEl (a
ref, Comment{Bool
Text
XlsxText
_commentVisible :: Comment -> Bool
_commentAuthor :: Comment -> Text
_commentText :: Comment -> XlsxText
_commentVisible :: Bool
_commentAuthor :: Text
_commentText :: XlsxText
..}) = Element
          { elementName :: Name
elementName = Name
"comment"
          , elementAttributes :: Map Name Text
elementAttributes = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (Name
"ref" forall a. ToAttrVal a => Name -> a -> (Name, Text)
.= a
ref)
                                           , (Name
"authorId" forall a. ToAttrVal a => Name -> a -> (Name, Text)
.= Text -> Text
lookupAuthor Text
_commentAuthor)
                                           , (Name
"visible" forall a. ToAttrVal a => Name -> a -> (Name, Text)
.= forall a. Show a => a -> Text
tshow Bool
_commentVisible)]
          , elementNodes :: [Node]
elementNodes      = [Element -> Node
NodeElement forall a b. (a -> b) -> a -> b
$ forall a. ToElement a => Name -> a -> Element
toElement Name
"text" XlsxText
_commentText]
          }
      lookupAuthor :: Text -> Text
lookupAuthor Text
a = forall a. Partial => String -> Maybe a -> a
fromJustNote String
"author lookup" forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
a Map Text Text
authorIds
      authorNames :: [Text]
authorNames = forall a. Ord a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Comment -> Text
_commentAuthor forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems Map CellRef Comment
m
      decimalToText :: Integer -> Text
      decimalToText :: Integer -> Text
decimalToText = Text -> Text
toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
B.toLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Builder
B.decimal
      authorIds :: Map Text Text
authorIds = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
authorNames (forall a b. (a -> b) -> [a] -> [b]
map Integer -> Text
decimalToText [Integer
0..])
      authorNodes :: [Element]
authorNodes = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Text -> Element
elementContent Name
"author") [Text]
authorNames

instance FromCursor CommentTable where
  fromCursor :: Cursor -> [CommentTable]
fromCursor Cursor
cur = do
    let authorNames :: [Text]
authorNames = Cursor
cur forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
n_ Text
"authors") forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Axis
element (Text -> Name
n_ Text
"author") forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Cursor -> [Text]
contentOrEmpty
        authors :: Map Int Text
authors = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Text]
authorNames
        items :: [(CellRef, Comment)]
items = Cursor
cur forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
n_ Text
"commentList") forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Axis
element (Text -> Name
n_ Text
"comment") forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Map Int Text -> Cursor -> [(CellRef, Comment)]
parseComment Map Int Text
authors
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map CellRef Comment -> CommentTable
CommentTable forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(CellRef, Comment)]
items

parseComment :: Map Int Text -> Cursor -> [(CellRef, Comment)]
parseComment :: Map Int Text -> Cursor -> [(CellRef, Comment)]
parseComment Map Int Text
authors Cursor
cur = do
    CellRef
ref <- forall a. FromAttrVal a => Name -> Cursor -> [a]
fromAttribute Name
"ref" Cursor
cur
    XlsxText
txt <- Cursor
cur forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
n_ Text
"text") forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a. FromCursor a => Cursor -> [a]
fromCursor
    Int
authorId <- Cursor
cur forall node a. Cursor node -> (Cursor node -> a) -> a
$| Name -> Cursor -> [Text]
attribute Name
"authorId" forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *) a. (MonadFail m, Integral a) => Text -> m a
decimal
    Bool
visible <- (forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack :: Text -> Bool)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. FromAttrVal a => Name -> Cursor -> [a]
fromAttribute Name
"visible" Cursor
cur :: [Text])
    let author :: Text
author = forall a. Partial => String -> Maybe a -> a
fromJustNote String
"authorId" forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
authorId Map Int Text
authors
    forall (m :: * -> *) a. Monad m => a -> m a
return (CellRef
ref, XlsxText -> Text -> Bool -> Comment
Comment XlsxText
txt Text
author Bool
visible)

-- | helper to render comment baloons vml file,
-- currently uses fixed shape
renderShapes :: CommentTable -> ByteString
renderShapes :: CommentTable -> ByteString
renderShapes (CommentTable Map CellRef Comment
m) = [ByteString] -> ByteString
LB.concat
    [ ByteString
"<xml xmlns:v=\"urn:schemas-microsoft-com:vml\" "
    , ByteString
"xmlns:o=\"urn:schemas-microsoft-com:office:office\" "
    , ByteString
"xmlns:x=\"urn:schemas-microsoft-com:office:excel\">"
    , ByteString
commentShapeType
    , [ByteString] -> ByteString
LB.concat [ByteString]
commentShapes
    , ByteString
"</xml>"
    ]
  where
    commentShapeType :: ByteString
commentShapeType = [ByteString] -> ByteString
LB.concat
        [ ByteString
"<v:shapetype id=\"baloon\" coordsize=\"21600,21600\" o:spt=\"202\" "
        , ByteString
"path=\"m,l,21600r21600,l21600,xe\">"
        , ByteString
"<v:stroke joinstyle=\"miter\"></v:stroke>"
        , ByteString
"<v:path gradientshapeok=\"t\" o:connecttype=\"rect\"></v:path>"
        , ByteString
"</v:shapetype>"
        ]
    fromRef :: CellRef -> (RowIndex, ColumnIndex)
fromRef CellRef
cr =
      forall a. Partial => String -> Maybe a -> a
fromJustNote (String
"Invalid comment ref: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show CellRef
cr) forall a b. (a -> b) -> a -> b
$ CellRef -> Maybe (RowIndex, ColumnIndex)
fromSingleCellRef CellRef
cr
    commentShapes :: [ByteString]
commentShapes = [ forall {a} {a}.
(Show a, Show a, Num a, Num a) =>
(a, a) -> Bool -> ByteString
commentShape (CellRef -> (RowIndex, ColumnIndex)
fromRef CellRef
ref) (Comment -> Bool
_commentVisible Comment
cmnt)
                    | (CellRef
ref, Comment
cmnt) <- forall k a. Map k a -> [(k, a)]
M.toList Map CellRef Comment
m ]
    commentShape :: (a, a) -> Bool -> ByteString
commentShape (a
r, a
c) Bool
v = [ByteString] -> ByteString
LB.concat
        [ ByteString
"<v:shape type=\"#baloon\" "
        , ByteString
"style=\"position:absolute;width:auto" -- ;width:108pt;height:59.25pt"
        , if Bool
v then ByteString
"" else ByteString
";visibility:hidden"
        , ByteString
"\" fillcolor=\"#ffffe1\" o:insetmode=\"auto\">"
        , ByteString
"<v:fill color2=\"#ffffe1\"></v:fill><v:shadow color=\"black\" obscured=\"t\"></v:shadow>"
        , ByteString
"<v:path o:connecttype=\"none\"></v:path><v:textbox style=\"mso-direction-alt:auto\">"
        , ByteString
"<div style=\"text-align:left\"></div></v:textbox>"
        , ByteString
"<x:ClientData ObjectType=\"Note\">"
        , ByteString
"<x:MoveWithCells></x:MoveWithCells><x:SizeWithCells></x:SizeWithCells>"
        , ByteString
"<x:Anchor>4, 15, 0, 7, 6, 31, 5, 1</x:Anchor><x:AutoFill>False</x:AutoFill>"
        , ByteString
"<x:Row>"
        , String -> ByteString
LBC8.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (a
r forall a. Num a => a -> a -> a
- a
1)
        , ByteString
"</x:Row>"
        , ByteString
"<x:Column>"
        , String -> ByteString
LBC8.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (a
c forall a. Num a => a -> a -> a
- a
1)
        , ByteString
"</x:Column>"
        , ByteString
"</x:ClientData>"
        , ByteString
"</v:shape>"
        ]