{-# 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
(CacheId -> CacheId -> Bool)
-> (CacheId -> CacheId -> Bool) -> Eq CacheId
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. CacheId -> Rep CacheId x)
-> (forall x. Rep CacheId x -> CacheId) -> Generic CacheId
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
(CacheField -> CacheField -> Bool)
-> (CacheField -> CacheField -> Bool) -> Eq CacheField
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
(Int -> CacheField -> ShowS)
-> (CacheField -> String)
-> ([CacheField] -> ShowS)
-> Show CacheField
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. CacheField -> Rep CacheField x)
-> (forall x. Rep CacheField x -> CacheField) -> Generic CacheField
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
(CacheRecordValue -> CacheRecordValue -> Bool)
-> (CacheRecordValue -> CacheRecordValue -> Bool)
-> Eq CacheRecordValue
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
(Int -> CacheRecordValue -> ShowS)
-> (CacheRecordValue -> String)
-> ([CacheRecordValue] -> ShowS)
-> Show CacheRecordValue
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. CacheRecordValue -> Rep CacheRecordValue x)
-> (forall x. Rep CacheRecordValue x -> CacheRecordValue)
-> Generic CacheRecordValue
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 = ((Int, Text) -> (CacheId, Text))
-> Either String (Int, Text) -> Either String (CacheId, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> CacheId) -> (Int, Text) -> (CacheId, Text)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Int -> CacheId
CacheId) (Either String (Int, Text) -> Either String (CacheId, Text))
-> (Text -> Either String (Int, Text)) -> Reader CacheId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String (Int, Text)
forall a. FromAttrVal a => Reader a
fromAttrVal

instance FromCursor CacheField where
  fromCursor :: Cursor -> [CacheField]
fromCursor Cursor
cur = do
    PivotFieldName
cfName <- Name -> Cursor -> [PivotFieldName]
forall a. FromAttrVal a => Name -> Cursor -> [a]
fromAttribute Name
"name" Cursor
cur
    let cfItems :: [CellValue]
cfItems =
          Cursor
cur Cursor -> (Cursor -> [CellValue]) -> [CellValue]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
n_ Text
"sharedItems") Axis -> (Cursor -> [CellValue]) -> Cursor -> [CellValue]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Axis
anyElement Axis -> (Cursor -> [CellValue]) -> Cursor -> [CellValue]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
          Node -> [CellValue]
cellValueFromNode (Node -> [CellValue]) -> (Cursor -> Node) -> Cursor -> [CellValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> Node
forall node. Cursor node -> node
node
    CacheField -> [CacheField]
forall (m :: * -> *) a. Monad m => a -> m a
return CacheField :: PivotFieldName -> [CellValue] -> CacheField
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 (Text -> CellValue) -> [Text] -> [CellValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
forall a. FromAttrVal a => [a]
attributeV
  | Node
n Node -> Name -> Bool
`nodeElNameIs` (Text -> Name
n_ Text
"n") = Double -> CellValue
CellDouble (Double -> CellValue) -> [Double] -> [CellValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Double]
forall a. FromAttrVal a => [a]
attributeV
  | Bool
otherwise = String -> [CellValue]
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 :: [a]
attributeV = Name -> Cursor -> [a]
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 (Text -> CacheRecordValue) -> [Text] -> [CacheRecordValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
forall a. FromAttrVal a => [a]
attributeV
  | Node
n Node -> Name -> Bool
`nodeElNameIs` (Text -> Name
n_ Text
"n") = Double -> CacheRecordValue
CacheNumber (Double -> CacheRecordValue) -> [Double] -> [CacheRecordValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Double]
forall a. FromAttrVal a => [a]
attributeV
  | Node
n Node -> Name -> Bool
`nodeElNameIs` (Text -> Name
n_ Text
"x") = Int -> CacheRecordValue
CacheIndex (Int -> CacheRecordValue) -> [Int] -> [CacheRecordValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
forall a. FromAttrVal a => [a]
attributeV
  | Bool
otherwise = String -> [CacheRecordValue]
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 :: [a]
attributeV = Name -> Cursor -> [a]
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" Name -> PivotFieldName -> (Name, Text)
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 ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
        if Bool
containsString then (CellValue -> Element) -> [CellValue] -> [Element]
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" Name -> Text -> (Name, Text)
forall a. ToAttrVal a => Name -> a -> (Name, Text)
.= Text
t]
      cvToItem (CellDouble Double
n) = Name -> [(Name, Text)] -> Element
leafElement Name
"n" [Name
"v" Name -> Double -> (Name, Text)
forall a. ToAttrVal a => Name -> a -> (Name, Text)
.= Double
n]
      cvToItem CellValue
_ = String -> Element
forall a. HasCallStack => String -> a
error String
"Only string and number values are currently supported"
      typeAttrs :: [(Name, Text)]
typeAttrs =
        [Maybe (Name, Text)] -> [(Name, Text)]
forall a. [Maybe a] -> [a]
catMaybes
          [ Name
"containsNumber" Name -> Maybe Bool -> Maybe (Name, Text)
forall a. ToAttrVal a => Name -> Maybe a -> Maybe (Name, Text)
.=? Bool -> Maybe Bool
justTrue Bool
containsNumber
          , Name
"containsString" Name -> Maybe Bool -> Maybe (Name, Text)
forall a. ToAttrVal a => Name -> Maybe a -> Maybe (Name, Text)
.=? Bool -> Maybe Bool
justFalse Bool
containsString
          , Name
"containsSemiMixedTypes" Name -> Maybe Bool -> Maybe (Name, Text)
forall a. ToAttrVal a => Name -> Maybe a -> Maybe (Name, Text)
.=? Bool -> Maybe Bool
justFalse Bool
containsString
          , Name
"containsMixedTypes" Name -> Maybe Bool -> Maybe (Name, Text)
forall a. ToAttrVal a => Name -> Maybe a -> Maybe (Name, Text)
.=? Bool -> Maybe Bool
justTrue (Bool
containsNumber Bool -> Bool -> Bool
&& Bool
containsString)
          ]
      containsNumber :: Bool
containsNumber = (CellValue -> Bool) -> [CellValue] -> Bool
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 = (CellValue -> Bool) -> [CellValue] -> Bool
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