xlsx 0.2.2.2 → 0.2.3
raw patch · 20 files changed
+816/−169 lines, 20 filesdep +Diffdep +groomdep −HUnitdep −unordered-containersdep ~mtl
Dependencies added: Diff, groom
Dependencies removed: HUnit, unordered-containers
Dependency ranges changed: mtl
Files
- CHANGELOG.markdown +5/−0
- src/Codec/Xlsx/Formatted.hs +104/−32
- src/Codec/Xlsx/Parser.hs +6/−4
- src/Codec/Xlsx/Parser/Internal.hs +19/−7
- src/Codec/Xlsx/Types.hs +38/−15
- src/Codec/Xlsx/Types/Common.hs +36/−20
- src/Codec/Xlsx/Types/ConditionalFormatting.hs +295/−0
- src/Codec/Xlsx/Types/Internal/CfPair.hs +30/−0
- src/Codec/Xlsx/Types/Internal/CommentTable.hs +16/−16
- src/Codec/Xlsx/Types/Internal/SharedStringTable.hs +12/−14
- src/Codec/Xlsx/Types/PageSetup.hs +0/−1
- src/Codec/Xlsx/Types/RichText.hs +0/−1
- src/Codec/Xlsx/Types/SheetViews.hs +1/−2
- src/Codec/Xlsx/Types/StyleSheet.hs +81/−13
- src/Codec/Xlsx/Types/Variant.hs +5/−5
- src/Codec/Xlsx/Writer.hs +12/−7
- src/Codec/Xlsx/Writer/Internal.hs +5/−5
- test/DataTest.hs +121/−15
- test/Diff.hs +14/−0
- xlsx.cabal +16/−12
CHANGELOG.markdown view
@@ -1,3 +1,8 @@+0.2.3+-----+* added conditional formatting support+* fixed reading empty <font> subelements with defaults (thanks Steve Bigham <steve.bigham@gmail.com>)+ 0.2.2.2 ----- * fixed missing from parsing code font family value 0 (Not applicable) (thanks Steve Bigham <steve.bigham@gmail.com>)
src/Codec/Xlsx/Formatted.hs view
@@ -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+ }
src/Codec/Xlsx/Parser.hs view
@@ -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 =
src/Codec/Xlsx/Parser/Internal.hs view
@@ -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
src/Codec/Xlsx/Types.hs view
@@ -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)
src/Codec/Xlsx/Types/Common.hs view
@@ -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
+ src/Codec/Xlsx/Types/ConditionalFormatting.hs view
@@ -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"
+ src/Codec/Xlsx/Types/Internal/CfPair.hs view
@@ -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)
src/Codec/Xlsx/Types/Internal/CommentTable.hs view
@@ -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)
@@ -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
src/Codec/Xlsx/Types/PageSetup.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -Wall #-} module Codec.Xlsx.Types.PageSetup ( -- * Main types PageSetup(..)
src/Codec/Xlsx/Types/RichText.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -Wall #-} module Codec.Xlsx.Types.RichText ( -- * Main types RichTextRun(..)
src/Codec/Xlsx/Types/SheetViews.hs view
@@ -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
src/Codec/Xlsx/Types/StyleSheet.hs view
@@ -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
src/Codec/Xlsx/Types/Variant.hs view
@@ -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"
src/Codec/Xlsx/Writer.hs view
@@ -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"
src/Codec/Xlsx/Writer/Internal.hs view
@@ -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 {
test/DataTest.hs view
@@ -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 @@ </property> </Properties> |]++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]
+ test/Diff.hs view
@@ -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)
xlsx.cabal view
@@ -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