{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.PivotTable.Internal
  ( CacheId(..)
  , CacheField(..)
  , CacheRecordValue(..)
  , CacheRecord
  , recordValueFromNode
  ) where

import GHC.Generics (Generic)

import Control.Arrow (first)
import Data.Maybe (catMaybes)
import Data.Text (Text)
import Text.XML
import Text.XML.Cursor

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

newtype CacheId = CacheId Int deriving (CacheId -> CacheId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheId -> CacheId -> Bool
$c/= :: CacheId -> CacheId -> Bool
== :: CacheId -> CacheId -> Bool
$c== :: CacheId -> CacheId -> Bool
Eq, forall x. Rep CacheId x -> CacheId
forall x. CacheId -> Rep CacheId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CacheId x -> CacheId
$cfrom :: forall x. CacheId -> Rep CacheId x
Generic)

data CacheField = CacheField
  { CacheField -> PivotFieldName
cfName :: PivotFieldName
  , CacheField -> [CellValue]
cfItems :: [CellValue]
  } deriving (CacheField -> CacheField -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheField -> CacheField -> Bool
$c/= :: CacheField -> CacheField -> Bool
== :: CacheField -> CacheField -> Bool
$c== :: CacheField -> CacheField -> Bool
Eq, Int -> CacheField -> ShowS
[CacheField] -> ShowS
CacheField -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CacheField] -> ShowS
$cshowList :: [CacheField] -> ShowS
show :: CacheField -> String
$cshow :: CacheField -> String
showsPrec :: Int -> CacheField -> ShowS
$cshowsPrec :: Int -> CacheField -> ShowS
Show, forall x. Rep CacheField x -> CacheField
forall x. CacheField -> Rep CacheField x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CacheField x -> CacheField
$cfrom :: forall x. CacheField -> Rep CacheField x
Generic)

data CacheRecordValue
  = CacheText Text
  | CacheNumber Double
  | CacheIndex Int
  deriving (CacheRecordValue -> CacheRecordValue -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheRecordValue -> CacheRecordValue -> Bool
$c/= :: CacheRecordValue -> CacheRecordValue -> Bool
== :: CacheRecordValue -> CacheRecordValue -> Bool
$c== :: CacheRecordValue -> CacheRecordValue -> Bool
Eq, Int -> CacheRecordValue -> ShowS
[CacheRecordValue] -> ShowS
CacheRecordValue -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CacheRecordValue] -> ShowS
$cshowList :: [CacheRecordValue] -> ShowS
show :: CacheRecordValue -> String
$cshow :: CacheRecordValue -> String
showsPrec :: Int -> CacheRecordValue -> ShowS
$cshowsPrec :: Int -> CacheRecordValue -> ShowS
Show, forall x. Rep CacheRecordValue x -> CacheRecordValue
forall x. CacheRecordValue -> Rep CacheRecordValue x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CacheRecordValue x -> CacheRecordValue
$cfrom :: forall x. CacheRecordValue -> Rep CacheRecordValue x
Generic)

type CacheRecord = [CacheRecordValue]

{-------------------------------------------------------------------------------
  Parsing
-------------------------------------------------------------------------------}

instance FromAttrVal CacheId where
  fromAttrVal :: Reader CacheId
fromAttrVal = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Int -> CacheId
CacheId) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromAttrVal a => Reader a
fromAttrVal

instance FromCursor CacheField where
  fromCursor :: Cursor -> [CacheField]
fromCursor Cursor
cur = do
    PivotFieldName
cfName <- forall a. FromAttrVal a => Name -> Cursor -> [a]
fromAttribute Name
"name" Cursor
cur
    let cfItems :: [CellValue]
cfItems =
          Cursor
cur forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
n_ Text
"sharedItems") forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Axis
anyElement forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
          Node -> [CellValue]
cellValueFromNode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall node. Cursor node -> node
node
    forall (m :: * -> *) a. Monad m => a -> m a
return CacheField {[CellValue]
PivotFieldName
cfItems :: [CellValue]
cfName :: PivotFieldName
cfItems :: [CellValue]
cfName :: PivotFieldName
..}

cellValueFromNode :: Node -> [CellValue]
cellValueFromNode :: Node -> [CellValue]
cellValueFromNode Node
n
  | Node
n Node -> Name -> Bool
`nodeElNameIs` (Text -> Name
n_ Text
"s") = Text -> CellValue
CellText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromAttrVal a => [a]
attributeV
  | Node
n Node -> Name -> Bool
`nodeElNameIs` (Text -> Name
n_ Text
"n") = Double -> CellValue
CellDouble forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromAttrVal a => [a]
attributeV
  | Bool
