diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,8 @@ +0.2.3 +----- +* added conditional formatting support +* fixed reading empty subelements with defaults (thanks Steve Bigham ) + 0.2.2.2 ----- * fixed missing from parsing code font family value 0 (Not applicable) (thanks Steve Bigham ) diff --git a/src/Codec/Xlsx/Formatted.hs b/src/Codec/Xlsx/Formatted.hs --- a/src/Codec/Xlsx/Formatted.hs +++ b/src/Codec/Xlsx/Formatted.hs @@ -3,11 +3,12 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} -{-# OPTIONS_GHC -Wall #-} module Codec.Xlsx.Formatted ( FormattedCell(..) , Formatted(..) , formatted + , CondFormatted(..) + , conditionallyFormatted -- * Lenses -- ** FormattedCell , formattedAlignment @@ -21,6 +22,11 @@ , formattedValue , formattedColSpan , formattedRowSpan + -- ** FormattedCondFmt + , condfmtCondition + , condfmtDxf + , condfmtPriority + , condfmtStopIfTrue ) where import Prelude hiding (mapM) @@ -28,12 +34,14 @@ import Control.Monad.State hiding (mapM, forM_) import Data.Default import Data.Foldable (forM_) -import Data.List (sortBy) +import Data.Function (on) +import Data.List (sortBy, groupBy, sortBy) import Data.Map (Map) import Data.Ord (comparing) import Data.Traversable (mapM) import Data.Tuple (swap) -import qualified Data.Map as Map +import qualified Data.Map as M +import Safe (headNote) import Codec.Xlsx.Types @@ -42,48 +50,61 @@ -------------------------------------------------------------------------------} data FormattingState = FormattingState { - _formattingBorders :: Map Border Int - , _formattingCellXfs :: Map CellXf Int - , _formattingFills :: Map Fill Int - , _formattingFonts :: Map Font Int - , _formattingMerges :: [Range] -- ^ In reverse order + _formattingBorders :: Map Border Int + , _formattingCellXfs :: Map CellXf Int + , _formattingFills :: Map Fill Int + , _formattingFonts :: Map Font Int + , _formattingMerges :: [Range] -- ^ In reverse order } makeLenses ''FormattingState stateFromStyleSheet :: StyleSheet -> FormattingState stateFromStyleSheet StyleSheet{..} = FormattingState{ - _formattingBorders = fromValueList _styleSheetBorders - , _formattingCellXfs = fromValueList _styleSheetCellXfs - , _formattingFills = fromValueList _styleSheetFills - , _formattingFonts = fromValueList _styleSheetFonts - , _formattingMerges = [] + _formattingBorders = fromValueList _styleSheetBorders + , _formattingCellXfs = fromValueList _styleSheetCellXfs + , _formattingFills = fromValueList _styleSheetFills + , _formattingFonts = fromValueList _styleSheetFonts + , _formattingMerges = [] } - where - fromValueList :: Ord a => [a] -> Map a Int - fromValueList = Map.fromList . (`zip` [0..]) -stateToStyleSheet :: FormattingState -> StyleSheet -stateToStyleSheet FormattingState{..} = StyleSheet{ - _styleSheetBorders = toList _formattingBorders - , _styleSheetCellXfs = toList _formattingCellXfs - , _styleSheetFills = toList _formattingFills - , _styleSheetFonts = toList _formattingFonts +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 } - 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 + case M.lookup a aMap of Just aId -> return aId - Nothing -> do let aId = Map.size aMap - f %= Map.insert a aId + Nothing -> do let aId = M.size aMap + f %= M.insert a aId return aId {------------------------------------------------------------------------------- + Unwrapped cell conditional formatting +-------------------------------------------------------------------------------} + +data FormattedCondFmt = FormattedCondFmt + { _condfmtCondition :: Condition + , _condfmtDxf :: Dxf + , _condfmtPriority :: Int + , _condfmtStopIfTrue :: Maybe Bool + } deriving (Eq, Show) + +makeLenses ''FormattedCondFmt + +{------------------------------------------------------------------------------- Cell with formatting -------------------------------------------------------------------------------} @@ -112,6 +133,11 @@ makeLenses ''FormattedCell + +{------------------------------------------------------------------------------- + Default instances +-------------------------------------------------------------------------------} + instance Default FormattedCell where def = FormattedCell { _formattedAlignment = Nothing @@ -127,6 +153,9 @@ , _formattedRowSpan = 1 } +instance Default FormattedCondFmt where + def = FormattedCondFmt ContainsBlanks def topCfPriority Nothing + {------------------------------------------------------------------------------- Client-facing API -------------------------------------------------------------------------------} @@ -143,7 +172,7 @@ -- | The final list of cell merges; see '_wsMerges' , formattedMerges :: [Range] - } + } deriving (Eq, Show) -- | Higher level API for creating formatted documents -- @@ -173,14 +202,40 @@ 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 + (cs', finalSt) = runState (mapM (uncurry formatCell) (M.toList cs)) initSt + styleSheet' = updateStyleSheetFromState styleSheet finalSt in Formatted { - formattedCellMap = Map.fromList (concat cs') + formattedCellMap = M.fromList (concat cs') , formattedStyleSheet = styleSheet' , formattedMerges = reverse (finalSt ^. formattingMerges) } +data CondFormatted = CondFormatted { + -- | The resulting stylesheet + condformattedStyleSheet :: StyleSheet + -- | The final map of conditional formatting rules applied to ranges + , 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 + +{------------------------------------------------------------------------------- + Implementation details +-------------------------------------------------------------------------------} + -- | Format a cell with (potentially) rowspan or colspan formatCell :: (Int, Int) -> FormattedCell -> State FormattingState [((Int, Int), Cell)] formatCell (row, col) cell = do @@ -268,3 +323,20 @@ 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 + } diff --git a/src/Codec/Xlsx/Parser.hs b/src/Codec/Xlsx/Parser.hs --- a/src/Codec/Xlsx/Parser.hs +++ b/src/Codec/Xlsx/Parser.hs @@ -28,11 +28,11 @@ import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types import Codec.Xlsx.Types.Internal -import Codec.Xlsx.Types.Internal.Relationships as Relationships -import Codec.Xlsx.Types.Internal.SharedStringTable -import Codec.Xlsx.Types.Internal.CustomProperties +import Codec.Xlsx.Types.Internal.CfPair import Codec.Xlsx.Types.Internal.CommentTable import Codec.Xlsx.Types.Internal.CustomProperties as CustomProperties +import Codec.Xlsx.Types.Internal.Relationships as Relationships +import Codec.Xlsx.Types.Internal.SharedStringTable -- | Reads `Xlsx' from raw data (lazy bytestring) @@ -55,7 +55,7 @@ -> SharedStringTable -> WorksheetFile -> Worksheet -extractSheet ar sst wf = Worksheet cws rowProps cells merges sheetViews pageSetup +extractSheet ar sst wf = Worksheet cws rowProps cells merges sheetViews pageSetup condFormtattings where file = fromJust $ Zip.fromEntry <$> Zip.findEntryByPath (wfPath wf) ar cur = case parseLBS def file of @@ -113,6 +113,8 @@ parseMerges :: Cursor -> [Text] parseMerges = element (n"mergeCells") &/ element (n"mergeCell") >=> parseMerge parseMerge c = c $| attribute "ref" + + condFormtattings = M.fromList . map unCfPair $ cur $/ element (n"conditionalFormatting") >=> fromCursor extractCellValue :: SharedStringTable -> Text -> Text -> [CellValue] extractCellValue sst "s" v = diff --git a/src/Codec/Xlsx/Parser/Internal.hs b/src/Codec/Xlsx/Parser/Internal.hs --- a/src/Codec/Xlsx/Parser/Internal.hs +++ b/src/Codec/Xlsx/Parser/Internal.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Codec.Xlsx.Parser.Internal ( ParseException(..) , n @@ -9,6 +9,8 @@ , fromAttribute , maybeAttribute , maybeElementValue + , maybeElementValueDef + , maybeBoolElemValue , maybeFromElement , readSuccess , readFailure @@ -19,11 +21,12 @@ , rational ) where -import Control.Exception (Exception) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Read as T -import Data.Typeable (Typeable) +import Control.Exception (Exception) +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Read as T +import Data.Typeable (Typeable) import Text.XML import Text.XML.Cursor @@ -73,6 +76,15 @@ case cursor $/ element name of [cursor'] -> maybeAttribute "val" cursor' _ -> [Nothing] + +maybeElementValueDef :: FromAttrVal a => Name -> a -> Cursor -> [Maybe a] +maybeElementValueDef name defVal cursor = + case cursor $/ element name of + [cursor'] -> Just . fromMaybe defVal <$> maybeAttribute "val" cursor' + _ -> [Nothing] + +maybeBoolElemValue :: Name -> Cursor -> [Maybe Bool] +maybeBoolElemValue name cursor = maybeElementValueDef name True cursor maybeFromElement :: FromCursor a => Name -> Cursor -> [Maybe a] maybeFromElement name cursor = case cursor $/ element name of diff --git a/src/Codec/Xlsx/Types.hs b/src/Codec/Xlsx/Types.hs --- a/src/Codec/Xlsx/Types.hs +++ b/src/Codec/Xlsx/Types.hs @@ -2,22 +2,43 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -module Codec.Xlsx.Types - ( Xlsx(..), xlSheets, xlStyles, xlDefinedNames, xlCustomProperties - , def +module Codec.Xlsx.Types ( + -- * The main types + Xlsx(..) , Styles(..) - , emptyStyles - , renderStyleSheet - , parseStyleSheet , DefinedNames(..) , ColumnsWidth(..) , PageSetup(..) - , Worksheet(..), wsColumns, wsRowPropertiesMap, wsCells, wsMerges, wsSheetViews, wsPageSetup + , Worksheet(..) , CellMap , CellValue(..) - , Cell(..), cellValue, cellStyle, cellComment + , Cell(..) , RowProperties (..) , Range + -- * Lenses + -- ** Workbook + , xlSheets + , xlStyles + , xlDefinedNames + , xlCustomProperties + -- ** Worksheet + , wsColumns + , wsRowPropertiesMap + , wsCells + , wsMerges + , wsSheetViews + , wsPageSetup + , wsConditionalFormattings + -- ** Cells + , cellValue + , cellStyle + , cellComment + -- * Style helpers + , emptyStyles + , renderStyleSheet + , parseStyleSheet + -- * Misc + , def , int2col , col2int , mkCellRef @@ -44,6 +65,7 @@ import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.Comment as X import Codec.Xlsx.Types.Common as X +import Codec.Xlsx.Types.ConditionalFormatting as X import Codec.Xlsx.Types.PageSetup as X import Codec.Xlsx.Types.RichText as X import Codec.Xlsx.Types.SheetViews as X @@ -104,18 +126,19 @@ -- | Xlsx worksheet data Worksheet = Worksheet - { _wsColumns :: [ColumnsWidth] -- ^ column widths - , _wsRowPropertiesMap :: Map Int RowProperties -- ^ custom row properties (height, style) map - , _wsCells :: CellMap -- ^ data mapped by (row, column) pairs - , _wsMerges :: [Range] -- ^ list of cell merges - , _wsSheetViews :: Maybe [SheetView] - , _wsPageSetup :: Maybe PageSetup + { _wsColumns :: [ColumnsWidth] -- ^ column widths + , _wsRowPropertiesMap :: Map Int RowProperties -- ^ custom row properties (height, style) map + , _wsCells :: CellMap -- ^ data mapped by (row, column) pairs + , _wsMerges :: [Range] -- ^ list of cell merges + , _wsSheetViews :: Maybe [SheetView] + , _wsPageSetup :: Maybe PageSetup + , _wsConditionalFormattings :: Map SqRef ConditionalFormatting } deriving (Eq, Show) makeLenses ''Worksheet instance Default Worksheet where - def = Worksheet [] M.empty M.empty [] Nothing Nothing + def = Worksheet [] M.empty M.empty [] Nothing Nothing M.empty newtype Styles = Styles {unStyles :: L.ByteString} deriving (Eq, Show) diff --git a/src/Codec/Xlsx/Types/Common.hs b/src/Codec/Xlsx/Types/Common.hs --- a/src/Codec/Xlsx/Types/Common.hs +++ b/src/Codec/Xlsx/Types/Common.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Codec.Xlsx.Types.Common ( CellRef , SqRef (..) , XlsxText (..) + , Formula (..) ) where import qualified Data.Map as Map @@ -17,7 +18,7 @@ -- | Excel cell reference (e.g. @E3@) --- see 18.18.62 @ST_Ref@ (p. 2482) +-- See 18.18.62 @ST_Ref@ (p. 2482) type CellRef = Text newtype SqRef = SqRef [CellRef] @@ -45,25 +46,12 @@ | XlsxRichText [RichTextRun] deriving (Show, Eq, Ord) -{------------------------------------------------------------------------------- - Rendering --------------------------------------------------------------------------------} --- | See @CT_Rst@, p. 3903 -instance ToElement XlsxText where - toElement nm si = Element { - elementName = nm - , elementAttributes = Map.empty - , elementNodes = map NodeElement $ - case si of - XlsxText text -> [elementContent "t" text] - XlsxRichText rich -> map (toElement "r") rich - } - --- | A sequence of cell references, space delimited. --- See 18.18.76, "ST_Sqref (Reference Sequence)", p. 2488. -instance ToAttrVal SqRef where - toAttrVal (SqRef refs) = T.intercalate " " refs +-- | A formula +-- +-- See 18.18.35 "ST_Formula (Formula)" (p. 2457) +newtype Formula = Formula {unFormula :: Text} + deriving (Eq, Ord, Show) {------------------------------------------------------------------------------- Parsing @@ -89,3 +77,31 @@ instance FromAttrVal SqRef where fromAttrVal t = readSuccess (SqRef $ T.split (== ' ') t) + +-- | See @ST_Formula@, p. 3873 +instance FromCursor Formula where + fromCursor cur = [Formula . T.concat $ cur $/ content] + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +-- | See @CT_Rst@, p. 3903 +instance ToElement XlsxText where + toElement nm si = Element { + elementName = nm + , elementAttributes = Map.empty + , elementNodes = map NodeElement $ + case si of + XlsxText text -> [elementContent "t" text] + XlsxRichText rich -> map (toElement "r") rich + } + +-- | A sequence of cell references, space delimited. +-- See 18.18.76, "ST_Sqref (Reference Sequence)", p. 2488. +instance ToAttrVal SqRef where + toAttrVal (SqRef refs) = T.intercalate " " refs + +-- | See @ST_Formula@, p. 3873 +instance ToElement Formula where + toElement nm (Formula txt) = elementContent nm txt diff --git a/src/Codec/Xlsx/Types/ConditionalFormatting.hs b/src/Codec/Xlsx/Types/ConditionalFormatting.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/ConditionalFormatting.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +module Codec.Xlsx.Types.ConditionalFormatting + ( ConditionalFormatting + , CfRule(..) + , Condition(..) + , OperatorExpression (..) + , TimePeriod (..) + -- * Lenses + -- ** CfRule + , cfrCondition + , cfrDxfId + , cfrPriority + , cfrStopIfTrue + -- * Misc + , topCfPriority + ) where + +import Control.Lens (makeLenses) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Text (Text) +import Text.XML +import Text.XML.Cursor + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Writer.Internal + +-- | Logical operation used in 'CellIs' condition +-- +-- See 18.18.15 "ST_ConditionalFormattingOperator +-- (Conditional Format Operators)" (p. 2446) +data OperatorExpression + = OpBeginsWith Formula -- ^ 'Begins with' operator + | OpBetween Formula Formula -- ^ 'Between' operator + | OpContainsText Formula -- ^ 'Contains' operator + | OpEndsWith Formula -- ^ 'Ends with' operator + | OpEqual Formula -- ^ 'Equal to' operator + | OpGreaterThan Formula -- ^ 'Greater than' operator + | OpGreaterThanOrEqual Formula -- ^ 'Greater than or equal to' operator + | OpLessThan Formula -- ^ 'Less than' operator + | OpLessThanOrEqual Formula -- ^ 'Less than or equal to' operator + | OpNotBetween Formula Formula -- ^ 'Not between' operator + | OpNotContains Formula -- ^ 'Does not contain' operator + | OpNotEqual Formula -- ^ 'Not equal to' operator + deriving (Eq, Ord, Show) + +-- | Used in a "contains dates" conditional formatting rule. +-- These are dynamic time periods, which change based on +-- the date the conditional formatting is refreshed / applied. +-- +-- See 18.18.82 "ST_TimePeriod (Time Period Types)" (p. 2508) +data TimePeriod + = PerLast7Days -- ^ A date in the last seven days. + | PerLastMonth -- ^ A date occuring in the last calendar month. + | PerLastWeek -- ^ A date occuring last week. + | PerNextMonth -- ^ A date occuring in the next calendar month. + | PerNextWeek -- ^ A date occuring next week. + | PerThisMonth -- ^ A date occuring in this calendar month. + | PerThisWeek -- ^ A date occuring this week. + | PerToday -- ^ Today's date. + | PerTomorrow -- ^ Tomorrow's date. + | PerYesterday -- ^ Yesterday's date. + deriving (Eq, Ord, Show) + +-- | Conditions which could be used for conditional formatting +-- +-- See 18.18.12 "ST_CfType (Conditional Format Type)" (p. 2443) +data Condition + -- | This conditional formatting rule highlights cells in the + -- range that begin with the given text. Equivalent to + -- using the LEFT() sheet function and comparing values. + = BeginsWith Text + -- | This conditional formatting rule compares a cell value + -- to a formula calculated result, using an operator. + | CellIs OperatorExpression + -- | This conditional formatting rule highlights cells that + -- are completely blank. Equivalent of using LEN(TRIM()). + -- This means that if the cell contains only characters + -- that TRIM() would remove, then it is considered blank. + -- An empty cell is also considered blank. + | ContainsBlanks + -- | This conditional formatting rule highlights cells with + -- formula errors. Equivalent to using ISERROR() sheet + -- function to determine if there is a formula error. + | ContainsErrors + -- | This conditional formatting rule highlights cells + -- containing given text. Equivalent to using the SEARCH() + -- sheet function to determine whether the cell contains + -- the text. + | ContainsText Text + -- | This conditional formatting rule highlights cells + -- without formula errors. Equivalent to using ISERROR() + -- sheet function to determine if there is a formula error. + | DoesNotContainErrors + -- | This conditional formatting rule highlights cells that + -- are not blank. Equivalent of using LEN(TRIM()). This + -- means that if the cell contains only characters that + -- TRIM() would remove, then it is considered blank. An + -- empty cell is also considered blank. + | DoesNotContainBlanks + -- | This conditional formatting rule highlights cells that do + -- not contain given text. Equivalent to using the + -- SEARCH() sheet function. + | DoesNotContainText Text + -- | This conditional formatting rule highlights cells ending + -- with given text. Equivalent to using the RIGHT() sheet + -- function and comparing values. + | EndsWith Text + -- | This conditional formatting rule contains a formula to + -- evaluate. When the formula result is true, the cell is + -- highlighted. + | Expression Formula + -- | This conditional formatting rule highlights cells + -- containing dates in the specified time period. The + -- underlying value of the cell is evaluated, therefore the + -- cell does not need to be formatted as a date to be + -- evaluated. For example, with a cell containing the + -- value 38913 the conditional format shall be applied if + -- the rule requires a value of 7/14/2006. + | InTimePeriod TimePeriod + -- TODO: aboveAverage + -- TODO: colorScale + -- TODO: dataBar + -- TODO: iconSet + -- TODO: timePeriod + -- TODO: top10 + -- TODO: uniqueValues + deriving (Eq, Ord, Show) + +-- | This collection represents a description of a conditional formatting rule. +-- +-- See 18.3.1.10 "cfRule (Conditional Formatting Rule)" (p. 1602) +data CfRule = CfRule + { _cfrCondition :: Condition + -- | This is an index to a dxf element in the Styles Part + -- indicating which cell formatting to + -- apply when the conditional formatting rule criteria is met. + , _cfrDxfId :: Maybe Int + -- | The priority of this conditional formatting rule. This value + -- is used to determine which format should be evaluated and + -- rendered. Lower numeric values are higher priority than + -- higher numeric values, where 1 is the highest priority. + , _cfrPriority :: Int + -- | If this flag is set, no rules with lower priority shall + -- be applied over this rule, when this rule + -- evaluates to true. + , _cfrStopIfTrue :: Maybe Bool + } deriving (Eq, Ord, Show) + +makeLenses ''CfRule + +type ConditionalFormatting = [CfRule] + +topCfPriority :: Int +topCfPriority = 1 + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromCursor CfRule where + fromCursor cur = do + _cfrDxfId <- maybeAttribute "dxfId" cur + _cfrPriority <- fromAttribute "priority" cur + _cfrStopIfTrue <- maybeAttribute "stopIfTrue" cur + -- spec shows this attribute as optional but it's not clear why could + -- conditional formatting record be needed with no condition type set + cfType <- fromAttribute "type" cur + _cfrCondition <- readCondition cfType cur + return CfRule{..} + +readCondition :: Text -> Cursor -> [Condition] +readCondition "beginsWith" cur = do + txt <- fromAttribute "text" cur + return $ BeginsWith txt +readCondition "cellIs" cur = do + operator <- fromAttribute "operator" cur + let formulas = cur $/ element (n"formula") >=> fromCursor + expr <- readOpExpression operator formulas + return $ CellIs expr +readCondition "containsBlanks" _ = return ContainsBlanks +readCondition "containsErrors" _ = return ContainsErrors +readCondition "containsText" cur = do + txt <- fromAttribute "text" cur + return $ ContainsText txt +readCondition "notContainsBlanks" _ = return DoesNotContainBlanks +readCondition "notContainsErrors" _ = return DoesNotContainErrors +readCondition "notContainsText" cur = do + txt <- fromAttribute "text" cur + return $ DoesNotContainText txt +readCondition "endsWith" cur = do + txt <- fromAttribute "text" cur + return $ EndsWith txt +readCondition "expression" cur = do + formula <- cur $/ element "formula" >=> fromCursor + return $ Expression formula +readCondition "timePeriod" cur = do + period <- fromAttribute "timePeriod" cur + return $ InTimePeriod period +readCondition _ _ = error "Unexpected conditional formatting type" + +readOpExpression :: Text -> [Formula] -> [OperatorExpression] +readOpExpression "beginsWith" [f ] = [OpBeginsWith f ] +readOpExpression "between" [f1, f2] = [OpBetween f1 f2] +readOpExpression "containsText" [f] = [OpContainsText f] +readOpExpression "endsWith" [f] = [OpEndsWith f] +readOpExpression "equal" [f] = [OpEqual f] +readOpExpression "greaterThan" [f] = [OpGreaterThan f] +readOpExpression "greaterThanOrEqual" [f] = [OpGreaterThanOrEqual f] +readOpExpression "lessThan" [f] = [OpLessThan f] +readOpExpression "lessThanOrEqual" [f] = [OpLessThanOrEqual f] +readOpExpression "notBetween" [f1, f2] = [OpNotBetween f1 f2] +readOpExpression "notContains" [f] = [OpNotContains f] +readOpExpression "notEqual" [f] = [OpNotEqual f] +readOpExpression _ _ = [] + +instance FromAttrVal TimePeriod where + fromAttrVal "last7Days" = readSuccess PerLast7Days + fromAttrVal "lastMonth" = readSuccess PerLastMonth + fromAttrVal "lastWeek" = readSuccess PerLastWeek + fromAttrVal "nextMonth" = readSuccess PerNextMonth + fromAttrVal "nextWeek" = readSuccess PerNextWeek + fromAttrVal "thisMonth" = readSuccess PerThisMonth + fromAttrVal "thisWeek" = readSuccess PerThisWeek + fromAttrVal "today" = readSuccess PerToday + fromAttrVal "tomorrow" = readSuccess PerTomorrow + fromAttrVal "yesterday" = readSuccess PerYesterday + fromAttrVal t = invalidText "TimePeriod" t + + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToElement CfRule where + toElement nm CfRule{..} = + let (condType, condAttrs, condNodes) = conditionData _cfrCondition + baseAttrs = M.fromList . catMaybes $ + [ Just $ "type" .= condType + , "dxfId" .=? _cfrDxfId + , Just $ "priority" .= _cfrPriority + , "stopIfTrue" .=? _cfrStopIfTrue + ] + in Element + { elementName = nm + , elementAttributes = M.union baseAttrs condAttrs + , elementNodes = condNodes + } + +conditionData :: Condition -> (Text, Map Name Text, [Node]) +conditionData (BeginsWith t) = ("beginsWith", M.fromList [ "text" .= t], []) +conditionData (CellIs opExpr) = ("cellIs", M.fromList [ "operator" .= op], formulas) + where (op, formulas) = operatorExpressionData opExpr +conditionData ContainsBlanks = ("containsBlanks", M.empty, []) +conditionData ContainsErrors = ("containsErrors", M.empty, []) +conditionData (ContainsText t) = ("containsText", M.fromList [ "text" .= t], []) +conditionData DoesNotContainBlanks = ("notContainsBlanks", M.empty, []) +conditionData DoesNotContainErrors = ("notContainsErrors", M.empty, []) +conditionData (DoesNotContainText t) = ("notContainsText", M.fromList [ "text" .= t], []) +conditionData (EndsWith t) = ("endsWith", M.fromList [ "text" .= t], []) +conditionData (Expression formula) = ("expression", M.empty, [formulaNode formula]) +conditionData (InTimePeriod period) = ("timePeriod", M.fromList [ "timePeriod" .= period ], []) + +operatorExpressionData :: OperatorExpression -> (Text, [Node]) +operatorExpressionData (OpBeginsWith f) = ("beginsWith", [formulaNode f]) +operatorExpressionData (OpBetween f1 f2) = ("between", [formulaNode f1, formulaNode f2]) +operatorExpressionData (OpContainsText f) = ("containsText", [formulaNode f]) +operatorExpressionData (OpEndsWith f) = ("endsWith", [formulaNode f]) +operatorExpressionData (OpEqual f) = ("equal", [formulaNode f]) +operatorExpressionData (OpGreaterThan f) = ("greaterThan", [formulaNode f]) +operatorExpressionData (OpGreaterThanOrEqual f) = ("greaterThanOrEqual", [formulaNode f]) +operatorExpressionData (OpLessThan f) = ("lessThan", [formulaNode f]) +operatorExpressionData (OpLessThanOrEqual f) = ("lessThanOrEqual", [formulaNode f]) +operatorExpressionData (OpNotBetween f1 f2) = ("notBetween", [formulaNode f1, formulaNode f2]) +operatorExpressionData (OpNotContains f) = ("notContains", [formulaNode f]) +operatorExpressionData (OpNotEqual f) = ("notEqual", [formulaNode f]) + +formulaNode :: Formula -> Node +formulaNode = NodeElement . toElement "formula" + +instance ToAttrVal TimePeriod where + toAttrVal PerLast7Days = "last7Days" + toAttrVal PerLastMonth = "lastMonth" + toAttrVal PerLastWeek = "lastWeek" + toAttrVal PerNextMonth = "nextMonth" + toAttrVal PerNextWeek = "nextWeek" + toAttrVal PerThisMonth = "thisMonth" + toAttrVal PerThisWeek = "thisWeek" + toAttrVal PerToday = "today" + toAttrVal PerTomorrow = "tomorrow" + toAttrVal PerYesterday = "yesterday" diff --git a/src/Codec/Xlsx/Types/Internal/CfPair.hs b/src/Codec/Xlsx/Types/Internal/CfPair.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Internal/CfPair.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +module Codec.Xlsx.Types.Internal.CfPair where + +import Text.XML.Cursor + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.ConditionalFormatting +import Codec.Xlsx.Writer.Internal + + +-- | Internal helper type for parsing "conditionalFormatting recods +-- TODO: pivot, extList +-- Implementing those will need this implementation to be changed +-- +-- See 18.3.1.18 "conditionalFormatting (Conditional Formatting)" (p. 1610) +newtype CfPair = CfPair + { unCfPair :: (SqRef, ConditionalFormatting) + } deriving (Eq, Show) + +instance FromCursor CfPair where + fromCursor cur = do + sqref <- fromAttribute "sqref" cur + let cfRules = cur $/ element (n"cfRule") >=> fromCursor + return $ CfPair (sqref, cfRules) + +instance ToElement CfPair where + toElement nm (CfPair (sqRef, cfRules)) = + elementList nm [ "sqref" .= toAttrVal sqRef ] + (map (toElement "cfRule") cfRules) diff --git a/src/Codec/Xlsx/Types/Internal/CommentTable.hs b/src/Codec/Xlsx/Types/Internal/CommentTable.hs --- a/src/Codec/Xlsx/Types/Internal/CommentTable.hs +++ b/src/Codec/Xlsx/Types/Internal/CommentTable.hs @@ -2,9 +2,9 @@ {-# LANGUAGE RecordWildCards #-} module Codec.Xlsx.Types.Internal.CommentTable where -import qualified Data.HashMap.Strict as HM import Data.List.Extra (nubOrd) -import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Map as M import Data.Text (Text) import Data.Text.Lazy (toStrict) import qualified Data.Text.Lazy.Builder as B @@ -19,14 +19,14 @@ import Codec.Xlsx.Writer.Internal newtype CommentTable = CommentTable - { _commentsTable :: HM.HashMap CellRef Comment } + { _commentsTable :: Map CellRef Comment } deriving (Show, Eq) fromList :: [(CellRef, Comment)] -> CommentTable -fromList = CommentTable . HM.fromList +fromList = CommentTable . M.fromList lookupComment :: CellRef -> CommentTable -> Maybe Comment -lookupComment ref = HM.lookup ref . _commentsTable +lookupComment ref = M.lookup ref . _commentsTable instance ToDocument CommentTable where toDocument = documentFromElement "Sheet comments generated by xlsx" @@ -35,35 +35,35 @@ instance ToElement CommentTable where toElement nm (CommentTable m) = Element { elementName = nm - , elementAttributes = Map.empty + , elementAttributes = M.empty , elementNodes = [ NodeElement $ elementListSimple "authors" authorNodes - , NodeElement . elementListSimple "commentList" $ map commentToEl (HM.toList m) ] + , NodeElement . elementListSimple "commentList" $ map commentToEl (M.toList m) ] } where commentToEl (ref, Comment{..}) = Element { elementName = "comment" - , elementAttributes = Map.fromList [ ("ref", ref) - , ("authorId", lookupAuthor _commentAuthor)] + , elementAttributes = M.fromList [ ("ref", ref) + , ("authorId", lookupAuthor _commentAuthor)] , elementNodes = [NodeElement $ toElement "text" _commentText] } - lookupAuthor a = fromJustNote "author lookup" $ HM.lookup a authorIds - authorNames = nubOrd . map _commentAuthor $ HM.elems m + lookupAuthor a = fromJustNote "author lookup" $ M.lookup a authorIds + authorNames = nubOrd . map _commentAuthor $ M.elems m decimalToText :: Integer -> Text decimalToText = toStrict . B.toLazyText . B.decimal - authorIds = HM.fromList $ zip authorNames (map decimalToText [0..]) + authorIds = M.fromList $ zip authorNames (map decimalToText [0..]) authorNodes = map (elementContent "author") authorNames instance FromCursor CommentTable where fromCursor cur = do let authorNames = cur $/ element (n"authors") &/ element (n"author") &/ content - authors = HM.fromList $ zip [0..] authorNames + authors = M.fromList $ zip [0..] authorNames items = cur $/ element (n"commentList") &/ element (n"comment") >=> parseComment authors - return . CommentTable $ HM.fromList items + return . CommentTable $ M.fromList items -parseComment :: HM.HashMap Int Text -> Cursor -> [(CellRef, Comment)] +parseComment :: Map Int Text -> Cursor -> [(CellRef, Comment)] parseComment authors cur = do ref <- cur $| attribute "ref" txt <- cur $/ element (n"text") >=> fromCursor authorId <- cur $| attribute "authorId" >=> decimal - let author = fromJustNote "authorId" $ HM.lookup authorId authors + let author = fromJustNote "authorId" $ M.lookup authorId authors return (ref, Comment txt author) diff --git a/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs --- a/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs +++ b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Codec.Xlsx.Types.Internal.SharedStringTable ( -- * Main types SharedStringTable(..) @@ -13,15 +11,16 @@ import Control.Monad -import Data.Maybe (mapMaybe) -import Data.Text (Text) -import Data.Vector (Vector) -import Numeric.Search.Range (searchFromTo) +import qualified Data.Map as Map +import Data.Maybe (mapMaybe) +import qualified Data.Set as Set +import Data.Text (Text) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Numeric.Search.Range (searchFromTo) +import Safe (fromJustNote) import Text.XML import Text.XML.Cursor -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Vector as V import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types @@ -110,9 +109,8 @@ -- | Internal generalization used by 'sstLookupText' and 'sstLookupRich' sstLookup :: SharedStringTable -> XlsxText -> Int sstLookup SharedStringTable{sstTable = shared} si = - case searchFromTo (\p -> shared V.! p >= si) 0 (V.length shared - 1) of - Just i -> i - Nothing -> error $ "SST entry for " ++ show si ++ " not found" + fromJustNote ("SST entry for " ++ show si ++ " not found") $ + searchFromTo (\p -> shared V.! p >= si) 0 (V.length shared - 1) sstItem :: SharedStringTable -> Int -> XlsxText sstItem (SharedStringTable shared) = (V.!) shared diff --git a/src/Codec/Xlsx/Types/PageSetup.hs b/src/Codec/Xlsx/Types/PageSetup.hs --- a/src/Codec/Xlsx/Types/PageSetup.hs +++ b/src/Codec/Xlsx/Types/PageSetup.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wall #-} module Codec.Xlsx.Types.PageSetup ( -- * Main types PageSetup(..) diff --git a/src/Codec/Xlsx/Types/RichText.hs b/src/Codec/Xlsx/Types/RichText.hs --- a/src/Codec/Xlsx/Types/RichText.hs +++ b/src/Codec/Xlsx/Types/RichText.hs @@ -2,7 +2,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wall #-} module Codec.Xlsx.Types.RichText ( -- * Main types RichTextRun(..) diff --git a/src/Codec/Xlsx/Types/SheetViews.hs b/src/Codec/Xlsx/Types/SheetViews.hs --- a/src/Codec/Xlsx/Types/SheetViews.hs +++ b/src/Codec/Xlsx/Types/SheetViews.hs @@ -2,7 +2,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wall #-} module Codec.Xlsx.Types.SheetViews ( -- * Structured type to construct 'SheetViews' SheetView(..) @@ -56,7 +55,7 @@ import qualified Data.Map as Map #if !MIN_VERSION_base(4,8,0) -import Control.Applicative +import Control.Applicative () #endif import Codec.Xlsx.Types.Common diff --git a/src/Codec/Xlsx/Types/StyleSheet.hs b/src/Codec/Xlsx/Types/StyleSheet.hs --- a/src/Codec/Xlsx/Types/StyleSheet.hs +++ b/src/Codec/Xlsx/Types/StyleSheet.hs @@ -2,7 +2,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wall #-} -- | Support for writing (but not reading) style sheets module Codec.Xlsx.Types.StyleSheet ( -- * The main two types @@ -14,6 +13,7 @@ , Border(..) , BorderStyle(..) , Color(..) + , Dxf(..) , Fill(..) , FillPattern(..) , Font(..) @@ -35,6 +35,7 @@ , styleSheetFonts , styleSheetFills , styleSheetCellXfs + , styleSheetDxfs -- ** CellXf , cellXfApplyAlignment , cellXfApplyBorder @@ -51,6 +52,12 @@ , cellXfId , cellXfAlignment , cellXfProtection + -- ** Dxf + , dxfAlignment + , dxfBorder + , dxfFill + , dxfFont + , dxfProtection -- ** Alignment , alignmentHorizontal , alignmentIndent @@ -147,7 +154,6 @@ -- * cellStyles -- * cellStyleXfs -- * colors --- * dxfs -- * extLst -- * numFmts -- * tableStyles @@ -167,7 +173,7 @@ -- | Cell formats -- - -- This element contains the master formatting records (xf) which define the + -- This element contains the master formatting records (xf) which define the -- formatting applied to cells in this workbook. These records are the -- starting point for determining the formatting for a cell. Cells in the -- Sheet Part reference the xf records by zero-based index. @@ -187,6 +193,20 @@ -- -- Section 18.8.23 "fonts (Fonts)" (p. 1769) , _styleSheetFonts :: [Font] + + -- | Differential formatting + -- + -- This element contains the master differential formatting records (dxf's) + -- which define formatting for all non-cell formatting in this workbook. + -- Whereas xf records fully specify a particular aspect of formatting (e.g., + -- cell borders) by referencing those formatting definitions elsewhere in + -- the Styles part, dxf records specify incremental (or differential) aspects + -- of formatting directly inline within the dxf element. The dxf formatting + -- is to be applied on top of or in addition to any formatting already + -- present on the object using the dxf record. + -- + -- Section 18.8.15, "dxfs (Formats)" (p. 1765) + , _styleSheetDxfs :: [Dxf] } deriving (Show, Eq, Ord) @@ -554,6 +574,19 @@ } deriving (Show, Eq, Ord) +-- | A single dxf record, expressing incremental formatting to be applied. +-- +-- Section 18.8.14, "dxf (Formatting)" (p. 1765) +data Dxf = Dxf + { _dxfFont :: Maybe Font + -- TODO: numFmt + , _dxfFill :: Maybe Fill + , _dxfAlignment :: Maybe Alignment + , _dxfBorder :: Maybe Border + , _dxfProtection :: Maybe Protection + -- TODO: extList + } deriving (Eq, Ord, Show) + -- Section 18.2.30 "font (Font)" (p. 1777) -- Note: This only implements the predefined values for 18.2.30 "All Languages", -- not the extended languages or custom ones from 18.2.31 @@ -775,6 +808,7 @@ makeLenses ''StyleSheet makeLenses ''CellXf +makeLenses ''Dxf makeLenses ''Alignment makeLenses ''Border @@ -841,6 +875,7 @@ , _styleSheetFonts = [] , _styleSheetFills = [] , _styleSheetCellXfs = [] + , _styleSheetDxfs = [] } instance Default CellXf where @@ -862,6 +897,15 @@ , _cellXfProtection = Nothing } +instance Default Dxf where + def = Dxf + { _dxfFont = Nothing + , _dxfFill = Nothing + , _dxfAlignment = Nothing + , _dxfBorder = Nothing + , _dxfProtection = Nothing + } + instance Default Alignment where def = Alignment { _alignmentHorizontal = Nothing @@ -969,7 +1013,7 @@ -- TODO: cellStyleXfs , countedElementList "cellXfs" $ map (toElement "xf") _styleSheetCellXfs -- TODO: cellStyles - -- TODO: dxfs + , countedElementList "dxfs" $ map (toElement "dxf") _styleSheetDxfs -- TODO: tableStyles -- TODO: colors -- TODO: extLst @@ -1002,6 +1046,20 @@ ] } +-- | See @CT_Dxf@, p. 3937 +instance ToElement Dxf where + toElement nm Dxf{..} = Element + { elementName = nm + , elementNodes = map NodeElement $ + catMaybes [ toElement "font" <$> _dxfFont + , toElement "fill" <$> _dxfFill + , toElement "alignment" <$> _dxfAlignment + , toElement "border" <$> _dxfBorder + , toElement "protection" <$> _dxfProtection + ] + , elementAttributes = Map.empty + } + -- | See @CT_CellAlignment@, p. 4482 instance ToElement Alignment where toElement nm Alignment{..} = Element { @@ -1228,7 +1286,7 @@ -- TODO: cellStyleXfs _styleSheetCellXfs = cur $/ element (n"cellXfs") &/ element (n"xf") >=> fromCursor -- TODO: cellStyles - -- TODO: dxfs + _styleSheetDxfs = cur $/ element (n"dxfs") &/ element (n"dxf") >=> fromCursor -- TODO: tableStyles -- TODO: colors -- TODO: extLst @@ -1240,16 +1298,16 @@ _fontName <- maybeElementValue (n"name") cur _fontCharset <- maybeElementValue (n"charset") cur _fontFamily <- maybeElementValue (n"family") cur - _fontBold <- maybeElementValue (n"b") cur - _fontItalic <- maybeElementValue (n"i") cur - _fontStrikeThrough<- maybeElementValue (n"strike") cur - _fontOutline <- maybeElementValue (n"outline") cur - _fontShadow <- maybeElementValue (n"shadow") cur - _fontCondense <- maybeElementValue (n"condense") cur - _fontExtend <- maybeElementValue (n"extend") cur + _fontBold <- maybeBoolElemValue (n"b") cur + _fontItalic <- maybeBoolElemValue (n"i") cur + _fontStrikeThrough<- maybeBoolElemValue (n"strike") cur + _fontOutline <- maybeBoolElemValue (n"outline") cur + _fontShadow <- maybeBoolElemValue (n"shadow") cur + _fontCondense <- maybeBoolElemValue (n"condense") cur + _fontExtend <- maybeBoolElemValue (n"extend") cur _fontColor <- maybeFromElement (n"color") cur _fontSize <- maybeElementValue (n"sz") cur - _fontUnderline <- maybeElementValue (n"u") cur + _fontUnderline <- maybeElementValueDef (n"u") FontUnderlineSingle cur _fontVertAlign <- maybeElementValue (n"vertAlign") cur _fontScheme <- maybeElementValue (n"scheme") cur return Font{..} @@ -1389,6 +1447,16 @@ _cellXfApplyAlignment <- maybeAttribute "applyAlignment" cur _cellXfApplyProtection <- maybeAttribute "applyProtection" cur return CellXf{..} + +-- | See @CT_Dxf@, p. 3937 +instance FromCursor Dxf where + fromCursor cur = do + _dxfFont <- maybeFromElement (n"font") cur + _dxfFill <- maybeFromElement (n"fill") cur + _dxfAlignment <- maybeFromElement (n"alignment") cur + _dxfBorder <- maybeFromElement (n"border") cur + _dxfProtection <- maybeFromElement (n"protection") cur + return Dxf{..} -- | See @CT_CellAlignment@, p. 4482 instance FromCursor Alignment where diff --git a/src/Codec/Xlsx/Types/Variant.hs b/src/Codec/Xlsx/Types/Variant.hs --- a/src/Codec/Xlsx/Types/Variant.hs +++ b/src/Codec/Xlsx/Types/Variant.hs @@ -32,15 +32,15 @@ fromCursor = variantFromNode . node variantFromNode :: Node -> [Variant] -variantFromNode n@(NodeElement el) | elementName el == (vt"lpwstr") = +variantFromNode n@(NodeElement el) | elementName el == vt "lpwstr" = fromNode n $/ content &| VtLpwstr - | elementName el == (vt"bool") = + | elementName el == vt "bool" = fromNode n $/ content >=> fmap VtBool . boolean - | elementName el == (vt"int") = + | elementName el == vt "int" = fromNode n $/ content >=> fmap VtInt . decimal - | elementName el == (vt"decimal") = + | elementName el == vt "decimal" = fromNode n $/ content >=> fmap VtDecimal . rational - | elementName el == (vt"blob") = + | elementName el == vt "blob" = fromNode n $/ content >=> fmap VtBlob . decodeBase64 . killWhitespace variantFromNode _ = fail "no matching nodes" diff --git a/src/Codec/Xlsx/Writer.hs b/src/Codec/Xlsx/Writer.hs --- a/src/Codec/Xlsx/Writer.hs +++ b/src/Codec/Xlsx/Writer.hs @@ -32,6 +32,7 @@ #endif import Codec.Xlsx.Types +import Codec.Xlsx.Types.Internal.CfPair import qualified Codec.Xlsx.Types.Internal.CommentTable as CommentTable import Codec.Xlsx.Types.Internal.CustomProperties import Codec.Xlsx.Types.Internal.Relationships as Relationships hiding (lookup) @@ -193,14 +194,18 @@ merges = ws ^. wsMerges sheetViews = ws ^. wsSheetViews pageSetup = ws ^. wsPageSetup - cType = xlsxCellType + cfPairs = map CfPair . M.toList $ ws ^. wsConditionalFormattings root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $ - Element "worksheet" M.empty $ catMaybes - [renderSheetViews <$> sheetViews, - nonEmptyNmEl "cols" M.empty $ map cwEl cws, - justNmEl "sheetData" M.empty $ map rowEl rows, - nonEmptyNmEl "mergeCells" M.empty $ map mergeE1 merges, - NodeElement . toElement "pageSetup" <$> pageSetup] + Element "worksheet" M.empty $ catMaybes $ + [ renderSheetViews <$> sheetViews, + nonEmptyNmEl "cols" M.empty $ map cwEl cws, + justNmEl "sheetData" M.empty $ map rowEl rows + ] ++ + map (Just . NodeElement . toElement "conditionalFormatting") cfPairs ++ + [ nonEmptyNmEl "mergeCells" M.empty $ map mergeE1 merges, + NodeElement . toElement "pageSetup" <$> pageSetup + ] + cType = xlsxCellType cwEl cw = NodeElement $! Element "col" (M.fromList [("min", txti $ cwMin cw), ("max", txti $ cwMax cw), ("width", txtd $ cwWidth cw), ("style", txti $ cwStyle cw)]) [] rowEl (r, cells) = nEl "row" diff --git a/src/Codec/Xlsx/Writer/Internal.hs b/src/Codec/Xlsx/Writer/Internal.hs --- a/src/Codec/Xlsx/Writer/Internal.hs +++ b/src/Codec/Xlsx/Writer/Internal.hs @@ -2,7 +2,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall #-} module Codec.Xlsx.Writer.Internal ( -- * Rendering documents ToDocument(..) @@ -11,6 +10,7 @@ -- * Rendering elements , ToElement(..) , countedElementList + , elementList , elementListSimple , elementContent , elementContentPreserved @@ -69,17 +69,17 @@ toElement :: Name -> a -> Element countedElementList :: Name -> [Element] -> Element -countedElementList nm as = elementList0 nm as [ "count" .= length as ] +countedElementList nm as = elementList nm [ "count" .= length as ] as -elementList0 :: Name -> [Element] -> [(Name, Text)] -> Element -elementList0 nm els attrs = Element { +elementList :: Name -> [(Name, Text)] -> [Element] -> Element +elementList nm attrs els = Element { elementName = nm , elementNodes = map NodeElement els , elementAttributes = Map.fromList attrs } elementListSimple :: Name -> [Element] -> Element -elementListSimple nm els = elementList0 nm els [] +elementListSimple nm els = elementList nm [] els elementContent0 :: Name -> [(Name, Text)] -> Text -> Element elementContent0 nm attrs txt = Element { diff --git a/test/DataTest.hs b/test/DataTest.hs --- a/test/DataTest.hs +++ b/test/DataTest.hs @@ -3,28 +3,32 @@ module Main (main) where import Control.Lens -import Data.ByteString.Lazy (ByteString) -import qualified Data.Map as M -import qualified Data.HashMap.Strict as HM -import Data.Time.Clock.POSIX (POSIXTime) -import qualified Data.Vector as V +import Control.Monad.State.Lazy +import Data.ByteString.Lazy (ByteString) +import qualified Data.Map as M +import Data.Time.Clock.POSIX (POSIXTime) +import qualified Data.Vector as V import Text.RawString.QQ import Text.XML import Text.XML.Cursor -import Test.Tasty (defaultMain, testGroup) -import Test.Tasty.HUnit (testCase) -import Test.Tasty.SmallCheck (testProperty) +import Test.Tasty (defaultMain, + testGroup) +import Test.Tasty.HUnit (testCase) +import Test.Tasty.SmallCheck (testProperty) -import Test.HUnit ((@=?)) -import Test.SmallCheck.Series (Positive (..)) +import Test.SmallCheck.Series (Positive (..)) +import Test.Tasty.HUnit (HUnitFailure (..), + (@=?)) import Codec.Xlsx +import Codec.Xlsx.Formatted import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Types.Internal.CustomProperties as CustomProperties import Codec.Xlsx.Types.Internal.CommentTable +import Codec.Xlsx.Types.Internal.CustomProperties as CustomProperties import Codec.Xlsx.Types.Internal.SharedStringTable +import Diff main :: IO () main = defaultMain $ @@ -44,14 +48,18 @@ , testCase "correct comments parsing" $ [testCommentTable] @=? testParsedComments , testCase "correct custom properties parsing" $ - [testCustomProperties] @=? testParsedCustomProperties + [testCustomProperties] @==? testParsedCustomProperties + , testCase "proper results from `formatted`" $ + testFormattedResult @==? testRunFormatted + , testCase "proper results from `conditionalltyFormatted`" $ + testCondFormattedResult @==? testRunCondFormatted ] testXlsx :: Xlsx testXlsx = Xlsx sheets minimalStyles definedNames customProperties where sheets = M.fromList [("List1", sheet1), ("Another sheet", sheet2)] - sheet1 = Worksheet cols rowProps testCellMap1 ranges sheetViews pageSetup + sheet1 = Worksheet cols rowProps testCellMap1 ranges sheetViews pageSetup cFormatting sheet2 = def & wsCells .~ testCellMap2 rowProps = M.fromList [(1, RowProps (Just 50) (Just 3))] cols = [ColumnsWidth 1 10 15 1] @@ -73,6 +81,17 @@ & pageSetupErrors .~ Just PrintErrorsDash & pageSetupPaperSize .~ Just PaperA4 customProperties = M.fromList [("some_prop", VtInt 42)] + cFormatting = M.fromList [(SqRef ["A1:B3"], rules1), (SqRef ["C1:C10"], rules2)] + cfRule c d = CfRule { _cfrCondition = c + , _cfrDxfId = Just d + , _cfrPriority = topCfPriority + , _cfrStopIfTrue = Nothing + } + rules1 = [ cfRule ContainsBlanks 1 + , cfRule (ContainsText "foo") 2 + , cfRule (CellIs (OpBetween (Formula "A1") (Formula "B10"))) 3 + ] + rules2 = [ cfRule ContainsErrors 3 ] testCellMap1 :: CellMap testCellMap1 = M.fromList [ ((1, 2), cd1), ((1, 5), cd2) @@ -117,7 +136,12 @@ fromRight (Right b) = b testStyleSheet :: StyleSheet -testStyleSheet = minimalStyleSheet +testStyleSheet = minimalStyleSheet & styleSheetDxfs .~ [dxf1, dxf2] + where + dxf1 = def & dxfFont ?~ (def & fontBold ?~ True + & fontSize ?~ 12) + dxf2 = def & dxfFill ?~ (def & fillPattern ?~ (def & fillPatternBgColor ?~ red)) + red = def & colorARGB ?~ "FFFF0000" testSharedStringTable :: SharedStringTable testSharedStringTable = SharedStringTable $ V.fromList items @@ -142,7 +166,7 @@ testParsedSharedStringTablesWithEmpty :: [SharedStringTable] testParsedSharedStringTablesWithEmpty = fromCursor . fromDocument $ parseLBS_ def testStringsWithEmpty -testCommentTable = CommentTable $ HM.fromList +testCommentTable = CommentTable $ M.fromList [ ("D4", Comment (XlsxRichText rich) "Bob") , ("A2", Comment (XlsxText "Some comment here") "CBR") ] where @@ -254,3 +278,85 @@ |] + +testFormattedResult :: Formatted +testFormattedResult = Formatted cm styleSheet merges + where + cm = M.fromList [((1, 1), cell11),((1, 2), cell2)] + cell11 = Cell + { _cellStyle = Just 1 + , _cellValue = Just (CellText "text at A1") + , _cellComment = Nothing } + cell2 = Cell + { _cellStyle = Just 2 + , _cellValue = Just (CellDouble 1.23) + , _cellComment = Nothing } + merges = [] + styleSheet = + minimalStyleSheet & styleSheetCellXfs %~ (++ [cellXf1, cellXf2]) + & styleSheetFonts %~ (++ [font1, font2]) + nextFontId = length (minimalStyleSheet ^. styleSheetFonts) + cellXf1 = def + { _cellXfApplyFont = Just True + , _cellXfFontId = Just nextFontId } + font1 = def + { _fontName = Just "Calibri" + , _fontBold = Just True } + cellXf2 = def + { _cellXfApplyFont = Just True + , _cellXfFontId = Just (nextFontId + 1) } + font2 = def + { _fontItalic = Just True } + +testRunFormatted :: Formatted +testRunFormatted = formatted formattedCellMap minimalStyleSheet + where + formattedCellMap = flip execState def $ do + let font1 = def & fontBold ?~ True + & fontName ?~ "Calibri" + at (1, 1) ?= (def & formattedValue ?~ CellText "text at A1" + & formattedFont ?~ font1) + at (1, 2) ?= (def & formattedValue ?~ CellDouble 1.23 + & formattedFont . non def . fontItalic ?~ True) + +testCondFormattedResult :: CondFormatted +testCondFormattedResult = CondFormatted styleSheet formattings + where + styleSheet = + minimalStyleSheet & styleSheetDxfs .~ dxfs + dxfs = [ def & dxfFont ?~ (def & fontUnderline ?~ FontUnderlineSingle) + , def & dxfFont ?~ (def & fontStrikeThrough ?~ True) + , def & dxfFont ?~ (def & fontBold ?~ True) ] + formattings = M.fromList [ (SqRef ["A1:A2", "B2:B3"], [cfRule1, cfRule2]) + , (SqRef ["C3:E10"], [cfRule1]) + , (SqRef ["F1:G10"], [cfRule3]) ] + cfRule1 = CfRule + { _cfrCondition = ContainsBlanks + , _cfrDxfId = Just 0 + , _cfrPriority = 1 + , _cfrStopIfTrue = Nothing } + cfRule2 = CfRule + { _cfrCondition = BeginsWith "foo" + , _cfrDxfId = Just 1 + , _cfrPriority = 1 + , _cfrStopIfTrue = Nothing } + cfRule3 = CfRule + { _cfrCondition = CellIs (OpGreaterThan (Formula "A1")) + , _cfrDxfId = Just 2 + , _cfrPriority = 1 + , _cfrStopIfTrue = Nothing } + +testRunCondFormatted :: CondFormatted +testRunCondFormatted = conditionallyFormatted condFmts minimalStyleSheet + where + condFmts = flip execState def $ do + let cfRule1 = def & condfmtCondition .~ ContainsBlanks + & condfmtDxf . dxfFont . non def . fontUnderline ?~ FontUnderlineSingle + cfRule2 = def & condfmtCondition .~ BeginsWith "foo" + & condfmtDxf . dxfFont . non def . fontStrikeThrough ?~ True + cfRule3 = def & condfmtCondition .~ CellIs (OpGreaterThan (Formula "A1")) + & condfmtDxf . dxfFont . non def . fontBold ?~ True + at "A1:A2" ?= [cfRule1, cfRule2] + at "B2:B3" ?= [cfRule1, cfRule2] + at "C3:E10" ?= [cfRule1] + at "F1:G10" ?= [cfRule3] diff --git a/test/Diff.hs b/test/Diff.hs new file mode 100644 --- /dev/null +++ b/test/Diff.hs @@ -0,0 +1,14 @@ +module Diff where + +import Data.Algorithm.Diff (Diff (..), getGroupedDiff) +import Data.Algorithm.DiffOutput (ppDiff) +import Data.Monoid ((<>)) +import Test.Tasty.HUnit (Assertion, assertBool) +import Text.Groom (groom) + +-- | Like '@=?' but producing a diff on failure. +(@==?) :: (Eq a, Show a) => a -> a -> Assertion +x @==? y = + assertBool ("Expected:\n" <> groom x <> "\nDifference:\n" <> msg) (x == y) + where + msg = ppDiff $ getGroupedDiff (lines . groom $ x) (lines . groom $ y) diff --git a/xlsx.cabal b/xlsx.cabal --- a/xlsx.cabal +++ b/xlsx.cabal @@ -1,6 +1,6 @@ Name: xlsx -Version: 0.2.2.2 +Version: 0.2.3 Synopsis: Simple and incomplete Excel file parser/writer Description: @@ -26,17 +26,20 @@ Category: Codec Build-type: Simple -Tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2 +Tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 Cabal-version: >=1.10 Library Hs-source-dirs: src + ghc-options: -Wall Exposed-modules: Codec.Xlsx , Codec.Xlsx.Types , Codec.Xlsx.Types.Comment , Codec.Xlsx.Types.Common + , Codec.Xlsx.Types.ConditionalFormatting , Codec.Xlsx.Types.Internal + , Codec.Xlsx.Types.Internal.CfPair , Codec.Xlsx.Types.Internal.CommentTable , Codec.Xlsx.Types.Internal.CustomProperties , Codec.Xlsx.Types.Internal.Relationships @@ -69,7 +72,6 @@ , text >= 0.11.3.1 , time >= 1.4.0.1 , transformers >= 0.3.0.0 - , unordered-containers , vector >= 0.10 , xml-conduit >= 1.1.0 , zip-archive >= 0.2 @@ -90,21 +92,23 @@ type: exitcode-stdio-1.0 main-is: DataTest.hs hs-source-dirs: test/ + other-modules: Diff Build-Depends: base + , bytestring , containers - , time - , xlsx - , xml-conduit >= 1.1.0 + , Diff >= 0.3.0 + , groom + , lens + , mtl + , raw-strings-qq , smallcheck - , HUnit , tasty - , tasty-smallcheck , tasty-hunit - , lens - , bytestring + , tasty-smallcheck + , time , vector - , raw-strings-qq - , unordered-containers + , xlsx + , xml-conduit >= 1.1.0 Default-Language: Haskell2010 source-repository head