module Codec.Xlsx.Formatted (
FormattedCell(..)
, Formatted(..)
, formatted
, formattedAlignment
, formattedBorder
, formattedFill
, formattedFont
, formattedProtection
, formattedPivotButton
, formattedQuotePrefix
, formattedValue
, formattedColSpan
, formattedRowSpan
) where
import Prelude hiding (mapM)
import Control.Lens
import Control.Monad.State hiding (mapM, forM_)
import Data.Default
import Data.Foldable (forM_)
import Data.List (sortBy)
import Data.Map (Map)
import Data.Ord (comparing)
import Data.Traversable (mapM)
import Data.Tuple (swap)
import qualified Data.Map as Map
import Codec.Xlsx.Types
data FormattingState = FormattingState {
_formattingBorders :: Map Border Int
, _formattingCellXfs :: Map CellXf Int
, _formattingFills :: Map Fill Int
, _formattingFonts :: Map Font Int
, _formattingMerges :: [Range]
}
makeLenses ''FormattingState
stateFromStyleSheet :: StyleSheet -> FormattingState
stateFromStyleSheet StyleSheet{..} = FormattingState{
_formattingBorders = fromList _styleSheetBorders
, _formattingCellXfs = fromList _styleSheetCellXfs
, _formattingFills = fromList _styleSheetFills
, _formattingFonts = fromList _styleSheetFonts
, _formattingMerges = []
}
where
fromList :: Ord a => [a] -> Map a Int
fromList = Map.fromList . (`zip` [0..])
stateToStyleSheet :: FormattingState -> StyleSheet
stateToStyleSheet FormattingState{..} = StyleSheet{
_styleSheetBorders = toList _formattingBorders
, _styleSheetCellXfs = toList _formattingCellXfs
, _styleSheetFills = toList _formattingFills
, _styleSheetFonts = toList _formattingFonts
}
where
toList :: Map a Int -> [a]
toList = map snd . sortBy (comparing fst) . map swap . Map.toList
getId :: Ord a => Lens' FormattingState (Map a Int) -> a -> State FormattingState Int
getId f a = do
aMap <- use f
case Map.lookup a aMap of
Just aId -> return aId
Nothing -> do let aId = Map.size aMap
f %= Map.insert a aId
return aId
data FormattedCell = FormattedCell {
_formattedAlignment :: Maybe Alignment
, _formattedBorder :: Maybe Border
, _formattedFill :: Maybe Fill
, _formattedFont :: Maybe Font
, _formattedProtection :: Maybe Protection
, _formattedPivotButton :: Maybe Bool
, _formattedQuotePrefix :: Maybe Bool
, _formattedValue :: Maybe CellValue
, _formattedColSpan :: Int
, _formattedRowSpan :: Int
}
deriving (Show, Eq)
makeLenses ''FormattedCell
instance Default FormattedCell where
def = FormattedCell {
_formattedAlignment = Nothing
, _formattedBorder = Nothing
, _formattedFill = Nothing
, _formattedFont = Nothing
, _formattedProtection = Nothing
, _formattedPivotButton = Nothing
, _formattedQuotePrefix = Nothing
, _formattedValue = Nothing
, _formattedColSpan = 1
, _formattedRowSpan = 1
}
data Formatted = Formatted {
formattedCellMap :: CellMap
, formattedStyleSheet :: StyleSheet
, formattedMerges :: [Range]
}
formatted :: Map (Int, Int) FormattedCell -> StyleSheet -> Formatted
formatted cs styleSheet =
let initSt = stateFromStyleSheet styleSheet
(cs', finalSt) = runState (mapM (uncurry formatCell) (Map.toList cs)) initSt
styleSheet' = stateToStyleSheet finalSt
in Formatted {
formattedCellMap = Map.fromList (concat cs')
, formattedStyleSheet = styleSheet'
, formattedMerges = reverse (finalSt ^. formattingMerges)
}
formatCell :: (Int, Int) -> FormattedCell -> State FormattingState [((Int, Int), Cell)]
formatCell (row, col) cell = do
let (block, mMerge) = cellBlock (row, col) cell
forM_ mMerge $ \merge -> formattingMerges %= (:) merge
mapM go block
where
go :: ((Int, Int), FormattedCell) -> State FormattingState ((Int, Int), Cell)
go (pos, c) = do
styleId <- cellStyleId c
return (pos, Cell styleId (_formattedValue c))
cellBlock :: (Int, Int) -> FormattedCell
-> ([((Int, Int), FormattedCell)], Maybe Range)
cellBlock (row, col) cell@FormattedCell{..} = (block, merge)
where
block :: [((Int, Int), FormattedCell)]
block = [ ((row', col'), cellAt (row', col'))
| row' <- [topRow .. bottomRow]
, col' <- [leftCol .. rightCol]
]
merge :: Maybe Range
merge = do guard (topRow /= bottomRow || leftCol /= rightCol)
return $ mkRange (topRow, leftCol) (bottomRow, rightCol)
cellAt :: (Int, Int) -> FormattedCell
cellAt (row', col') =
if row' == row && col == col'
then cell
else def & formattedBorder .~ Just (borderAt (row', col'))
borderAt :: (Int, Int) -> Border
borderAt (row', col') = def
& borderTop .~ do guard (row' == topRow) ; _borderTop =<< _formattedBorder
& borderBottom .~ do guard (row' == bottomRow) ; _borderBottom =<< _formattedBorder
& borderLeft .~ do guard (col' == leftCol) ; _borderLeft =<< _formattedBorder
& borderRight .~ do guard (col' == rightCol) ; _borderRight =<< _formattedBorder
topRow, bottomRow, leftCol, rightCol :: Int
topRow = row
bottomRow = row + _formattedRowSpan 1
leftCol = col
rightCol = col + _formattedColSpan 1
cellStyleId :: FormattedCell -> State FormattingState (Maybe Int)
cellStyleId c = mapM (getId formattingCellXfs) =<< cellXf c
cellXf :: FormattedCell -> State FormattingState (Maybe CellXf)
cellXf FormattedCell{..} = do
mBorderId <- getId formattingBorders `mapM` _formattedBorder
mFillId <- getId formattingFills `mapM` _formattedFill
mFontId <- getId formattingFonts `mapM` _formattedFont
let xf = CellXf {
_cellXfApplyAlignment = apply _formattedAlignment
, _cellXfApplyBorder = apply mBorderId
, _cellXfApplyFill = apply mFillId
, _cellXfApplyFont = apply mFontId
, _cellXfApplyNumberFormat = Nothing
, _cellXfApplyProtection = apply _formattedProtection
, _cellXfBorderId = mBorderId
, _cellXfFillId = mFillId
, _cellXfFontId = mFontId
, _cellXfNumFmtId = Nothing
, _cellXfPivotButton = _formattedPivotButton
, _cellXfQuotePrefix = _formattedQuotePrefix
, _cellXfId = Nothing
, _cellXfAlignment = _formattedAlignment
, _cellXfProtection = _formattedProtection
}
return $ if xf == def then Nothing else Just xf
where
apply :: Maybe a -> Maybe Bool
apply Nothing = Nothing
apply (Just _) = Just True