otherwise = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no matching shared item"
  where
    cur :: Cursor
cur = Node -> Cursor
fromNode Node
n
    attributeV :: FromAttrVal a => [a]
    attributeV :: forall a. FromAttrVal a => [a]
attributeV = forall a. FromAttrVal a => Name -> Cursor -> [a]
fromAttribute Name
"v" Cursor
cur

recordValueFromNode :: Node -> [CacheRecordValue]
recordValueFromNode :: Node -> [CacheRecordValue]
recordValueFromNode Node
n
  | Node
n Node -> Name -> Bool
`nodeElNameIs` (Text -> Name
n_ Text
"s") = Text -> CacheRecordValue
CacheText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromAttrVal a => [a]
attributeV
  | Node
n Node -> Name -> Bool
`nodeElNameIs` (Text -> Name
n_ Text
"n") = Double -> CacheRecordValue
CacheNumber forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromAttrVal a => [a]
attributeV
  | Node
n Node -> Name -> Bool
`nodeElNameIs` (Text -> Name
n_ Text
"x") = Int -> CacheRecordValue
CacheIndex forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromAttrVal a => [a]
attributeV
  | Bool
otherwise = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not valid cache record value"
  where
    cur :: Cursor
cur = Node -> Cursor
fromNode Node
n
    attributeV :: FromAttrVal a => [a]
    attributeV :: forall a. FromAttrVal a => [a]
attributeV = forall a. FromAttrVal a => Name -> Cursor -> [a]
fromAttribute Name
"v" Cursor
cur

{-------------------------------------------------------------------------------
  Rendering
-------------------------------------------------------------------------------}

instance ToElement CacheField where
  toElement :: Name -> CacheField -> Element
toElement Name
nm CacheField {[CellValue]
PivotFieldName
cfItems :: [CellValue]
cfName :: PivotFieldName
cfItems :: CacheField -> [CellValue]
cfName :: CacheField -> PivotFieldName
..} =
    Name -> [(Name, Text)] -> [Element] -> Element
elementList Name
nm [Name
"name" forall a. ToAttrVal a => Name -> a -> (Name, Text)
.= PivotFieldName
cfName] [Element
sharedItems]
    where
      -- Excel doesn't like embedded integer sharedImes in cache
      sharedItems :: Element
sharedItems = Name -> [(Name, Text)] -> [Element] -> Element
elementList Name
"sharedItems" [(Name, Text)]
typeAttrs forall a b. (a -> b) -> a -> b
$
        if Bool
containsString then forall a b. (a -> b) -> [a] -> [b]
map CellValue -> Element
cvToItem [CellValue]
cfItems else []
      cvToItem :: CellValue -> Element
cvToItem (CellText Text
t) = Name -> [(Name, Text)] -> Element
leafElement Name
"s" [Name
"v" forall a. ToAttrVal a => Name -> a -> (Name, Text)
.= Text
t]
      cvToItem (CellDouble Double
n) = Name -> [(Name, Text)] -> Element
leafElement Name
"n" [Name
"v" forall a. ToAttrVal a => Name -> a -> (Name, Text)
.= Double
n]
      cvToItem CellValue
_ = forall a. HasCallStack => String -> a
error String
"Only string and number values are currently supported"
      typeAttrs :: [(Name, Text)]
typeAttrs =
        forall a. [Maybe a] -> [a]
catMaybes
          [ Name
"containsNumber" forall a. ToAttrVal a => Name -> Maybe a -> Maybe (Name, Text)
.=? Bool -> Maybe Bool
justTrue Bool
containsNumber
          , Name
"containsString" forall a. ToAttrVal a => Name -> Maybe a -> Maybe (Name, Text)
.=? Bool -> Maybe Bool
justFalse Bool
containsString
          , Name
"containsSemiMixedTypes" forall a. ToAttrVal a => Name -> Maybe a -> Maybe (Name, Text)
.=? Bool -> Maybe Bool
justFalse Bool
containsString
          , Name
"containsMixedTypes" forall a. ToAttrVal a => Name -> Maybe a -> Maybe (Name, Text)
.=? Bool -> Maybe Bool
justTrue (Bool
containsNumber Bool -> Bool -> Bool
&& Bool
containsString)
          ]
      containsNumber :: Bool
containsNumber = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CellValue -> Bool
isNumber [CellValue]
cfItems
      isNumber :: CellValue -> Bool
isNumber (CellDouble Double
_) = Bool
True
      isNumber CellValue
_ = Bool
False
      containsString :: Bool
containsString = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CellValue -> Bool
isString [CellValue]
cfItems
      isString :: CellValue -> Bool
isString (CellText Text
_) = Bool
True
      isString CellValue
_ = Bool
False