module Codec.Xlsx.Formatted (
FormattedCell(..)
, Formatted(..)
, formatted
, toFormattedCells
, CondFormatted(..)
, conditionallyFormatted
, formattedAlignment
, formattedBorder
, formattedFill
, formattedFont
, formattedNumberFormat
, formattedProtection
, formattedPivotButton
, formattedQuotePrefix
, formattedValue
, formattedFormula
, formattedColSpan
, formattedRowSpan
, condfmtCondition
, condfmtDxf
, condfmtPriority
, condfmtStopIfTrue
) where
import Control.Lens
import Control.Monad.State hiding (forM_, mapM)
import Data.Default
import Data.Foldable (forM_)
import Data.Function (on)
import Data.List (foldl', groupBy, sortBy, sortBy)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Ord (comparing)
import Data.Traversable (mapM)
import Data.Tuple (swap)
import Prelude hiding (mapM)
import Safe (headNote)
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 = fromValueList _styleSheetBorders
, _formattingCellXfs = fromValueList _styleSheetCellXfs
, _formattingFills = fromValueList _styleSheetFills
, _formattingFonts = fromValueList _styleSheetFonts
, _formattingMerges = []
}
fromValueList :: Ord a => [a] -> Map a Int
fromValueList = M.fromList . (`zip` [0..])
toValueList :: Map a Int -> [a]
toValueList = map snd . sortBy (comparing fst) . map swap . M.toList
updateStyleSheetFromState :: StyleSheet -> FormattingState -> StyleSheet
updateStyleSheetFromState sSheet FormattingState{..} = sSheet
{ _styleSheetBorders = toValueList _formattingBorders
, _styleSheetCellXfs = toValueList _formattingCellXfs
, _styleSheetFills = toValueList _formattingFills
, _styleSheetFonts = toValueList _formattingFonts
}
getId :: Ord a => Lens' FormattingState (Map a Int) -> a -> State FormattingState Int
getId f v = do
aMap <- use f
case M.lookup v aMap of
Just anId -> return anId
Nothing -> do let anId = M.size aMap
f %= M.insert v anId
return anId
data FormattedCondFmt = FormattedCondFmt
{ _condfmtCondition :: Condition
, _condfmtDxf :: Dxf
, _condfmtPriority :: Int
, _condfmtStopIfTrue :: Maybe Bool
} deriving (Eq, Show)
makeLenses ''FormattedCondFmt
data FormattedCell = FormattedCell {
_formattedAlignment :: Maybe Alignment
, _formattedBorder :: Maybe Border
, _formattedFill :: Maybe Fill
, _formattedFont :: Maybe Font
, _formattedNumberFormat :: Maybe NumberFormat
, _formattedProtection :: Maybe Protection
, _formattedPivotButton :: Maybe Bool
, _formattedQuotePrefix :: Maybe Bool
, _formattedValue :: Maybe CellValue
, _formattedFormula :: Maybe CellFormula
, _formattedColSpan :: Int
, _formattedRowSpan :: Int
}
deriving (Show, Eq)
makeLenses ''FormattedCell
instance Default FormattedCell where
def = FormattedCell {
_formattedAlignment = Nothing
, _formattedBorder = Nothing
, _formattedFill = Nothing
, _formattedFont = Nothing
, _formattedNumberFormat = Nothing
, _formattedProtection = Nothing
, _formattedPivotButton = Nothing
, _formattedQuotePrefix = Nothing
, _formattedValue = Nothing
, _formattedFormula = Nothing
, _formattedColSpan = 1
, _formattedRowSpan = 1
}
instance Default FormattedCondFmt where
def = FormattedCondFmt ContainsBlanks def topCfPriority Nothing
data Formatted = Formatted {
formattedCellMap :: CellMap
, formattedStyleSheet :: StyleSheet
, formattedMerges :: [Range]
} deriving (Eq, Show)
formatted :: Map (Int, Int) FormattedCell -> StyleSheet -> Formatted
formatted cs styleSheet =
let initSt = stateFromStyleSheet styleSheet
(cs', finalSt) = runState (mapM (uncurry formatCell) (M.toList cs)) initSt
styleSheet' = updateStyleSheetFromState styleSheet finalSt
in Formatted {
formattedCellMap = M.fromList (concat cs')
, formattedStyleSheet = styleSheet'
, formattedMerges = reverse (finalSt ^. formattingMerges)
}
toFormattedCells :: CellMap -> [Range] -> StyleSheet -> Map (Int, Int) FormattedCell
toFormattedCells m merges StyleSheet{..} = applyMerges $ M.map toFormattedCell m
where
toFormattedCell Cell{..} =
let mCellXf = _cellStyle >>= \styleId -> M.lookup styleId cellXfs
in FormattedCell
{ _formattedAlignment = applied _cellXfApplyAlignment _cellXfAlignment =<< mCellXf
, _formattedBorder = flip M.lookup borders =<<
applied _cellXfApplyBorder _cellXfBorderId =<< mCellXf
, _formattedFill = flip M.lookup fills =<<
applied _cellXfApplyFill _cellXfFillId =<< mCellXf
, _formattedFont = flip M.lookup fonts =<<
applied _cellXfApplyFont _cellXfFontId =<< mCellXf
, _formattedNumberFormat = idToStdNumberFormat =<<
applied _cellXfApplyNumberFormat _cellXfNumFmtId =<< mCellXf
, _formattedProtection = _cellXfProtection =<< mCellXf
, _formattedPivotButton = _cellXfPivotButton =<< mCellXf
, _formattedQuotePrefix = _cellXfQuotePrefix =<< mCellXf
, _formattedValue = _cellValue
, _formattedFormula = _cellFormula
, _formattedColSpan = 1
, _formattedRowSpan = 1 }
idMapped :: [a] -> Map Int a
idMapped = M.fromList . zip [0..]
cellXfs = idMapped _styleSheetCellXfs
borders = idMapped _styleSheetBorders
fills = idMapped _styleSheetFills
fonts = idMapped _styleSheetFonts
applied :: (CellXf -> Maybe Bool) -> (CellXf -> Maybe a) -> CellXf -> Maybe a
applied applyProp prop cXf = do
apply <- applyProp cXf
if apply then prop cXf else fail "not applied"
applyMerges cells = foldl' onlyTopLeft cells merges
onlyTopLeft cells range = flip execState cells $ do
let ((r1, c1), (r2, c2)) = fromRange range
nonTopLeft = tail [(r, c) | r<-[r1..r2], c<-[c1..c2]]
forM_ nonTopLeft (modify . M.delete)
at (r1, c1) . non def . formattedRowSpan .= (r2 r1 +1)
at (r1, c1) . non def . formattedColSpan .= (c2 c1 +1)
data CondFormatted = CondFormatted {
condformattedStyleSheet :: StyleSheet
, condformattedFormattings :: Map SqRef ConditionalFormatting
} deriving (Eq, Show)
conditionallyFormatted :: Map CellRef [FormattedCondFmt] -> StyleSheet -> CondFormatted
conditionallyFormatted cfs styleSheet = CondFormatted
{ condformattedStyleSheet = styleSheet & styleSheetDxfs .~ finalDxfs
, condformattedFormattings = fmts
}
where
(cellFmts, dxf2id) = runState (mapM (mapM mapDxf) cfs) dxf2id0
dxf2id0 = fromValueList (styleSheet ^. styleSheetDxfs)
fmts = M.fromList . map mergeSqRef . groupBy ((==) `on` snd) .
sortBy (comparing snd) $ M.toList cellFmts
mergeSqRef cellRefs2fmt =
(SqRef (map fst cellRefs2fmt),
headNote "fmt group should not be empty" (map snd cellRefs2fmt))
finalDxfs = toValueList dxf2id
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) Nothing (_formattedFormula 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 mNumFmtId = fmap numberFormatId _formattedNumberFormat
let xf = CellXf {
_cellXfApplyAlignment = apply _formattedAlignment
, _cellXfApplyBorder = apply mBorderId
, _cellXfApplyFill = apply mFillId
, _cellXfApplyFont = apply mFontId
, _cellXfApplyNumberFormat = apply _formattedNumberFormat
, _cellXfApplyProtection = apply _formattedProtection
, _cellXfBorderId = mBorderId
, _cellXfFillId = mFillId
, _cellXfFontId = mFontId
, _cellXfNumFmtId = mNumFmtId
, _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
mapDxf :: FormattedCondFmt -> State (Map Dxf Int) CfRule
mapDxf FormattedCondFmt{..} = do
dxf2id <- get
dxfId <- case M.lookup _condfmtDxf dxf2id of
Just i ->
return i
Nothing -> do
let newId = M.size dxf2id
modify $ M.insert _condfmtDxf newId
return newId
return CfRule
{ _cfrCondition = _condfmtCondition
, _cfrDxfId = Just dxfId
, _cfrPriority = _condfmtPriority
, _cfrStopIfTrue = _condfmtStopIfTrue
}