xlsx-1.1.2.2/benchmarks/ 0000755 0000000 0000000 00000000000 14551273353 013164 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/data/ 0000755 0000000 0000000 00000000000 14551273353 011760 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/src/ 0000755 0000000 0000000 00000000000 14551273353 011636 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/src/Codec/ 0000755 0000000 0000000 00000000000 14552150776 012657 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/src/Codec/Xlsx/ 0000755 0000000 0000000 00000000000 14552151411 013600 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/src/Codec/Xlsx/Parser/ 0000755 0000000 0000000 00000000000 14551273353 015045 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/src/Codec/Xlsx/Parser/Internal/ 0000755 0000000 0000000 00000000000 14551273353 016621 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/src/Codec/Xlsx/Parser/Stream/ 0000755 0000000 0000000 00000000000 14551273353 016300 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/src/Codec/Xlsx/Types/ 0000755 0000000 0000000 00000000000 14551552756 014724 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/src/Codec/Xlsx/Types/Drawing/ 0000755 0000000 0000000 00000000000 14551273353 016310 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/src/Codec/Xlsx/Types/Internal/ 0000755 0000000 0000000 00000000000 14551553042 016465 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/src/Codec/Xlsx/Types/PivotTable/ 0000755 0000000 0000000 00000000000 14551273353 016766 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/src/Codec/Xlsx/Writer/ 0000755 0000000 0000000 00000000000 14551273353 015065 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/src/Codec/Xlsx/Writer/Internal/ 0000755 0000000 0000000 00000000000 14551273353 016641 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/test/ 0000755 0000000 0000000 00000000000 14551273353 012026 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/test/CommonTests/ 0000755 0000000 0000000 00000000000 14551273353 014301 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/test/Test/ 0000755 0000000 0000000 00000000000 14551273353 012745 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/test/Test/SmallCheck/ 0000755 0000000 0000000 00000000000 14551273353 014753 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/test/Test/SmallCheck/Series/ 0000755 0000000 0000000 00000000000 14551273353 016205 5 ustar 00 0000000 0000000 xlsx-1.1.2.2/src/Codec/Xlsx.hs 0000644 0000000 0000000 00000002551 14551273353 014150 0 ustar 00 0000000 0000000 -- | This module provides solution for parsing and writing Microsoft
-- Open Office XML Workbook format i.e. *.xlsx files
--
-- As a simple example you could read cell B3 from the 1st sheet of workbook \"report.xlsx\"
-- using the following code:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > module Read where
-- > import Codec.Xlsx
-- > import qualified Data.ByteString.Lazy as L
-- > import Control.Lens
-- >
-- > main :: IO ()
-- > main = do
-- > bs <- L.readFile "report.xlsx"
-- > let value = toXlsx bs ^? ixSheet "List1" .
-- > ixCell (3,2) . cellValue . _Just
-- > putStrLn $ "Cell B3 contains " ++ show value
--
-- And the following example module shows a way to construct and write xlsx file
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > module Write where
-- > import Codec.Xlsx
-- > import Control.Lens
-- > import qualified Data.ByteString.Lazy as L
-- > import Data.Time.Clock.POSIX
-- >
-- > main :: IO ()
-- > main = do
-- > ct <- getPOSIXTime
-- > let
-- > sheet = def & cellValueAt (1,2) ?~ CellDouble 42.0
-- > & cellValueAt (3,2) ?~ CellText "foo"
-- > xlsx = def & atSheet "List1" ?~ sheet
-- > L.writeFile "example.xlsx" $ fromXlsx ct xlsx
module Codec.Xlsx
( module X
) where
import Codec.Xlsx.Types as X
import Codec.Xlsx.Parser as X
import Codec.Xlsx.Writer as X
import Codec.Xlsx.Lens as X
xlsx-1.1.2.2/src/Codec/Xlsx/Types.hs 0000644 0000000 0000000 00000032711 14551273353 015255 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RankNTypes #-}
module Codec.Xlsx.Types (
-- * The main types
Xlsx(..)
, Styles(..)
, DefinedNames(..)
, ColumnsProperties(..)
, PageSetup(..)
, Worksheet(..)
, SheetState(..)
, CellMap
, CellValue(..)
, CellFormula(..)
, FormulaExpression(..)
, Cell.SharedFormulaIndex(..)
, Cell.SharedFormulaOptions(..)
, Cell(..)
, RowHeight(..)
, RowProperties (..)
-- * Lenses
-- ** Workbook
, xlSheets
, xlStyles
, xlDefinedNames
, xlCustomProperties
, xlDateBase
-- ** Worksheet
, wsColumnsProperties
, wsRowPropertiesMap
, wsCells
, wsDrawing
, wsMerges
, wsSheetViews
, wsPageSetup
, wsConditionalFormattings
, wsDataValidations
, wsPivotTables
, wsAutoFilter
, wsTables
, wsProtection
, wsSharedFormulas
, wsState
-- ** Cells
, Cell.cellValue
, Cell.cellStyle
, Cell.cellComment
, Cell.cellFormula
-- ** Row properties
, rowHeightLens
, _CustomHeight
, _AutomaticHeight
-- * Style helpers
, emptyStyles
, renderStyleSheet
, parseStyleSheet
-- * Misc
, simpleCellFormula
, sharedFormulaByIndex
, def
, toRows
, fromRows
, module X
) where
import Control.Exception (SomeException, toException)
#ifdef USE_MICROLENS
import Lens.Micro.TH
import Data.Profunctor(dimap)
import Data.Profunctor.Choice
#else
#endif
import Control.DeepSeq (NFData)
import qualified Data.ByteString.Lazy as L
import Data.Default
import Data.Function (on)
import Data.List (groupBy)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (catMaybes, isJust)
import Data.Text (Text)
import GHC.Generics (Generic)
import Text.XML (parseLBS, renderLBS)
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.AutoFilter as X
import Codec.Xlsx.Types.Cell as Cell
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.DataValidation as X
import Codec.Xlsx.Types.Drawing as X
import Codec.Xlsx.Types.Drawing.Chart as X
import Codec.Xlsx.Types.Drawing.Common as X
import Codec.Xlsx.Types.PageSetup as X
import Codec.Xlsx.Types.PivotTable as X
import Codec.Xlsx.Types.Protection as X
import Codec.Xlsx.Types.RichText as X
import Codec.Xlsx.Types.SheetViews as X
import Codec.Xlsx.Types.StyleSheet as X
import Codec.Xlsx.Types.Table as X
import Codec.Xlsx.Types.Variant as X
import Codec.Xlsx.Writer.Internal
#ifdef USE_MICROLENS
import Lens.Micro
#else
import Control.Lens (lens, Lens', makeLenses)
import Control.Lens.TH (makePrisms)
#endif
-- | Height of a row in points (1/72in)
data RowHeight
= CustomHeight !Double
-- ^ Row height is set by the user
| AutomaticHeight !Double
-- ^ Row height is set automatically by the program
deriving (Eq, Ord, Show, Read, Generic)
instance NFData RowHeight
#ifdef USE_MICROLENS
-- Since micro-lens denies the existence of prisms,
-- I pasted the splice that's generated from makePrisms,
-- then I copied over the definitions from Control.Lens for the prism
-- function as well.
type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
type Prism' s a = Prism s s a a
prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism bt seta = dimap seta (either pure (fmap bt)) . right'
_CustomHeight :: Prism' RowHeight Double
_CustomHeight
= (prism (\ x1_a4xgd -> CustomHeight x1_a4xgd))
(\ x_a4xge
-> case x_a4xge of
CustomHeight y1_a4xgf -> Right y1_a4xgf
_ -> Left x_a4xge)
{-# INLINE _CustomHeight #-}
_AutomaticHeight :: Prism' RowHeight Double
_AutomaticHeight
= (prism (\ x1_a4xgg -> AutomaticHeight x1_a4xgg))
(\ x_a4xgh
-> case x_a4xgh of
AutomaticHeight y1_a4xgi -> Right y1_a4xgi
_ -> Left x_a4xgh)
{-# INLINE _AutomaticHeight #-}
#else
makePrisms ''RowHeight
#endif
-- | Properties of a row. See §18.3.1.73 "row (Row)" for more details
data RowProperties = RowProps
{ rowHeight :: Maybe RowHeight
-- ^ Row height in points
, rowStyle :: Maybe Int
-- ^ Style to be applied to row
, rowHidden :: Bool
-- ^ Whether row is visible or not
} deriving (Eq, Ord, Show, Read, Generic)
instance NFData RowProperties
rowHeightLens :: Lens' RowProperties (Maybe RowHeight)
rowHeightLens = lens rowHeight $ \x y -> x{rowHeight=y}
instance Default RowProperties where
def = RowProps { rowHeight = Nothing
, rowStyle = Nothing
, rowHidden = False
}
-- | Column range (from cwMin to cwMax) properties
data ColumnsProperties = ColumnsProperties
{ cpMin :: Int
-- ^ First column affected by this 'ColumnWidth' record.
, cpMax :: Int
-- ^ Last column affected by this 'ColumnWidth' record.
, cpWidth :: Maybe Double
-- ^ Column width measured as the number of characters of the
-- maximum digit width of the numbers 0, 1, 2, ..., 9 as rendered in
-- the normal style's font.
--
-- See longer description in Section 18.3.1.13 "col (Column Width &
-- Formatting)" (p. 1605)
, cpStyle :: Maybe Int
-- ^ Default style for the affected column(s). Affects cells not yet
-- allocated in the column(s). In other words, this style applies
-- to new columns.
, cpHidden :: Bool
-- ^ Flag indicating if the affected column(s) are hidden on this
-- worksheet.
, cpCollapsed :: Bool
-- ^ Flag indicating if the outlining of the affected column(s) is
-- in the collapsed state.
, cpBestFit :: Bool
-- ^ Flag indicating if the specified column(s) is set to 'best
-- fit'.
} deriving (Eq, Show, Generic)
instance NFData ColumnsProperties
instance FromCursor ColumnsProperties where
fromCursor c = do
cpMin <- fromAttribute "min" c
cpMax <- fromAttribute "max" c
cpWidth <- maybeAttribute "width" c
cpStyle <- maybeAttribute "style" c
cpHidden <- fromAttributeDef "hidden" False c
cpCollapsed <- fromAttributeDef "collapsed" False c
cpBestFit <- fromAttributeDef "bestFit" False c
return ColumnsProperties {..}
instance FromXenoNode ColumnsProperties where
fromXenoNode root = parseAttributes root $ do
cpMin <- fromAttr "min"
cpMax <- fromAttr "max"
cpWidth <- maybeAttr "width"
cpStyle <- maybeAttr "style"
cpHidden <- fromAttrDef "hidden" False
cpCollapsed <- fromAttrDef "collapsed" False
cpBestFit <- fromAttrDef "bestFit" False
return ColumnsProperties {..}
-- | Sheet visibility state
-- cf. Ecma Office Open XML Part 1:
-- 18.18.68 ST_SheetState (Sheet Visibility Types)
-- * "visible"
-- Indicates the sheet is visible (default)
-- * "hidden"
-- Indicates the workbook window is hidden, but can be shown by the user via the user interface.
-- * "veryHidden"
-- Indicates the sheet is hidden and cannot be shown in the user interface (UI). This state is only available programmatically.
data SheetState =
Visible -- ^ state="visible"
| Hidden -- ^ state="hidden"
| VeryHidden -- ^ state="veryHidden"
deriving (Eq, Show, Generic)
instance NFData SheetState
instance Default SheetState where
def = Visible
instance FromAttrVal SheetState where
fromAttrVal "visible" = readSuccess Visible
fromAttrVal "hidden" = readSuccess Hidden
fromAttrVal "veryHidden" = readSuccess VeryHidden
fromAttrVal t = invalidText "SheetState" t
instance FromAttrBs SheetState where
fromAttrBs "visible" = return Visible
fromAttrBs "hidden" = return Hidden
fromAttrBs "veryHidden" = return VeryHidden
fromAttrBs t = unexpectedAttrBs "SheetState" t
instance ToAttrVal SheetState where
toAttrVal Visible = "visible"
toAttrVal Hidden = "hidden"
toAttrVal VeryHidden = "veryHidden"
-- | Xlsx worksheet
data Worksheet = Worksheet
{ _wsColumnsProperties :: [ColumnsProperties] -- ^ column widths
, _wsRowPropertiesMap :: Map RowIndex RowProperties
-- ^ custom row properties (height, style) map
, _wsCells :: CellMap -- ^ data mapped by (row, column) pairs
, _wsDrawing :: Maybe Drawing -- ^ SpreadsheetML Drawing
, _wsMerges :: [Range] -- ^ list of cell merges
, _wsSheetViews :: Maybe [SheetView]
, _wsPageSetup :: Maybe PageSetup
, _wsConditionalFormattings :: Map SqRef ConditionalFormatting
, _wsDataValidations :: Map SqRef DataValidation
, _wsPivotTables :: [PivotTable]
, _wsAutoFilter :: Maybe AutoFilter
, _wsTables :: [Table]
, _wsProtection :: Maybe SheetProtection
, _wsSharedFormulas :: Map SharedFormulaIndex SharedFormulaOptions
, _wsState :: SheetState
} deriving (Eq, Show, Generic)
instance NFData Worksheet
makeLenses ''Worksheet
instance Default Worksheet where
def =
Worksheet
{ _wsColumnsProperties = []
, _wsRowPropertiesMap = M.empty
, _wsCells = M.empty
, _wsDrawing = Nothing
, _wsMerges = []
, _wsSheetViews = Nothing
, _wsPageSetup = Nothing
, _wsConditionalFormattings = M.empty
, _wsDataValidations = M.empty
, _wsPivotTables = []
, _wsAutoFilter = Nothing
, _wsTables = []
, _wsProtection = Nothing
, _wsSharedFormulas = M.empty
, _wsState = def
}
-- | Raw worksheet styles, for structured implementation see 'StyleSheet'
-- and functions in "Codec.Xlsx.Types.StyleSheet"
newtype Styles = Styles {unStyles :: L.ByteString}
deriving (Eq, Show, Generic)
instance NFData Styles
-- | Structured representation of Xlsx file (currently a subset of its contents)
data Xlsx = Xlsx
{ _xlSheets :: [(Text, Worksheet)]
, _xlStyles :: Styles
, _xlDefinedNames :: DefinedNames
, _xlCustomProperties :: Map Text Variant
, _xlDateBase :: DateBase
-- ^ date base to use when converting serial value (i.e. 'CellDouble d')
-- into date-time. Default value is 'DateBase1900'
--
-- See also 18.17.4.1 "Date Conversion for Serial Date-Times" (p. 2067)
} deriving (Eq, Show, Generic)
instance NFData Xlsx
-- | Defined names
--
-- Each defined name consists of a name, an optional local sheet ID, and a value.
--
-- This element defines the collection of defined names for this workbook.
-- Defined names are descriptive names to represent cells, ranges of cells,
-- formulas, or constant values. Defined names can be used to represent a range
-- on any worksheet.
--
-- Excel also defines a number of reserved names with a special interpretation:
--
-- * @_xlnm.Print_Area@ specifies the workbook's print area.
-- Example value: @SheetName!$A:$A,SheetName!$1:$4@
-- * @_xlnm.Print_Titles@ specifies the row(s) or column(s) to repeat
-- at the top of each printed page.
-- * @_xlnm.Sheet_Title@:refers to a sheet title.
--
-- and others. See Section 18.2.6, "definedNames (Defined Names)" (p. 1728) of
-- the spec (second edition).
--
-- NOTE: Right now this is only a minimal implementation of defined names.
newtype DefinedNames = DefinedNames [(Text, Maybe Text, Text)]
deriving (Eq, Show, Generic)
instance NFData DefinedNames
makeLenses ''Xlsx
instance Default Xlsx where
def = Xlsx [] emptyStyles def M.empty DateBase1900
instance Default DefinedNames where
def = DefinedNames []
emptyStyles :: Styles
emptyStyles = Styles ""
-- | Render 'StyleSheet'
--
-- This is used to render a structured 'StyleSheet' into a raw XML 'Styles'
-- document. Actually /replacing/ 'Styles' with 'StyleSheet' would mean we
-- would need to write a /parser/ for 'StyleSheet' as well (and would moreover
-- require that we support the full style sheet specification, which is still
-- quite a bit of work).
renderStyleSheet :: StyleSheet -> Styles
renderStyleSheet = Styles . renderLBS def . toDocument
-- | Parse 'StyleSheet'
--
-- This is used to parse raw 'Styles' into structured 'StyleSheet'
-- currently not all of the style sheet specification is supported
-- so parser (and the data model) is to be completed
parseStyleSheet :: Styles -> Either SomeException StyleSheet
parseStyleSheet (Styles bs) = parseLBS def bs >>= parseDoc
where
parseDoc doc = case fromCursor (fromDocument doc) of
[stylesheet] -> Right stylesheet
_ -> Left . toException $ ParseException "Could not parse style sheets"
-- | converts cells mapped by (row, column) into rows which contain
-- row index and cells as pairs of column indices and cell values
toRows :: CellMap -> [(RowIndex, [(ColumnIndex, Cell)])]
toRows cells =
map extractRow $ groupBy ((==) `on` (fst . fst)) $ M.toList cells
where
extractRow row@(((x,_),_):_) =
(x, map (\((_,y),v) -> (y,v)) row)
extractRow _ = error "invalid CellMap row"
-- | reverse to 'toRows'
fromRows :: [(RowIndex, [(ColumnIndex, Cell)])] -> CellMap
fromRows rows = M.fromList $ concatMap mapRow rows
where
mapRow (r, cells) = map (\(c, v) -> ((r, c), v)) cells
instance ToElement ColumnsProperties where
toElement nm ColumnsProperties {..} = leafElement nm attrs
where
attrs =
["min" .= cpMin, "max" .= cpMax] ++
catMaybes
[ "style" .=? (justNonDef 0 =<< cpStyle)
, "width" .=? cpWidth
, "customWidth" .=? justTrue (isJust cpWidth)
, "hidden" .=? justTrue cpHidden
, "collapsed" .=? justTrue cpCollapsed
, "bestFit" .=? justTrue cpBestFit
] xlsx-1.1.2.2/src/Codec/Xlsx/Formatted.hs 0000644 0000000 0000000 00000043166 14551273353 016104 0 ustar 00 0000000 0000000 -- | Higher level interface for creating styled worksheets
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Formatted
( FormattedCell(..)
, Formatted(..)
, Format(..)
, formatted
, formatWorkbook
, toFormattedCells
, CondFormatted(..)
, conditionallyFormatted
-- * Lenses
-- ** Format
, formatAlignment
, formatBorder
, formatFill
, formatFont
, formatNumberFormat
, formatProtection
, formatPivotButton
, formatQuotePrefix
-- ** FormattedCell
, formattedCell
, formattedFormat
, formattedColSpan
, formattedRowSpan
-- ** FormattedCondFmt
, condfmtCondition
, condfmtDxf
, condfmtPriority
, condfmtStopIfTrue
) where
#ifdef USE_MICROLENS
import Lens.Micro
import Lens.Micro.Mtl
import Lens.Micro.TH
import Lens.Micro.GHC ()
#else
import Control.Lens
#endif
import Control.Monad (forM, guard)
import Control.Monad.State hiding (forM_, mapM)
import Data.Default
import Data.Foldable (asum, forM_)
import Data.Function (on)
import Data.List (foldl', groupBy, sortBy, sortBy)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Ord (comparing)
import Data.Text (Text)
import Data.Traversable (mapM)
import Data.Tuple (swap)
import GHC.Generics (Generic)
import Prelude hiding (mapM)
import Safe (headNote, fromJustNote)
import Codec.Xlsx.Types
{-------------------------------------------------------------------------------
Internal: formatting state
-------------------------------------------------------------------------------}
data FormattingState = FormattingState {
_formattingBorders :: Map Border Int
, _formattingCellXfs :: Map CellXf Int
, _formattingFills :: Map Fill Int
, _formattingFonts :: Map Font Int
, _formattingNumFmts :: Map Text 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
, _formattingNumFmts = M.fromList . map swap $ M.toList _styleSheetNumFmts
, _formattingMerges = []
}
fromValueList :: Ord a => [a] -> Map a Int
fromValueList = M.fromList . (`zip` [0..])
toValueList :: Map a Int -> [a]
toValueList = map snd . sortBy (comparing fst) . map swap . M.toList
updateStyleSheetFromState :: StyleSheet -> FormattingState -> StyleSheet
updateStyleSheetFromState sSheet FormattingState{..} = sSheet
{ _styleSheetBorders = toValueList _formattingBorders
, _styleSheetCellXfs = toValueList _formattingCellXfs
, _styleSheetFills = toValueList _formattingFills
, _styleSheetFonts = toValueList _formattingFonts
, _styleSheetNumFmts = M.fromList . map swap $ M.toList _formattingNumFmts
}
getId :: Ord a => Lens' FormattingState (Map a Int) -> a -> State FormattingState Int
getId = getId' 0
getId' :: Ord a
=> Int
-> Lens' FormattingState (Map a Int)
-> a
-> State FormattingState Int
getId' k f v = do
aMap <- use f
case M.lookup v aMap of
Just anId -> return anId
Nothing -> do let anId = k + M.size aMap
f %= M.insert v anId
return anId
{-------------------------------------------------------------------------------
Unwrapped cell conditional formatting
-------------------------------------------------------------------------------}
data FormattedCondFmt = FormattedCondFmt
{ _condfmtCondition :: Condition
, _condfmtDxf :: Dxf
, _condfmtPriority :: Int
, _condfmtStopIfTrue :: Maybe Bool
} deriving (Eq, Show, Generic)
makeLenses ''FormattedCondFmt
{-------------------------------------------------------------------------------
Cell with formatting
-------------------------------------------------------------------------------}
-- | Formatting options used to format cells
--
-- TODOs:
--
-- * Add a number format ('_cellXfApplyNumberFormat', '_cellXfNumFmtId')
-- * Add references to the named style sheets ('_cellXfId')
data Format = Format
{ _formatAlignment :: Maybe Alignment
, _formatBorder :: Maybe Border
, _formatFill :: Maybe Fill
, _formatFont :: Maybe Font
, _formatNumberFormat :: Maybe NumberFormat
, _formatProtection :: Maybe Protection
, _formatPivotButton :: Maybe Bool
, _formatQuotePrefix :: Maybe Bool
} deriving (Eq, Show, Generic)
makeLenses ''Format
-- | Cell with formatting. '_cellStyle' property of '_formattedCell' is ignored
--
-- See 'formatted' for more details.
data FormattedCell = FormattedCell
{ _formattedCell :: Cell
, _formattedFormat :: Format
, _formattedColSpan :: Int
, _formattedRowSpan :: Int
} deriving (Eq, Show, Generic)
makeLenses ''FormattedCell
{-------------------------------------------------------------------------------
Default instances
-------------------------------------------------------------------------------}
instance Default FormattedCell where
def = FormattedCell
{ _formattedCell = def
, _formattedFormat = def
, _formattedColSpan = 1
, _formattedRowSpan = 1
}
instance Default Format where
def = Format
{ _formatAlignment = Nothing
, _formatBorder = Nothing
, _formatFill = Nothing
, _formatFont = Nothing
, _formatNumberFormat = Nothing
, _formatProtection = Nothing
, _formatPivotButton = Nothing
, _formatQuotePrefix = Nothing
}
instance Default FormattedCondFmt where
def = FormattedCondFmt ContainsBlanks def topCfPriority Nothing
{-------------------------------------------------------------------------------
Client-facing API
-------------------------------------------------------------------------------}
-- | Result of formatting
--
-- See 'formatted'
data Formatted = Formatted {
-- | The final 'CellMap'; see '_wsCells'
formattedCellMap :: CellMap
-- | The final stylesheet; see '_xlStyles' (and 'renderStyleSheet')
, formattedStyleSheet :: StyleSheet
-- | The final list of cell merges; see '_wsMerges'
, formattedMerges :: [Range]
} deriving (Eq, Show, Generic)
-- | Higher level API for creating formatted documents
--
-- Creating formatted Excel spreadsheets using the 'Cell' datatype directly,
-- even with the support for the 'StyleSheet' datatype, is fairly painful.
-- This has a number of causes:
--
-- * The 'Cell' datatype wants an 'Int' for the style, which is supposed to
-- point into the '_styleSheetCellXfs' part of a stylesheet. However, this can
-- be difficult to work with, as it requires manual tracking of cell style
-- IDs, which in turns requires manual tracking of font IDs, border IDs, etc.
-- * Row-span and column-span properties are set on the worksheet as a whole
-- ('wsMerges') rather than on individual cells.
-- * Excel does not correctly deal with borders on cells that span multiple
-- columns or rows. Instead, these rows must be set on all the edge cells
-- in the block. Again, this means that this becomes a global property of
-- the spreadsheet rather than properties of individual cells.
--
-- This function deals with all these problems. Given a map of 'FormattedCell's,
-- which refer directly to 'Font's, 'Border's, etc. (rather than font IDs,
-- border IDs, etc.), and an initial stylesheet, it recovers all possible
-- sharing, constructs IDs, and then constructs the final 'CellMap', as well as
-- the final stylesheet and list of merges.
--
-- If you don't already have a 'StyleSheet' you want to use as starting point
-- then 'minimalStyleSheet' is a good choice.
formatted :: Map (RowIndex, ColumnIndex) FormattedCell -> StyleSheet -> Formatted
formatted cs styleSheet =
let initSt = stateFromStyleSheet styleSheet
(cs', finalSt) = runState (mapM (uncurry formatCell) (M.toList cs)) initSt
styleSheet' = updateStyleSheetFromState styleSheet finalSt
in Formatted {
formattedCellMap = M.fromList (concat cs')
, formattedStyleSheet = styleSheet'
, formattedMerges = reverse (finalSt ^. formattingMerges)
}
-- | Build an 'Xlsx', render provided cells as per the 'StyleSheet'.
formatWorkbook ::
[(Text, Map (RowIndex, ColumnIndex) FormattedCell)] -> StyleSheet -> Xlsx
formatWorkbook nfcss initStyle = extract go
where
initSt = stateFromStyleSheet initStyle
go = flip runState initSt $
forM nfcss $ \(name, fcs) -> do
cs' <- forM (M.toList fcs) $ \(rc, fc) -> formatCell rc fc
merges <- reverse . _formattingMerges <$> get
return ( name
, def & wsCells .~ M.fromList (concat cs')
& wsMerges .~ merges)
extract (sheets, st) =
def & xlSheets .~ sheets
& xlStyles .~ renderStyleSheet (updateStyleSheetFromState initStyle st)
-- | reverse to 'formatted' which allows to get a map of formatted cells
-- from an existing worksheet and its workbook's style sheet
toFormattedCells :: CellMap -> [Range] -> StyleSheet -> Map (RowIndex, ColumnIndex) FormattedCell
toFormattedCells m merges StyleSheet{..} = applyMerges $ M.map toFormattedCell m
where
toFormattedCell cell@Cell{..} =
FormattedCell
{ _formattedCell = cell{ _cellStyle = Nothing } -- just to remove confusion
, _formattedFormat = maybe def formatFromStyle $ flip M.lookup cellXfs =<< _cellStyle
, _formattedColSpan = 1
, _formattedRowSpan = 1 }
formatFromStyle cellXf =
Format
{ _formatAlignment = applied _cellXfApplyAlignment _cellXfAlignment cellXf
, _formatBorder = flip M.lookup borders =<<
applied _cellXfApplyBorder _cellXfBorderId cellXf
, _formatFill = flip M.lookup fills =<<
applied _cellXfApplyFill _cellXfFillId cellXf
, _formatFont = flip M.lookup fonts =<<
applied _cellXfApplyFont _cellXfFontId cellXf
, _formatNumberFormat = lookupNumFmt =<<
applied _cellXfApplyNumberFormat _cellXfNumFmtId cellXf
, _formatProtection = _cellXfProtection cellXf
, _formatPivotButton = _cellXfPivotButton cellXf
, _formatQuotePrefix = _cellXfQuotePrefix cellXf }
idMapped :: [a] -> Map Int a
idMapped = M.fromList . zip [0..]
cellXfs = idMapped _styleSheetCellXfs
borders = idMapped _styleSheetBorders
fills = idMapped _styleSheetFills
fonts = idMapped _styleSheetFonts
lookupNumFmt fId = asum
[ StdNumberFormat <$> idToStdNumberFormat fId
, UserNumberFormat <$> M.lookup fId _styleSheetNumFmts]
applied :: (CellXf -> Maybe Bool) -> (CellXf -> Maybe a) -> CellXf -> Maybe a
applied applyProp prop cXf = do
apply <- applyProp cXf
if apply then prop cXf else fail "not applied"
applyMerges cells = foldl' onlyTopLeft cells merges
onlyTopLeft cells range = flip execState cells $ do
let ((r1, c1), (r2, c2)) =
fromJustNote "fromRange" $ fromRange range
nonTopLeft = tail [(r, c) | r<-[r1..r2], c<-[c1..c2]]
forM_ nonTopLeft (modify . M.delete)
at (r1, c1) . non def . formattedRowSpan .=
(unRowIndex r2 - unRowIndex r1 + 1)
at (r1, c1) . non def . formattedColSpan .=
(unColumnIndex c2 - unColumnIndex c1 + 1)
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, Generic)
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 :: (RowIndex, ColumnIndex) -> FormattedCell
-> State FormattingState [((RowIndex, ColumnIndex), Cell)]
formatCell (row, col) cell = do
let (block, mMerge) = cellBlock (row, col) cell
forM_ mMerge $ \merge -> formattingMerges %= (:) merge
mapM go block
where
go :: ((RowIndex, ColumnIndex), FormattedCell)
-> State FormattingState ((RowIndex, ColumnIndex), Cell)
go (pos, c@FormattedCell{..}) = do
styleId <- cellStyleId c
return (pos, _formattedCell{_cellStyle = styleId})
-- | Cell block corresponding to a single 'FormattedCell'
--
-- A single 'FormattedCell' might have a colspan or rowspan greater than 1.
-- Although Excel obviously supports cell merges, it does not correctly apply
-- borders to the cells covered by the rowspan or colspan. Therefore we create
-- a block of cells in this function; the top-left is the cell proper, and the
-- remaining cells are the cells covered by the rowspan/colspan.
--
-- Also returns the cell merge instruction, if any.
cellBlock :: (RowIndex, ColumnIndex) -> FormattedCell
-> ([((RowIndex, ColumnIndex), FormattedCell)], Maybe Range)
cellBlock (row, col) cell@FormattedCell{..} = (block, merge)
where
block :: [((RowIndex, ColumnIndex), FormattedCell)]
block = [ ((row', col'), cellAt (row', col'))
| row' <- [topRow .. bottomRow]
, col' <- [leftCol .. rightCol]
]
merge :: Maybe Range
merge = do guard (topRow /= bottomRow || leftCol /= rightCol)
return $ mkRange (topRow, leftCol) (bottomRow, rightCol)
cellAt :: (RowIndex, ColumnIndex) -> FormattedCell
cellAt (row', col') =
if row' == row && col == col'
then cell
else def & formattedFormat . formatBorder ?~ borderAt (row', col')
border = _formatBorder _formattedFormat
borderAt :: (RowIndex, ColumnIndex) -> Border
borderAt (row', col') = def
& borderTop .~ do guard (row' == topRow) ; _borderTop =<< border
& borderBottom .~ do guard (row' == bottomRow) ; _borderBottom =<< border
& borderLeft .~ do guard (col' == leftCol) ; _borderLeft =<< border
& borderRight .~ do guard (col' == rightCol) ; _borderRight =<< border
topRow, bottomRow :: RowIndex
leftCol, rightCol :: ColumnIndex
topRow = row
bottomRow = RowIndex $ unRowIndex row + _formattedRowSpan - 1
leftCol = col
rightCol = ColumnIndex $ unColumnIndex col + _formattedColSpan - 1
cellStyleId :: FormattedCell -> State FormattingState (Maybe Int)
cellStyleId c = mapM (getId formattingCellXfs) =<< constructCellXf c
constructCellXf :: FormattedCell -> State FormattingState (Maybe CellXf)
constructCellXf FormattedCell{_formattedFormat=Format{..}} = do
mBorderId <- getId formattingBorders `mapM` _formatBorder
mFillId <- getId formattingFills `mapM` _formatFill
mFontId <- getId formattingFonts `mapM` _formatFont
let getFmtId :: Lens' FormattingState (Map Text Int) -> NumberFormat -> State FormattingState Int
getFmtId _ (StdNumberFormat fmt) = return (stdNumberFormatId fmt)
getFmtId l (UserNumberFormat fmt) = getId' firstUserNumFmtId l fmt
mNumFmtId <- getFmtId formattingNumFmts `mapM` _formatNumberFormat
let xf = CellXf {
_cellXfApplyAlignment = apply _formatAlignment
, _cellXfApplyBorder = apply mBorderId
, _cellXfApplyFill = apply mFillId
, _cellXfApplyFont = apply mFontId
, _cellXfApplyNumberFormat = apply _formatNumberFormat
, _cellXfApplyProtection = apply _formatProtection
, _cellXfBorderId = mBorderId
, _cellXfFillId = mFillId
, _cellXfFontId = mFontId
, _cellXfNumFmtId = mNumFmtId
, _cellXfPivotButton = _formatPivotButton
, _cellXfQuotePrefix = _formatQuotePrefix
, _cellXfId = Nothing -- TODO
, _cellXfAlignment = _formatAlignment
, _cellXfProtection = _formatProtection
}
return $ if xf == def then Nothing else Just xf
where
-- If we have formatting instructions, we want to set the corresponding
-- applyXXX properties
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
}
xlsx-1.1.2.2/src/Codec/Xlsx/Lens.hs 0000644 0000000 0000000 00000007134 14551273353 015053 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}
-- | lenses to access sheets, cells and values of 'Xlsx'
module Codec.Xlsx.Lens
( ixSheet
, atSheet
, ixCell
, ixCellRC
, ixCellXY
, atCell
, atCellRC
, atCellXY
, cellValueAt
, cellValueAtRC
, cellValueAtXY
) where
import Codec.Xlsx.Types
#ifdef USE_MICROLENS
import Lens.Micro
import Lens.Micro.Internal
import Lens.Micro.GHC ()
#else
import Control.Lens
#endif
import Data.Function (on)
import Data.List (deleteBy)
import Data.Text
import Data.Tuple (swap)
import GHC.Generics (Generic)
newtype SheetList = SheetList{ unSheetList :: [(Text, Worksheet)] }
deriving (Eq, Show, Generic)
type instance IxValue (SheetList) = Worksheet
type instance Index (SheetList) = Text
instance Ixed SheetList where
ix k f sl@(SheetList l) = case lookup k l of
Just v -> f v <&> \v' -> SheetList (upsert k v' l)
Nothing -> pure sl
{-# INLINE ix #-}
instance At SheetList where
at k f (SheetList l) = f mv <&> \r -> case r of
Nothing -> SheetList $ maybe l (\v -> deleteBy ((==) `on` fst) (k,v) l) mv
Just v' -> SheetList $ upsert k v' l
where
mv = lookup k l
{-# INLINE at #-}
upsert :: (Eq k) => k -> v -> [(k,v)] -> [(k,v)]
upsert k v [] = [(k,v)]
upsert k v ((k1,v1):r) =
if k == k1
then (k,v):r
else (k1,v1):upsert k v r
-- | lens giving access to a worksheet from 'Xlsx' object
-- by its name
ixSheet :: Text -> Traversal' Xlsx Worksheet
ixSheet s = xlSheets . \f -> fmap unSheetList . ix s f . SheetList
-- | 'Control.Lens.At' variant of 'ixSheet' lens
--
-- /Note:/ if there is no such sheet in this workbook then new sheet will be
-- added as the last one to the sheet list
atSheet :: Text -> Lens' Xlsx (Maybe Worksheet)
atSheet s = xlSheets . \f -> fmap unSheetList . at s f . SheetList
-- | lens giving access to a cell in some worksheet
-- by its position, by default row+column index is used
-- so this lens is a synonym of 'ixCellRC'
ixCell :: (RowIndex, ColumnIndex) -> Traversal' Worksheet Cell
ixCell = ixCellRC
-- | lens to access cell in a worksheet
ixCellRC :: (RowIndex, ColumnIndex) -> Traversal' Worksheet Cell
ixCellRC i = wsCells . ix i
-- | lens to access cell in a worksheet using more traditional
-- x+y coordinates
ixCellXY :: (ColumnIndex, RowIndex) -> Traversal' Worksheet Cell
ixCellXY i = ixCellRC $ swap i
-- | accessor that can read, write or delete cell in a worksheet
-- synonym of 'atCellRC' so uses row+column index
atCell :: (RowIndex, ColumnIndex) -> Lens' Worksheet (Maybe Cell)
atCell = atCellRC
-- | lens to read, write or delete cell in a worksheet
atCellRC :: (RowIndex, ColumnIndex) -> Lens' Worksheet (Maybe Cell)
atCellRC i = wsCells . at i
-- | lens to read, write or delete cell in a worksheet
-- using more traditional x+y or row+column index
atCellXY :: (ColumnIndex, RowIndex) -> Lens' Worksheet (Maybe Cell)
atCellXY i = atCellRC $ swap i
-- | lens to read, write or delete cell value in a worksheet
-- with row+column coordinates, synonym for 'cellValueRC'
cellValueAt :: (RowIndex, ColumnIndex) -> Lens' Worksheet (Maybe CellValue)
cellValueAt = cellValueAtRC
-- | lens to read, write or delete cell value in a worksheet
-- using row+column coordinates of that cell
cellValueAtRC :: (RowIndex, ColumnIndex) -> Lens' Worksheet (Maybe CellValue)
cellValueAtRC i = atCell i . non def . cellValue
-- | lens to read, write or delete cell value in a worksheet
-- using traditional x+y coordinates
cellValueAtXY :: (ColumnIndex, RowIndex) -> Lens' Worksheet (Maybe CellValue)
cellValueAtXY i = cellValueAtRC $ swap i
xlsx-1.1.2.2/src/Codec/Xlsx/Parser.hs 0000644 0000000 0000000 00000072104 14552151411 015374 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
-- | This module provides a function for reading .xlsx files
module Codec.Xlsx.Parser
( toXlsx
, toXlsxEither
, toXlsxFast
, toXlsxEitherFast
, ParseError(..)
, Parser
) where
import qualified "zip-archive" Codec.Archive.Zip as Zip
import Control.Applicative
import Control.Arrow (left)
import Control.Error.Safe (headErr)
import Control.Error.Util (note)
import Control.Exception (Exception)
#ifdef USE_MICROLENS
import Lens.Micro
#else
import Control.Lens hiding ((<.>), element, views)
#endif
import Control.Monad (join, void)
import Control.Monad.Except (catchError, throwError)
import Data.Bool (bool)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy as LB
import Data.ByteString.Lazy.Char8 ()
import Data.List
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Traversable
import GHC.Generics (Generic)
import Prelude hiding (sequence)
import Safe (headNote)
import System.FilePath.Posix
import Text.XML as X
import Text.XML.Cursor hiding (bool)
import qualified Xeno.DOM as Xeno
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Parser.Internal.PivotTable
import Codec.Xlsx.Types
import Codec.Xlsx.Types.Cell (formulaDataFromCursor)
import Codec.Xlsx.Types.Internal
import Codec.Xlsx.Types.Internal.CfPair
import Codec.Xlsx.Types.Internal.CommentTable as CommentTable
import Codec.Xlsx.Types.Internal.ContentTypes as ContentTypes
import Codec.Xlsx.Types.Internal.CustomProperties
as CustomProperties
import Codec.Xlsx.Types.Internal.DvPair
import Codec.Xlsx.Types.Internal.FormulaData
import Codec.Xlsx.Types.Internal.Relationships as Relationships
import Codec.Xlsx.Types.Internal.SharedStringTable
import Codec.Xlsx.Types.PivotTable.Internal
-- | Reads `Xlsx' from raw data (lazy bytestring)
toXlsx :: L.ByteString -> Xlsx
toXlsx = either (error . show) id . toXlsxEither
data ParseError = InvalidZipArchive String
| MissingFile FilePath
| InvalidFile FilePath Text
| InvalidRef FilePath RefId
| InconsistentXlsx Text
deriving (Eq, Show, Generic)
instance Exception ParseError
type Parser = Either ParseError
-- | Reads `Xlsx' from raw data (lazy bytestring) using @xeno@ library
-- using some "cheating":
--
-- * not doing 100% xml validation
-- * replacing only
-- and
-- (without checking codepoint validity)
-- * almost not using XML namespaces
toXlsxFast :: L.ByteString -> Xlsx
toXlsxFast = either (error . show) id . toXlsxEitherFast
-- | Reads `Xlsx' from raw data (lazy bytestring), failing with 'Left' on parse error
toXlsxEither :: L.ByteString -> Parser Xlsx
toXlsxEither = toXlsxEitherBase extractSheet
-- | Fast parsing with 'Left' on parse error, see 'toXlsxFast'
toXlsxEitherFast :: L.ByteString -> Parser Xlsx
toXlsxEitherFast = toXlsxEitherBase extractSheetFast
toXlsxEitherBase ::
(Zip.Archive -> SharedStringTable -> ContentTypes -> Caches -> WorksheetFile -> Parser Worksheet)
-> L.ByteString
-> Parser Xlsx
toXlsxEitherBase parseSheet bs = do
ar <- left InvalidZipArchive $ Zip.toArchiveOrFail bs
sst <- getSharedStrings ar
contentTypes <- getContentTypes ar
(wfs, names, cacheSources, dateBase) <- readWorkbook ar
sheets <- forM wfs $ \wf -> do
sheet <- parseSheet ar sst contentTypes cacheSources wf
return . (wfName wf,) . (wsState .~ wfState wf) $ sheet
CustomProperties customPropMap <- getCustomProperties ar
return $ Xlsx sheets (getStyles ar) names customPropMap dateBase
data WorksheetFile = WorksheetFile { wfName :: Text
, wfState :: SheetState
, wfPath :: FilePath
}
deriving (Show, Generic)
type Caches = [(CacheId, (Text, CellRef, [CacheField]))]
extractSheetFast :: Zip.Archive
-> SharedStringTable
-> ContentTypes
-> Caches
-> WorksheetFile
-> Parser Worksheet
extractSheetFast ar sst contentTypes caches wf = do
file <-
note (MissingFile filePath) $
Zip.fromEntry <$> Zip.findEntryByPath filePath ar
sheetRels <- getRels ar filePath
root <-
left (\ex -> InvalidFile filePath $ T.pack (show ex)) $
Xeno.parse (LB.toStrict file)
parseWorksheet root sheetRels
where
filePath = wfPath wf
parseWorksheet :: Xeno.Node -> Relationships -> Parser Worksheet
parseWorksheet root sheetRels = do
let prefixes = nsPrefixes root
odrNs =
"http://schemas.openxmlformats.org/officeDocument/2006/relationships"
odrX = addPrefix prefixes odrNs
skip = void . maybeChild
(ws, tableIds, drawingRId, legacyDrRId) <-
liftEither . collectChildren root $ do
skip "sheetPr"
skip "dimension"
_wsSheetViews <- fmap justNonEmpty . maybeParse "sheetViews" $ \n ->
collectChildren n $ fromChildList "sheetView"
skip "sheetFormatPr"
_wsColumnsProperties <-
fmap (fromMaybe []) . maybeParse "cols" $ \n ->
collectChildren n (fromChildList "col")
(_wsRowPropertiesMap, _wsCells, _wsSharedFormulas) <-
requireAndParse "sheetData" $ \n -> do
rows <- collectChildren n $ childList "row"
collectRows <$> forM rows parseRow
skip "sheetCalcPr"
_wsProtection <- maybeFromChild "sheetProtection"
skip "protectedRanges"
skip "scenarios"
_wsAutoFilter <- maybeFromChild "autoFilter"
skip "sortState"
skip "dataConsolidate"
skip "customSheetViews"
_wsMerges <- fmap (fromMaybe []) . maybeParse "mergeCells" $ \n -> do
mCells <- collectChildren n $ childList "mergeCell"
forM mCells $ \mCell -> parseAttributes mCell $ fromAttr "ref"
_wsConditionalFormattings <-
M.fromList . map unCfPair <$> fromChildList "conditionalFormatting"
_wsDataValidations <-
fmap (fromMaybe mempty) . maybeParse "dataValidations" $ \n -> do
M.fromList . map unDvPair <$>
collectChildren n (fromChildList "dataValidation")
skip "hyperlinks"
skip "printOptions"
skip "pageMargins"
_wsPageSetup <- maybeFromChild "pageSetup"
skip "headerFooter"
skip "rowBreaks"
skip "colBreaks"
skip "customProperties"
skip "cellWatches"
skip "ignoredErrors"
skip "smartTags"
drawingRId <- maybeParse "drawing" $ \n ->
parseAttributes n $ fromAttr (odrX "id")
legacyDrRId <- maybeParse "legacyDrawing" $ \n ->
parseAttributes n $ fromAttr (odrX "id")
tableIds <- fmap (fromMaybe []) . maybeParse "tableParts" $ \n -> do
tParts <- collectChildren n $ childList "tablePart"
forM tParts $ \part ->
parseAttributes part $ fromAttr (odrX "id")
-- all explicitly assigned fields filled below
return (
Worksheet
{ _wsDrawing = Nothing
, _wsPivotTables = []
, _wsTables = []
, _wsState = wfState wf
, ..
}
, tableIds
, drawingRId
, legacyDrRId)
let commentsType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments"
commentTarget :: Maybe FilePath
commentTarget = relTarget <$> findRelByType commentsType sheetRels
legacyDrPath = fmap relTarget . flip Relationships.lookup sheetRels =<< legacyDrRId
commentsMap <-
fmap join . forM commentTarget $ getComments ar legacyDrPath
let commentCells =
M.fromList
[ (fromSingleCellRefNoting r, def { _cellComment = Just cmnt})
| (r, cmnt) <- maybe [] CommentTable.toList commentsMap
]
assignComment withCmnt noCmnt =
noCmnt & cellComment .~ (withCmnt ^. cellComment)
mergeComments = M.unionWith assignComment commentCells
tables <- forM tableIds $ \rId -> do
fp <- lookupRelPath filePath sheetRels rId
getTable ar fp
drawing <- forM drawingRId $ \dId -> do
rel <- note (InvalidRef filePath dId) $ Relationships.lookup dId sheetRels
getDrawing ar contentTypes (relTarget rel)
let ptType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/pivotTable"
pivotTables <- forM (allByType ptType sheetRels) $ \rel -> do
let ptPath = relTarget rel
bs <- note (MissingFile ptPath) $ Zip.fromEntry <$> Zip.findEntryByPath ptPath ar
note (InconsistentXlsx $ "Bad pivot table in " <> T.pack ptPath) $
parsePivotTable (flip Prelude.lookup caches) bs
return $ ws & wsTables .~ tables
& wsCells %~ mergeComments
& wsDrawing .~ drawing
& wsPivotTables .~ pivotTables
liftEither :: Either Text a -> Parser a
liftEither = left (\t -> InvalidFile filePath t)
justNonEmpty v@(Just (_:_)) = v
justNonEmpty _ = Nothing
collectRows = foldr collectRow (M.empty, M.empty, M.empty)
collectRow ::
( RowIndex
, Maybe RowProperties
, [(RowIndex, ColumnIndex, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))])
-> ( Map RowIndex RowProperties
, CellMap
, Map SharedFormulaIndex SharedFormulaOptions)
-> ( Map RowIndex RowProperties
, CellMap
, Map SharedFormulaIndex SharedFormulaOptions)
collectRow (r, mRP, rowCells) (rowMap, cellMap, sharedF) =
let (newCells0, newSharedF0) =
unzip [(((rInd, cInd), cd), shared) | (rInd, cInd, cd, shared) <- rowCells]
newCells = M.fromAscList newCells0
newSharedF = M.fromAscList $ catMaybes newSharedF0
newRowMap =
case mRP of
Just rp -> M.insert r rp rowMap
Nothing -> rowMap
in (newRowMap, cellMap <> newCells, sharedF <> newSharedF)
parseRow ::
Xeno.Node
-> Either Text ( RowIndex
, Maybe RowProperties
, [( RowIndex
, ColumnIndex
, Cell
, Maybe (SharedFormulaIndex, SharedFormulaOptions))])
parseRow row = do
(r, s, ht, cstHt, hidden) <-
parseAttributes row $
((,,,,) <$> fromAttr "r" <*> maybeAttr "s" <*> maybeAttr "ht" <*>
fromAttrDef "customHeight" False <*>
fromAttrDef "hidden" False)
let props =
RowProps
{ rowHeight =
if cstHt
then CustomHeight <$> ht
else AutomaticHeight <$> ht
, rowStyle = s
, rowHidden = hidden
}
cellNodes <- collectChildren row $ childList "c"
cells <- forM cellNodes parseCell
return
( RowIndex r
, if props == def
then Nothing
else Just props
, cells)
-- NB: According to format specification default value for cells without
-- `t` attribute is a `n` - number.
--
-- Schema part from spec (see the `CellValue` spec reference):
--
-- ..
--
--
parseCell ::
Xeno.Node
-> Either Text ( RowIndex
, ColumnIndex
, Cell
, Maybe (SharedFormulaIndex, SharedFormulaOptions))
parseCell cell = do
(ref, s, t) <-
parseAttributes cell $
(,,) <$> fromAttr "r" <*> maybeAttr "s" <*> fromAttrDef "t" "n"
(fNode, vNode, isNode) <-
collectChildren cell $
(,,) <$> maybeChild "f" <*> maybeChild "v" <*> maybeChild "is"
let vConverted :: (FromAttrBs a) => Either Text (Maybe a)
vConverted =
case contentBs <$> vNode of
Nothing -> return Nothing
Just c -> Just <$> fromAttrBs c
mFormulaData <- mapM fromXenoNode fNode
d <-
case t of
("s" :: ByteString) -> do
si <- vConverted
case sstItem sst =<< si of
Just xlTxt -> return $ Just (xlsxTextToCellValue xlTxt)
Nothing -> throwError "bad shared string index"
"inlineStr" -> mapM (fmap xlsxTextToCellValue . fromXenoNode) isNode
"str" -> fmap CellText <$> vConverted
"n" -> fmap CellDouble <$> vConverted
"b" -> fmap CellBool <$> vConverted
"e" -> fmap CellError <$> vConverted
unexpected ->
throwError $ "unexpected cell type " <> T.pack (show unexpected)
let (r, c) = fromSingleCellRefNoting ref
f = frmdFormula <$> mFormulaData
shared = frmdShared =<< mFormulaData
return (r, c, Cell s d Nothing f, shared)
extractSheet ::
Zip.Archive
-> SharedStringTable
-> ContentTypes
-> Caches
-> WorksheetFile
-> Parser Worksheet
extractSheet ar sst contentTypes caches wf = do
let filePath = wfPath wf
file <- note (MissingFile filePath) $ Zip.fromEntry <$> Zip.findEntryByPath filePath ar
cur <- fmap fromDocument . left (\ex -> InvalidFile filePath (T.pack $ show ex)) $
parseLBS def file
sheetRels <- getRels ar filePath
-- The specification says the file should contain either 0 or 1 @sheetViews@
-- (4th edition, section 18.3.1.88, p. 1704 and definition CT_Worksheet, p. 3910)
let sheetViewList = cur $/ element (n_ "sheetViews") &/ element (n_ "sheetView") >=> fromCursor
sheetViews = case sheetViewList of
[] -> Nothing
views -> Just views
let commentsType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments"
commentTarget :: Maybe FilePath
commentTarget = relTarget <$> findRelByType commentsType sheetRels
legacyDrRId = cur $/ element (n_ "legacyDrawing") >=> fromAttribute (odr"id")
legacyDrPath = fmap relTarget . flip Relationships.lookup sheetRels =<< listToMaybe legacyDrRId
commentsMap :: Maybe CommentTable <- maybe (Right Nothing) (getComments ar legacyDrPath) commentTarget
-- Likewise, @pageSetup@ also occurs either 0 or 1 times
let pageSetup = listToMaybe $ cur $/ element (n_ "pageSetup") >=> fromCursor
cws = cur $/ element (n_ "cols") &/ element (n_ "col") >=> fromCursor
(rowProps, cells0, sharedFormulas) =
collect $ cur $/ element (n_ "sheetData") &/ element (n_ "row") >=> parseRow
parseRow ::
Cursor
-> [( RowIndex
, Maybe RowProperties
, [(RowIndex, ColumnIndex, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))])]
parseRow c = do
r <- RowIndex <$> fromAttribute "r" c
let prop = RowProps
{ rowHeight = do h <- listToMaybe $ fromAttribute "ht" c
case fromAttribute "customHeight" c of
[True] -> return $ CustomHeight h
_ -> return $ AutomaticHeight h
, rowStyle = listToMaybe $ fromAttribute "s" c
, rowHidden =
case fromAttribute "hidden" c of
[] -> False
f:_ -> f
}
return ( r
, if prop == def then Nothing else Just prop
, c $/ element (n_ "c") >=> parseCell
)
parseCell ::
Cursor
-> [(RowIndex, ColumnIndex, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))]
parseCell cell = do
ref <- fromAttribute "r" cell
let s = listToMaybe $ cell $| attribute "s" >=> decimal
-- NB: According to format specification default value for cells without
-- `t` attribute is a `n` - number.
--
--
-- ..
--
--
t = fromMaybe "n" $ listToMaybe $ cell $| attribute "t"
d = listToMaybe $ extractCellValue sst t cell
mFormulaData = listToMaybe $ cell $/ element (n_ "f") >=> formulaDataFromCursor
f = fst <$> mFormulaData
shared = snd =<< mFormulaData
(r, c) = fromSingleCellRefNoting ref
comment = commentsMap >>= lookupComment ref
return (r, c, Cell s d comment f, shared)
collect = foldr collectRow (M.empty, M.empty, M.empty)
collectRow ::
( RowIndex
, Maybe RowProperties
, [(RowIndex, ColumnIndex, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))])
-> (Map RowIndex RowProperties, CellMap, Map SharedFormulaIndex SharedFormulaOptions)
-> (Map RowIndex RowProperties, CellMap, Map SharedFormulaIndex SharedFormulaOptions)
collectRow (r, mRP, rowCells) (rowMap, cellMap, sharedF) =
let (newCells0, newSharedF0) =
unzip [(((x,y),cd), shared) | (x, y, cd, shared) <- rowCells]
newCells = M.fromList newCells0
newSharedF = M.fromList $ catMaybes newSharedF0
newRowMap = case mRP of
Just rp -> M.insert r rp rowMap
Nothing -> rowMap
in (newRowMap, cellMap <> newCells, sharedF <> newSharedF)
commentCells =
M.fromList
[ (fromSingleCellRefNoting r, def {_cellComment = Just cmnt})
| (r, cmnt) <- maybe [] CommentTable.toList commentsMap
]
cells = cells0 `M.union` commentCells
mProtection = listToMaybe $ cur $/ element (n_ "sheetProtection") >=> fromCursor
mDrawingId = listToMaybe $ cur $/ element (n_ "drawing") >=> fromAttribute (odr"id")
merges = cur $/ parseMerges
parseMerges :: Cursor -> [Range]
parseMerges = element (n_ "mergeCells") &/ element (n_ "mergeCell") >=> fromAttribute "ref"
condFormtattings = M.fromList . map unCfPair $ cur $/ element (n_ "conditionalFormatting") >=> fromCursor
validations = M.fromList . map unDvPair $
cur $/ element (n_ "dataValidations") &/ element (n_ "dataValidation") >=> fromCursor
tableIds =
cur $/ element (n_ "tableParts") &/ element (n_ "tablePart") >=>
fromAttribute (odr "id")
let mAutoFilter = listToMaybe $ cur $/ element (n_ "autoFilter") >=> fromCursor
mDrawing <- case mDrawingId of
Just dId -> do
rel <- note (InvalidRef filePath dId) $ Relationships.lookup dId sheetRels
Just <$> getDrawing ar contentTypes (relTarget rel)
Nothing ->
return Nothing
let ptType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/pivotTable"
pTables <- forM (allByType ptType sheetRels) $ \rel -> do
let ptPath = relTarget rel
bs <- note (MissingFile ptPath) $ Zip.fromEntry <$> Zip.findEntryByPath ptPath ar
note (InconsistentXlsx $ "Bad pivot table in " <> T.pack ptPath) $
parsePivotTable (flip Prelude.lookup caches) bs
tables <- forM tableIds $ \rId -> do
fp <- lookupRelPath filePath sheetRels rId
getTable ar fp
return $
Worksheet
cws
rowProps
cells
mDrawing
merges
sheetViews
pageSetup
condFormtattings
validations
pTables
mAutoFilter
tables
mProtection
sharedFormulas
(wfState wf)
extractCellValue :: SharedStringTable -> Text -> Cursor -> [CellValue]
extractCellValue sst t cur
| t == "s" = do
si <- vConverted "shared string"
case sstItem sst si of
Just xlTxt -> return $ xlsxTextToCellValue xlTxt
Nothing -> fail "bad shared string index"
| t == "inlineStr" =
cur $/ element (n_ "is") >=> fmap xlsxTextToCellValue . fromCursor
| t == "str" = CellText <$> vConverted "string"
| t == "n" = CellDouble <$> vConverted "double"
| t == "b" = CellBool <$> vConverted "boolean"
| t == "e" = CellError <$> vConverted "error"
| otherwise = fail "bad cell value"
where
vConverted typeStr = do
vContent <- cur $/ element (n_ "v") >=> \c ->
return (T.concat $ c $/ content)
case fromAttrVal vContent of
Right (val, _) -> return $ val
_ -> fail $ "bad " ++ typeStr ++ " cell value"
-- | Get xml cursor from the specified file inside the zip archive.
xmlCursorOptional :: Zip.Archive -> FilePath -> Parser (Maybe Cursor)
xmlCursorOptional ar fname =
(Just <$> xmlCursorRequired ar fname) `catchError` missingToNothing
where
missingToNothing :: ParseError -> Either ParseError (Maybe a)
missingToNothing (MissingFile _) = return Nothing
missingToNothing other = throwError other
-- | Get xml cursor from the given file, failing with MissingFile if not found.
xmlCursorRequired :: Zip.Archive -> FilePath -> Parser Cursor
xmlCursorRequired ar fname = do
entry <- note (MissingFile fname) $ Zip.findEntryByPath fname ar
cur <- left (\ex -> InvalidFile fname (T.pack $ show ex)) $ parseLBS def (Zip.fromEntry entry)
return $ fromDocument cur
fromFileCursorDef ::
FromCursor a => Zip.Archive -> FilePath -> Text -> a -> Parser a
fromFileCursorDef x fp contentsDescr defVal = do
mCur <- xmlCursorOptional x fp
case mCur of
Just cur ->
headErr (InvalidFile fp $ "Couldn't parse " <> contentsDescr) $ fromCursor cur
Nothing -> return defVal
fromFileCursor :: FromCursor a => Zip.Archive -> FilePath -> Text -> Parser a
fromFileCursor x fp contentsDescr = do
cur <- xmlCursorRequired x fp
headErr (InvalidFile fp $ "Couldn't parse " <> contentsDescr) $ fromCursor cur
-- | Get shared string table
getSharedStrings :: Zip.Archive -> Parser SharedStringTable
getSharedStrings x =
fromFileCursorDef x "xl/sharedStrings.xml" "shared strings" sstEmpty
getContentTypes :: Zip.Archive -> Parser ContentTypes
getContentTypes x = fromFileCursor x "[Content_Types].xml" "content types"
getStyles :: Zip.Archive -> Styles
getStyles ar = case Zip.fromEntry <$> Zip.findEntryByPath "xl/styles.xml" ar of
Nothing -> Styles L.empty
Just xml -> Styles xml
getComments :: Zip.Archive -> Maybe FilePath -> FilePath -> Parser (Maybe CommentTable)
getComments ar drp fp = do
mCurComments <- xmlCursorOptional ar fp
mCurDr <- maybe (return Nothing) (xmlCursorOptional ar) drp
return (liftA2 hide (hidden <$> mCurDr) . listToMaybe . fromCursor =<< mCurComments)
where
hide refs (CommentTable m) = CommentTable $ foldl' hideComment m refs
hideComment m r = M.adjust (\c->c{_commentVisible = False}) r m
v nm = Name nm (Just "urn:schemas-microsoft-com:vml") Nothing
x nm = Name nm (Just "urn:schemas-microsoft-com:office:excel") Nothing
hidden :: Cursor -> [CellRef]
hidden cur = cur $/ checkElement visibleShape &/
element (x"ClientData") >=> shapeCellRef
visibleShape Element{..} = elementName == (v"shape") &&
maybe False (any ("visibility:hidden"==) . T.split (==';')) (M.lookup "style" elementAttributes)
shapeCellRef :: Cursor -> [CellRef]
shapeCellRef c = do
r0 <- c $/ element (x"Row") &/ content >=> decimal
c0 <- c $/ element (x"Column") &/ content >=> decimal
return $ singleCellRef (r0 + 1, c0 + 1)
getCustomProperties :: Zip.Archive -> Parser CustomProperties
getCustomProperties ar =
fromFileCursorDef ar "docProps/custom.xml" "custom properties" CustomProperties.empty
getDrawing :: Zip.Archive -> ContentTypes -> FilePath -> Parser Drawing
getDrawing ar contentTypes fp = do
cur <- xmlCursorRequired ar fp
drawingRels <- getRels ar fp
unresolved <- headErr (InvalidFile fp "Couldn't parse drawing") (fromCursor cur)
anchors <- forM (unresolved ^. xdrAnchors) $ resolveFileInfo drawingRels
return $ Drawing anchors
where
resolveFileInfo :: Relationships -> Anchor RefId RefId -> Parser (Anchor FileInfo ChartSpace)
resolveFileInfo rels uAnch =
case uAnch ^. anchObject of
Picture {..} -> do
let mRefId = _picBlipFill ^. bfpImageInfo
mFI <- lookupFI rels mRefId
let pic' =
Picture
{ _picMacro = _picMacro
, _picPublished = _picPublished
, _picNonVisual = _picNonVisual
, _picBlipFill = (_picBlipFill & bfpImageInfo .~ mFI)
, _picShapeProperties = _picShapeProperties
}
return uAnch {_anchObject = pic'}
Graphic nv rId tr -> do
chartPath <- lookupRelPath fp rels rId
chart <- readChart ar chartPath
return uAnch {_anchObject = Graphic nv chart tr}
lookupFI _ Nothing = return Nothing
lookupFI rels (Just rId) = do
path <- lookupRelPath fp rels rId
-- content types use paths starting with /
contentType <-
note (InvalidFile path "Missing content type") $
ContentTypes.lookup ("/" <> path) contentTypes
contents <-
Zip.fromEntry <$> note (MissingFile path) (Zip.findEntryByPath path ar)
return . Just $ FileInfo (stripMediaPrefix path) contentType contents
stripMediaPrefix :: FilePath -> FilePath
stripMediaPrefix p = fromMaybe p $ stripPrefix "xl/media/" p
readChart :: Zip.Archive -> FilePath -> Parser ChartSpace
readChart ar path = fromFileCursor ar path "chart"
-- | readWorkbook pulls the names of the sheets and the defined names
readWorkbook :: Zip.Archive -> Parser ([WorksheetFile], DefinedNames, Caches, DateBase)
readWorkbook ar = do
let wbPath = "xl/workbook.xml"
cur <- xmlCursorRequired ar wbPath
wbRels <- getRels ar wbPath
-- Specification says the 'name' is required.
let mkDefinedName :: Cursor -> [(Text, Maybe Text, Text)]
mkDefinedName c =
return
( headNote "Missing name attribute" $ attribute "name" c
, listToMaybe $ attribute "localSheetId" c
, T.concat $ c $/ content)
names =
cur $/ element (n_ "definedNames") &/ element (n_ "definedName") >=>
mkDefinedName
sheets <-
sequence $
cur $/ element (n_ "sheets") &/ element (n_ "sheet") >=>
liftA3 (worksheetFile wbPath wbRels) <$> attribute "name" <*> fromAttributeDef "state" def <*>
fromAttribute (odr "id")
let cacheRefs =
cur $/ element (n_ "pivotCaches") &/ element (n_ "pivotCache") >=>
liftA2 (,) <$> fromAttribute "cacheId" <*> fromAttribute (odr "id")
caches <-
forM cacheRefs $ \(cacheId, rId) -> do
path <- lookupRelPath wbPath wbRels rId
bs <-
note (MissingFile path) $ Zip.fromEntry <$> Zip.findEntryByPath path ar
(sheet, ref, fields0, mRecRId) <-
note (InconsistentXlsx $ "Bad pivot table cache in " <> T.pack path) $
parseCache bs
fields <- case mRecRId of
Just recId -> do
cacheRels <- getRels ar path
recsPath <- lookupRelPath path cacheRels recId
rCur <- xmlCursorRequired ar recsPath
let recs = rCur $/ element (n_ "r") >=> \cur' ->
return $ cur' $/ anyElement >=> recordValueFromNode . node
return $ fillCacheFieldsFromRecords fields0 recs
Nothing ->
return fields0
return $ (cacheId, (sheet, ref, fields))
let dateBase = bool DateBase1900 DateBase1904 . fromMaybe False . listToMaybe $
cur $/ element (n_ "workbookPr") >=> fromAttribute "date1904"
return (sheets, DefinedNames names, caches, dateBase)
getTable :: Zip.Archive -> FilePath -> Parser Table
getTable ar fp = do
cur <- xmlCursorRequired ar fp
headErr (InvalidFile fp "Couldn't parse drawing") (fromCursor cur)
worksheetFile :: FilePath -> Relationships -> Text -> SheetState -> RefId -> Parser WorksheetFile
worksheetFile parentPath wbRels name visibility rId =
WorksheetFile name visibility <$> lookupRelPath parentPath wbRels rId
getRels :: Zip.Archive -> FilePath -> Parser Relationships
getRels ar fp = do
let (dir, file) = splitFileName fp
relsPath = dir "_rels" file <.> "rels"
c <- xmlCursorOptional ar relsPath
return $ maybe Relationships.empty (setTargetsFrom fp . headNote "Missing rels" . fromCursor) c
-- According to part 2, section 7.3.4 of ECMA-376, when mapping logical item
-- names to ZIP item names we need to remove the leading slash.
--
-- Non-ASCII characters should be percent-encoded as well, but this is not
-- currently implemented.
--
-- https://ecma-international.org/publications-and-standards/standards/ecma-376/
logicalNameToZipItemName :: FilePath -> FilePath
logicalNameToZipItemName ('/' : name) = name
logicalNameToZipItemName name = name
lookupRelPath :: FilePath
-> Relationships
-> RefId
-> Either ParseError FilePath
lookupRelPath fp rels rId =
logicalNameToZipItemName . relTarget <$> note (InvalidRef fp rId) (Relationships.lookup rId rels)
xlsx-1.1.2.2/src/Codec/Xlsx/Parser/Internal.hs 0000644 0000000 0000000 00000010644 14551273353 017162 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Codec.Xlsx.Parser.Internal
( ParseException(..)
, n_
, nodeElNameIs
, FromCursor(..)
, FromAttrVal(..)
, fromAttribute
, fromAttributeDef
, maybeAttribute
, fromElementValue
, maybeElementValue
, maybeElementValueDef
, maybeBoolElementValue
, maybeFromElement
, attrValIs
, contentOrEmpty
, readSuccess
, readFailure
, invalidText
, defaultReadFailure
, module Codec.Xlsx.Parser.Internal.Util
, module Codec.Xlsx.Parser.Internal.Fast
) where
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 GHC.Generics (Generic)
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal.Fast
import Codec.Xlsx.Parser.Internal.Util
data ParseException = ParseException String
deriving (Show, Typeable, Generic)
instance Exception ParseException
nodeElNameIs :: Node -> Name -> Bool
nodeElNameIs (NodeElement el) name = elementName el == name
nodeElNameIs _ _ = False
class FromCursor a where
fromCursor :: Cursor -> [a]
class FromAttrVal a where
fromAttrVal :: T.Reader a
instance FromAttrVal Text where
fromAttrVal = readSuccess
instance FromAttrVal Int where
fromAttrVal = T.signed T.decimal
instance FromAttrVal Integer where
fromAttrVal = T.signed T.decimal
instance FromAttrVal Double where
fromAttrVal = T.rational
instance FromAttrVal Bool where
fromAttrVal x | x == "1" || x == "true" = readSuccess True
| x == "0" || x == "false" = readSuccess False
| otherwise = defaultReadFailure
-- | required attribute parsing
fromAttribute :: FromAttrVal a => Name -> Cursor -> [a]
fromAttribute name cursor =
attribute name cursor >>= runReader fromAttrVal
-- | parsing optional attributes with defaults
fromAttributeDef :: FromAttrVal a => Name -> a -> Cursor -> [a]
fromAttributeDef name defVal cursor =
case attribute name cursor of
[attr] -> runReader fromAttrVal attr
_ -> [defVal]
-- | parsing optional attributes
maybeAttribute :: FromAttrVal a => Name -> Cursor -> [Maybe a]
maybeAttribute name cursor =
case attribute name cursor of
[attr] -> Just <$> runReader fromAttrVal attr
_ -> [Nothing]
fromElementValue :: FromAttrVal a => Name -> Cursor -> [a]
fromElementValue name cursor =
cursor $/ element name >=> fromAttribute "val"
maybeElementValue :: FromAttrVal a => Name -> Cursor -> [Maybe a]
maybeElementValue name cursor =
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]
maybeBoolElementValue :: Name -> Cursor -> [Maybe Bool]
maybeBoolElementValue name cursor = maybeElementValueDef name True cursor
maybeFromElement :: FromCursor a => Name -> Cursor -> [Maybe a]
maybeFromElement name cursor = case cursor $/ element name of
[cursor'] -> Just <$> fromCursor cursor'
_ -> [Nothing]
attrValIs :: (Eq a, FromAttrVal a) => Name -> a -> Axis
attrValIs n v c =
case fromAttribute n c of
[x] | x == v -> [c]
_ -> []
contentOrEmpty :: Cursor -> [Text]
contentOrEmpty c =
case c $/ content of
[t] -> [t]
[] -> [""]
_ -> error "invalid item: more than one text node encountered"
readSuccess :: a -> Either String (a, Text)
readSuccess x = Right (x, T.empty)
readFailure :: Text -> Either String (a, Text)
readFailure = Left . T.unpack
invalidText :: Text -> Text -> Either String (a, Text)
invalidText what txt = readFailure $ T.concat ["Invalid ", what, ": '", txt , "'"]
defaultReadFailure :: Either String (a, Text)
defaultReadFailure = Left "invalid text"
runReader :: T.Reader a -> Text -> [a]
runReader reader t = case reader t of
Right (r, leftover) | T.null leftover -> [r]
_ -> []
-- | Add sml namespace to name
n_ :: Text -> Name
n_ x = Name
{ nameLocalName = x
, nameNamespace = Just "http://schemas.openxmlformats.org/spreadsheetml/2006/main"
, namePrefix = Just "n"
}
xlsx-1.1.2.2/src/Codec/Xlsx/Parser/Internal/Fast.hs 0000644 0000000 0000000 00000027226 14551273353 020063 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Codec.Xlsx.Parser.Internal.Fast
( FromXenoNode(..)
, collectChildren
, maybeChild
, requireChild
, childList
, maybeFromChild
, fromChild
, fromChildList
, maybeParse
, requireAndParse
, childListAny
, maybeElementVal
, toAttrParser
, parseAttributes
, FromAttrBs(..)
, unexpectedAttrBs
, maybeAttrBs
, maybeAttr
, fromAttr
, fromAttrDef
, contentBs
, contentX
, nsPrefixes
, addPrefix
) where
import Control.Applicative
import Control.Arrow (second)
import Control.Exception (Exception, throw)
import Control.Monad (ap, forM, join, liftM)
import Data.Bifunctor (first)
import Data.Bits ((.|.), shiftL)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as SU
import Data.Char (chr)
import Data.Maybe
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Word (Word8)
import Xeno.DOM hiding (parse)
import Codec.Xlsx.Parser.Internal.Util
class FromXenoNode a where
fromXenoNode :: Node -> Either Text a
newtype ChildCollector a = ChildCollector
{ runChildCollector :: [Node] -> Either Text ([Node], a)
}
instance Functor ChildCollector where
fmap f a = ChildCollector $ \ns ->
second f <$> runChildCollector a ns
instance Applicative ChildCollector where
pure a = ChildCollector $ \ns ->
return (ns, a)
cf <*> ca = ChildCollector $ \ns -> do
(ns', f) <- runChildCollector cf ns
(ns'', a) <- runChildCollector ca ns'
return (ns'', f a)
instance Alternative ChildCollector where
empty = ChildCollector $ \_ -> Left "ChildCollector.empty"
ChildCollector f <|> ChildCollector g = ChildCollector $ \ns ->
either (const $ g ns) Right (f ns)
instance Monad ChildCollector where
return = pure
ChildCollector f >>= g = ChildCollector $ \ns ->
either Left (\(!ns', f') -> runChildCollector (g f') ns') (f ns)
toChildCollector :: Either Text a -> ChildCollector a
toChildCollector unlifted =
case unlifted of
Right a -> return a
Left e -> ChildCollector $ \_ -> Left e
collectChildren :: Node -> ChildCollector a -> Either Text a
collectChildren n c = snd <$> runChildCollector c (children n)
maybeChild :: ByteString -> ChildCollector (Maybe Node)
maybeChild nm =
ChildCollector $ \case
(n:ns)
| name n == nm -> pure (ns, Just n)
ns -> pure (ns, Nothing)
requireChild :: ByteString -> ChildCollector Node
requireChild nm =
ChildCollector $ \case
(n:ns)
| name n == nm -> pure (ns, n)
_ ->
Left $ "required element " <> T.pack (show nm) <> " was not found"
childList :: ByteString -> ChildCollector [Node]
childList nm = do
mNode <- maybeChild nm
case mNode of
Just n -> (n:) <$> childList nm
Nothing -> return []
maybeFromChild :: (FromXenoNode a) => ByteString -> ChildCollector (Maybe a)
maybeFromChild nm = do
mNode <- maybeChild nm
mapM (toChildCollector . fromXenoNode) mNode
fromChild :: (FromXenoNode a) => ByteString -> ChildCollector a
fromChild nm = do
n <- requireChild nm
case fromXenoNode n of
Right a -> return a
Left e -> ChildCollector $ \_ -> Left e
fromChildList :: (FromXenoNode a) => ByteString -> ChildCollector [a]
fromChildList nm = do
mA <- maybeFromChild nm
case mA of
Just a -> (a:) <$> fromChildList nm
Nothing -> return []
maybeParse :: ByteString -> (Node -> Either Text a) -> ChildCollector (Maybe a)
maybeParse nm parse = maybeChild nm >>= (toChildCollector . mapM parse)
requireAndParse :: ByteString -> (Node -> Either Text a) -> ChildCollector a
requireAndParse nm parse = requireChild nm >>= (toChildCollector . parse)
childListAny :: (FromXenoNode a) => Node -> Either Text [a]
childListAny = mapM fromXenoNode . children
maybeElementVal :: (FromAttrBs a) => ByteString -> ChildCollector (Maybe a)
maybeElementVal nm = do
mN <- maybeChild nm
fmap join . forM mN $ \n ->
toChildCollector . parseAttributes n $ maybeAttr "val"
-- Stolen from XML Conduit
newtype AttrParser a = AttrParser
{ runAttrParser :: [(ByteString, ByteString)] -> Either Text ( [( ByteString
, ByteString)]
, a)
}
instance Monad AttrParser where
return a = AttrParser $ \as -> Right (as, a)
(AttrParser f) >>= g =
AttrParser $ \as ->
either Left (\(as', f') -> runAttrParser (g f') as') (f as)
instance Applicative AttrParser where
pure = return
(<*>) = ap
instance Functor AttrParser where
fmap = liftM
attrError :: Text -> AttrParser a
attrError err = AttrParser $ \_ -> Left err
toAttrParser :: Either Text a -> AttrParser a
toAttrParser unlifted =
case unlifted of
Right a -> return a
Left e -> AttrParser $ \_ -> Left e
maybeAttrBs :: ByteString -> AttrParser (Maybe ByteString)
maybeAttrBs attrName = AttrParser $ go id
where
go front [] = Right (front [], Nothing)
go front (a@(nm, val):as) =
if nm == attrName
then Right (front as, Just val)
else go (front . (:) a) as
requireAttrBs :: ByteString -> AttrParser ByteString
requireAttrBs nm = do
mVal <- maybeAttrBs nm
case mVal of
Just val -> return val
Nothing -> attrError $ "attribute " <> T.pack (show nm) <> " is required"
unexpectedAttrBs :: Text -> ByteString -> Either Text a
unexpectedAttrBs typ val =
Left $ "Unexpected value for " <> typ <> ": " <> T.pack (show val)
fromAttr :: FromAttrBs a => ByteString -> AttrParser a
fromAttr nm = do
bs <- requireAttrBs nm
toAttrParser $ fromAttrBs bs
maybeAttr :: FromAttrBs a => ByteString -> AttrParser (Maybe a)
maybeAttr nm = do
mBs <- maybeAttrBs nm
forM mBs (toAttrParser . fromAttrBs)
fromAttrDef :: FromAttrBs a => ByteString -> a -> AttrParser a
fromAttrDef nm defVal = fromMaybe defVal <$> maybeAttr nm
parseAttributes :: Node -> AttrParser a -> Either Text a
parseAttributes n attrParser =
case runAttrParser attrParser (attributes n) of
Left e -> Left e
Right (_, a) -> return a
class FromAttrBs a where
fromAttrBs :: ByteString -> Either Text a
instance FromAttrBs ByteString where
fromAttrBs = pure
instance FromAttrBs Bool where
fromAttrBs x | x == "1" || x == "true" = return True
| x == "0" || x == "false" = return False
| otherwise = unexpectedAttrBs "boolean" x
instance FromAttrBs Int where
-- it appears that parser in text is more optimized than the one in
-- attoparsec at least as of text-1.2.2.2 and attoparsec-0.13.1.0
fromAttrBs = first T.pack . eitherDecimal . T.decodeLatin1
instance FromAttrBs Double where
-- as for rationals
fromAttrBs = first T.pack . eitherRational . T.decodeLatin1
instance FromAttrBs Text where
fromAttrBs = replaceEntititesBs
replaceEntititesBs :: ByteString -> Either Text Text
replaceEntititesBs str =
T.decodeUtf8 . BS.concat <$> findAmp 0
where
findAmp :: Int -> Either Text [ByteString]
findAmp index =
case elemIndexFrom ampersand str index of
Nothing -> if BS.null text then return [] else return [text]
where text = BS.drop index str
Just fromAmp ->
if BS.null text
then checkEntity fromAmp
else (text:) <$> checkEntity fromAmp
where text = substring str index fromAmp
checkEntity index =
case elemIndexFrom semicolon str index of
Just fromSemi | fromSemi >= index + 3 -> do
entity <- checkElementVal (index + 1) (fromSemi - index - 1)
(BS.singleton entity:) <$> findAmp (fromSemi + 1)
_ -> Left "Unending entity"
checkElementVal index len =
if | len == 2
&& s_index this 0 == 108 -- l
&& s_index this 1 == 116 -- t
-> return 60 -- '<'
| len == 2
&& s_index this 0 == 103 -- g
&& s_index this 1 == 116 -- t
-> return 62 -- '>'
| len == 3
&& s_index this 0 == 97 -- a
&& s_index this 1 == 109 -- m
&& s_index this 2 == 112 -- p
-> return 38 -- '&'
| len == 4
&& s_index this 0 == 113 -- q
&& s_index this 1 == 117 -- u
&& s_index this 2 == 111 -- o
&& s_index this 3 == 116 -- t
-> return 34 -- '"'
| len == 4
&& s_index this 0 == 97 -- a
&& s_index this 1 == 112 -- p
&& s_index this 2 == 111 -- o
&& s_index this 3 == 115 -- s
-> return 39 -- '\''
| s_index this 0 == 35 -- '#'
->
if s_index this 1 == 120 -- 'x'
then toEnum <$> checkHexadecimal (index + 2) (len - 2)
else toEnum <$> checkDecimal (index + 1) (len - 1)
| otherwise -> Left $ "Bad entity " <> T.pack (show $ (substring str (index-1) (index+len+1)))
where
this = BS.drop index str
checkDecimal index len = BS.foldl' go (Right 0) (substring str index (index + len))
where
go :: Either Text Int -> Word8 -> Either Text Int
go prev c = do
a <- prev
if c >= 48 && c <= 57
then return $ a * 10 + fromIntegral (c - 48)
else Left $ "Expected decimal digit but encountered " <> T.pack (show (chr $ fromIntegral c))
checkHexadecimal index len = BS.foldl' go (Right 0) (substring str index (index + len))
where
go :: Either Text Int -> Word8 -> Either Text Int
go prev c = do
a <- prev
if | c >= 48 && c <= 57
-> return $ (a `shiftL` 4) .|. fromIntegral (c - 48)
| c >= 97 && c <= 122
-> return $ (a `shiftL` 4) .|. fromIntegral (c - 87)
| c >= 65 && c <= 90
-> return $ (a `shiftL` 4) .|. fromIntegral (c - 55)
| otherwise
->
Left $ "Expected hexadecimal digit but encountered " <> T.pack (show (chr $ fromIntegral c))
ampersand = 38
semicolon = 59
data EntityReplaceException = EntityReplaceException deriving Show
instance Exception EntityReplaceException
-- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0.
s_index :: ByteString -> Int -> Word8
s_index ps n
| n < 0 = throw EntityReplaceException
| n >= BS.length ps = throw EntityReplaceException
| otherwise = ps `SU.unsafeIndex` n
{-# INLINE s_index #-}
-- | Get index of an element starting from offset.
elemIndexFrom :: Word8 -> ByteString -> Int -> Maybe Int
elemIndexFrom c str offset = fmap (+ offset) (BS.elemIndex c (BS.drop offset str))
-- Without the INLINE below, the whole function is twice as slow and
-- has linear allocation. See git commit with this comment for
-- results.
{-# INLINE elemIndexFrom #-}
-- | Get a substring of a string.
substring :: ByteString -> Int -> Int -> ByteString
substring s start end = BS.take (end - start) (BS.drop start s)
{-# INLINE substring #-}
newtype NsPrefixes = NsPrefixes [(ByteString, ByteString)]
nsPrefixes :: Node -> NsPrefixes
nsPrefixes root =
NsPrefixes . flip mapMaybe (attributes root) $ \(nm, val) ->
(val, ) <$> BS.stripPrefix "xmlns:" nm
addPrefix :: NsPrefixes -> ByteString -> (ByteString -> ByteString)
addPrefix (NsPrefixes prefixes) ns =
maybe id (\prefix nm -> BS.concat [prefix, ":", nm]) $ Prelude.lookup ns prefixes
contentBs :: Node -> ByteString
contentBs n = BS.concat . map toBs $ contents n
where
toBs (Element _) = BS.empty
toBs (Text bs) = bs
toBs (CData bs) = bs
contentX :: Node -> Either Text Text
contentX = replaceEntititesBs . contentBs
xlsx-1.1.2.2/src/Codec/Xlsx/Parser/Internal/Util.hs 0000644 0000000 0000000 00000002377 14551273353 020103 0 ustar 00 0000000 0000000 module Codec.Xlsx.Parser.Internal.Util
( boolean
, eitherBoolean
, decimal
, eitherDecimal
, rational
, eitherRational
) where
import Data.Text (Text)
import Control.Monad.Fail (MonadFail)
import qualified Data.Text as T
import qualified Data.Text.Read as T
import qualified Control.Monad.Fail as F
decimal :: (MonadFail m, Integral a) => Text -> m a
decimal = fromEither . eitherDecimal
eitherDecimal :: (Integral a) => Text -> Either String a
eitherDecimal t = case T.signed T.decimal t of
Right (d, leftover) | T.null leftover -> Right d
_ -> Left $ "invalid decimal: " ++ show t
rational :: (MonadFail m) => Text -> m Double
rational = fromEither . eitherRational
eitherRational :: Text -> Either String Double
eitherRational t = case T.signed T.rational t of
Right (r, leftover) | T.null leftover -> Right r
_ -> Left $ "invalid rational: " ++ show t
boolean :: (MonadFail m) => Text -> m Bool
boolean = fromEither . eitherBoolean
eitherBoolean :: Text -> Either String Bool
eitherBoolean t = case T.unpack $ T.strip t of
"true" -> Right True
"false" -> Right False
_ -> Left $ "invalid boolean: " ++ show t
fromEither :: (MonadFail m) => Either String b -> m b
fromEither (Left a) = F.fail a
fromEither (Right b) = return b
xlsx-1.1.2.2/src/Codec/Xlsx/Parser/Internal/PivotTable.hs 0000644 0000000 0000000 00000011500 14551273353 021223 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Parser.Internal.PivotTable
( parsePivotTable
, parseCache
, fillCacheFieldsFromRecords
) where
import Control.Applicative
import Data.ByteString.Lazy (ByteString)
import Data.List (transpose)
import Data.Maybe (listToMaybe, mapMaybe, maybeToList)
import Data.Text (Text)
import Safe (atMay)
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Types.Internal
import Codec.Xlsx.Types.Internal.Relationships (odr)
import Codec.Xlsx.Types.PivotTable
import Codec.Xlsx.Types.PivotTable.Internal
parsePivotTable
:: (CacheId -> Maybe (Text, Range, [CacheField]))
-> ByteString
-> Maybe PivotTable
parsePivotTable srcByCacheId bs =
listToMaybe . parse . fromDocument $ parseLBS_ def bs
where
parse cur = do
cacheId <- fromAttribute "cacheId" cur
case srcByCacheId cacheId of
Nothing -> fail "no such cache"
Just (_pvtSrcSheet, _pvtSrcRef, cacheFields) -> do
_pvtDataCaption <- attribute "dataCaption" cur
_pvtName <- attribute "name" cur
_pvtLocation <- cur $/ element (n_ "location") >=> fromAttribute "ref"
_pvtRowGrandTotals <- fromAttributeDef "rowGrandTotals" True cur
_pvtColumnGrandTotals <- fromAttributeDef "colGrandTotals" True cur
_pvtOutline <- fromAttributeDef "outline" False cur
_pvtOutlineData <- fromAttributeDef "outlineData" False cur
let pvtFieldsWithHidden =
cur $/ element (n_ "pivotFields") &/ element (n_ "pivotField") >=> \c -> do
-- actually gets overwritten from cache to have consistent field names
_pfiName <- maybeAttribute "name" c
_pfiSortType <- fromAttributeDef "sortType" FieldSortManual c
_pfiOutline <- fromAttributeDef "outline" True c
let hidden =
c $/ element (n_ "items") &/ element (n_ "item") >=>
attrValIs "h" True >=> fromAttribute "x"
_pfiHiddenItems = []
return (PivotFieldInfo {..}, hidden)
_pvtFields = flip map (zip [0.. ] pvtFieldsWithHidden) $
\(i, (PivotFieldInfo {..}, hidden)) ->
let _pfiHiddenItems =
[item | (n, item) <- zip [(0 :: Int) ..] items, n `elem` hidden]
(_pfiName, items) = case atMay cacheFields i of
Just CacheField{..} -> (Just cfName, cfItems)
Nothing -> (Nothing, [])
in PivotFieldInfo {..}
nToFieldName = zip [0 ..] $ map cfName cacheFields
fieldNameList fld = maybeToList $ lookup fld nToFieldName
_pvtRowFields =
cur $/ element (n_ "rowFields") &/ element (n_ "field") >=>
fromAttribute "x" >=> fieldPosition
_pvtColumnFields =
cur $/ element (n_ "colFields") &/ element (n_ "field") >=>
fromAttribute "x" >=> fieldPosition
_pvtDataFields =
cur $/ element (n_ "dataFields") &/ element (n_ "dataField") >=> \c -> do
fld <- fromAttribute "fld" c
_dfField <- fieldNameList fld
-- TOFIX
_dfName <- fromAttributeDef "name" "" c
_dfFunction <- fromAttributeDef "subtotal" ConsolidateSum c
return DataField {..}
fieldPosition :: Int -> [PositionedField]
fieldPosition (-2) = return DataPosition
fieldPosition n =
FieldPosition <$> fieldNameList n
return PivotTable {..}
parseCache :: ByteString -> Maybe (Text, CellRef, [CacheField], Maybe RefId)
parseCache bs = listToMaybe . parse . fromDocument $ parseLBS_ def bs
where
parse cur = do
refId <- maybeAttribute (odr "id") cur
(sheet, ref) <-
cur $/ element (n_ "cacheSource") &/ element (n_ "worksheetSource") >=>
liftA2 (,) <$> attribute "sheet" <*> fromAttribute "ref"
let fields =
cur $/ element (n_ "cacheFields") &/ element (n_ "cacheField") >=>
fromCursor
return (sheet, ref, fields, refId)
fillCacheFieldsFromRecords :: [CacheField] -> [CacheRecord] -> [CacheField]
fillCacheFieldsFromRecords fields recs =
zipWith addValues fields (transpose recs)
where
addValues field recVals =
if null (cfItems field)
then field {cfItems = mapMaybe recToCellValue recVals}
else field
recToCellValue (CacheText t) = Just $ CellText t
recToCellValue (CacheNumber n) = Just $ CellDouble n
recToCellValue (CacheIndex _) = Nothing
xlsx-1.1.2.2/src/Codec/Xlsx/Types/AutoFilter.hs 0000644 0000000 0000000 00000072211 14551273353 017332 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.AutoFilter where
import Control.Arrow (first)
import Control.DeepSeq (NFData)
#ifdef USE_MICROLENS
import Lens.Micro.TH (makeLenses)
#else
import Control.Lens (makeLenses)
#endif
import Data.Bool (bool)
import Data.ByteString (ByteString)
import Data.Default
import Data.Foldable (asum)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Text.XML
import Text.XML.Cursor hiding (bool)
import qualified Xeno.DOM as Xeno
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Types.ConditionalFormatting (IconSetType)
import Codec.Xlsx.Writer.Internal
-- | The filterColumn collection identifies a particular column in the
-- AutoFilter range and specifies filter information that has been
-- applied to this column. If a column in the AutoFilter range has no
-- criteria specified, then there is no corresponding filterColumn
-- collection expressed for that column.
--
-- See 18.3.2.7 "filterColumn (AutoFilter Column)" (p. 1717)
data FilterColumn
= Filters FilterByBlank [FilterCriterion]
| ColorFilter ColorFilterOptions
| ACustomFilter CustomFilter
| CustomFiltersOr CustomFilter CustomFilter
| CustomFiltersAnd CustomFilter CustomFilter
| DynamicFilter DynFilterOptions
| IconFilter (Maybe Int) IconSetType
-- ^ Specifies the icon set and particular icon within that set to
-- filter by. Icon is specified using zero-based index of an icon in
-- an icon set. 'Nothing' means "no icon"
| BottomNFilter EdgeFilterOptions
-- ^ Specifies the bottom N (percent or number of items) to filter by
| TopNFilter EdgeFilterOptions
-- ^ Specifies the top N (percent or number of items) to filter by
deriving (Eq, Show, Generic)
instance NFData FilterColumn
data FilterByBlank
= FilterByBlank
| DontFilterByBlank
deriving (Eq, Show, Generic)
instance NFData FilterByBlank
data FilterCriterion
= FilterValue Text
| FilterDateGroup DateGroup
deriving (Eq, Show, Generic)
instance NFData FilterCriterion
-- | Used to express a group of dates or times which are used in an
-- AutoFilter criteria
--
-- Section 18.3.2.4 "dateGroupItem (Date Grouping)" (p. 1714)
data DateGroup
= DateGroupByYear Int
| DateGroupByMonth Int Int
| DateGroupByDay Int Int Int
| DateGroupByHour Int Int Int Int
| DateGroupByMinute Int Int Int Int Int
| DateGroupBySecond Int Int Int Int Int Int
deriving (Eq, Show, Generic)
instance NFData DateGroup
data CustomFilter = CustomFilter
{ cfltOperator :: CustomFilterOperator
, cfltValue :: Text
} deriving (Eq, Show, Generic)
instance NFData CustomFilter
data CustomFilterOperator
= FltrEqual
-- ^ Show results which are equal to criteria.
| FltrGreaterThan
-- ^ Show results which are greater than criteria.
| FltrGreaterThanOrEqual
-- ^ Show results which are greater than or equal to criteria.
| FltrLessThan
-- ^ Show results which are less than criteria.
| FltrLessThanOrEqual
-- ^ Show results which are less than or equal to criteria.
| FltrNotEqual
-- ^ Show results which are not equal to criteria.
deriving (Eq, Show, Generic)
instance NFData CustomFilterOperator
data EdgeFilterOptions = EdgeFilterOptions
{ _efoUsePercents :: Bool
-- ^ Flag indicating whether or not to filter by percent value of
-- the column. A false value filters by number of items.
, _efoVal :: Double
-- ^ Top or bottom value to use as the filter criteria.
-- Example: "Filter by Top 10 Percent" or "Filter by Top 5 Items"
, _efoFilterVal :: Maybe Double
-- ^ The actual cell value in the range which is used to perform the
-- comparison for this filter.
} deriving (Eq, Show, Generic)
instance NFData EdgeFilterOptions
-- | Specifies the color to filter by and whether to use the cell's
-- fill or font color in the filter criteria. If the cell's font or
-- fill color does not match the color specified in the criteria, the
-- rows corresponding to those cells are hidden from view.
--
-- See 18.3.2.1 "colorFilter (Color Filter Criteria)" (p. 1712)
data ColorFilterOptions = ColorFilterOptions
{ _cfoCellColor :: Bool
-- ^ Flag indicating whether or not to filter by the cell's fill
-- color. 'True' indicates to filter by cell fill. 'False' indicates
-- to filter by the cell's font color.
--
-- For rich text in cells, if the color specified appears in the
-- cell at all, it shall be included in the filter.
, _cfoDxfId :: Maybe Int
-- ^ Id of differential format record (dxf) in the Styles Part (see
-- '_styleSheetDxfs') which expresses the color value to filter by.
} deriving (Eq, Show, Generic)
instance NFData ColorFilterOptions
-- | Specifies dynamic filter criteria. These criteria are considered
-- dynamic because they can change, either with the data itself (e.g.,
-- "above average") or with the current system date (e.g., show values
-- for "today"). For any cells whose values do not meet the specified
-- criteria, the corresponding rows shall be hidden from view when the
-- filter is applied.
--
-- '_dfoMaxVal' shall be required for 'DynFilterTday',
-- 'DynFilterYesterday', 'DynFilterTomorrow', 'DynFilterNextWeek',
-- 'DynFilterThisWeek', 'DynFilterLastWeek', 'DynFilterNextMonth',
-- 'DynFilterThisMonth', 'DynFilterLastMonth', 'DynFilterNextQuarter',
-- 'DynFilterThisQuarter', 'DynFilterLastQuarter',
-- 'DynFilterNextYear', 'DynFilterThisYear', 'DynFilterLastYear', and
-- 'DynFilterYearToDate.
--
-- The above criteria are based on a value range; that is, if today's
-- date is September 22nd, then the range for thisWeek is the values
-- greater than or equal to September 17 and less than September
-- 24. In the thisWeek range, the lower value is expressed
-- '_dfoval'. The higher value is expressed using '_dfoMmaxVal'.
--
-- These dynamic filters shall not require '_dfoVal or '_dfoMaxVal':
-- 'DynFilterQ1', 'DynFilterQ2', 'DynFilterQ3', 'DynFilterQ4',
-- 'DynFilterM1', 'DynFilterM2', 'DynFilterM3', 'DynFilterM4',
-- 'DynFilterM5', 'DynFilterM6', 'DynFilterM7', 'DynFilterM8',
-- 'DynFilterM9', 'DynFilterM10', 'DynFilterM11' and 'DynFilterM12'.
--
-- The above criteria shall not specify the range using valIso and
-- maxValIso because Q1 always starts from M1 to M3, and M1 is always
-- January.
--
-- These types of dynamic filters shall use valIso and shall not use
-- '_dfoMaxVal': 'DynFilterAboveAverage' and 'DynFilterBelowAverage'
--
-- /Note:/ Specification lists 'valIso' and 'maxIso' to store datetime
-- values but it appears that Excel doesn't use them and stored them
-- as numeric values (as it does for datetimes in cell values)
--
-- See 18.3.2.5 "dynamicFilter (Dynamic Filter)" (p. 1715)
data DynFilterOptions = DynFilterOptions
{ _dfoType :: DynFilterType
, _dfoVal :: Maybe Double
-- ^ A minimum numeric value for dynamic filter.
, _dfoMaxVal :: Maybe Double
-- ^ A maximum value for dynamic filter.
} deriving (Eq, Show, Generic)
instance NFData DynFilterOptions
-- | Specifies concrete type of dynamic filter used
--
-- See 18.18.26 "ST_DynamicFilterType (Dynamic Filter)" (p. 2452)
data DynFilterType
= DynFilterAboveAverage
-- ^ Shows values that are above average.
| DynFilterBelowAverage
-- ^ Shows values that are below average.
| DynFilterLastMonth
-- ^ Shows last month's dates.
| DynFilterLastQuarter
-- ^ Shows last calendar quarter's dates.
| DynFilterLastWeek
-- ^ Shows last week's dates, using Sunday as the first weekday.
| DynFilterLastYear
-- ^ Shows last year's dates.
| DynFilterM1
-- ^ Shows the dates that are in January, regardless of year.
| DynFilterM10
-- ^ Shows the dates that are in October, regardless of year.
| DynFilterM11
-- ^ Shows the dates that are in November, regardless of year.
| DynFilterM12
-- ^ Shows the dates that are in December, regardless of year.
| DynFilterM2
-- ^ Shows the dates that are in February, regardless of year.
| DynFilterM3
-- ^ Shows the dates that are in March, regardless of year.
| DynFilterM4
-- ^ Shows the dates that are in April, regardless of year.
| DynFilterM5
-- ^ Shows the dates that are in May, regardless of year.
| DynFilterM6
-- ^ Shows the dates that are in June, regardless of year.
| DynFilterM7
-- ^ Shows the dates that are in July, regardless of year.
| DynFilterM8
-- ^ Shows the dates that are in August, regardless of year.
| DynFilterM9
-- ^ Shows the dates that are in September, regardless of year.
| DynFilterNextMonth
-- ^ Shows next month's dates.
| DynFilterNextQuarter
-- ^ Shows next calendar quarter's dates.
| DynFilterNextWeek
-- ^ Shows next week's dates, using Sunday as the first weekday.
| DynFilterNextYear
-- ^ Shows next year's dates.
| DynFilterNull
-- ^ Common filter type not available.
| DynFilterQ1
-- ^ Shows the dates that are in the 1st calendar quarter,
-- regardless of year.
| DynFilterQ2
-- ^ Shows the dates that are in the 2nd calendar quarter,
-- regardless of year.
| DynFilterQ3
-- ^ Shows the dates that are in the 3rd calendar quarter,
-- regardless of year.
| DynFilterQ4
-- ^ Shows the dates that are in the 4th calendar quarter,
-- regardless of year.
| DynFilterThisMonth
-- ^ Shows this month's dates.
| DynFilterThisQuarter
-- ^ Shows this calendar quarter's dates.
| DynFilterThisWeek
-- ^ Shows this week's dates, using Sunday as the first weekday.
| DynFilterThisYear
-- ^ Shows this year's dates.
| DynFilterToday
-- ^ Shows today's dates.
| DynFilterTomorrow
-- ^ Shows tomorrow's dates.
| DynFilterYearToDate
-- ^ Shows the dates between the beginning of the year and today, inclusive.
| DynFilterYesterday
-- ^ Shows yesterday's dates.
deriving (Eq, Show, Generic)
instance NFData DynFilterType
-- | AutoFilter temporarily hides rows based on a filter criteria,
-- which is applied column by column to a table of datain the
-- worksheet.
--
-- TODO: sortState, extList
--
-- See 18.3.1.2 "autoFilter (AutoFilter Settings)" (p. 1596)
data AutoFilter = AutoFilter
{ _afRef :: Maybe CellRef
, _afFilterColumns :: Map Int FilterColumn
} deriving (Eq, Show, Generic)
instance NFData AutoFilter
makeLenses ''AutoFilter
{-------------------------------------------------------------------------------
Default instances
-------------------------------------------------------------------------------}
instance Default AutoFilter where
def = AutoFilter Nothing M.empty
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
instance FromCursor AutoFilter where
fromCursor cur = do
_afRef <- maybeAttribute "ref" cur
let _afFilterColumns = M.fromList $ cur $/ element (n_ "filterColumn") >=> \c -> do
colId <- fromAttribute "colId" c
fcol <- c $/ anyElement >=> fltColFromNode . node
return (colId, fcol)
return AutoFilter {..}
instance FromXenoNode AutoFilter where
fromXenoNode root = do
_afRef <- parseAttributes root $ maybeAttr "ref"
_afFilterColumns <-
fmap M.fromList . collectChildren root $ fromChildList "filterColumn"
return AutoFilter {..}
instance FromXenoNode (Int, FilterColumn) where
fromXenoNode root = do
colId <- parseAttributes root $ fromAttr "colId"
fCol <-
collectChildren root $ asum [filters, color, custom, dynamic, icon, top10]
return (colId, fCol)
where
filters =
requireAndParse "filters" $ \node -> do
filterBlank <-
parseAttributes node $ fromAttrDef "blank" DontFilterByBlank
filterCriteria <- childListAny node
return $ Filters filterBlank filterCriteria
color =
requireAndParse "colorFilter" $ \node ->
parseAttributes node $ do
_cfoCellColor <- fromAttrDef "cellColor" True
_cfoDxfId <- maybeAttr "dxfId"
return $ ColorFilter ColorFilterOptions {..}
custom =
requireAndParse "customFilters" $ \node -> do
isAnd <- parseAttributes node $ fromAttrDef "and" False
cfilters <- collectChildren node $ fromChildList "customFilter"
case cfilters of
[f] -> return $ ACustomFilter f
[f1, f2] ->
if isAnd
then return $ CustomFiltersAnd f1 f2
else return $ CustomFiltersOr f1 f2
_ ->
Left $
"expected 1 or 2 custom filters but found " <>
T.pack (show $ length cfilters)
dynamic =
requireAndParse "dynamicFilter" . flip parseAttributes $ do
_dfoType <- fromAttr "type"
_dfoVal <- maybeAttr "val"
_dfoMaxVal <- maybeAttr "maxVal"
return $ DynamicFilter DynFilterOptions {..}
icon =
requireAndParse "iconFilter" . flip parseAttributes $
IconFilter <$> maybeAttr "iconId" <*> fromAttr "iconSet"
top10 =
requireAndParse "top10" . flip parseAttributes $ do
top <- fromAttrDef "top" True
percent <- fromAttrDef "percent" False
val <- fromAttr "val"
filterVal <- maybeAttr "filterVal"
let opts = EdgeFilterOptions percent val filterVal
if top
then return $ TopNFilter opts
else return $ BottomNFilter opts
instance FromXenoNode CustomFilter where
fromXenoNode root =
parseAttributes root $
CustomFilter <$> fromAttrDef "operator" FltrEqual <*> fromAttr "val"
fltColFromNode :: Node -> [FilterColumn]
fltColFromNode n | n `nodeElNameIs` (n_ "filters") = do
let filterCriteria = cur $/ anyElement >=> fromCursor
filterBlank <- fromAttributeDef "blank" DontFilterByBlank cur
return $ Filters filterBlank filterCriteria
| n `nodeElNameIs` (n_ "colorFilter") = do
_cfoCellColor <- fromAttributeDef "cellColor" True cur
_cfoDxfId <- maybeAttribute "dxfId" cur
return $ ColorFilter ColorFilterOptions {..}
| n `nodeElNameIs` (n_ "customFilters") = do
isAnd <- fromAttributeDef "and" False cur
let cFilters = cur $/ element (n_ "customFilter") >=> \c -> do
op <- fromAttributeDef "operator" FltrEqual c
val <- fromAttribute "val" c
return $ CustomFilter op val
case cFilters of
[f] ->
return $ ACustomFilter f
[f1, f2] ->
if isAnd
then return $ CustomFiltersAnd f1 f2
else return $ CustomFiltersOr f1 f2
_ ->
fail "bad custom filter"
| n `nodeElNameIs` (n_ "dynamicFilter") = do
_dfoType <- fromAttribute "type" cur
_dfoVal <- maybeAttribute "val" cur
_dfoMaxVal <- maybeAttribute "maxVal" cur
return $ DynamicFilter DynFilterOptions{..}
| n `nodeElNameIs` (n_ "iconFilter") = do
iconId <- maybeAttribute "iconId" cur
iconSet <- fromAttribute "iconSet" cur
return $ IconFilter iconId iconSet
| n `nodeElNameIs` (n_ "top10") = do
top <- fromAttributeDef "top" True cur
let percent = fromAttributeDef "percent" False cur
val = fromAttribute "val" cur
filterVal = maybeAttribute "filterVal" cur
if top
then fmap TopNFilter $
EdgeFilterOptions <$> percent <*> val <*> filterVal
else fmap BottomNFilter $
EdgeFilterOptions <$> percent <*> val <*> filterVal
| otherwise = fail "no matching nodes"
where
cur = fromNode n
instance FromCursor FilterCriterion where
fromCursor = filterCriterionFromNode . node
instance FromXenoNode FilterCriterion where
fromXenoNode root =
case Xeno.name root of
"filter" -> parseAttributes root $ do FilterValue <$> fromAttr "val"
"dateGroupItem" ->
parseAttributes root $ do
grouping <- fromAttr "dateTimeGrouping"
group <- case grouping of
("year" :: ByteString) ->
DateGroupByYear <$> fromAttr "year"
"month" ->
DateGroupByMonth <$> fromAttr "year"
<*> fromAttr "month"
"day" ->
DateGroupByDay <$> fromAttr "year"
<*> fromAttr "month"
<*> fromAttr "day"
"hour" ->
DateGroupByHour <$> fromAttr "year"
<*> fromAttr "month"
<*> fromAttr "day"
<*> fromAttr "hour"
"minute" ->
DateGroupByMinute <$> fromAttr "year"
<*> fromAttr "month"
<*> fromAttr "day"
<*> fromAttr "hour"
<*> fromAttr "minute"
"second" ->
DateGroupBySecond <$> fromAttr "year"
<*> fromAttr "month"
<*> fromAttr "day"
<*> fromAttr "hour"
<*> fromAttr "minute"
<*> fromAttr "second"
_ -> toAttrParser . Left $ "Unexpected date grouping"
return $ FilterDateGroup group
_ -> Left "Bad FilterCriterion"
-- TODO: follow the spec about the fact that dategroupitem always go after filter
filterCriterionFromNode :: Node -> [FilterCriterion]
filterCriterionFromNode n
| n `nodeElNameIs` (n_ "filter") = do
v <- fromAttribute "val" cur
return $ FilterValue v
| n `nodeElNameIs` (n_ "dateGroupItem") = do
g <- fromAttribute "dateTimeGrouping" cur
let year = fromAttribute "year" cur
month = fromAttribute "month" cur
day = fromAttribute "day" cur
hour = fromAttribute "hour" cur
minute = fromAttribute "minute" cur
second = fromAttribute "second" cur
FilterDateGroup <$>
case g of
"year" -> DateGroupByYear <$> year
"month" -> DateGroupByMonth <$> year <*> month
"day" -> DateGroupByDay <$> year <*> month <*> day
"hour" -> DateGroupByHour <$> year <*> month <*> day <*> hour
"minute" ->
DateGroupByMinute <$> year <*> month <*> day <*> hour <*> minute
"second" ->
DateGroupBySecond <$> year <*> month <*> day <*> hour <*> minute <*>
second
_ -> fail $ "unexpected dateTimeGrouping " ++ show (g :: Text)
| otherwise = fail "no matching nodes"
where
cur = fromNode n
instance FromAttrVal CustomFilterOperator where
fromAttrVal "equal" = readSuccess FltrEqual
fromAttrVal "greaterThan" = readSuccess FltrGreaterThan
fromAttrVal "greaterThanOrEqual" = readSuccess FltrGreaterThanOrEqual
fromAttrVal "lessThan" = readSuccess FltrLessThan
fromAttrVal "lessThanOrEqual" = readSuccess FltrLessThanOrEqual
fromAttrVal "notEqual" = readSuccess FltrNotEqual
fromAttrVal t = invalidText "CustomFilterOperator" t
instance FromAttrBs CustomFilterOperator where
fromAttrBs "equal" = return FltrEqual
fromAttrBs "greaterThan" = return FltrGreaterThan
fromAttrBs "greaterThanOrEqual" = return FltrGreaterThanOrEqual
fromAttrBs "lessThan" = return FltrLessThan
fromAttrBs "lessThanOrEqual" = return FltrLessThanOrEqual
fromAttrBs "notEqual" = return FltrNotEqual
fromAttrBs x = unexpectedAttrBs "CustomFilterOperator" x
instance FromAttrVal FilterByBlank where
fromAttrVal =
fmap (first $ bool DontFilterByBlank FilterByBlank) . fromAttrVal
instance FromAttrBs FilterByBlank where
fromAttrBs = fmap (bool DontFilterByBlank FilterByBlank) . fromAttrBs
instance FromAttrVal DynFilterType where
fromAttrVal "aboveAverage" = readSuccess DynFilterAboveAverage
fromAttrVal "belowAverage" = readSuccess DynFilterBelowAverage
fromAttrVal "lastMonth" = readSuccess DynFilterLastMonth
fromAttrVal "lastQuarter" = readSuccess DynFilterLastQuarter
fromAttrVal "lastWeek" = readSuccess DynFilterLastWeek
fromAttrVal "lastYear" = readSuccess DynFilterLastYear
fromAttrVal "M1" = readSuccess DynFilterM1
fromAttrVal "M10" = readSuccess DynFilterM10
fromAttrVal "M11" = readSuccess DynFilterM11
fromAttrVal "M12" = readSuccess DynFilterM12
fromAttrVal "M2" = readSuccess DynFilterM2
fromAttrVal "M3" = readSuccess DynFilterM3
fromAttrVal "M4" = readSuccess DynFilterM4
fromAttrVal "M5" = readSuccess DynFilterM5
fromAttrVal "M6" = readSuccess DynFilterM6
fromAttrVal "M7" = readSuccess DynFilterM7
fromAttrVal "M8" = readSuccess DynFilterM8
fromAttrVal "M9" = readSuccess DynFilterM9
fromAttrVal "nextMonth" = readSuccess DynFilterNextMonth
fromAttrVal "nextQuarter" = readSuccess DynFilterNextQuarter
fromAttrVal "nextWeek" = readSuccess DynFilterNextWeek
fromAttrVal "nextYear" = readSuccess DynFilterNextYear
fromAttrVal "null" = readSuccess DynFilterNull
fromAttrVal "Q1" = readSuccess DynFilterQ1
fromAttrVal "Q2" = readSuccess DynFilterQ2
fromAttrVal "Q3" = readSuccess DynFilterQ3
fromAttrVal "Q4" = readSuccess DynFilterQ4
fromAttrVal "thisMonth" = readSuccess DynFilterThisMonth
fromAttrVal "thisQuarter" = readSuccess DynFilterThisQuarter
fromAttrVal "thisWeek" = readSuccess DynFilterThisWeek
fromAttrVal "thisYear" = readSuccess DynFilterThisYear
fromAttrVal "today" = readSuccess DynFilterToday
fromAttrVal "tomorrow" = readSuccess DynFilterTomorrow
fromAttrVal "yearToDate" = readSuccess DynFilterYearToDate
fromAttrVal "yesterday" = readSuccess DynFilterYesterday
fromAttrVal t = invalidText "DynFilterType" t
instance FromAttrBs DynFilterType where
fromAttrBs "aboveAverage" = return DynFilterAboveAverage
fromAttrBs "belowAverage" = return DynFilterBelowAverage
fromAttrBs "lastMonth" = return DynFilterLastMonth
fromAttrBs "lastQuarter" = return DynFilterLastQuarter
fromAttrBs "lastWeek" = return DynFilterLastWeek
fromAttrBs "lastYear" = return DynFilterLastYear
fromAttrBs "M1" = return DynFilterM1
fromAttrBs "M10" = return DynFilterM10
fromAttrBs "M11" = return DynFilterM11
fromAttrBs "M12" = return DynFilterM12
fromAttrBs "M2" = return DynFilterM2
fromAttrBs "M3" = return DynFilterM3
fromAttrBs "M4" = return DynFilterM4
fromAttrBs "M5" = return DynFilterM5
fromAttrBs "M6" = return DynFilterM6
fromAttrBs "M7" = return DynFilterM7
fromAttrBs "M8" = return DynFilterM8
fromAttrBs "M9" = return DynFilterM9
fromAttrBs "nextMonth" = return DynFilterNextMonth
fromAttrBs "nextQuarter" = return DynFilterNextQuarter
fromAttrBs "nextWeek" = return DynFilterNextWeek
fromAttrBs "nextYear" = return DynFilterNextYear
fromAttrBs "null" = return DynFilterNull
fromAttrBs "Q1" = return DynFilterQ1
fromAttrBs "Q2" = return DynFilterQ2
fromAttrBs "Q3" = return DynFilterQ3
fromAttrBs "Q4" = return DynFilterQ4
fromAttrBs "thisMonth" = return DynFilterThisMonth
fromAttrBs "thisQuarter" = return DynFilterThisQuarter
fromAttrBs "thisWeek" = return DynFilterThisWeek
fromAttrBs "thisYear" = return DynFilterThisYear
fromAttrBs "today" = return DynFilterToday
fromAttrBs "tomorrow" = return DynFilterTomorrow
fromAttrBs "yearToDate" = return DynFilterYearToDate
fromAttrBs "yesterday" = return DynFilterYesterday
fromAttrBs x = unexpectedAttrBs "DynFilterType" x
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
instance ToElement AutoFilter where
toElement nm AutoFilter {..} =
elementList
nm
(catMaybes ["ref" .=? _afRef])
[ elementList
(n_ "filterColumn")
["colId" .= colId]
[fltColToElement fCol]
| (colId, fCol) <- M.toList _afFilterColumns
]
fltColToElement :: FilterColumn -> Element
fltColToElement (Filters filterBlank filterCriteria) =
let attrs = catMaybes ["blank" .=? justNonDef DontFilterByBlank filterBlank]
in elementList
(n_ "filters") attrs $ map filterCriterionToElement filterCriteria
fltColToElement (ColorFilter opts) = toElement (n_ "colorFilter") opts
fltColToElement (ACustomFilter f) =
elementListSimple (n_ "customFilters") [toElement (n_ "customFilter") f]
fltColToElement (CustomFiltersOr f1 f2) =
elementListSimple
(n_ "customFilters")
[toElement (n_ "customFilter") f | f <- [f1, f2]]
fltColToElement (CustomFiltersAnd f1 f2) =
elementList
(n_ "customFilters")
["and" .= True]
[toElement (n_ "customFilter") f | f <- [f1, f2]]
fltColToElement (DynamicFilter opts) = toElement (n_ "dynamicFilter") opts
fltColToElement (IconFilter iconId iconSet) =
leafElement (n_ "iconFilter") $
["iconSet" .= iconSet] ++ catMaybes ["iconId" .=? iconId]
fltColToElement (BottomNFilter opts) = edgeFilter False opts
fltColToElement (TopNFilter opts) = edgeFilter True opts
edgeFilter :: Bool -> EdgeFilterOptions -> Element
edgeFilter top EdgeFilterOptions {..} =
leafElement (n_ "top10") $
["top" .= top, "percent" .= _efoUsePercents, "val" .= _efoVal] ++
catMaybes ["filterVal" .=? _efoFilterVal]
filterCriterionToElement :: FilterCriterion -> Element
filterCriterionToElement (FilterValue v) =
leafElement (n_ "filter") ["val" .= v]
filterCriterionToElement (FilterDateGroup (DateGroupByYear y)) =
leafElement
(n_ "dateGroupItem")
["dateTimeGrouping" .= ("year" :: Text), "year" .= y]
filterCriterionToElement (FilterDateGroup (DateGroupByMonth y m)) =
leafElement
(n_ "dateGroupItem")
["dateTimeGrouping" .= ("month" :: Text), "year" .= y, "month" .= m]
filterCriterionToElement (FilterDateGroup (DateGroupByDay y m d)) =
leafElement
(n_ "dateGroupItem")
["dateTimeGrouping" .= ("day" :: Text), "year" .= y, "month" .= m, "day" .= d]
filterCriterionToElement (FilterDateGroup (DateGroupByHour y m d h)) =
leafElement
(n_ "dateGroupItem")
[ "dateTimeGrouping" .= ("hour" :: Text)
, "year" .= y
, "month" .= m
, "day" .= d
, "hour" .= h
]
filterCriterionToElement (FilterDateGroup (DateGroupByMinute y m d h mi)) =
leafElement
(n_ "dateGroupItem")
[ "dateTimeGrouping" .= ("minute" :: Text)
, "year" .= y
, "month" .= m
, "day" .= d
, "hour" .= h
, "minute" .= mi
]
filterCriterionToElement (FilterDateGroup (DateGroupBySecond y m d h mi s)) =
leafElement
(n_ "dateGroupItem")
[ "dateTimeGrouping" .= ("second" :: Text)
, "year" .= y
, "month" .= m
, "day" .= d
, "hour" .= h
, "minute" .= mi
, "second" .= s
]
instance ToElement CustomFilter where
toElement nm CustomFilter {..} =
leafElement nm ["operator" .= cfltOperator, "val" .= cfltValue]
instance ToAttrVal CustomFilterOperator where
toAttrVal FltrEqual = "equal"
toAttrVal FltrGreaterThan = "greaterThan"
toAttrVal FltrGreaterThanOrEqual = "greaterThanOrEqual"
toAttrVal FltrLessThan = "lessThan"
toAttrVal FltrLessThanOrEqual = "lessThanOrEqual"
toAttrVal FltrNotEqual = "notEqual"
instance ToAttrVal FilterByBlank where
toAttrVal FilterByBlank = toAttrVal True
toAttrVal DontFilterByBlank = toAttrVal False
instance ToElement ColorFilterOptions where
toElement nm ColorFilterOptions {..} =
leafElement nm $
catMaybes ["cellColor" .=? justFalse _cfoCellColor, "dxfId" .=? _cfoDxfId]
instance ToElement DynFilterOptions where
toElement nm DynFilterOptions {..} =
leafElement nm $
["type" .= _dfoType] ++
catMaybes ["val" .=? _dfoVal, "maxVal" .=? _dfoMaxVal]
instance ToAttrVal DynFilterType where
toAttrVal DynFilterAboveAverage = "aboveAverage"
toAttrVal DynFilterBelowAverage = "belowAverage"
toAttrVal DynFilterLastMonth = "lastMonth"
toAttrVal DynFilterLastQuarter = "lastQuarter"
toAttrVal DynFilterLastWeek = "lastWeek"
toAttrVal DynFilterLastYear = "lastYear"
toAttrVal DynFilterM1 = "M1"
toAttrVal DynFilterM10 = "M10"
toAttrVal DynFilterM11 = "M11"
toAttrVal DynFilterM12 = "M12"
toAttrVal DynFilterM2 = "M2"
toAttrVal DynFilterM3 = "M3"
toAttrVal DynFilterM4 = "M4"
toAttrVal DynFilterM5 = "M5"
toAttrVal DynFilterM6 = "M6"
toAttrVal DynFilterM7 = "M7"
toAttrVal DynFilterM8 = "M8"
toAttrVal DynFilterM9 = "M9"
toAttrVal DynFilterNextMonth = "nextMonth"
toAttrVal DynFilterNextQuarter = "nextQuarter"
toAttrVal DynFilterNextWeek = "nextWeek"
toAttrVal DynFilterNextYear = "nextYear"
toAttrVal DynFilterNull = "null"
toAttrVal DynFilterQ1 = "Q1"
toAttrVal DynFilterQ2 = "Q2"
toAttrVal DynFilterQ3 = "Q3"
toAttrVal DynFilterQ4 = "Q4"
toAttrVal DynFilterThisMonth = "thisMonth"
toAttrVal DynFilterThisQuarter = "thisQuarter"
toAttrVal DynFilterThisWeek = "thisWeek"
toAttrVal DynFilterThisYear = "thisYear"
toAttrVal DynFilterToday = "today"
toAttrVal DynFilterTomorrow = "tomorrow"
toAttrVal DynFilterYearToDate = "yearToDate"
toAttrVal DynFilterYesterday = "yesterday"
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Cell.hs 0000644 0000000 0000000 00000013116 14551273353 016132 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Cell
( CellFormula(..)
, FormulaExpression(..)
, simpleCellFormula
, sharedFormulaByIndex
, SharedFormulaIndex(..)
, SharedFormulaOptions(..)
, formulaDataFromCursor
, applySharedFormulaOpts
, Cell(..)
, cellStyle
, cellValue
, cellComment
, cellFormula
, CellMap
) where
import Control.Arrow (first)
#ifdef USE_MICROLENS
import Lens.Micro.TH (makeLenses)
#else
import Control.Lens.TH (makeLenses)
#endif
import Control.DeepSeq (NFData)
import Data.Default
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (catMaybes, listToMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import GHC.Generics (Generic)
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Comment
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Writer.Internal
-- | Formula for the cell.
--
-- TODO: array, dataTable formula types support
--
-- See 18.3.1.40 "f (Formula)" (p. 1636)
data CellFormula = CellFormula
{ _cellfExpression :: FormulaExpression
, _cellfAssignsToName :: Bool
-- ^ Specifies that this formula assigns a value to a name.
, _cellfCalculate :: Bool
-- ^ Indicates that this formula needs to be recalculated
-- the next time calculation is performed.
-- [/Example/: This is always set on volatile functions,
-- like =RAND(), and circular references. /end example/]
} deriving (Eq, Show, Generic)
instance NFData CellFormula
-- | formula type with type-specific options
data FormulaExpression
= NormalFormula Formula
| SharedFormula SharedFormulaIndex
deriving (Eq, Show, Generic)
instance NFData FormulaExpression
defaultFormulaType :: Text
defaultFormulaType = "normal"
-- | index of shared formula in worksheet's 'wsSharedFormulas'
-- property
newtype SharedFormulaIndex = SharedFormulaIndex Int
deriving (Eq, Ord, Show, Generic)
instance NFData SharedFormulaIndex
data SharedFormulaOptions = SharedFormulaOptions
{ _sfoRef :: CellRef
, _sfoExpression :: Formula
}
deriving (Eq, Show, Generic)
instance NFData SharedFormulaOptions
simpleCellFormula :: Text -> CellFormula
simpleCellFormula expr = CellFormula
{ _cellfExpression = NormalFormula $ Formula expr
, _cellfAssignsToName = False
, _cellfCalculate = False
}
sharedFormulaByIndex :: SharedFormulaIndex -> CellFormula
sharedFormulaByIndex si =
CellFormula
{ _cellfExpression = SharedFormula si
, _cellfAssignsToName = False
, _cellfCalculate = False
}
-- | Currently cell details include cell values, style ids and cell
-- formulas (inline strings from @\@ subelements are ignored)
data Cell = Cell
{ _cellStyle :: Maybe Int
, _cellValue :: Maybe CellValue
, _cellComment :: Maybe Comment
, _cellFormula :: Maybe CellFormula
} deriving (Eq, Show, Generic)
instance NFData Cell
instance Default Cell where
def = Cell Nothing Nothing Nothing Nothing
makeLenses ''Cell
-- | Map containing cell values which are indexed by row and column
-- if you need to use more traditional (x,y) indexing please you could
-- use corresponding accessors from ''Codec.Xlsx.Lens''
type CellMap = Map (RowIndex, ColumnIndex) Cell
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
formulaDataFromCursor ::
Cursor -> [(CellFormula, Maybe (SharedFormulaIndex, SharedFormulaOptions))]
formulaDataFromCursor cur = do
_cellfAssignsToName <- fromAttributeDef "bx" False cur
_cellfCalculate <- fromAttributeDef "ca" False cur
t <- fromAttributeDef "t" defaultFormulaType cur
(_cellfExpression, shared) <-
case t of
d| d == defaultFormulaType -> do
formula <- fromCursor cur
return (NormalFormula formula, Nothing)
"shared" -> do
let expr = listToMaybe $ fromCursor cur
ref <- maybeAttribute "ref" cur
si <- fromAttribute "si" cur
return (SharedFormula si, (,) <$> pure si <*>
(SharedFormulaOptions <$> ref <*> expr))
_ ->
fail $ "Unexpected formula type" ++ show t
return (CellFormula {..}, shared)
instance FromAttrVal SharedFormulaIndex where
fromAttrVal = fmap (first SharedFormulaIndex) . fromAttrVal
instance FromAttrBs SharedFormulaIndex where
fromAttrBs = fmap SharedFormulaIndex . fromAttrBs
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
instance ToElement CellFormula where
toElement nm CellFormula {..} =
formulaEl {elementAttributes = elementAttributes formulaEl <> commonAttrs}
where
commonAttrs =
M.fromList $
catMaybes
[ "bx" .=? justTrue _cellfAssignsToName
, "ca" .=? justTrue _cellfCalculate
, "t" .=? justNonDef defaultFormulaType fType
]
(formulaEl, fType) =
case _cellfExpression of
NormalFormula f -> (toElement nm f, defaultFormulaType)
SharedFormula si -> (leafElement nm ["si" .= si], "shared")
instance ToAttrVal SharedFormulaIndex where
toAttrVal (SharedFormulaIndex si) = toAttrVal si
applySharedFormulaOpts :: SharedFormulaOptions -> Element -> Element
applySharedFormulaOpts SharedFormulaOptions {..} el =
el
{ elementAttributes = elementAttributes el <> M.fromList ["ref" .= _sfoRef]
, elementNodes = NodeContent (unFormula _sfoExpression) : elementNodes el
}
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Comment.hs 0000644 0000000 0000000 00000001175 14551273353 016657 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Comment where
import Control.DeepSeq (NFData)
import Data.Text (Text)
import GHC.Generics (Generic)
import Codec.Xlsx.Types.Common
-- | User comment for a cell
--
-- TODO: the following child elements:
-- guid, shapeId, commentPr
--
-- Section 18.7.3 "comment (Comment)" (p. 1749)
data Comment = Comment
{ _commentText :: XlsxText
-- ^ cell comment text, maybe formatted
-- Section 18.7.7 "text (Comment Text)" (p. 1754)
, _commentAuthor :: Text
-- ^ comment author
, _commentVisible :: Bool
} deriving (Eq, Show, Generic)
instance NFData Comment
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Common.hs 0000644 0000000 0000000 00000062722 14551273353 016512 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Codec.Xlsx.Types.Common
( CellRef(..)
, RowCoord(..)
, ColumnCoord(..)
, CellCoord
, RangeCoord
, mapBoth
, col2coord
, coord2col
, row2coord
, coord2row
, singleCellRef
, singleCellRef'
, fromSingleCellRef
, fromSingleCellRef'
, fromSingleCellRefNoting
, escapeRefSheetName
, unEscapeRefSheetName
, mkForeignSingleCellRef
, fromForeignSingleCellRef
, Range
, mkRange
, mkRange'
, mkForeignRange
, fromRange
, fromRange'
, fromForeignRange
, SqRef(..)
, XlsxText(..)
, xlsxTextToCellValue
, Formula(..)
, CellValue(..)
, ErrorType(..)
, DateBase(..)
, dateFromNumber
, dateToNumber
, int2col
, col2int
, columnIndexToText
, textToColumnIndex
-- ** prisms
, _XlsxText
, _XlsxRichText
, _CellText
, _CellDouble
, _CellBool
, _CellRich
, _CellError
, RowIndex(..)
, ColumnIndex(..)
) where
import GHC.Generics (Generic)
import Control.Applicative (liftA2)
import Control.Arrow
import Control.DeepSeq (NFData)
import Control.Monad (forM, guard)
import Data.Bifunctor (bimap)
import qualified Data.ByteString as BS
import Data.Char
import Data.Maybe (isJust, fromMaybe)
import Data.Function ((&))
import Data.Ix (inRange)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time.Calendar (Day, addDays, diffDays, fromGregorian)
import Data.Time.Clock (UTCTime(UTCTime), picosecondsToDiffTime)
import Safe
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.RichText
import Codec.Xlsx.Writer.Internal
#ifdef USE_MICROLENS
import Lens.Micro
import Lens.Micro.Internal
import Lens.Micro.GHC ()
import Data.Profunctor.Choice
import Data.Profunctor(dimap)
#else
import Control.Lens(makePrisms)
#endif
newtype RowIndex = RowIndex {unRowIndex :: Int}
deriving (Eq, Ord, Show, Read, Generic, Num, Real, Enum, Integral)
newtype ColumnIndex = ColumnIndex {unColumnIndex :: Int}
deriving (Eq, Ord, Show, Read, Generic, Num, Real, Enum, Integral)
instance NFData RowIndex
instance NFData ColumnIndex
instance ToAttrVal RowIndex where
toAttrVal = toAttrVal . unRowIndex
{-# DEPRECATED int2col
"this function will be removed in an upcoming release, use columnIndexToText instead." #-}
int2col :: ColumnIndex -> Text
int2col = columnIndexToText
{-# DEPRECATED col2int
"this function will be removed in an upcoming release, use textToColumnIndex instead." #-}
col2int :: Text -> ColumnIndex
col2int = textToColumnIndex
-- | convert column number (starting from 1) to its textual form (e.g. 3 -> \"C\")
columnIndexToText :: ColumnIndex -> Text
columnIndexToText = T.pack . reverse . map int2let . base26 . unColumnIndex
where
int2let 0 = 'Z'
int2let x = chr $ (x - 1) + ord 'A'
base26 0 = []
base26 i = let i' = (i `mod` 26)
i'' = if i' == 0 then 26 else i'
in seq i' (i' : base26 ((i - i'') `div` 26))
rowIndexToText :: RowIndex -> Text
rowIndexToText = T.pack . show . unRowIndex
-- | reverse of 'columnIndexToText'
textToColumnIndex :: Text -> ColumnIndex
textToColumnIndex = ColumnIndex . T.foldl' (\i c -> i * 26 + let2int c) 0
where
let2int c = 1 + ord c - ord 'A'
textToRowIndex :: Text -> RowIndex
textToRowIndex = RowIndex . read . T.unpack
-- | Excel cell or cell range reference (e.g. @E3@), possibly absolute.
-- See 18.18.62 @ST_Ref@ (p. 2482)
--
-- Note: The @ST_Ref@ type can point to another sheet (supported)
-- or a sheet in another workbook (separate .xlsx file, not implemented).
newtype CellRef = CellRef
{ unCellRef :: Text
} deriving (Eq, Ord, Show, Generic)
instance NFData CellRef
-- | A helper type for coordinates to carry the intent of them being relative or absolute (preceded by '$'):
--
-- > singleCellRefRaw' (RowRel 5, ColumnAbs 1) == "$A5"
data RowCoord
= RowAbs !RowIndex
| RowRel !RowIndex
deriving (Eq, Ord, Show, Read, Generic)
instance NFData RowCoord
data ColumnCoord
= ColumnAbs !ColumnIndex
| ColumnRel !ColumnIndex
deriving (Eq, Ord, Show, Read, Generic)
instance NFData ColumnCoord
type CellCoord = (RowCoord, ColumnCoord)
type RangeCoord = (CellCoord, CellCoord)
mkColumnCoord :: Bool -> ColumnIndex -> ColumnCoord
mkColumnCoord isAbs = if isAbs then ColumnAbs else ColumnRel
mkRowCoord :: Bool -> RowIndex -> RowCoord
mkRowCoord isAbs = if isAbs then RowAbs else RowRel
coord2col :: ColumnCoord -> Text
coord2col (ColumnAbs c) = "$" <> coord2col (ColumnRel c)
coord2col (ColumnRel c) = columnIndexToText c
col2coord :: Text -> ColumnCoord
col2coord t =
let t' = T.stripPrefix "$" t
in mkColumnCoord (isJust t') (textToColumnIndex (fromMaybe t t'))
coord2row :: RowCoord -> Text
coord2row (RowAbs c) = "$" <> coord2row (RowRel c)
coord2row (RowRel c) = rowIndexToText c
row2coord :: Text -> RowCoord
row2coord t =
let t' = T.stripPrefix "$" t
in mkRowCoord (isJust t') (textToRowIndex (fromMaybe t t'))
-- | Unwrap a Coord into an abstract Int coordinate
unRowCoord :: RowCoord -> RowIndex
unRowCoord (RowAbs i) = i
unRowCoord (RowRel i) = i
-- | Unwrap a Coord into an abstract Int coordinate
unColumnCoord :: ColumnCoord -> ColumnIndex
unColumnCoord (ColumnAbs i) = i
unColumnCoord (ColumnRel i) = i
-- | Helper function to apply the same transformation to both members of a tuple
--
-- > mapBoth Abs (1, 2) == (Abs 1, Abs 2s)
mapBoth :: (a -> b) -> (a, a) -> (b, b)
mapBoth f = bimap f f
-- | Render position in @(row, col)@ format to an Excel reference.
--
-- > singleCellRef (RowIndex 2, ColumnIndex 4) == CellRef "D2"
singleCellRef :: (RowIndex, ColumnIndex) -> CellRef
singleCellRef = CellRef . singleCellRefRaw
-- | Allow specifying whether a coordinate parameter is relative or absolute.
--
-- > singleCellRef' (Rel 5, Abs 1) == CellRef "$A5"
singleCellRef' :: CellCoord -> CellRef
singleCellRef' = CellRef . singleCellRefRaw'
singleCellRefRaw :: (RowIndex, ColumnIndex) -> Text
singleCellRefRaw (row, col) = T.concat [columnIndexToText col, rowIndexToText row]
singleCellRefRaw' :: CellCoord -> Text
singleCellRefRaw' (row, col) =
coord2col col <> coord2row row
-- | Converse function to 'singleCellRef'
-- Ignores a potential foreign sheet prefix.
fromSingleCellRef :: CellRef -> Maybe (RowIndex, ColumnIndex)
fromSingleCellRef = fromSingleCellRefRaw . unCellRef
-- | Converse function to 'singleCellRef\''
-- Ignores a potential foreign sheet prefix.
fromSingleCellRef' :: CellRef -> Maybe CellCoord
fromSingleCellRef' = fromSingleCellRefRaw' . unCellRef
fromSingleCellRefRaw :: Text -> Maybe (RowIndex, ColumnIndex)
fromSingleCellRefRaw =
fmap (first unRowCoord . second unColumnCoord) . fromSingleCellRefRaw'
fromSingleCellRefRaw' :: Text -> Maybe CellCoord
fromSingleCellRefRaw' t' = ignoreRefSheetName t' >>= \t -> do
let (isColAbsolute, remT) =
T.stripPrefix "$" t
& \remT' -> (isJust remT', fromMaybe t remT')
let (colT, rowExpr) = T.span (inRange ('A', 'Z')) remT
let (isRowAbsolute, rowT) =
T.stripPrefix "$" rowExpr
& \rowT' -> (isJust rowT', fromMaybe rowExpr rowT')
guard $ not (T.null colT) && not (T.null rowT) && T.all isDigit rowT
row <- decimal rowT
return $
bimap
(mkRowCoord isRowAbsolute)
(mkColumnCoord isColAbsolute)
(row, textToColumnIndex colT)
-- | Converse function to 'singleCellRef' expecting valid reference and failig with
-- a standard error message like /"Bad cell reference 'XXX'"/
fromSingleCellRefNoting :: CellRef -> (RowIndex, ColumnIndex)
fromSingleCellRefNoting ref = fromJustNote errMsg $ fromSingleCellRefRaw txt
where
txt = unCellRef ref
errMsg = "Bad cell reference '" ++ T.unpack txt ++ "'"
-- | Frame and escape the referenced sheet name in single quotes (apostrophe).
--
-- Sheet name in ST_Ref can be single-quoted when it contains non-alphanum class, non-ASCII range characters.
-- Intermediate squote characters are escaped in a doubled fashion:
-- "My ' Sheet" -> 'My '' Sheet'
escapeRefSheetName :: Text -> Text
escapeRefSheetName sheetName =
T.concat ["'", escape sheetName, "'"]
where
escape sn = T.splitOn "'" sn & T.intercalate "''"
-- | Unframe and unescape the referenced sheet name.
unEscapeRefSheetName :: Text -> Text
unEscapeRefSheetName = unescape . unFrame
where
unescape = T.intercalate "'" . T.splitOn "''"
unFrame sn = fromMaybe sn $ T.stripPrefix "'" sn >>= T.stripSuffix "'"
ignoreRefSheetName :: Text -> Maybe Text
ignoreRefSheetName t =
case T.split (== '!') t of
[_, r] -> Just r
[r] -> Just r
_ -> Nothing
-- | Render a single cell existing in another worksheet.
-- This function always renders the sheet name single-quoted regardless the presence of spaces.
-- A sheet name shouldn't contain @"[]*:?/\"@ chars and apostrophe @"'"@ should not happen at extremities.
--
-- > mkForeignRange "MyOtherSheet" (Rel 2, Rel 4) (Abs 6, Abs 8) == "'MyOtherSheet'!D2:$H$6"
mkForeignSingleCellRef :: Text -> CellCoord -> CellRef
mkForeignSingleCellRef sheetName coord =
let cr = singleCellRefRaw' coord
in CellRef $ T.concat [escapeRefSheetName sheetName, "!", cr]
-- | Converse function to 'mkForeignSingleCellRef'.
-- The provided CellRef must be a foreign range.
fromForeignSingleCellRef :: CellRef -> Maybe (Text, CellCoord)
fromForeignSingleCellRef r =
case T.split (== '!') (unCellRef r) of
[sheetName, ref] -> (unEscapeRefSheetName sheetName,) <$> fromSingleCellRefRaw' ref
_ -> Nothing
-- | Excel range (e.g. @D13:H14@), actually store as as 'CellRef' in
-- xlsx
type Range = CellRef
-- | Render range
--
-- > mkRange (RowIndex 2, ColumnIndex 4) (RowIndex 6, ColumnIndex 8) == CellRef "D2:H6"
mkRange :: (RowIndex, ColumnIndex) -> (RowIndex, ColumnIndex) -> Range
mkRange fr to = CellRef $ T.concat [singleCellRefRaw fr, ":", singleCellRefRaw to]
-- | Render range with possibly absolute coordinates
--
-- > mkRange' (Abs 2, Abs 4) (6, 8) == CellRef "$D$2:H6"
mkRange' :: (RowCoord,ColumnCoord) -> (RowCoord,ColumnCoord) -> Range
mkRange' fr to =
CellRef $ T.concat [singleCellRefRaw' fr, ":", singleCellRefRaw' to]
-- | Render a cell range existing in another worksheet.
-- This function always renders the sheet name single-quoted regardless the presence of spaces.
-- A sheet name shouldn't contain @"[]*:?/\"@ chars and apostrophe @"'"@ should not happen at extremities.
--
-- > mkForeignRange "MyOtherSheet" (Rel 2, Rel 4) (Abs 6, Abs 8) == "'MyOtherSheet'!D2:$H$6"
mkForeignRange :: Text -> CellCoord -> CellCoord -> Range
mkForeignRange sheetName fr to =
case mkRange' fr to of
CellRef cr -> CellRef $ T.concat [escapeRefSheetName sheetName, "!", cr]
-- | Converse function to 'mkRange' ignoring absolute coordinates.
-- Ignores a potential foreign sheet prefix.
fromRange :: Range -> Maybe ((RowIndex, ColumnIndex), (RowIndex, ColumnIndex))
fromRange r =
mapBoth (first unRowCoord . second unColumnCoord) <$> fromRange' r
-- | Converse function to 'mkRange\'' to handle possibly absolute coordinates.
-- Ignores a potential foreign sheet prefix.
fromRange' :: Range -> Maybe RangeCoord
fromRange' t' = parseRange =<< ignoreRefSheetName (unCellRef t')
where
parseRange t =
case T.split (== ':') t of
[from, to] -> liftA2 (,) (fromSingleCellRefRaw' from) (fromSingleCellRefRaw' to)
_ -> Nothing
-- | Converse function to 'mkForeignRange'.
-- The provided Range must be a foreign range.
fromForeignRange :: Range -> Maybe (Text, RangeCoord)
fromForeignRange r =
case T.split (== '!') (unCellRef r) of
[sheetName, ref] -> (unEscapeRefSheetName sheetName,) <$> fromRange' (CellRef ref)
_ -> Nothing
-- | A sequence of cell references
--
-- See 18.18.76 "ST_Sqref (Reference Sequence)" (p.2488)
newtype SqRef = SqRef [CellRef]
deriving (Eq, Ord, Show, Generic)
instance NFData SqRef
-- | Common type containing either simple string or rich formatted text.
-- Used in @si@, @comment@ and @is@ elements
--
-- E.g. @si@ spec says: "If the string is just a simple string with formatting applied
-- at the cell level, then the String Item (si) should contain a single text
-- element used to express the string. However, if the string in the cell is
-- more complex - i.e., has formatting applied at the character level - then the
-- string item shall consist of multiple rich text runs which collectively are
-- used to express the string.". So we have either a single "Text" field, or
-- else a list of "RichTextRun"s, each of which is some "Text" with layout
-- properties.
--
-- TODO: Currently we do not support @phoneticPr@ (Phonetic Properties, 18.4.3,
-- p. 1723) or @rPh@ (Phonetic Run, 18.4.6, p. 1725).
--
-- Section 18.4.8, "si (String Item)" (p. 1725)
--
-- See @CT_Rst@, p. 3903
data XlsxText = XlsxText Text
| XlsxRichText [RichTextRun]
deriving (Eq, Ord, Show, Generic)
instance NFData XlsxText
xlsxTextToCellValue :: XlsxText -> CellValue
xlsxTextToCellValue (XlsxText txt) = CellText txt
xlsxTextToCellValue (XlsxRichText rich) = CellRich rich
-- | A formula
--
-- See 18.18.35 "ST_Formula (Formula)" (p. 2457)
newtype Formula = Formula {unFormula :: Text}
deriving (Eq, Ord, Show, Generic)
instance NFData Formula
-- | Cell values include text, numbers and booleans,
-- standard includes date format also but actually dates
-- are represented by numbers with a date format assigned
-- to a cell containing it
-- Specification (ECMA-376):
-- - 18.3.1.4 c (Cell)
-- - 18.18.11 ST_CellType (Cell Type)
data CellValue
= CellText Text
| CellDouble Double
| CellBool Bool
| CellRich [RichTextRun]
| CellError ErrorType
deriving (Eq, Ord, Show, Generic)
instance NFData CellValue
-- | The evaluation of an expression can result in an error having one
-- of a number of error values.
--
-- See Annex L, L.2.16.8 "Error values" (p. 4764)
data ErrorType
= ErrorDiv0
-- ^ @#DIV/0!@ - Intended to indicate when any number, including
-- zero, is divided by zero.
| ErrorNA
-- ^ @#N/A@ - Intended to indicate when a designated value is not
-- available. For example, some functions, such as @SUMX2MY2@,
-- perform a series of operations on corresponding elements in two
-- arrays. If those arrays do not have the same number of elements,
-- then for some elements in the longer array, there are no
-- corresponding elements in the shorter one; that is, one or more
-- values in the shorter array are not available. This error value
-- can be produced by calling the function @NA@.
| ErrorName
-- ^ @#NAME?@ - Intended to indicate when what looks like a name is
-- used, but no such name has been defined. For example, @XYZ/3@,
-- where @XYZ@ is not a defined name. @Total is & A10@, where
-- neither @Total@ nor @is@ is a defined name. Presumably, @"Total
-- is " & A10@ was intended. @SUM(A1C10)@, where the range @A1:C10@
-- was intended.
| ErrorNull
-- ^ @#NULL!@ - Intended to indicate when two areas are required to
-- intersect, but do not. For example, In the case of @SUM(B1 C1)@,
-- the space between @B1@ and @C1@ is treated as the binary
-- intersection operator, when a comma was intended.
| ErrorNum
-- ^ @#NUM!@ - Intended to indicate when an argument to a function
-- has a compatible type, but has a value that is outside the domain
-- over which that function is defined. (This is known as a domain
-- error.) For example, Certain calls to @ASIN@, @ATANH@, @FACT@,
-- and @SQRT@ might result in domain errors. Intended to indicate
-- that the result of a function cannot be represented in a value of
-- the specified type, typically due to extreme magnitude. (This is
-- known as a range error.) For example, @FACT(1000)@ might result
-- in a range error.
| ErrorRef
-- ^ @#REF!@ - Intended to indicate when a cell reference is
-- invalid. For example, If a formula contains a reference to a
-- cell, and then the row or column containing that cell is deleted,
-- a @#REF!@ error results. If a worksheet does not support 20,001
-- columns, @OFFSET(A1,0,20000)@ results in a @#REF!@ error.
| ErrorValue
-- ^ @#VALUE!@ - Intended to indicate when an incompatible type
-- argument is passed to a function, or an incompatible type operand
-- is used with an operator. For example, In the case of a function
-- argument, a number was expected, but text was provided. In the
-- case of @1+"ABC"@, the binary addition operator is not defined for
-- text.
deriving (Eq, Ord, Show, Generic)
instance NFData ErrorType
-- | Specifies date base used for conversion of serial values to and
-- from datetime values
--
-- See Annex L, L.2.16.9.1 "Date Conversion for Serial Values" (p. 4765)
data DateBase
= DateBase1900
-- ^ 1900 date base system, the lower limit is January 1, -9999
-- 00:00:00, which has serial value -4346018. The upper-limit is
-- December 31, 9999, 23:59:59, which has serial value
-- 2,958,465.9999884. The base date for this date base system is
-- December 30, 1899, which has a serial value of 0.
| DateBase1904
-- ^ 1904 backward compatibility date-base system, the lower limit
-- is January 1, 1904, 00:00:00, which has serial value 0. The upper
-- limit is December 31, 9999, 23:59:59, which has serial value
-- 2,957,003.9999884. The base date for this date base system is
-- January 1, 1904, which has a serial value of 0.
deriving (Eq, Show, Generic)
instance NFData DateBase
baseDate :: DateBase -> Day
baseDate DateBase1900 = fromGregorian 1899 12 30
baseDate DateBase1904 = fromGregorian 1904 1 1
-- | Converts serial value into datetime according to the specified
-- date base. Because Excel treats 1900 as a leap year even though it isn't,
-- this function converts any numbers that represent some time in /1900-02-29/
-- in Excel to `UTCTime` /1900-03-01 00:00/.
-- See https://docs.microsoft.com/en-gb/office/troubleshoot/excel/wrongly-assumes-1900-is-leap-year for details.
--
-- > show (dateFromNumber DateBase1900 42929.75) == "2017-07-13 18:00:00 UTC"
-- > show (dateFromNumber DateBase1900 60) == "1900-03-01 00:00:00 UTC"
-- > show (dateFromNumber DateBase1900 61) == "1900-03-01 00:00:00 UTC"
dateFromNumber :: forall t. RealFrac t => DateBase -> t -> UTCTime
dateFromNumber b d
-- 60 is Excel's 2020-02-29 00:00 and 61 is Excel's 2020-03-01
| b == DateBase1900 && d < 60 = getUTCTime (d + 1)
| b == DateBase1900 && d >= 60 && d < 61 = getUTCTime (61 :: t)
| otherwise = getUTCTime d
where
getUTCTime n =
let
(numberOfDays, fractionOfOneDay) = properFraction n
day = addDays numberOfDays $ baseDate b
diffTime = picosecondsToDiffTime (round (fractionOfOneDay * 24*60*60*1E12))
in
UTCTime day diffTime
-- | Converts datetime into serial value.
-- Because Excel treats 1900 as a leap year even though it isn't,
-- the numbers that represent times in /1900-02-29/ in Excel, in the range /[60, 61[/,
-- are never generated by this function for `DateBase1900`. This means that
-- under those conditions this is not an inverse of `dateFromNumber`.
-- See https://docs.microsoft.com/en-gb/office/troubleshoot/excel/wrongly-assumes-1900-is-leap-year for details.
dateToNumber :: Fractional a => DateBase -> UTCTime -> a
dateToNumber b (UTCTime day diffTime) = numberOfDays + fractionOfOneDay
where
numberOfDays = fromIntegral (diffDays excel1900CorrectedDay $ baseDate b)
fractionOfOneDay = realToFrac diffTime / (24 * 60 * 60)
marchFirst1900 = fromGregorian 1900 3 1
excel1900CorrectedDay = if day < marchFirst1900
then addDays (-1) day
else day
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
-- | See @CT_Rst@, p. 3903
instance FromCursor XlsxText where
fromCursor cur = do
let
ts = cur $/ element (n_ "t") >=> contentOrEmpty
rs = cur $/ element (n_ "r") >=> fromCursor
case (ts,rs) of
([t], []) ->
return $ XlsxText t
([], _:_) ->
return $ XlsxRichText rs
_ ->
fail "invalid item"
instance FromXenoNode XlsxText where
fromXenoNode root = do
(mCh, rs) <-
collectChildren root $ (,) <$> maybeChild "t" <*> fromChildList "r"
mT <- mapM contentX mCh
case mT of
Just t -> return $ XlsxText t
Nothing ->
case rs of
[] -> Left $ "missing rich text subelements"
_ -> return $ XlsxRichText rs
instance FromAttrVal CellRef where
fromAttrVal = fmap (first CellRef) . fromAttrVal
instance FromAttrBs CellRef where
-- we presume that cell references contain only latin letters,
-- numbers and colon
fromAttrBs = pure . CellRef . T.decodeLatin1
instance FromAttrVal SqRef where
fromAttrVal t = do
rs <- mapM (fmap fst . fromAttrVal) $ T.split (== ' ') t
readSuccess $ SqRef rs
instance FromAttrBs SqRef where
fromAttrBs bs = do
-- split on space
rs <- forM (BS.split 32 bs) fromAttrBs
return $ SqRef rs
-- | See @ST_Formula@, p. 3873
instance FromCursor Formula where
fromCursor cur = [Formula . T.concat $ cur $/ content]
instance FromXenoNode Formula where
fromXenoNode = fmap Formula . contentX
instance FromAttrVal Formula where
fromAttrVal t = readSuccess $ Formula t
instance FromAttrBs Formula where
fromAttrBs = fmap Formula . fromAttrBs
instance FromAttrVal ErrorType where
fromAttrVal "#DIV/0!" = readSuccess ErrorDiv0
fromAttrVal "#N/A" = readSuccess ErrorNA
fromAttrVal "#NAME?" = readSuccess ErrorName
fromAttrVal "#NULL!" = readSuccess ErrorNull
fromAttrVal "#NUM!" = readSuccess ErrorNum
fromAttrVal "#REF!" = readSuccess ErrorRef
fromAttrVal "#VALUE!" = readSuccess ErrorValue
fromAttrVal t = invalidText "ErrorType" t
instance FromAttrBs ErrorType where
fromAttrBs "#DIV/0!" = return ErrorDiv0
fromAttrBs "#N/A" = return ErrorNA
fromAttrBs "#NAME?" = return ErrorName
fromAttrBs "#NULL!" = return ErrorNull
fromAttrBs "#NUM!" = return ErrorNum
fromAttrBs "#REF!" = return ErrorRef
fromAttrBs "#VALUE!" = return ErrorValue
fromAttrBs x = unexpectedAttrBs "ErrorType" x
{-------------------------------------------------------------------------------
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
}
instance ToAttrVal CellRef where
toAttrVal = toAttrVal . unCellRef
-- See 18.18.76, "ST_Sqref (Reference Sequence)", p. 2488.
instance ToAttrVal SqRef where
toAttrVal (SqRef refs) = T.intercalate " " $ map toAttrVal refs
-- | See @ST_Formula@, p. 3873
instance ToElement Formula where
toElement nm (Formula txt) = elementContent nm txt
instance ToAttrVal ErrorType where
toAttrVal ErrorDiv0 = "#DIV/0!"
toAttrVal ErrorNA = "#N/A"
toAttrVal ErrorName = "#NAME?"
toAttrVal ErrorNull = "#NULL!"
toAttrVal ErrorNum = "#NUM!"
toAttrVal ErrorRef = "#REF!"
toAttrVal ErrorValue = "#VALUE!"
#ifdef USE_MICROLENS
-- Since micro-lens denies the existence of prisms,
-- I pasted the splice that's generated from makePrisms,
-- then I copied over the definitions from Control.Lens for the prism
-- function as well.
-- Essentially this is doing the template haskell by hand.
type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
type Prism' s a = Prism s s a a
prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism bt seta = dimap seta (either pure (fmap bt)) . right'
_CellText :: Prism' CellValue Text
_CellText
= (prism (\ x1_a1ZQv -> CellText x1_a1ZQv))
(\ x_a1ZQw
-> case x_a1ZQw of
CellText y1_a1ZQx -> Right y1_a1ZQx
_ -> Left x_a1ZQw)
{-# INLINE _CellText #-}
_CellDouble :: Prism' CellValue Double
_CellDouble
= (prism (\ x1_a1ZQy -> CellDouble x1_a1ZQy))
(\ x_a1ZQz
-> case x_a1ZQz of
CellDouble y1_a1ZQA -> Right y1_a1ZQA
_ -> Left x_a1ZQz)
{-# INLINE _CellDouble #-}
_CellBool :: Prism' CellValue Bool
_CellBool
= (prism (\ x1_a1ZQB -> CellBool x1_a1ZQB))
(\ x_a1ZQC
-> case x_a1ZQC of
CellBool y1_a1ZQD -> Right y1_a1ZQD
_ -> Left x_a1ZQC)
{-# INLINE _CellBool #-}
_CellRich :: Prism' CellValue [RichTextRun]
_CellRich
= (prism (\ x1_a1ZQE -> CellRich x1_a1ZQE))
(\ x_a1ZQF
-> case x_a1ZQF of
CellRich y1_a1ZQG -> Right y1_a1ZQG
_ -> Left x_a1ZQF)
{-# INLINE _CellRich #-}
_CellError :: Prism' CellValue ErrorType
_CellError
= (prism (\ x1_a1ZQH -> CellError x1_a1ZQH))
(\ x_a1ZQI
-> case x_a1ZQI of
CellError y1_a1ZQJ -> Right y1_a1ZQJ
_ -> Left x_a1ZQI)
{-# INLINE _CellError #-}
_XlsxText :: Prism' XlsxText Text
_XlsxText
= (prism (\ x1_a1ZzU -> XlsxText x1_a1ZzU))
(\ x_a1ZzV
-> case x_a1ZzV of
XlsxText y1_a1ZzW -> Right y1_a1ZzW
_ -> Left x_a1ZzV)
{-# INLINE _XlsxText #-}
_XlsxRichText :: Prism' XlsxText [RichTextRun]
_XlsxRichText
= (prism (\ x1_a1ZzX -> XlsxRichText x1_a1ZzX))
(\ x_a1ZzY
-> case x_a1ZzY of
XlsxRichText y1_a1ZzZ -> Right y1_a1ZzZ
_ -> Left x_a1ZzY)
{-# INLINE _XlsxRichText #-}
#else
makePrisms ''XlsxText
makePrisms ''CellValue
#endif
xlsx-1.1.2.2/src/Codec/Xlsx/Types/ConditionalFormatting.hs 0000644 0000000 0000000 00000116627 14551273353 021564 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Codec.Xlsx.Types.ConditionalFormatting
( ConditionalFormatting
, CfRule(..)
, NStdDev(..)
, Inclusion(..)
, CfValue(..)
, MinCfValue(..)
, MaxCfValue(..)
, Condition(..)
, OperatorExpression(..)
, TimePeriod(..)
, IconSetOptions(..)
, IconSetType(..)
, DataBarOptions(..)
, dataBarWithColor
-- * Lenses
-- ** CfRule
, cfrCondition
, cfrDxfId
, cfrPriority
, cfrStopIfTrue
-- ** IconSetOptions
, isoIconSet
, isoValues
, isoReverse
, isoShowValue
-- ** DataBarOptions
, dboMaxLength
, dboMinLength
, dboShowValue
, dboMinimum
, dboMaximum
, dboColor
-- * Misc
, topCfPriority
) where
import Control.Arrow (first, right)
import Control.DeepSeq (NFData)
#ifdef USE_MICROLENS
import Lens.Micro.TH (makeLenses)
#else
import Control.Lens (makeLenses)
#endif
import Data.Bool (bool)
import Data.ByteString (ByteString)
import Data.Default
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Text.XML
import Text.XML.Cursor hiding (bool)
import qualified Xeno.DOM as Xeno
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Types.StyleSheet (Color)
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, Generic)
instance NFData OperatorExpression
-- | 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, Generic)
instance NFData TimePeriod
-- | Flag indicating whether the 'aboveAverage' and 'belowAverage'
-- criteria is inclusive of the average itself, or exclusive of that
-- value.
data Inclusion
= Inclusive
| Exclusive
deriving (Eq, Ord, Show, Generic)
instance NFData Inclusion
-- | The number of standard deviations to include above or below the
-- average in the conditional formatting rule.
newtype NStdDev =
NStdDev Int
deriving (Eq, Ord, Show, Generic)
instance NFData NStdDev
-- | 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 that are
-- above (or maybe equal to) the average for all values in the range.
= AboveAverage Inclusion (Maybe NStdDev)
-- | 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 highlights cells that are
-- below the average for all values in the range.
| BelowAverage Inclusion (Maybe NStdDev)
-- | This conditional formatting rule highlights cells whose
-- values fall in the bottom N percent bracket.
| BottomNPercent Int
-- | This conditional formatting rule highlights cells whose
-- values fall in the bottom N bracket.
| BottomNValues Int
-- | This conditional formatting rule compares a cell value
-- to a formula calculated result, using an operator.
| CellIs OperatorExpression
-- | This conditional formatting rule creates a gradated color
-- scale on the cells with specified colors for specified minimum
-- and maximum.
| ColorScale2 MinCfValue Color MaxCfValue Color
-- | This conditional formatting rule creates a gradated color
-- scale on the cells with specified colors for specified minimum,
-- midpoint and maximum.
| ColorScale3 MinCfValue Color CfValue Color MaxCfValue Color
-- | 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 displays a gradated data bar
-- in the range of cells.
| DataBar DataBarOptions
-- | 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 duplicated
-- values.
| DuplicateValues
-- | 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 applies icons to cells
-- according to their values.
| IconSet IconSetOptions
-- | 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
-- | This conditional formatting rule highlights cells whose
-- values fall in the top N percent bracket.
| TopNPercent Int
-- | This conditional formatting rule highlights cells whose
-- values fall in the top N bracket.
| TopNValues Int
-- | This conditional formatting rule highlights unique values in the range.
| UniqueValues
deriving (Eq, Ord, Show, Generic)
instance NFData Condition
-- | Describes the values of the interpolation points in a color
-- scale, data bar or icon set conditional formatting rules.
--
-- See 18.3.1.11 "cfvo (Conditional Format Value Object)" (p. 1604)
data CfValue
= CfValue Double
| CfPercent Double
| CfPercentile Double
| CfFormula Formula
deriving (Eq, Ord, Show, Generic)
instance NFData CfValue
data MinCfValue
= CfvMin
| MinCfValue CfValue
deriving (Eq, Ord, Show, Generic)
instance NFData MinCfValue
data MaxCfValue
= CfvMax
| MaxCfValue CfValue
deriving (Eq, Ord, Show, Generic)
instance NFData MaxCfValue
-- | internal type for (de)serialization
--
-- See 18.18.13 "ST_CfvoType (Conditional Format Value Object Type)" (p. 2445)
data CfvType =
CfvtFormula
-- ^ The minimum\/ midpoint \/ maximum value for the gradient is
-- determined by a formula.
| CfvtMax
-- ^ Indicates that the maximum value in the range shall be used as
-- the maximum value for the gradient.
| CfvtMin
-- ^ Indicates that the minimum value in the range shall be used as
-- the minimum value for the gradient.
| CfvtNum
-- ^ Indicates that the minimum \/ midpoint \/ maximum value for the
-- gradient is specified by a constant numeric value.
| CfvtPercent
-- ^ Value indicates a percentage between the minimum and maximum
-- values in the range shall be used as the minimum \/ midpoint \/
-- maximum value for the gradient.
| CfvtPercentile
-- ^ Value indicates a percentile ranking in the range shall be used
-- as the minimum \/ midpoint \/ maximum value for the gradient.
deriving (Eq, Ord, Show, Generic)
instance NFData CfvType
-- | Describes an icon set conditional formatting rule.
--
-- See 18.3.1.49 "iconSet (Icon Set)" (p. 1645)
data IconSetOptions = IconSetOptions
{ _isoIconSet :: IconSetType
-- ^ icon set used, default value is 'IconSet3Trafficlights1'
, _isoValues :: [CfValue]
-- ^ values describing per icon ranges
, _isoReverse :: Bool
-- ^ reverses the default order of the icons in the specified icon set
, _isoShowValue :: Bool
-- ^ indicates whether to show the values of the cells on which this
-- icon set is applied.
} deriving (Eq, Ord, Show, Generic)
instance NFData IconSetOptions
-- | Icon set type for conditional formatting. 'CfValue' fields
-- determine lower range bounds. I.e. @IconSet3Signs (CfPercent 0)
-- (CfPercent 33) (CfPercent 67)@ say that 1st icon will be shown for
-- values ranging from 0 to 33 percents, 2nd for 33 to 67 percent and
-- the 3rd one for values from 67 to 100 percent.
--
-- 18.18.42 "ST_IconSetType (Icon Set Type)" (p. 2463)
data IconSetType =
IconSet3Arrows -- CfValue CfValue CfValue
| IconSet3ArrowsGray -- CfValue CfValue CfValue
| IconSet3Flags -- CfValue CfValue CfValue
| IconSet3Signs -- CfValue CfValue CfValue
| IconSet3Symbols -- CfValue CfValue CfValue
| IconSet3Symbols2 -- CfValue CfValue CfValue
| IconSet3TrafficLights1 -- CfValue CfValue CfValue
| IconSet3TrafficLights2 -- CfValue CfValue CfValue
-- ^ 3 traffic lights icon set with thick black border.
| IconSet4Arrows -- CfValue CfValue CfValue CfValue
| IconSet4ArrowsGray -- CfValue CfValue CfValue CfValue
| IconSet4Rating -- CfValue CfValue CfValue CfValue
| IconSet4RedToBlack -- CfValue CfValue CfValue CfValue
| IconSet4TrafficLights -- CfValue CfValue CfValue CfValue
| IconSet5Arrows -- CfValue CfValue CfValue CfValue CfValue
| IconSet5ArrowsGray -- CfValue CfValue CfValue CfValue CfValue
| IconSet5Quarters -- CfValue CfValue CfValue CfValue CfValue
| IconSet5Rating -- CfValue CfValue CfValue CfValue CfValue
deriving (Eq, Ord, Show, Generic)
instance NFData IconSetType
-- | Describes a data bar conditional formatting rule.
--
-- See 18.3.1.28 "dataBar (Data Bar)" (p. 1621)
data DataBarOptions = DataBarOptions
{ _dboMaxLength :: Int
-- ^ The maximum length of the data bar, as a percentage of the cell
-- width.
, _dboMinLength :: Int
-- ^ The minimum length of the data bar, as a percentage of the cell
-- width.
, _dboShowValue :: Bool
-- ^ Indicates whether to show the values of the cells on which this
-- data bar is applied.
, _dboMinimum :: MinCfValue
, _dboMaximum :: MaxCfValue
, _dboColor :: Color
} deriving (Eq, Ord, Show, Generic)
instance NFData DataBarOptions
defaultDboMaxLength :: Int
defaultDboMaxLength = 90
defaultDboMinLength :: Int
defaultDboMinLength = 10
dataBarWithColor :: Color -> Condition
dataBarWithColor c =
DataBar
DataBarOptions
{ _dboMaxLength = defaultDboMaxLength
, _dboMinLength = defaultDboMinLength
, _dboShowValue = True
, _dboMinimum = CfvMin
, _dboMaximum = CfvMax
, _dboColor = c
}
-- | 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, Generic)
instance NFData CfRule
instance Default IconSetOptions where
def =
IconSetOptions
{ _isoIconSet = IconSet3TrafficLights1
, _isoValues = [CfPercent 0, CfPercent 33.33, CfPercent 66.67]
-- IconSet3TrafficLights1 (CfPercent 0) (CfPercent 33.33) (CfPercent 66.67)
, _isoReverse = False
, _isoShowValue = True
}
makeLenses ''CfRule
makeLenses ''IconSetOptions
makeLenses ''DataBarOptions
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 "aboveAverage" cur = do
above <- fromAttributeDef "aboveAverage" True cur
inclusion <- fromAttributeDef "equalAverage" Exclusive cur
nStdDev <- maybeAttribute "stdDev" cur
if above
then return $ AboveAverage inclusion nStdDev
else return $ BelowAverage inclusion nStdDev
readCondition "beginsWith" cur = do
txt <- fromAttribute "text" cur
return $ BeginsWith txt
readCondition "colorScale" cur = do
let cfvos = cur $/ element (n_ "colorScale") &/ element (n_ "cfvo") &| node
colors = cur $/ element (n_ "colorScale") &/ element (n_ "color") &| node
case (cfvos, colors) of
([n1, n2], [cn1, cn2]) -> do
mincfv <- fromCursor $ fromNode n1
minc <- fromCursor $ fromNode cn1
maxcfv <- fromCursor $ fromNode n2
maxc <- fromCursor $ fromNode cn2
return $ ColorScale2 mincfv minc maxcfv maxc
([n1, n2, n3], [cn1, cn2, cn3]) -> do
mincfv <- fromCursor $ fromNode n1
minc <- fromCursor $ fromNode cn1
midcfv <- fromCursor $ fromNode n2
midc <- fromCursor $ fromNode cn2
maxcfv <- fromCursor $ fromNode n3
maxc <- fromCursor $ fromNode cn3
return $ ColorScale3 mincfv minc midcfv midc maxcfv maxc
_ ->
error "Malformed colorScale condition"
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 "dataBar" cur = fmap DataBar $ cur $/ element (n_ "dataBar") >=> fromCursor
readCondition "duplicateValues" _ = return DuplicateValues
readCondition "endsWith" cur = do
txt <- fromAttribute "text" cur
return $ EndsWith txt
readCondition "expression" cur = do
formula <- cur $/ element (n_ "formula") >=> fromCursor
return $ Expression formula
readCondition "iconSet" cur = fmap IconSet $ cur $/ element (n_ "iconSet") >=> fromCursor
readCondition "notContainsBlanks" _ = return DoesNotContainBlanks
readCondition "notContainsErrors" _ = return DoesNotContainErrors
readCondition "notContainsText" cur = do
txt <- fromAttribute "text" cur
return $ DoesNotContainText txt
readCondition "timePeriod" cur = do
period <- fromAttribute "timePeriod" cur
return $ InTimePeriod period
readCondition "top10" cur = do
bottom <- fromAttributeDef "bottom" False cur
percent <- fromAttributeDef "percent" False cur
rank <- fromAttribute "rank" cur
case (bottom, percent) of
(True, True) -> return $ BottomNPercent rank
(True, False) -> return $ BottomNValues rank
(False, True) -> return $ TopNPercent rank
(False, False) -> return $ TopNValues rank
readCondition "uniqueValues" _ = return UniqueValues
readCondition t _ = error $ "Unexpected conditional formatting type " ++ show t
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 FromXenoNode CfRule where
fromXenoNode root = parseAttributes root $ do
_cfrDxfId <- maybeAttr "dxfId"
_cfrPriority <- fromAttr "priority"
_cfrStopIfTrue <- maybeAttr "stopIfTrue"
-- spec shows this attribute as optional but it's not clear why could
-- conditional formatting record be needed with no condition type set
cfType <- fromAttr "type"
_cfrCondition <- readConditionX cfType
return CfRule {..}
where
readConditionX ("aboveAverage" :: ByteString) = do
above <- fromAttrDef "aboveAverage" True
inclusion <- fromAttrDef "equalAverage" Exclusive
nStdDev <- maybeAttr "stdDev"
if above
then return $ AboveAverage inclusion nStdDev
else return $ BelowAverage inclusion nStdDev
readConditionX "beginsWith" = BeginsWith <$> fromAttr "text"
readConditionX "colorScale" = toAttrParser $ do
xs <- collectChildren root . maybeParse "colorScale" $ \node ->
collectChildren node $ (,) <$> childList "cfvo"
<*> childList "color"
case xs of
Just ([n1, n2], [cn1, cn2]) -> do
mincfv <- fromXenoNode n1
minc <- fromXenoNode cn1
maxcfv <- fromXenoNode n2
maxc <- fromXenoNode cn2
return $ ColorScale2 mincfv minc maxcfv maxc
Just ([n1, n2, n3], [cn1, cn2, cn3]) -> do
mincfv <- fromXenoNode n1
minc <- fromXenoNode cn1
midcfv <- fromXenoNode n2
midc <- fromXenoNode cn2
maxcfv <- fromXenoNode n3
maxc <- fromXenoNode cn3
return $ ColorScale3 mincfv minc midcfv midc maxcfv maxc
_ ->
Left "Malformed colorScale condition"
readConditionX "cellIs" = do
operator <- fromAttr "operator"
formulas <- toAttrParser . collectChildren root $ fromChildList "formula"
case (operator, formulas) of
("beginsWith" :: ByteString, [f]) -> return . CellIs $ OpBeginsWith f
("between", [f1, f2]) -> return . CellIs $ OpBetween f1 f2
("containsText", [f]) -> return . CellIs $ OpContainsText f
("endsWith", [f]) -> return . CellIs $ OpEndsWith f
("equal", [f]) -> return . CellIs $ OpEqual f
("greaterThan", [f]) -> return . CellIs $ OpGreaterThan f
("greaterThanOrEqual", [f]) -> return . CellIs $ OpGreaterThanOrEqual f
("lessThan", [f]) -> return . CellIs $ OpLessThan f
("lessThanOrEqual", [f]) -> return . CellIs $ OpLessThanOrEqual f
("notBetween", [f1, f2]) -> return . CellIs $ OpNotBetween f1 f2
("notContains", [f]) -> return . CellIs $ OpNotContains f
("notEqual", [f]) -> return . CellIs $ OpNotEqual f
_ -> toAttrParser $ Left "Bad cellIs rule"
readConditionX "containsBlanks" = return ContainsBlanks
readConditionX "containsErrors" = return ContainsErrors
readConditionX "containsText" = ContainsText <$> fromAttr "text"
readConditionX "dataBar" =
fmap DataBar . toAttrParser . collectChildren root $ fromChild "dataBar"
readConditionX "duplicateValues" = return DuplicateValues
readConditionX "endsWith" = EndsWith <$> fromAttr "text"
readConditionX "expression" =
fmap Expression . toAttrParser . collectChildren root $ fromChild "formula"
readConditionX "iconSet" =
fmap IconSet . toAttrParser . collectChildren root $ fromChild "iconSet"
readConditionX "notContainsBlanks" = return DoesNotContainBlanks
readConditionX "notContainsErrors" = return DoesNotContainErrors
readConditionX "notContainsText" =
DoesNotContainText <$> fromAttr "text"
readConditionX "timePeriod" = InTimePeriod <$> fromAttr "timePeriod"
readConditionX "top10" = do
bottom <- fromAttrDef "bottom" False
percent <- fromAttrDef "percent" False
rank <- fromAttr "rank"
case (bottom, percent) of
(True, True) -> return $ BottomNPercent rank
(True, False) -> return $ BottomNValues rank
(False, True) -> return $ TopNPercent rank
(False, False) -> return $ TopNValues rank
readConditionX "uniqueValues" = return UniqueValues
readConditionX x =
toAttrParser . Left $ "Unexpected conditional formatting type " <> T.pack (show x)
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
instance FromAttrBs TimePeriod where
fromAttrBs "last7Days" = return PerLast7Days
fromAttrBs "lastMonth" = return PerLastMonth
fromAttrBs "lastWeek" = return PerLastWeek
fromAttrBs "nextMonth" = return PerNextMonth
fromAttrBs "nextWeek" = return PerNextWeek
fromAttrBs "thisMonth" = return PerThisMonth
fromAttrBs "thisWeek" = return PerThisWeek
fromAttrBs "today" = return PerToday
fromAttrBs "tomorrow" = return PerTomorrow
fromAttrBs "yesterday" = return PerYesterday
fromAttrBs x = unexpectedAttrBs "TimePeriod" x
instance FromAttrVal CfvType where
fromAttrVal "num" = readSuccess CfvtNum
fromAttrVal "percent" = readSuccess CfvtPercent
fromAttrVal "max" = readSuccess CfvtMax
fromAttrVal "min" = readSuccess CfvtMin
fromAttrVal "formula" = readSuccess CfvtFormula
fromAttrVal "percentile" = readSuccess CfvtPercentile
fromAttrVal t = invalidText "CfvType" t
instance FromAttrBs CfvType where
fromAttrBs "num" = return CfvtNum
fromAttrBs "percent" = return CfvtPercent
fromAttrBs "max" = return CfvtMax
fromAttrBs "min" = return CfvtMin
fromAttrBs "formula" = return CfvtFormula
fromAttrBs "percentile" = return CfvtPercentile
fromAttrBs x = unexpectedAttrBs "CfvType" x
readCfValue :: (CfValue -> a) -> [a] -> [a] -> Cursor -> [a]
readCfValue f minVal maxVal c = do
vType <- fromAttribute "type" c
case vType of
CfvtNum -> do
v <- fromAttribute "val" c
return . f $ CfValue v
CfvtFormula -> do
v <- fromAttribute "val" c
return . f $ CfFormula v
CfvtPercent -> do
v <- fromAttribute "val" c
return . f $ CfPercent v
CfvtPercentile -> do
v <- fromAttribute "val" c
return . f $ CfPercentile v
CfvtMin -> minVal
CfvtMax -> maxVal
readCfValueX ::
(CfValue -> a)
-> Either Text a
-> Either Text a
-> Xeno.Node
-> Either Text a
readCfValueX f minVal maxVal root =
parseAttributes root $ do
vType <- fromAttr "type"
case vType of
CfvtNum -> do
v <- fromAttr "val"
return . f $ CfValue v
CfvtFormula -> do
v <- fromAttr "val"
return . f $ CfFormula v
CfvtPercent -> do
v <- fromAttr "val"
return . f $ CfPercent v
CfvtPercentile -> do
v <- fromAttr "val"
return . f $ CfPercentile v
CfvtMin -> toAttrParser minVal
CfvtMax -> toAttrParser maxVal
failMinCfvType :: [a]
failMinCfvType = fail "unexpected 'min' type"
failMinCfvTypeX :: Either Text a
failMinCfvTypeX = Left "unexpected 'min' type"
failMaxCfvType :: [a]
failMaxCfvType = fail "unexpected 'max' type"
failMaxCfvTypeX :: Either Text a
failMaxCfvTypeX = Left "unexpected 'max' type"
instance FromCursor CfValue where
fromCursor = readCfValue id failMinCfvType failMaxCfvType
instance FromXenoNode CfValue where
fromXenoNode root = readCfValueX id failMinCfvTypeX failMaxCfvTypeX root
instance FromCursor MinCfValue where
fromCursor = readCfValue MinCfValue (return CfvMin) failMaxCfvType
instance FromXenoNode MinCfValue where
fromXenoNode root =
readCfValueX MinCfValue (return CfvMin) failMaxCfvTypeX root
instance FromCursor MaxCfValue where
fromCursor = readCfValue MaxCfValue failMinCfvType (return CfvMax)
instance FromXenoNode MaxCfValue where
fromXenoNode root =
readCfValueX MaxCfValue failMinCfvTypeX (return CfvMax) root
defaultIconSet :: IconSetType
defaultIconSet = IconSet3TrafficLights1
instance FromCursor IconSetOptions where
fromCursor cur = do
_isoIconSet <- fromAttributeDef "iconSet" defaultIconSet cur
let _isoValues = cur $/ element (n_ "cfvo") >=> fromCursor
_isoReverse <- fromAttributeDef "reverse" False cur
_isoShowValue <- fromAttributeDef "showValue" True cur
return IconSetOptions {..}
instance FromXenoNode IconSetOptions where
fromXenoNode root = do
(_isoIconSet, _isoReverse, _isoShowValue) <-
parseAttributes root $ (,,) <$> fromAttrDef "iconSet" defaultIconSet
<*> fromAttrDef "reverse" False
<*> fromAttrDef "showValue" True
_isoValues <- collectChildren root $ fromChildList "cfvo"
return IconSetOptions {..}
instance FromAttrVal IconSetType where
fromAttrVal "3Arrows" = readSuccess IconSet3Arrows
fromAttrVal "3ArrowsGray" = readSuccess IconSet3ArrowsGray
fromAttrVal "3Flags" = readSuccess IconSet3Flags
fromAttrVal "3Signs" = readSuccess IconSet3Signs
fromAttrVal "3Symbols" = readSuccess IconSet3Symbols
fromAttrVal "3Symbols2" = readSuccess IconSet3Symbols2
fromAttrVal "3TrafficLights1" = readSuccess IconSet3TrafficLights1
fromAttrVal "3TrafficLights2" = readSuccess IconSet3TrafficLights2
fromAttrVal "4Arrows" = readSuccess IconSet4Arrows
fromAttrVal "4ArrowsGray" = readSuccess IconSet4ArrowsGray
fromAttrVal "4Rating" = readSuccess IconSet4Rating
fromAttrVal "4RedToBlack" = readSuccess IconSet4RedToBlack
fromAttrVal "4TrafficLights" = readSuccess IconSet4TrafficLights
fromAttrVal "5Arrows" = readSuccess IconSet5Arrows
fromAttrVal "5ArrowsGray" = readSuccess IconSet5ArrowsGray
fromAttrVal "5Quarters" = readSuccess IconSet5Quarters
fromAttrVal "5Rating" = readSuccess IconSet5Rating
fromAttrVal t = invalidText "IconSetType" t
instance FromAttrBs IconSetType where
fromAttrBs "3Arrows" = return IconSet3Arrows
fromAttrBs "3ArrowsGray" = return IconSet3ArrowsGray
fromAttrBs "3Flags" = return IconSet3Flags
fromAttrBs "3Signs" = return IconSet3Signs
fromAttrBs "3Symbols" = return IconSet3Symbols
fromAttrBs "3Symbols2" = return IconSet3Symbols2
fromAttrBs "3TrafficLights1" = return IconSet3TrafficLights1
fromAttrBs "3TrafficLights2" = return IconSet3TrafficLights2
fromAttrBs "4Arrows" = return IconSet4Arrows
fromAttrBs "4ArrowsGray" = return IconSet4ArrowsGray
fromAttrBs "4Rating" = return IconSet4Rating
fromAttrBs "4RedToBlack" = return IconSet4RedToBlack
fromAttrBs "4TrafficLights" = return IconSet4TrafficLights
fromAttrBs "5Arrows" = return IconSet5Arrows
fromAttrBs "5ArrowsGray" = return IconSet5ArrowsGray
fromAttrBs "5Quarters" = return IconSet5Quarters
fromAttrBs "5Rating" = return IconSet5Rating
fromAttrBs x = unexpectedAttrBs "IconSetType" x
instance FromCursor DataBarOptions where
fromCursor cur = do
_dboMaxLength <- fromAttributeDef "maxLength" defaultDboMaxLength cur
_dboMinLength <- fromAttributeDef "minLength" defaultDboMinLength cur
_dboShowValue <- fromAttributeDef "showValue" True cur
let cfvos = cur $/ element (n_ "cfvo") &| node
case cfvos of
[nMin, nMax] -> do
_dboMinimum <- fromCursor (fromNode nMin)
_dboMaximum <- fromCursor (fromNode nMax)
_dboColor <- cur $/ element (n_ "color") >=> fromCursor
return DataBarOptions{..}
ns -> do
fail $ "expected minimum and maximum cfvo nodes but see instead " ++
show (length ns) ++ " cfvo nodes"
instance FromXenoNode DataBarOptions where
fromXenoNode root = do
(_dboMaxLength, _dboMinLength, _dboShowValue) <-
parseAttributes root $ (,,) <$> fromAttrDef "maxLength" defaultDboMaxLength
<*> fromAttrDef "minLength" defaultDboMinLength
<*> fromAttrDef "showValue" True
(_dboMinimum, _dboMaximum, _dboColor) <-
collectChildren root $ (,,) <$> fromChild "cfvo"
<*> fromChild "cfvo"
<*> fromChild "color"
return DataBarOptions{..}
instance FromAttrVal Inclusion where
fromAttrVal = right (first $ bool Exclusive Inclusive) . fromAttrVal
instance FromAttrBs Inclusion where
fromAttrBs = fmap (bool Exclusive Inclusive) . fromAttrBs
instance FromAttrVal NStdDev where
fromAttrVal = right (first NStdDev) . fromAttrVal
instance FromAttrBs NStdDev where
fromAttrBs = fmap NStdDev . fromAttrBs
{-------------------------------------------------------------------------------
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 (AboveAverage i sDevs) =
("aboveAverage", M.fromList $ ["aboveAverage" .= True] ++
catMaybes [ "equalAverage" .=? justNonDef Exclusive i
, "stdDev" .=? sDevs], [])
conditionData (BeginsWith t) = ("beginsWith", M.fromList [ "text" .= t], [])
conditionData (BelowAverage i sDevs) =
("aboveAverage", M.fromList $ ["aboveAverage" .= False] ++
catMaybes [ "equalAverage" .=? justNonDef Exclusive i
, "stdDev" .=? sDevs], [])
conditionData (BottomNPercent n) = ("top10", M.fromList [ "bottom" .= True, "rank" .= n, "percent" .= True ], [])
conditionData (BottomNValues n) = ("top10", M.fromList [ "bottom" .= True, "rank" .= n ], [])
conditionData (CellIs opExpr) = ("cellIs", M.fromList [ "operator" .= op], formulas)
where (op, formulas) = operatorExpressionData opExpr
conditionData (ColorScale2 minv minc maxv maxc) =
( "colorScale"
, M.empty
, [ NodeElement $
elementListSimple
"colorScale"
[ toElement "cfvo" minv
, toElement "cfvo" maxv
, toElement "color" minc
, toElement "color" maxc
]
])
conditionData (ColorScale3 minv minc midv midc maxv maxc) =
( "colorScale"
, M.empty
, [ NodeElement $
elementListSimple
"colorScale"
[ toElement "cfvo" minv
, toElement "cfvo" midv
, toElement "cfvo" maxv
, toElement "color" minc
, toElement "color" midc
, toElement "color" maxc
]
])
conditionData ContainsBlanks = ("containsBlanks", M.empty, [])
conditionData ContainsErrors = ("containsErrors", M.empty, [])
conditionData (ContainsText t) = ("containsText", M.fromList [ "text" .= t], [])
conditionData (DataBar dbOpts) = ("dataBar", M.empty, [toNode "dataBar" dbOpts])
conditionData DoesNotContainBlanks = ("notContainsBlanks", M.empty, [])
conditionData DoesNotContainErrors = ("notContainsErrors", M.empty, [])
conditionData (DoesNotContainText t) = ("notContainsText", M.fromList [ "text" .= t], [])
conditionData DuplicateValues = ("duplicateValues", M.empty, [])
conditionData (EndsWith t) = ("endsWith", M.fromList [ "text" .= t], [])
conditionData (Expression formula) = ("expression", M.empty, [formulaNode formula])
conditionData (InTimePeriod period) = ("timePeriod", M.fromList [ "timePeriod" .= period ], [])
conditionData (IconSet isOptions) = ("iconSet", M.empty, [toNode "iconSet" isOptions])
conditionData (TopNPercent n) = ("top10", M.fromList [ "rank" .= n, "percent" .= True ], [])
conditionData (TopNValues n) = ("top10", M.fromList [ "rank" .= n ], [])
conditionData UniqueValues = ("uniqueValues", M.empty, [])
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])
instance ToElement MinCfValue where
toElement nm CfvMin = leafElement nm ["type" .= CfvtMin]
toElement nm (MinCfValue cfv) = toElement nm cfv
instance ToElement MaxCfValue where
toElement nm CfvMax = leafElement nm ["type" .= CfvtMax]
toElement nm (MaxCfValue cfv) = toElement nm cfv
instance ToElement CfValue where
toElement nm (CfValue v) = leafElement nm ["type" .= CfvtNum, "val" .= v]
toElement nm (CfPercent v) =
leafElement nm ["type" .= CfvtPercent, "val" .= v]
toElement nm (CfPercentile v) =
leafElement nm ["type" .= CfvtPercentile, "val" .= v]
toElement nm (CfFormula f) =
leafElement nm ["type" .= CfvtFormula, "val" .= unFormula f]
instance ToAttrVal CfvType where
toAttrVal CfvtNum = "num"
toAttrVal CfvtPercent = "percent"
toAttrVal CfvtMax = "max"
toAttrVal CfvtMin = "min"
toAttrVal CfvtFormula = "formula"
toAttrVal CfvtPercentile = "percentile"
instance ToElement IconSetOptions where
toElement nm IconSetOptions {..} =
elementList nm attrs $ map (toElement "cfvo") _isoValues
where
attrs = catMaybes
[ "iconSet" .=? justNonDef defaultIconSet _isoIconSet
, "reverse" .=? justTrue _isoReverse
, "showValue" .=? justFalse _isoShowValue
]
instance ToAttrVal IconSetType where
toAttrVal IconSet3Arrows = "3Arrows"
toAttrVal IconSet3ArrowsGray = "3ArrowsGray"
toAttrVal IconSet3Flags = "3Flags"
toAttrVal IconSet3Signs = "3Signs"
toAttrVal IconSet3Symbols = "3Symbols"
toAttrVal IconSet3Symbols2 = "3Symbols2"
toAttrVal IconSet3TrafficLights1 = "3TrafficLights1"
toAttrVal IconSet3TrafficLights2 = "3TrafficLights2"
toAttrVal IconSet4Arrows = "4Arrows"
toAttrVal IconSet4ArrowsGray = "4ArrowsGray"
toAttrVal IconSet4Rating = "4Rating"
toAttrVal IconSet4RedToBlack = "4RedToBlack"
toAttrVal IconSet4TrafficLights = "4TrafficLights"
toAttrVal IconSet5Arrows = "5Arrows"
toAttrVal IconSet5ArrowsGray = "5ArrowsGray"
toAttrVal IconSet5Quarters = "5Quarters"
toAttrVal IconSet5Rating = "5Rating"
instance ToElement DataBarOptions where
toElement nm DataBarOptions {..} = elementList nm attrs elements
where
attrs = catMaybes
[ "maxLength" .=? justNonDef defaultDboMaxLength _dboMaxLength
, "minLength" .=? justNonDef defaultDboMinLength _dboMinLength
, "showValue" .=? justFalse _dboShowValue
]
elements =
[ toElement "cfvo" _dboMinimum
, toElement "cfvo" _dboMaximum
, toElement "color" _dboColor
]
toNode :: ToElement a => Name -> a -> Node
toNode nm = NodeElement . toElement nm
formulaNode :: Formula -> Node
formulaNode = toNode "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"
instance ToAttrVal Inclusion where
toAttrVal = toAttrVal . (== Inclusive)
instance ToAttrVal NStdDev where
toAttrVal (NStdDev n) = toAttrVal n
xlsx-1.1.2.2/src/Codec/Xlsx/Types/DataValidation.hs 0000644 0000000 0000000 00000037127 14551273353 020147 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Codec.Xlsx.Types.DataValidation
( ValidationExpression(..)
, ValidationType(..)
, dvAllowBlank
, dvError
, dvErrorStyle
, dvErrorTitle
, dvPrompt
, dvPromptTitle
, dvShowDropDown
, dvShowErrorMessage
, dvShowInputMessage
, dvValidationType
, ErrorStyle(..)
, DataValidation(..)
, ListOrRangeExpression(..)
, ValidationList
, maybePlainValidationList
, maybeValidationRange
, readValidationType
, readListFormulas
, readOpExpression2
, readValidationTypeOpExp
, readValExpression
, viewValidationExpression
) where
import Control.Applicative ((<|>))
import Control.DeepSeq (NFData)
#ifdef USE_MICROLENS
import Lens.Micro.TH (makeLenses)
#else
import Control.Lens.TH (makeLenses)
#endif
import Control.Monad ((>=>), guard)
import Data.ByteString (ByteString)
import Data.Char (isSpace)
import Data.Default
import qualified Data.Map as M
import Data.Maybe (catMaybes, maybeToList)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Text.XML (Element(..), Node(..))
import Text.XML.Cursor (Cursor, ($/), element)
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Writer.Internal
-- See 18.18.20 "ST_DataValidationOperator (Data Validation Operator)" (p. 2439/2449)
data ValidationExpression
= ValBetween Formula Formula -- ^ "Between" operator
| ValEqual Formula -- ^ "Equal to" operator
| ValGreaterThan Formula -- ^ "Greater than" operator
| ValGreaterThanOrEqual Formula -- ^ "Greater than or equal to" operator
| ValLessThan Formula -- ^ "Less than" operator
| ValLessThanOrEqual Formula -- ^ "Less than or equal to" operator
| ValNotBetween Formula Formula -- ^ "Not between" operator
| ValNotEqual Formula -- ^ "Not equal to" operator
deriving (Eq, Show, Generic)
instance NFData ValidationExpression
-- See 18.18.21 "ST_DataValidationType (Data Validation Type)" (p. 2440/2450)
data ValidationType
= ValidationTypeNone
| ValidationTypeCustom Formula
| ValidationTypeDate ValidationExpression
| ValidationTypeDecimal ValidationExpression
| ValidationTypeList ListOrRangeExpression
| ValidationTypeTextLength ValidationExpression
| ValidationTypeTime ValidationExpression
| ValidationTypeWhole ValidationExpression
deriving (Eq, Show, Generic)
instance NFData ValidationType
type ValidationList = [Text]
data ListOrRangeExpression
= ListExpression ValidationList -- ^ a plain list of elements
| RangeExpression Range -- ^ a cell or range reference
deriving (Eq, Show, Generic)
instance NFData ListOrRangeExpression
-- See 18.18.18 "ST_DataValidationErrorStyle (Data Validation Error Styles)" (p. 2438/2448)
data ErrorStyle
= ErrorStyleInformation
| ErrorStyleStop
| ErrorStyleWarning
deriving (Eq, Show, Generic)
instance NFData ErrorStyle
-- See 18.3.1.32 "dataValidation (Data Validation)" (p. 1614/1624)
data DataValidation = DataValidation
{ _dvAllowBlank :: Bool
, _dvError :: Maybe Text
, _dvErrorStyle :: ErrorStyle
, _dvErrorTitle :: Maybe Text
, _dvPrompt :: Maybe Text
, _dvPromptTitle :: Maybe Text
, _dvShowDropDown :: Bool
, _dvShowErrorMessage :: Bool
, _dvShowInputMessage :: Bool
, _dvValidationType :: ValidationType
} deriving (Eq, Show, Generic)
instance NFData DataValidation
makeLenses ''DataValidation
instance Default DataValidation where
def = DataValidation
False Nothing ErrorStyleStop Nothing Nothing Nothing False False False ValidationTypeNone
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
instance FromAttrVal ErrorStyle where
fromAttrVal "information" = readSuccess ErrorStyleInformation
fromAttrVal "stop" = readSuccess ErrorStyleStop
fromAttrVal "warning" = readSuccess ErrorStyleWarning
fromAttrVal t = invalidText "ErrorStyle" t
instance FromAttrBs ErrorStyle where
fromAttrBs "information" = return ErrorStyleInformation
fromAttrBs "stop" = return ErrorStyleStop
fromAttrBs "warning" = return ErrorStyleWarning
fromAttrBs x = unexpectedAttrBs "ErrorStyle" x
instance FromCursor DataValidation where
fromCursor cur = do
_dvAllowBlank <- fromAttributeDef "allowBlank" False cur
_dvError <- maybeAttribute "error" cur
_dvErrorStyle <- fromAttributeDef "errorStyle" ErrorStyleStop cur
_dvErrorTitle <- maybeAttribute "errorTitle" cur
mop <- fromAttributeDef "operator" "between" cur
_dvPrompt <- maybeAttribute "prompt" cur
_dvPromptTitle <- maybeAttribute "promptTitle" cur
_dvShowDropDown <- fromAttributeDef "showDropDown" False cur
_dvShowErrorMessage <- fromAttributeDef "showErrorMessage" False cur
_dvShowInputMessage <- fromAttributeDef "showInputMessage" False cur
mtype <- fromAttributeDef "type" "none" cur
_dvValidationType <- readValidationType mop mtype cur
return DataValidation{..}
instance FromXenoNode DataValidation where
fromXenoNode root = do
(op, atype, genDV) <- parseAttributes root $ do
_dvAllowBlank <- fromAttrDef "allowBlank" False
_dvError <- maybeAttr "error"
_dvErrorStyle <- fromAttrDef "errorStyle" ErrorStyleStop
_dvErrorTitle <- maybeAttr "errorTitle"
_dvPrompt <- maybeAttr "prompt"
_dvPromptTitle <- maybeAttr "promptTitle"
_dvShowDropDown <- fromAttrDef "showDropDown" False
_dvShowErrorMessage <- fromAttrDef "showErrorMessage" False
_dvShowInputMessage <- fromAttrDef "showInputMessage" False
op <- fromAttrDef "operator" "between"
typ <- fromAttrDef "type" "none"
return (op, typ, \_dvValidationType -> DataValidation {..})
valType <- parseValidationType op atype
return $ genDV valType
where
parseValidationType :: ByteString -> ByteString -> Either Text ValidationType
parseValidationType op atype =
case atype of
"none" -> return ValidationTypeNone
"custom" ->
ValidationTypeCustom <$> formula1
"list" -> do
f <- formula1
case readListFormulas f of
Nothing -> Left "validation of type \"list\" with empty formula list"
Just fs -> return $ ValidationTypeList fs
"date" ->
ValidationTypeDate <$> readOpExpression op
"decimal" ->
ValidationTypeDecimal <$> readOpExpression op
"textLength" ->
ValidationTypeTextLength <$> readOpExpression op
"time" ->
ValidationTypeTime <$> readOpExpression op
"whole" ->
ValidationTypeWhole <$> readOpExpression op
unexpected ->
Left $ "unexpected type of data validation " <> T.pack (show unexpected)
readOpExpression "between" = uncurry ValBetween <$> formulaPair
readOpExpression "notBetween" = uncurry ValNotBetween <$> formulaPair
readOpExpression "equal" = ValEqual <$> formula1
readOpExpression "greaterThan" = ValGreaterThan <$> formula1
readOpExpression "greaterThanOrEqual" = ValGreaterThanOrEqual <$> formula1
readOpExpression "lessThan" = ValLessThan <$> formula1
readOpExpression "lessThanOrEqual" = ValLessThanOrEqual <$> formula1
readOpExpression "notEqual" = ValNotEqual <$> formula1
readOpExpression op = Left $ "data validation, unexpected operator " <> T.pack (show op)
formula1 = collectChildren root $ fromChild "formula1"
formulaPair =
collectChildren root $ (,) <$> fromChild "formula1" <*> fromChild "formula2"
readValidationType :: Text -> Text -> Cursor -> [ValidationType]
readValidationType _ "none" _ = return ValidationTypeNone
readValidationType _ "custom" cur = do
f <- fromCursor cur
return $ ValidationTypeCustom f
readValidationType _ "list" cur = do
f <- cur $/ element (n_ "formula1") >=> fromCursor
as <- maybeToList $ readListFormulas f
return $ ValidationTypeList as
readValidationType op ty cur = do
opExp <- readOpExpression2 op cur
readValidationTypeOpExp ty opExp
-- | Attempt to obtain a plain list expression
maybePlainValidationList :: ValidationType -> Maybe ValidationList
maybePlainValidationList (ValidationTypeList (ListExpression le)) = Just le
maybePlainValidationList _ = Nothing
-- | Attempt to obtain a range expression
maybeValidationRange :: ValidationType -> Maybe Range
maybeValidationRange (ValidationTypeList (RangeExpression re)) = Just re
maybeValidationRange _ = Nothing
readListFormulas :: Formula -> Maybe ListOrRangeExpression
readListFormulas (Formula f) = readQuotedList f <|> readUnquotedCellRange f
where
readQuotedList t
| Just t' <- T.stripPrefix "\"" (T.dropAround isSpace t)
, Just t'' <- T.stripSuffix "\"" t'
= Just . ListExpression $ map (T.dropAround isSpace) $ T.splitOn "," t''
| otherwise = Nothing
readUnquotedCellRange t =
-- a CellRef expression of a range (this is not validated beyond the absence of quotes)
-- note that the foreign sheet name can be 'single-quoted'
let stripped = T.dropAround isSpace t
in RangeExpression (CellRef stripped) <$ guard (not (T.null stripped))
-- This parser expects a comma-separated list surrounded by quotation marks.
-- Spaces around the quotation marks and commas are removed, but inner spaces
-- are kept.
--
-- The parser seems to be consistent with how Excel treats list formulas, but
-- I wasn't able to find a specification of the format.
--
-- Addendum: undescriminately designates an actual list or a cell range.
-- For a cell range validation, instead of a quoted list, it's an unquoted CellRef-like contents of the form:
-- ActualSheetName!$C$2:$C$18
readOpExpression2 :: Text -> Cursor -> [ValidationExpression]
readOpExpression2 op cur
| op `elem` ["between", "notBetween"] = do
f1 <- cur $/ element (n_ "formula1") >=> fromCursor
f2 <- cur $/ element (n_ "formula2") >=> fromCursor
readValExpression op [f1,f2]
readOpExpression2 op cur = do
f <- cur $/ element (n_ "formula1") >=> fromCursor
readValExpression op [f]
readValidationTypeOpExp :: Text -> ValidationExpression -> [ValidationType]
readValidationTypeOpExp "date" oe = [ValidationTypeDate oe]
readValidationTypeOpExp "decimal" oe = [ValidationTypeDecimal oe]
readValidationTypeOpExp "textLength" oe = [ValidationTypeTextLength oe]
readValidationTypeOpExp "time" oe = [ValidationTypeTime oe]
readValidationTypeOpExp "whole" oe = [ValidationTypeWhole oe]
readValidationTypeOpExp _ _ = []
readValExpression :: Text -> [Formula] -> [ValidationExpression]
readValExpression "between" [f1, f2] = [ValBetween f1 f2]
readValExpression "equal" [f] = [ValEqual f]
readValExpression "greaterThan" [f] = [ValGreaterThan f]
readValExpression "greaterThanOrEqual" [f] = [ValGreaterThanOrEqual f]
readValExpression "lessThan" [f] = [ValLessThan f]
readValExpression "lessThanOrEqual" [f] = [ValLessThanOrEqual f]
readValExpression "notBetween" [f1, f2] = [ValNotBetween f1 f2]
readValExpression "notEqual" [f] = [ValNotEqual f]
readValExpression _ _ = []
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
instance ToAttrVal ValidationType where
toAttrVal ValidationTypeNone = "none"
toAttrVal (ValidationTypeCustom _) = "custom"
toAttrVal (ValidationTypeDate _) = "date"
toAttrVal (ValidationTypeDecimal _) = "decimal"
toAttrVal (ValidationTypeList _) = "list"
toAttrVal (ValidationTypeTextLength _) = "textLength"
toAttrVal (ValidationTypeTime _) = "time"
toAttrVal (ValidationTypeWhole _) = "whole"
instance ToAttrVal ErrorStyle where
toAttrVal ErrorStyleInformation = "information"
toAttrVal ErrorStyleStop = "stop"
toAttrVal ErrorStyleWarning = "warning"
instance ToElement DataValidation where
toElement nm DataValidation{..} = Element
{ elementName = nm
, elementAttributes = M.fromList . catMaybes $
[ Just $ "allowBlank" .= _dvAllowBlank
, "error" .=? _dvError
, Just $ "errorStyle" .= _dvErrorStyle
, "errorTitle" .=? _dvErrorTitle
, "operator" .=? op
, "prompt" .=? _dvPrompt
, "promptTitle" .=? _dvPromptTitle
, Just $ "showDropDown" .= _dvShowDropDown
, Just $ "showErrorMessage" .= _dvShowErrorMessage
, Just $ "showInputMessage" .= _dvShowInputMessage
, Just $ "type" .= _dvValidationType
]
, elementNodes = catMaybes
[ fmap (NodeElement . toElement "formula1") f1
, fmap (NodeElement . toElement "formula2") f2
]
}
where
opExp (o,f1',f2') = (Just o, Just f1', f2')
op :: Maybe Text
f1,f2 :: Maybe Formula
(op,f1,f2) = case _dvValidationType of
ValidationTypeNone -> (Nothing, Nothing, Nothing)
ValidationTypeCustom f -> (Nothing, Just f, Nothing)
ValidationTypeDate f -> opExp $ viewValidationExpression f
ValidationTypeDecimal f -> opExp $ viewValidationExpression f
ValidationTypeTextLength f -> opExp $ viewValidationExpression f
ValidationTypeTime f -> opExp $ viewValidationExpression f
ValidationTypeWhole f -> opExp $ viewValidationExpression f
ValidationTypeList as ->
let renderPlainList l =
let csvFy xs = T.intercalate "," xs
reQuote x = '"' `T.cons` x `T.snoc` '"'
in reQuote (csvFy l)
f = Formula $
case as of
RangeExpression re -> unCellRef re
ListExpression le -> renderPlainList le
in (Nothing, Just f, Nothing)
viewValidationExpression :: ValidationExpression -> (Text, Formula, Maybe Formula)
viewValidationExpression (ValBetween f1 f2) = ("between", f1, Just f2)
viewValidationExpression (ValEqual f) = ("equal", f, Nothing)
viewValidationExpression (ValGreaterThan f) = ("greaterThan", f, Nothing)
viewValidationExpression (ValGreaterThanOrEqual f) = ("greaterThanOrEqual", f, Nothing)
viewValidationExpression (ValLessThan f) = ("lessThan", f, Nothing)
viewValidationExpression (ValLessThanOrEqual f) = ("lessThanOrEqual", f, Nothing)
viewValidationExpression (ValNotBetween f1 f2) = ("notBetween", f1, Just f2)
viewValidationExpression (ValNotEqual f) = ("notEqual", f, Nothing)
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Drawing.hs 0000644 0000000 0000000 00000043144 14551273353 016652 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Drawing where
import Control.Arrow (first)
import Control.DeepSeq (NFData)
#ifdef USE_MICROLENS
import Lens.Micro.TH (makeLenses)
#else
import Control.Lens.TH
#endif
import Data.ByteString.Lazy (ByteString)
import Data.Default
import qualified Data.Map as M
import Data.Maybe (catMaybes, listToMaybe, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Drawing.Chart
import Codec.Xlsx.Types.Drawing.Common
import Codec.Xlsx.Types.Internal
import Codec.Xlsx.Types.Internal.Relationships
import Codec.Xlsx.Writer.Internal
-- | information about image file as a par of a drawing
data FileInfo = FileInfo
{ _fiFilename :: FilePath
-- ^ image filename, images are assumed to be stored under path "xl\/media\/"
, _fiContentType :: Text
-- ^ image content type, ECMA-376 advises to use "image\/png" or "image\/jpeg"
-- if interoperability is wanted
, _fiContents :: ByteString
-- ^ image file contents
} deriving (Eq, Show, Generic)
instance NFData FileInfo
data Marker = Marker
{ _mrkCol :: Int
, _mrkColOff :: Coordinate
, _mrkRow :: Int
, _mrkRowOff :: Coordinate
} deriving (Eq, Show, Generic)
instance NFData Marker
unqMarker :: (Int, Int) -> (Int, Int) -> Marker
unqMarker (col, colOff) (row, rowOff) =
Marker col (UnqCoordinate colOff) row (UnqCoordinate rowOff)
data EditAs
= EditAsTwoCell
| EditAsOneCell
| EditAsAbsolute
deriving (Eq, Show, Generic)
instance NFData EditAs
data Anchoring
= AbsoluteAnchor
{ absaPos :: Point2D
, absaExt :: PositiveSize2D
}
| OneCellAnchor
{ onecaFrom :: Marker
, onecaExt :: PositiveSize2D
}
| TwoCellAnchor
{ tcaFrom :: Marker
, tcaTo :: Marker
, tcaEditAs :: EditAs
}
deriving (Eq, Show, Generic)
instance NFData Anchoring
data DrawingObject p g
= Picture { _picMacro :: Maybe Text
, _picPublished :: Bool
, _picNonVisual :: PicNonVisual
, _picBlipFill :: BlipFillProperties p
, _picShapeProperties :: ShapeProperties
-- TODO: style
}
| Graphic { _grNonVisual :: GraphNonVisual
, _grChartSpace :: g
, _grTransform :: Transform2D}
-- TODO: sp, grpSp, graphicFrame, cxnSp, contentPart
deriving (Eq, Show, Generic)
instance (NFData p, NFData g) => NFData (DrawingObject p g)
-- | basic function to create picture drawing object
--
-- /Note:/ specification says that drawing element ids need to be
-- unique within 1 document, otherwise /...document shall be
-- considered non-conformant/.
picture :: DrawingElementId -> FileInfo -> DrawingObject FileInfo c
picture dId fi =
Picture
{ _picMacro = Nothing
, _picPublished = False
, _picNonVisual = nonVis
, _picBlipFill = bfProps
, _picShapeProperties = shProps
}
where
nonVis =
PicNonVisual $
NonVisualDrawingProperties
{ _nvdpId = dId
, _nvdpName = T.pack $ _fiFilename fi
, _nvdpDescription = Nothing
, _nvdpHidden = False
, _nvdpTitle = Nothing
}
bfProps =
BlipFillProperties
{_bfpImageInfo = Just fi, _bfpFillMode = Just FillStretch}
shProps =
ShapeProperties
{ _spXfrm = Nothing
, _spGeometry = Nothing
, _spFill = Just NoFill
, _spOutline = Just $ def {_lnFill = Just NoFill}
}
-- | helper to retrive information about all picture files in
-- particular drawing alongside with their anchorings (i.e. sizes and
-- positions)
extractPictures :: Drawing -> [(Anchoring, FileInfo)]
extractPictures dr = mapMaybe maybePictureInfo $ _xdrAnchors dr
where
maybePictureInfo Anchor {..} =
case _anchObject of
Picture {..} -> (_anchAnchoring,) <$> _bfpImageInfo _picBlipFill
_ -> Nothing
-- | This element is used to set certain properties related to a drawing
-- element on the client spreadsheet application.
--
-- see 20.5.2.3 "clientData (Client Data)" (p. 3156)
data ClientData = ClientData
{ _cldLcksWithSheet :: Bool
-- ^ This attribute indicates whether to disable selection on
-- drawing elements when the sheet is protected.
, _cldPrintsWithSheet :: Bool
-- ^ This attribute indicates whether to print drawing elements
-- when printing the sheet.
} deriving (Eq, Show, Generic)
instance NFData ClientData
data PicNonVisual = PicNonVisual
{ _pnvDrawingProps :: NonVisualDrawingProperties
-- TODO: cNvPicPr
} deriving (Eq, Show, Generic)
instance NFData PicNonVisual
data GraphNonVisual = GraphNonVisual
{ _gnvDrawingProps :: NonVisualDrawingProperties
-- TODO cNvGraphicFramePr
} deriving (Eq, Show, Generic)
instance NFData GraphNonVisual
newtype DrawingElementId = DrawingElementId
{ unDrawingElementId :: Int
} deriving (Eq, Show, Generic)
instance NFData DrawingElementId
-- see 20.1.2.2.8 "cNvPr (Non-Visual Drawing Properties)" (p. 2731)
data NonVisualDrawingProperties = NonVisualDrawingProperties
{ _nvdpId :: DrawingElementId
-- ^ Specifies a unique identifier for the current
-- DrawingML object within the current
--
-- TODO: make ids internal and consistent by construction
, _nvdpName :: Text
-- ^ Specifies the name of the object.
-- Typically, this is used to store the original file
-- name of a picture object.
, _nvdpDescription :: Maybe Text
-- ^ Alternative Text for Object
, _nvdpHidden :: Bool
, _nvdpTitle :: Maybe Text
} deriving (Eq, Show, Generic)
instance NFData NonVisualDrawingProperties
data BlipFillProperties a = BlipFillProperties
{ _bfpImageInfo :: Maybe a
, _bfpFillMode :: Maybe FillMode
-- TODO: dpi, rotWithShape, srcRect
} deriving (Eq, Show, Generic)
instance NFData a => NFData (BlipFillProperties a)
-- see @a_EG_FillModeProperties@ (p. 4319)
data FillMode
-- See 20.1.8.58 "tile (Tile)" (p. 2880)
= FillTile -- TODO: tx, ty, sx, sy, flip, algn
-- See 20.1.8.56 "stretch (Stretch)" (p. 2879)
| FillStretch -- TODO: srcRect
deriving (Eq, Show, Generic)
instance NFData FillMode
-- See @EG_Anchor@ (p. 4052)
data Anchor p g = Anchor
{ _anchAnchoring :: Anchoring
, _anchObject :: DrawingObject p g
, _anchClientData :: ClientData
} deriving (Eq, Show, Generic)
instance (NFData p, NFData g) => NFData (Anchor p g)
data GenericDrawing p g = Drawing
{ _xdrAnchors :: [Anchor p g]
} deriving (Eq, Show, Generic)
instance (NFData p, NFData g) => NFData (GenericDrawing p g)
-- See 20.5.2.35 "wsDr (Worksheet Drawing)" (p. 3176)
type Drawing = GenericDrawing FileInfo ChartSpace
type UnresolvedDrawing = GenericDrawing RefId RefId
makeLenses ''Anchor
makeLenses ''DrawingObject
makeLenses ''BlipFillProperties
makeLenses ''GenericDrawing
-- | simple drawing object anchoring using one cell as a top lelft
-- corner and dimensions of that object
simpleAnchorXY :: (Int, Int) -- ^ x+y coordinates of a cell used as
-- top left anchoring corner
-> PositiveSize2D -- ^ size of drawing object to be
-- anchored
-> DrawingObject p g
-> Anchor p g
simpleAnchorXY (x, y) sz obj =
Anchor
{ _anchAnchoring =
OneCellAnchor {onecaFrom = unqMarker (x, 0) (y, 0), onecaExt = sz}
, _anchObject = obj
, _anchClientData = def
}
{-------------------------------------------------------------------------------
Default instances
-------------------------------------------------------------------------------}
instance Default ClientData where
def = ClientData True True
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
instance FromCursor UnresolvedDrawing where
fromCursor cur = [Drawing $ cur $/ anyElement >=> fromCursor]
instance FromCursor (Anchor RefId RefId) where
fromCursor cur = do
_anchAnchoring <- fromCursor cur
_anchObject <- cur $/ anyElement >=> fromCursor
_anchClientData <- cur $/ element (xdr"clientData") >=> fromCursor
return Anchor{..}
instance FromCursor Anchoring where
fromCursor = anchoringFromNode . node
anchoringFromNode :: Node -> [Anchoring]
anchoringFromNode n | n `nodeElNameIs` xdr "twoCellAnchor" = do
tcaEditAs <- fromAttributeDef "editAs" EditAsTwoCell cur
tcaFrom <- cur $/ element (xdr"from") >=> fromCursor
tcaTo <- cur $/ element (xdr"to") >=> fromCursor
return TwoCellAnchor{..}
| n `nodeElNameIs` xdr "oneCellAnchor" = do
onecaFrom <- cur $/ element (xdr"from") >=> fromCursor
onecaExt <- cur $/ element (xdr"ext") >=> fromCursor
return OneCellAnchor{..}
| n `nodeElNameIs` xdr "absolueAnchor" = do
absaPos <- cur $/ element (xdr"pos") >=> fromCursor
absaExt <- cur $/ element (xdr"ext") >=> fromCursor
return AbsoluteAnchor{..}
| otherwise = fail "no matching anchoring node"
where
cur = fromNode n
instance FromCursor Marker where
fromCursor cur = do
_mrkCol <- cur $/ element (xdr"col") &/ content >=> decimal
_mrkColOff <- cur $/ element (xdr"colOff") &/ content >=> coordinate
_mrkRow <- cur $/ element (xdr"row") &/ content >=> decimal
_mrkRowOff <- cur $/ element (xdr"rowOff") &/ content >=> coordinate
return Marker{..}
instance FromCursor (DrawingObject RefId RefId) where
fromCursor = drawingObjectFromNode . node
drawingObjectFromNode :: Node -> [DrawingObject RefId RefId]
drawingObjectFromNode n
| n `nodeElNameIs` xdr "pic" = do
_picMacro <- maybeAttribute "macro" cur
_picPublished <- fromAttributeDef "fPublished" False cur
_picNonVisual <- cur $/ element (xdr "nvPicPr") >=> fromCursor
_picBlipFill <- cur $/ element (xdr "blipFill") >=> fromCursor
_picShapeProperties <- cur $/ element (xdr "spPr") >=> fromCursor
return Picture {..}
| n `nodeElNameIs` xdr "graphicFrame" = do
_grNonVisual <-
cur $/ element (xdr "nvGraphicFramePr") >=> fromCursor
_grTransform <- cur $/ element (xdr "xfrm") >=> fromCursor
_grChartSpace <-
cur $/ element (a_ "graphic") &/ element (a_ "graphicData") &/
element (c_ "chart") >=> fmap RefId . attribute (odr "id")
return Graphic {..}
| otherwise = fail "no matching drawing object node"
where
cur = fromNode n
instance FromCursor PicNonVisual where
fromCursor cur = do
_pnvDrawingProps <- cur $/ element (xdr"cNvPr") >=> fromCursor
return PicNonVisual{..}
instance FromCursor GraphNonVisual where
fromCursor cur = do
_gnvDrawingProps <- cur $/ element (xdr "cNvPr") >=> fromCursor
return GraphNonVisual {..}
instance FromCursor NonVisualDrawingProperties where
fromCursor cur = do
_nvdpId <- fromAttribute "id" cur
_nvdpName <- fromAttribute "name" cur
_nvdpDescription <- maybeAttribute "descr" cur
_nvdpHidden <- fromAttributeDef "hidden" False cur
_nvdpTitle <- maybeAttribute "title" cur
return NonVisualDrawingProperties{..}
instance FromAttrVal DrawingElementId where
fromAttrVal = fmap (first DrawingElementId) . fromAttrVal
instance FromCursor (BlipFillProperties RefId) where
fromCursor cur = do
let _bfpImageInfo = listToMaybe $ cur $/ element (a_ "blip") >=>
fmap RefId . attribute (odr"embed")
_bfpFillMode = listToMaybe $ cur $/ anyElement >=> fromCursor
return BlipFillProperties{..}
instance FromCursor FillMode where
fromCursor = fillModeFromNode . node
fillModeFromNode :: Node -> [FillMode]
fillModeFromNode n | n `nodeElNameIs` a_ "stretch" = return FillStretch
| n `nodeElNameIs` a_ "stretch" = return FillTile
| otherwise = fail "no matching fill mode node"
-- see 20.5.3.2 "ST_EditAs (Resizing Behaviors)" (p. 3177)
instance FromAttrVal EditAs where
fromAttrVal "absolute" = readSuccess EditAsAbsolute
fromAttrVal "oneCell" = readSuccess EditAsOneCell
fromAttrVal "twoCell" = readSuccess EditAsTwoCell
fromAttrVal t = invalidText "EditAs" t
instance FromCursor ClientData where
fromCursor cur = do
_cldLcksWithSheet <- fromAttributeDef "fLocksWithSheet" True cur
_cldPrintsWithSheet <- fromAttributeDef "fPrintsWithSheet" True cur
return ClientData{..}
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
instance ToDocument UnresolvedDrawing where
toDocument = documentFromNsElement "Drawing generated by xlsx" xlDrawingNs
. toElement "wsDr"
instance ToElement UnresolvedDrawing where
toElement nm (Drawing anchors) = Element
{ elementName = nm
, elementAttributes = M.empty
, elementNodes = map NodeElement $
map anchorToElement anchors
}
anchorToElement :: Anchor RefId RefId -> Element
anchorToElement Anchor{..} = el
{ elementNodes = elementNodes el ++
map NodeElement [ drawingObjEl, cdEl ] }
where
el = anchoringToElement _anchAnchoring
drawingObjEl = drawingObjToElement _anchObject
cdEl = toElement "clientData" _anchClientData
anchoringToElement :: Anchoring -> Element
anchoringToElement anchoring = elementList nm attrs elements
where
(nm, attrs, elements) = case anchoring of
AbsoluteAnchor{..} ->
("absoluteAnchor", [],
[ toElement "pos" absaPos, toElement "ext" absaExt ])
OneCellAnchor{..} ->
("oneCellAnchor", [],
[ toElement "from" onecaFrom, toElement "ext" onecaExt ])
TwoCellAnchor{..} ->
("twoCellAnchor", [ "editAs" .= tcaEditAs ],
[ toElement "from" tcaFrom, toElement "to" tcaTo ])
instance ToElement Marker where
toElement nm Marker{..} = elementListSimple nm elements
where
elements = [ elementContent "col" (toAttrVal _mrkCol)
, elementContent "colOff" (toAttrVal _mrkColOff)
, elementContent "row" (toAttrVal _mrkRow)
, elementContent "rowOff" (toAttrVal _mrkRowOff)]
drawingObjToElement :: DrawingObject RefId RefId -> Element
drawingObjToElement Picture {..} = elementList "pic" attrs elements
where
attrs =
catMaybes ["macro" .=? _picMacro, "fPublished" .=? justTrue _picPublished]
elements =
[ toElement "nvPicPr" _picNonVisual
, toElement "blipFill" _picBlipFill
, toElement "spPr" _picShapeProperties
]
drawingObjToElement Graphic {..} = elementListSimple "graphicFrame" elements
where
elements =
[ toElement "nvGraphicFramePr" _grNonVisual
, toElement "xfrm" _grTransform
, graphicEl
]
graphicEl =
elementListSimple
(a_ "graphic")
[ elementList
(a_ "graphicData")
["uri" .= chartNs]
[leafElement (c_ "chart") [odr "id" .= _grChartSpace]]
]
instance ToElement PicNonVisual where
toElement nm PicNonVisual {..} =
elementListSimple
nm
[toElement "cNvPr" _pnvDrawingProps, emptyElement "cNvPicPr"]
instance ToElement GraphNonVisual where
toElement nm GraphNonVisual {..} =
elementListSimple
nm
[toElement "cNvPr" _gnvDrawingProps, emptyElement "cNvGraphicFramePr"]
instance ToElement NonVisualDrawingProperties where
toElement nm NonVisualDrawingProperties{..} =
leafElement nm attrs
where
attrs = [ "id" .= _nvdpId
, "name" .= _nvdpName ] ++
catMaybes [ "descr" .=? _nvdpDescription
, "hidden" .=? justTrue _nvdpHidden
, "title" .=? _nvdpTitle ]
instance ToAttrVal DrawingElementId where
toAttrVal = toAttrVal . unDrawingElementId
instance ToElement (BlipFillProperties RefId) where
toElement nm BlipFillProperties{..} =
elementListSimple nm elements
where
elements = catMaybes [ (\rId -> leafElement (a_ "blip") [ odr "embed" .= rId ]) <$> _bfpImageInfo
, fillModeToElement <$> _bfpFillMode ]
fillModeToElement :: FillMode -> Element
fillModeToElement FillStretch = emptyElement (a_ "stretch")
fillModeToElement FillTile = emptyElement (a_ "stretch")
instance ToElement ClientData where
toElement nm ClientData{..} = leafElement nm attrs
where
attrs = catMaybes [ "fLocksWithSheet" .=? justFalse _cldLcksWithSheet
, "fPrintsWithSheet" .=? justFalse _cldPrintsWithSheet
]
instance ToAttrVal EditAs where
toAttrVal EditAsAbsolute = "absolute"
toAttrVal EditAsOneCell = "oneCell"
toAttrVal EditAsTwoCell = "twoCell"
-- | Add Spreadsheet DrawingML namespace to name
xdr :: Text -> Name
xdr x = Name
{ nameLocalName = x
, nameNamespace = Just xlDrawingNs
, namePrefix = Nothing
}
xlDrawingNs :: Text
xlDrawingNs = "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing"
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Drawing/Chart.hs 0000644 0000000 0000000 00000067450 14551273353 017721 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Drawing.Chart where
import GHC.Generics (Generic)
#ifdef USE_MICROLENS
import Lens.Micro.TH (makeLenses)
#else
import Control.Lens.TH
#endif
import Control.DeepSeq (NFData)
import Data.Default
import Data.Maybe (catMaybes, listToMaybe, maybeToList)
import Data.Text (Text)
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Types.Drawing.Common
import Codec.Xlsx.Writer.Internal
-- | Main Chart holder, combines
-- TODO: title, autoTitleDeleted, pivotFmts
-- view3D, floor, sideWall, backWall, showDLblsOverMax, extLst
data ChartSpace = ChartSpace
{ _chspTitle :: Maybe ChartTitle
, _chspCharts :: [Chart]
, _chspLegend :: Maybe Legend
, _chspPlotVisOnly :: Maybe Bool
, _chspDispBlanksAs :: Maybe DispBlanksAs
} deriving (Eq, Show, Generic)
instance NFData ChartSpace
-- | Chart title
--
-- TODO: layout, overlay, spPr, txPr, extLst
newtype ChartTitle =
ChartTitle (Maybe TextBody)
deriving (Eq, Show, Generic)
instance NFData ChartTitle
-- | This simple type specifies the possible ways to display blanks.
--
-- See 21.2.3.10 "ST_DispBlanksAs (Display Blanks As)" (p. 3444)
data DispBlanksAs
= DispBlanksAsGap
-- ^ Specifies that blank values shall be left as a gap.
| DispBlanksAsSpan
-- ^ Specifies that blank values shall be spanned with a line.
| DispBlanksAsZero
-- ^ Specifies that blank values shall be treated as zero.
deriving (Eq, Show, Generic)
instance NFData DispBlanksAs
-- TODO: legendEntry, layout, overlay, spPr, txPr, extLst
data Legend = Legend
{ _legendPos :: Maybe LegendPos
, _legendOverlay :: Maybe Bool
} deriving (Eq, Show, Generic)
instance NFData Legend
-- See 21.2.3.24 "ST_LegendPos (Legend Position)" (p. 3449)
data LegendPos
= LegendBottom
-- ^ b (Bottom) Specifies that the legend shall be drawn at the
-- bottom of the chart.
| LegendLeft
-- ^ l (Left) Specifies that the legend shall be drawn at the left
-- of the chart.
| LegendRight
-- ^ r (Right) Specifies that the legend shall be drawn at the
-- right of the chart.
| LegendTop
-- ^ t (Top) Specifies that the legend shall be drawn at the top
-- of the chart.
| LegendTopRight
-- ^ tr (Top Right) Specifies that the legend shall be drawn at
-- the top right of the chart.
deriving (Eq, Show, Generic)
instance NFData LegendPos
-- | Specific Chart
-- TODO:
-- area3DChart, line3DChart, stockChart, radarChart,
-- pie3DChart, doughnutChart, bar3DChart, ofPieChart,
-- surfaceChart, surface3DChart, bubbleChart
data Chart
= LineChart { _lnchGrouping :: ChartGrouping
, _lnchSeries :: [LineSeries]
, _lnchMarker :: Maybe Bool
-- ^ specifies that the marker shall be shown
, _lnchSmooth :: Maybe Bool
-- ^ specifies the line connecting the points on the chart shall be
-- smoothed using Catmull-Rom splines
}
| AreaChart { _archGrouping :: Maybe ChartGrouping
, _archSeries :: [AreaSeries]
}
| BarChart { _brchDirection :: BarDirection
, _brchGrouping :: Maybe BarChartGrouping
, _brchSeries :: [BarSeries]
}
| PieChart { _pichSeries :: [PieSeries]
}
| ScatterChart { _scchStyle :: ScatterStyle
, _scchSeries :: [ScatterSeries]
}
deriving (Eq, Show, Generic)
instance NFData Chart
-- | Possible groupings for a chart
--
-- See 21.2.3.17 "ST_Grouping (Grouping)" (p. 3446)
data ChartGrouping
= PercentStackedGrouping
-- ^ (100% Stacked) Specifies that the chart series are drawn next to each
-- other along the value axis and scaled to total 100%.
| StackedGrouping
-- ^ (Stacked) Specifies that the chart series are drawn next to each
-- other on the value axis.
| StandardGrouping
-- ^(Standard) Specifies that the chart series are drawn on the value
-- axis.
deriving (Eq, Show, Generic)
instance NFData ChartGrouping
-- | Possible groupings for a bar chart
--
-- See 21.2.3.4 "ST_BarGrouping (Bar Grouping)" (p. 3441)
data BarChartGrouping
= BarClusteredGrouping
-- ^ Specifies that the chart series are drawn next to each other
-- along the category axis.
| BarPercentStackedGrouping
-- ^ (100% Stacked) Specifies that the chart series are drawn next to each
-- other along the value axis and scaled to total 100%.
| BarStackedGrouping
-- ^ (Stacked) Specifies that the chart series are drawn next to each
-- other on the value axis.
| BarStandardGrouping
-- ^(Standard) Specifies that the chart series are drawn on the value
-- axis.
deriving (Eq, Show, Generic)
instance NFData BarChartGrouping
-- | Possible directions for a bar chart
--
-- See 21.2.3.3 "ST_BarDir (Bar Direction)" (p. 3441)
data BarDirection
= DirectionBar
| DirectionColumn
deriving (Eq, Show, Generic)
instance NFData BarDirection
-- | Possible styles of scatter chart
--
-- /Note:/ It appears that even for 'ScatterMarker' style Exel draws a
-- line between chart points if otline fill for '_scserShared' isn't
-- set to so it's not quite clear how could Excel use this property
--
-- See 21.2.3.40 "ST_ScatterStyle (Scatter Style)" (p. 3455)
data ScatterStyle
= ScatterNone
| ScatterLine
| ScatterLineMarker
| ScatterMarker
| ScatterSmooth
| ScatterSmoothMarker
deriving (Eq, Show, Generic)
instance NFData ScatterStyle
-- | Single data point options
--
-- TODO: invertIfNegative, bubble3D, explosion, pictureOptions, extLst
--
-- See 21.2.2.52 "dPt (Data Point)" (p. 3384)
data DataPoint = DataPoint
{ _dpMarker :: Maybe DataMarker
, _dpShapeProperties :: Maybe ShapeProperties
} deriving (Eq, Show, Generic)
instance NFData DataPoint
-- | Specifies common series options
-- TODO: spPr
--
-- See @EG_SerShared@ (p. 4063)
data Series = Series
{ _serTx :: Maybe Formula
-- ^ specifies text for a series name, without rich text formatting
-- currently only reference formula is supported
, _serShapeProperties :: Maybe ShapeProperties
} deriving (Eq, Show, Generic)
instance NFData Series
-- | A series on a line chart
--
-- TODO: dPt, trendline, errBars, cat, extLst
--
-- See @CT_LineSer@ (p. 4064)
data LineSeries = LineSeries
{ _lnserShared :: Series
, _lnserMarker :: Maybe DataMarker
, _lnserDataLblProps :: Maybe DataLblProps
, _lnserVal :: Maybe Formula
-- ^ currently only reference formula is supported
, _lnserSmooth :: Maybe Bool
} deriving (Eq, Show, Generic)
instance NFData LineSeries
-- | A series on an area chart
--
-- TODO: pictureOptions, dPt, trendline, errBars, cat, extLst
--
-- See @CT_AreaSer@ (p. 4065)
data AreaSeries = AreaSeries
{ _arserShared :: Series
, _arserDataLblProps :: Maybe DataLblProps
, _arserVal :: Maybe Formula
} deriving (Eq, Show, Generic)
instance NFData AreaSeries
-- | A series on a bar chart
--
-- TODO: invertIfNegative, pictureOptions, dPt, trendline, errBars,
-- cat, shape, extLst
--
-- See @CT_BarSer@ (p. 4064)
data BarSeries = BarSeries
{ _brserShared :: Series
, _brserDataLblProps :: Maybe DataLblProps
, _brserVal :: Maybe Formula
} deriving (Eq, Show, Generic)
instance NFData BarSeries
-- | A series on a pie chart
--
-- TODO: explosion, cat, extLst
--
-- See @CT_PieSer@ (p. 4065)
data PieSeries = PieSeries
{ _piserShared :: Series
, _piserDataPoints :: [DataPoint]
-- ^ normally you should set fill for chart datapoints to make them
-- properly colored
, _piserDataLblProps :: Maybe DataLblProps
, _piserVal :: Maybe Formula
} deriving (Eq, Show, Generic)
instance NFData PieSeries
-- | A series on a scatter chart
--
-- TODO: dPt, trendline, errBars, smooth, extLst
--
-- See @CT_ScatterSer@ (p. 4064)
data ScatterSeries = ScatterSeries
{ _scserShared :: Series
, _scserMarker :: Maybe DataMarker
, _scserDataLblProps :: Maybe DataLblProps
, _scserXVal :: Maybe Formula
, _scserYVal :: Maybe Formula
, _scserSmooth :: Maybe Bool
} deriving (Eq, Show, Generic)
instance NFData ScatterSeries
-- See @CT_Marker@ (p. 4061)
data DataMarker = DataMarker
{ _dmrkSymbol :: Maybe DataMarkerSymbol
, _dmrkSize :: Maybe Int
-- ^ integer between 2 and 72, specifying a size in points
} deriving (Eq, Show, Generic)
instance NFData DataMarker
data DataMarkerSymbol
= DataMarkerCircle
| DataMarkerDash
| DataMarkerDiamond
| DataMarkerDot
| DataMarkerNone
| DataMarkerPicture
| DataMarkerPlus
| DataMarkerSquare
| DataMarkerStar
| DataMarkerTriangle
| DataMarkerX
| DataMarkerAuto
deriving (Eq, Show, Generic)
instance NFData DataMarkerSymbol
-- | Settings for the data labels for an entire series or the
-- entire chart
--
-- TODO: numFmt, spPr, txPr, dLblPos, showBubbleSize,
-- separator, showLeaderLines, leaderLines
-- See 21.2.2.49 "dLbls (Data Labels)" (p. 3384)
data DataLblProps = DataLblProps
{ _dlblShowLegendKey :: Maybe Bool
, _dlblShowVal :: Maybe Bool
, _dlblShowCatName :: Maybe Bool
, _dlblShowSerName :: Maybe Bool
, _dlblShowPercent :: Maybe Bool
} deriving (Eq, Show, Generic)
instance NFData DataLblProps
-- | Specifies the possible positions for tick marks.
-- See 21.2.3.48 "ST_TickMark (Tick Mark)" (p. 3467)
data TickMark
= TickMarkCross
-- ^ (Cross) Specifies the tick marks shall cross the axis.
| TickMarkIn
-- ^ (Inside) Specifies the tick marks shall be inside the plot area.
| TickMarkNone
-- ^ (None) Specifies there shall be no tick marks.
| TickMarkOut
-- ^ (Outside) Specifies the tick marks shall be outside the plot area.
deriving (Eq, Show, Generic)
instance NFData TickMark
makeLenses ''DataPoint
{-------------------------------------------------------------------------------
Default instances
-------------------------------------------------------------------------------}
instance Default DataPoint where
def = DataPoint Nothing Nothing
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
instance FromCursor ChartSpace where
fromCursor cur = do
cur' <- cur $/ element (c_ "chart")
_chspTitle <- maybeFromElement (c_ "title") cur'
let _chspCharts =
cur' $/ element (c_ "plotArea") &/ anyElement >=> chartFromNode . node
_chspLegend <- maybeFromElement (c_ "legend") cur'
_chspPlotVisOnly <- maybeBoolElementValue (c_ "plotVisOnly") cur'
_chspDispBlanksAs <- maybeElementValue (c_ "dispBlanksAs") cur'
return ChartSpace {..}
chartFromNode :: Node -> [Chart]
chartFromNode n
| n `nodeElNameIs` (c_ "lineChart") = do
_lnchGrouping <- fromElementValue (c_ "grouping") cur
let _lnchSeries = cur $/ element (c_ "ser") >=> fromCursor
_lnchMarker <- maybeBoolElementValue (c_ "marker") cur
_lnchSmooth <- maybeBoolElementValue (c_ "smooth") cur
return LineChart {..}
| n `nodeElNameIs` (c_ "areaChart") = do
_archGrouping <- maybeElementValue (c_ "grouping") cur
let _archSeries = cur $/ element (c_ "ser") >=> fromCursor
return AreaChart {..}
| n `nodeElNameIs` (c_ "barChart") = do
_brchDirection <- fromElementValue (c_ "barDir") cur
_brchGrouping <-
maybeElementValueDef (c_ "grouping") BarClusteredGrouping cur
let _brchSeries = cur $/ element (c_ "ser") >=> fromCursor
return BarChart {..}
| n `nodeElNameIs` (c_ "pieChart") = do
let _pichSeries = cur $/ element (c_ "ser") >=> fromCursor
return PieChart {..}
| n `nodeElNameIs` (c_ "scatterChart") = do
_scchStyle <- fromElementValue (c_ "scatterStyle") cur
let _scchSeries = cur $/ element (c_ "ser") >=> fromCursor
return ScatterChart {..}
| otherwise = fail "no matching chart node"
where
cur = fromNode n
instance FromCursor LineSeries where
fromCursor cur = do
_lnserShared <- fromCursor cur
_lnserMarker <- maybeFromElement (c_ "marker") cur
_lnserDataLblProps <- maybeFromElement (c_ "dLbls") cur
_lnserVal <-
cur $/ element (c_ "val") &/ element (c_ "numRef") >=>
maybeFromElement (c_ "f")
_lnserSmooth <- maybeElementValueDef (c_ "smooth") True cur
return LineSeries {..}
instance FromCursor AreaSeries where
fromCursor cur = do
_arserShared <- fromCursor cur
_arserDataLblProps <- maybeFromElement (c_ "dLbls") cur
_arserVal <-
cur $/ element (c_ "val") &/ element (c_ "numRef") >=>
maybeFromElement (c_ "f")
return AreaSeries {..}
instance FromCursor BarSeries where
fromCursor cur = do
_brserShared <- fromCursor cur
_brserDataLblProps <- maybeFromElement (c_ "dLbls") cur
_brserVal <-
cur $/ element (c_ "val") &/ element (c_ "numRef") >=>
maybeFromElement (c_ "f")
return BarSeries {..}
instance FromCursor PieSeries where
fromCursor cur = do
_piserShared <- fromCursor cur
let _piserDataPoints = cur $/ element (c_ "dPt") >=> fromCursor
_piserDataLblProps <- maybeFromElement (c_ "dLbls") cur
_piserVal <-
cur $/ element (c_ "val") &/ element (c_ "numRef") >=>
maybeFromElement (c_ "f")
return PieSeries {..}
instance FromCursor ScatterSeries where
fromCursor cur = do
_scserShared <- fromCursor cur
_scserMarker <- maybeFromElement (c_ "marker") cur
_scserDataLblProps <- maybeFromElement (c_ "dLbls") cur
_scserXVal <-
cur $/ element (c_ "xVal") &/ element (c_ "numRef") >=>
maybeFromElement (c_ "f")
_scserYVal <-
cur $/ element (c_ "yVal") &/ element (c_ "numRef") >=>
maybeFromElement (c_ "f")
_scserSmooth <- maybeElementValueDef (c_ "smooth") True cur
return ScatterSeries {..}
-- should we respect idx and order?
instance FromCursor Series where
fromCursor cur = do
_serTx <-
cur $/ element (c_ "tx") &/ element (c_ "strRef") >=>
maybeFromElement (c_ "f")
_serShapeProperties <- maybeFromElement (c_ "spPr") cur
return Series {..}
instance FromCursor DataMarker where
fromCursor cur = do
_dmrkSymbol <- maybeElementValue (c_ "symbol") cur
_dmrkSize <- maybeElementValue (c_ "size") cur
return DataMarker {..}
instance FromCursor DataPoint where
fromCursor cur = do
_dpMarker <- maybeFromElement (c_ "marker") cur
_dpShapeProperties <- maybeFromElement (c_ "spPr") cur
return DataPoint {..}
instance FromAttrVal DataMarkerSymbol where
fromAttrVal "circle" = readSuccess DataMarkerCircle
fromAttrVal "dash" = readSuccess DataMarkerDash
fromAttrVal "diamond" = readSuccess DataMarkerDiamond
fromAttrVal "dot" = readSuccess DataMarkerDot
fromAttrVal "none" = readSuccess DataMarkerNone
fromAttrVal "picture" = readSuccess DataMarkerPicture
fromAttrVal "plus" = readSuccess DataMarkerPlus
fromAttrVal "square" = readSuccess DataMarkerSquare
fromAttrVal "star" = readSuccess DataMarkerStar
fromAttrVal "triangle" = readSuccess DataMarkerTriangle
fromAttrVal "x" = readSuccess DataMarkerX
fromAttrVal "auto" = readSuccess DataMarkerAuto
fromAttrVal t = invalidText "DataMarkerSymbol" t
instance FromAttrVal BarDirection where
fromAttrVal "bar" = readSuccess DirectionBar
fromAttrVal "col" = readSuccess DirectionColumn
fromAttrVal t = invalidText "BarDirection" t
instance FromAttrVal ScatterStyle where
fromAttrVal "none" = readSuccess ScatterNone
fromAttrVal "line" = readSuccess ScatterLine
fromAttrVal "lineMarker" = readSuccess ScatterLineMarker
fromAttrVal "marker" = readSuccess ScatterMarker
fromAttrVal "smooth" = readSuccess ScatterSmooth
fromAttrVal "smoothMarker" = readSuccess ScatterSmoothMarker
fromAttrVal t = invalidText "ScatterStyle" t
instance FromCursor DataLblProps where
fromCursor cur = do
_dlblShowLegendKey <- maybeBoolElementValue (c_ "showLegendKey") cur
_dlblShowVal <- maybeBoolElementValue (c_ "showVal") cur
_dlblShowCatName <- maybeBoolElementValue (c_ "showCatName") cur
_dlblShowSerName <- maybeBoolElementValue (c_ "showSerName") cur
_dlblShowPercent <- maybeBoolElementValue (c_ "showPercent") cur
return DataLblProps {..}
instance FromAttrVal ChartGrouping where
fromAttrVal "percentStacked" = readSuccess PercentStackedGrouping
fromAttrVal "standard" = readSuccess StandardGrouping
fromAttrVal "stacked" = readSuccess StackedGrouping
fromAttrVal t = invalidText "ChartGrouping" t
instance FromAttrVal BarChartGrouping where
fromAttrVal "clustered" = readSuccess BarClusteredGrouping
fromAttrVal "percentStacked" = readSuccess BarPercentStackedGrouping
fromAttrVal "standard" = readSuccess BarStandardGrouping
fromAttrVal "stacked" = readSuccess BarStackedGrouping
fromAttrVal t = invalidText "BarChartGrouping" t
instance FromCursor ChartTitle where
fromCursor cur = do
let mTitle = listToMaybe $
cur $/ element (c_ "tx") &/ element (c_ "rich") >=> fromCursor
return $ ChartTitle mTitle
instance FromCursor Legend where
fromCursor cur = do
_legendPos <- maybeElementValue (c_ "legendPos") cur
_legendOverlay <- maybeElementValueDef (c_ "overlay") True cur
return Legend {..}
instance FromAttrVal LegendPos where
fromAttrVal "b" = readSuccess LegendBottom
fromAttrVal "l" = readSuccess LegendLeft
fromAttrVal "r" = readSuccess LegendRight
fromAttrVal "t" = readSuccess LegendTop
fromAttrVal "tr" = readSuccess LegendTopRight
fromAttrVal t = invalidText "LegendPos" t
instance FromAttrVal DispBlanksAs where
fromAttrVal "gap" = readSuccess DispBlanksAsGap
fromAttrVal "span" = readSuccess DispBlanksAsSpan
fromAttrVal "zero" = readSuccess DispBlanksAsZero
fromAttrVal t = invalidText "DispBlanksAs" t
{-------------------------------------------------------------------------------
Default instances
-------------------------------------------------------------------------------}
instance Default Legend where
def = Legend {_legendPos = Just LegendBottom, _legendOverlay = Just False}
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
instance ToDocument ChartSpace where
toDocument =
documentFromNsPrefElement "Charts generated by xlsx" chartNs (Just "c") .
toElement "chartSpace"
instance ToElement ChartSpace where
toElement nm ChartSpace {..} =
elementListSimple nm [nonRounded, chartEl, chSpPr]
where
-- no such element gives a chart space with rounded corners
nonRounded = elementValue "roundedCorners" False
chSpPr = toElement "spPr" $ def {_spFill = Just $ solidRgb "ffffff"}
chartEl = elementListSimple "chart" elements
elements =
catMaybes
[ toElement "title" <$> _chspTitle
-- LO?
, Just $ elementValue "autoTitleDeleted" False
, Just $ elementListSimple "plotArea" areaEls
, toElement "legend" <$> _chspLegend
, elementValue "plotVisOnly" <$> _chspPlotVisOnly
, elementValue "dispBlanksAs" <$> _chspDispBlanksAs
]
areaEls = charts ++ axes
(_, charts, axes) = foldr addChart (1, [], []) _chspCharts
addChart ch (i, cs, as) =
let (c, as') = chartToElements ch i
in (i + length as', c : cs, as' ++ as)
chartToElements :: Chart -> Int -> (Element, [Element])
chartToElements chart axId =
case chart of
LineChart {..} ->
chartElement
"lineChart"
stdAxes
(Just _lnchGrouping)
_lnchSeries
[]
(catMaybes
[ elementValue "marker" <$> _lnchMarker
, elementValue "smooth" <$> _lnchSmooth
])
AreaChart {..} ->
chartElement "areaChart" stdAxes _archGrouping _archSeries [] []
BarChart {..} ->
chartElement
"barChart"
stdAxes
_brchGrouping
_brchSeries
[elementValue "barDir" _brchDirection]
[]
PieChart {..} -> chartElement "pieChart" [] noGrouping _pichSeries [] []
ScatterChart {..} ->
chartElement
"scatterChart"
xyAxes
noGrouping
_scchSeries
[elementValue "scatterStyle" _scchStyle]
[]
where
noGrouping :: Maybe ChartGrouping
noGrouping = Nothing
chartElement
:: (ToElement s, ToAttrVal gr)
=> Name
-> [Element]
-> Maybe gr
-> [s]
-> [Element]
-> [Element]
-> (Element, [Element])
chartElement nm axes mGrouping series prepended appended =
( elementListSimple nm $
prepended ++
(maybeToList $ elementValue "grouping" <$> mGrouping) ++
(varyColors : seriesEls series) ++
appended ++ zipWith (\n _ -> elementValue "axId" n) [axId ..] axes
, axes)
-- no element seems to be equal to varyColors=true in Excel Online
varyColors = elementValue "varyColors" False
seriesEls series = [indexedSeriesEl i s | (i, s) <- zip [0 ..] series]
indexedSeriesEl
:: ToElement a
=> Int -> a -> Element
indexedSeriesEl i s = prependI i $ toElement "ser" s
prependI i e@Element {..} = e {elementNodes = iNodes i ++ elementNodes}
iNodes i = map NodeElement [elementValue n i | n <- ["idx", "order"]]
stdAxes = [catAx axId (axId + 1), valAx "l" (axId + 1) axId]
xyAxes = [valAx "b" axId (axId + 1), valAx "l" (axId + 1) axId]
catAx :: Int -> Int -> Element
catAx i cr =
elementListSimple "catAx" $
[ elementValue "axId" i
, emptyElement "scaling"
, elementValue "delete" False
, elementValue "axPos" ("b" :: Text)
, elementValue "majorTickMark" TickMarkNone
, elementValue "minorTickMark" TickMarkNone
, toElement "spPr" grayLines
, elementValue "crossAx" cr
, elementValue "auto" True
]
valAx :: Text -> Int -> Int -> Element
valAx pos i cr =
elementListSimple "valAx" $
[ elementValue "axId" i
, emptyElement "scaling"
, elementValue "delete" False
, elementValue "axPos" pos
, gridLinesEl
, elementValue "majorTickMark" TickMarkNone
, elementValue "minorTickMark" TickMarkNone
, toElement "spPr" grayLines
, elementValue "crossAx" cr
]
grayLines = def {_spOutline = Just def {_lnFill = Just $ solidRgb "b3b3b3"}}
gridLinesEl =
elementListSimple "majorGridlines" [toElement "spPr" grayLines]
instance ToAttrVal ChartGrouping where
toAttrVal PercentStackedGrouping = "percentStacked"
toAttrVal StandardGrouping = "standard"
toAttrVal StackedGrouping = "stacked"
instance ToAttrVal BarChartGrouping where
toAttrVal BarClusteredGrouping = "clustered"
toAttrVal BarPercentStackedGrouping = "percentStacked"
toAttrVal BarStandardGrouping = "standard"
toAttrVal BarStackedGrouping = "stacked"
instance ToAttrVal BarDirection where
toAttrVal DirectionBar = "bar"
toAttrVal DirectionColumn = "col"
instance ToAttrVal ScatterStyle where
toAttrVal ScatterNone = "none"
toAttrVal ScatterLine = "line"
toAttrVal ScatterLineMarker = "lineMarker"
toAttrVal ScatterMarker = "marker"
toAttrVal ScatterSmooth = "smooth"
toAttrVal ScatterSmoothMarker = "smoothMarker"
instance ToElement LineSeries where
toElement nm LineSeries {..} = simpleSeries nm _lnserShared _lnserVal pr ap
where
pr =
catMaybes
[ toElement "marker" <$> _lnserMarker
, toElement "dLbls" <$> _lnserDataLblProps
]
ap = maybeToList $ elementValue "smooth" <$> _lnserSmooth
simpleSeries :: Name
-> Series
-> Maybe Formula
-> [Element]
-> [Element]
-> Element
simpleSeries nm shared val prepended appended =
serEl {elementNodes = elementNodes serEl ++ map NodeElement elements}
where
serEl = toElement nm shared
elements = prepended ++ (valEl val : appended)
valEl v =
elementListSimple
"val"
[elementListSimple "numRef" $ maybeToList (toElement "f" <$> v)]
instance ToElement DataMarker where
toElement nm DataMarker {..} = elementListSimple nm elements
where
elements =
catMaybes
[ elementValue "symbol" <$> _dmrkSymbol
, elementValue "size" <$> _dmrkSize
]
instance ToAttrVal DataMarkerSymbol where
toAttrVal DataMarkerCircle = "circle"
toAttrVal DataMarkerDash = "dash"
toAttrVal DataMarkerDiamond = "diamond"
toAttrVal DataMarkerDot = "dot"
toAttrVal DataMarkerNone = "none"
toAttrVal DataMarkerPicture = "picture"
toAttrVal DataMarkerPlus = "plus"
toAttrVal DataMarkerSquare = "square"
toAttrVal DataMarkerStar = "star"
toAttrVal DataMarkerTriangle = "triangle"
toAttrVal DataMarkerX = "x"
toAttrVal DataMarkerAuto = "auto"
instance ToElement DataLblProps where
toElement nm DataLblProps {..} = elementListSimple nm elements
where
elements =
catMaybes
[ elementValue "showLegendKey" <$> _dlblShowLegendKey
, elementValue "showVal" <$> _dlblShowVal
, elementValue "showCatName" <$> _dlblShowCatName
, elementValue "showSerName" <$> _dlblShowSerName
, elementValue "showPercent" <$> _dlblShowPercent
]
instance ToElement AreaSeries where
toElement nm AreaSeries {..} = simpleSeries nm _arserShared _arserVal pr []
where
pr = maybeToList $ fmap (toElement "dLbls") _arserDataLblProps
instance ToElement BarSeries where
toElement nm BarSeries {..} = simpleSeries nm _brserShared _brserVal pr []
where
pr = maybeToList $ fmap (toElement "dLbls") _brserDataLblProps
instance ToElement PieSeries where
toElement nm PieSeries {..} = simpleSeries nm _piserShared _piserVal pr []
where
pr = dPts ++ maybeToList (fmap (toElement "dLbls") _piserDataLblProps)
dPts = zipWith dPtEl [(0 :: Int) ..] _piserDataPoints
dPtEl i DataPoint {..} =
elementListSimple
"dPt"
(elementValue "idx" i :
catMaybes
[ toElement "marker" <$> _dpMarker
, toElement "spPr" <$> _dpShapeProperties
])
instance ToElement ScatterSeries where
toElement nm ScatterSeries {..} =
serEl {elementNodes = elementNodes serEl ++ map NodeElement elements}
where
serEl = toElement nm _scserShared
elements =
catMaybes
[ toElement "marker" <$> _scserMarker
, toElement "dLbls" <$> _scserDataLblProps
] ++
[valEl "xVal" _scserXVal, valEl "yVal" _scserYVal] ++
(maybeToList $ fmap (elementValue "smooth") _scserSmooth)
valEl vnm v =
elementListSimple
vnm
[elementListSimple "numRef" $ maybeToList (toElement "f" <$> v)]
-- should we respect idx and order?
instance ToElement Series where
toElement nm Series {..} =
elementListSimple nm $
[ elementListSimple
"tx"
[elementListSimple "strRef" $ maybeToList (toElement "f" <$> _serTx)]
] ++
maybeToList (toElement "spPr" <$> _serShapeProperties)
instance ToElement ChartTitle where
toElement nm (ChartTitle body) =
elementListSimple nm [txEl, elementValue "overlay" False]
where
txEl = elementListSimple "tx" $ catMaybes [toElement (c_ "rich") <$> body]
instance ToElement Legend where
toElement nm Legend{..} = elementListSimple nm elements
where
elements = catMaybes [ elementValue "legendPos" <$> _legendPos
, elementValue "overlay" <$>_legendOverlay]
instance ToAttrVal LegendPos where
toAttrVal LegendBottom = "b"
toAttrVal LegendLeft = "l"
toAttrVal LegendRight = "r"
toAttrVal LegendTop = "t"
toAttrVal LegendTopRight = "tr"
instance ToAttrVal DispBlanksAs where
toAttrVal DispBlanksAsGap = "gap"
toAttrVal DispBlanksAsSpan = "span"
toAttrVal DispBlanksAsZero = "zero"
instance ToAttrVal TickMark where
toAttrVal TickMarkCross = "cross"
toAttrVal TickMarkIn = "in"
toAttrVal TickMarkNone = "none"
toAttrVal TickMarkOut = "out"
-- | Add chart namespace to name
c_ :: Text -> Name
c_ x =
Name {nameLocalName = x, nameNamespace = Just chartNs, namePrefix = Just "c"}
chartNs :: Text
chartNs = "http://schemas.openxmlformats.org/drawingml/2006/chart"
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Drawing/Common.hs 0000644 0000000 0000000 00000057326 14551273353 020111 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Drawing.Common where
import GHC.Generics (Generic)
import Control.Arrow (first)
#ifdef USE_MICROLENS
import Lens.Micro.TH (makeLenses)
#else
import Control.Lens.TH
#endif
import Control.Monad (join)
import Control.Monad.Fail (MonadFail)
import Control.DeepSeq (NFData)
import Data.Default
import Data.Maybe (catMaybes, listToMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Read as T
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Writer.Internal
-- | This simple type represents an angle in 60,000ths of a degree.
-- Positive angles are clockwise (i.e., towards the positive y axis); negative
-- angles are counter-clockwise (i.e., towards the negative y axis).
newtype Angle =
Angle Int
deriving (Eq, Show, Generic)
instance NFData Angle
-- | A string with rich text formatting
--
-- TODO: horzOverflow, lIns, tIns, rIns, bIns, numCol, spcCol, rtlCol,
-- fromWordArt, forceAA, upright, compatLnSpc, prstTxWarp,
-- a_EG_TextAutofit, scene3d, a_EG_Text3D, extLst
--
-- See @CT_TextBody@ (p. 4034)
data TextBody = TextBody
{ _txbdRotation :: Angle
-- ^ Specifies the rotation that is being applied to the text within the bounding box.
, _txbdSpcFirstLastPara :: Bool
-- ^ Specifies whether the before and after paragraph spacing defined by the user is
-- to be respected.
, _txbdVertOverflow :: TextVertOverflow
-- ^ Determines whether the text can flow out of the bounding box vertically.
, _txbdVertical :: TextVertical
-- ^ Determines if the text within the given text body should be displayed vertically.
, _txbdWrap :: TextWrap
-- ^ Specifies the wrapping options to be used for this text body.
, _txbdAnchor :: TextAnchoring
-- ^ Specifies the anchoring position of the txBody within the shape.
, _txbdAnchorCenter :: Bool
-- ^ Specifies the centering of the text box. The way it works fundamentally is
-- to determine the smallest possible "bounds box" for the text and then to center
-- that "bounds box" accordingly. This is different than paragraph alignment, which
-- aligns the text within the "bounds box" for the text.
, _txbdParagraphs :: [TextParagraph]
-- ^ Paragraphs of text within the containing text body
} deriving (Eq, Show, Generic)
instance NFData TextBody
-- | Text vertical overflow
-- See 20.1.10.83 "ST_TextVertOverflowType (Text Vertical Overflow)" (p. 3083)
data TextVertOverflow
= TextVertOverflowClip
-- ^ Pay attention to top and bottom barriers. Provide no indication that there is
-- text which is not visible.
| TextVertOverflowEllipsis
-- ^ Pay attention to top and bottom barriers. Use an ellipsis to denote that
-- there is text which is not visible.
| TextVertOverflow
-- ^ Overflow the text and pay no attention to top and bottom barriers.
deriving (Eq, Show, Generic)
instance NFData TextVertOverflow
-- | If there is vertical text, determines what kind of vertical text is going to be used.
--
-- See 20.1.10.82 "ST_TextVerticalType (Vertical Text Types)" (p. 3083)
data TextVertical
= TextVerticalEA
-- ^ A special version of vertical text, where some fonts are displayed as if rotated
-- by 90 degrees while some fonts (mostly East Asian) are displayed vertical.
| TextVerticalHorz
-- ^ Horizontal text. This should be default.
| TextVerticalMongolian
-- ^ A special version of vertical text, where some fonts are displayed as if rotated
-- by 90 degrees while some fonts (mostly East Asian) are displayed vertical. The
-- difference between this and the 'TextVerticalEA' is the text flows top down then
-- LEFT RIGHT, instead of RIGHT LEFT
| TextVertical
-- ^ Determines if all of the text is vertical orientation (each line is 90 degrees
-- rotated clockwise, so it goes from top to bottom; each next line is to the left
-- from the previous one).
| TextVertical270
-- ^ Determines if all of the text is vertical orientation (each line is 270 degrees
-- rotated clockwise, so it goes from bottom to top; each next line is to the right
-- from the previous one).
| TextVerticalWordArt
-- ^ Determines if all of the text is vertical ("one letter on top of another").
| TextVerticalWordArtRtl
-- ^ Specifies that vertical WordArt should be shown from right to left rather than
-- left to right.
deriving (Eq, Show, Generic)
instance NFData TextVertical
-- | Text wrapping types
--
-- See 20.1.10.84 "ST_TextWrappingType (Text Wrapping Types)" (p. 3084)
data TextWrap
= TextWrapNone
-- ^ No wrapping occurs on this text body. Words spill out without
-- paying attention to the bounding rectangle boundaries.
| TextWrapSquare
-- ^ Determines whether we wrap words within the bounding rectangle.
deriving (Eq, Show, Generic)
instance NFData TextWrap
-- | This type specifies a list of available anchoring types for text.
--
-- See 20.1.10.59 "ST_TextAnchoringType (Text Anchoring Types)" (p. 3058)
data TextAnchoring
= TextAnchoringBottom
-- ^ Anchor the text at the bottom of the bounding rectangle.
| TextAnchoringCenter
-- ^ Anchor the text at the middle of the bounding rectangle.
| TextAnchoringDistributed
-- ^ Anchor the text so that it is distributed vertically. When text is horizontal,
-- this spaces out the actual lines of text and is almost always identical in
-- behavior to 'TextAnchoringJustified' (special case: if only 1 line, then anchored
-- in middle). When text is vertical, then it distributes the letters vertically.
-- This is different than 'TextAnchoringJustified', because it always forces distribution
-- of the words, even if there are only one or two words in a line.
| TextAnchoringJustified
-- ^ Anchor the text so that it is justified vertically. When text is horizontal,
-- this spaces out the actual lines of text and is almost always identical in
-- behavior to 'TextAnchoringDistributed' (special case: if only 1 line, then anchored at
-- top). When text is vertical, then it justifies the letters vertically. This is
-- different than 'TextAnchoringDistributed' because in some cases such as very little
-- text in a line, it does not justify.
| TextAnchoringTop
-- ^ Anchor the text at the top of the bounding rectangle.
deriving (Eq, Show, Generic)
instance NFData TextAnchoring
-- See 21.1.2.2.6 "p (Text Paragraphs)" (p. 3211)
data TextParagraph = TextParagraph
{ _txpaDefCharProps :: Maybe TextCharacterProperties
, _txpaRuns :: [TextRun]
} deriving (Eq, Show, Generic)
instance NFData TextParagraph
-- | Text character properties
--
-- TODO: kumimoji, lang, altLang, sz, strike, kern, cap, spc,
-- normalizeH, baseline, noProof, dirty, err, smtClean, smtId,
-- bmk, ln, a_EG_FillProperties, a_EG_EffectProperties, highlight,
-- a_EG_TextUnderlineLine, a_EG_TextUnderlineFill, latin, ea, cs,
-- sym, hlinkClick, hlinkMouseOver, rtl, extLst
--
-- See @CT_TextCharacterProperties@ (p. 4039)
data TextCharacterProperties = TextCharacterProperties
{ _txchBold :: Bool
, _txchItalic :: Bool
, _txchUnderline :: Bool
} deriving (Eq, Show, Generic)
instance NFData TextCharacterProperties
-- | Text run
--
-- TODO: br, fld
data TextRun = RegularRun
{ _txrCharProps :: Maybe TextCharacterProperties
, _txrText :: Text
} deriving (Eq, Show, Generic)
instance NFData TextRun
-- | This simple type represents a one dimensional position or length
--
-- See 20.1.10.16 "ST_Coordinate (Coordinate)" (p. 2921)
data Coordinate
= UnqCoordinate Int
-- ^ see 20.1.10.19 "ST_CoordinateUnqualified (Coordinate)" (p. 2922)
| UniversalMeasure UnitIdentifier
Double
-- ^ see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793)
deriving (Eq, Show, Generic)
instance NFData Coordinate
-- | Units used in "Universal measure" coordinates
-- see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793)
data UnitIdentifier
= UnitCm -- "cm" As defined in ISO 31.
| UnitMm -- "mm" As defined in ISO 31.
| UnitIn -- "in" 1 in = 2.54 cm (informative)
| UnitPt -- "pt" 1 pt = 1/72 in (informative)
| UnitPc -- "pc" 1 pc = 12 pt (informative)
| UnitPi -- "pi" 1 pi = 12 pt (informative)
deriving (Eq, Show, Generic)
instance NFData UnitIdentifier
-- See @CT_Point2D@ (p. 3989)
data Point2D = Point2D
{ _pt2dX :: Coordinate
, _pt2dY :: Coordinate
} deriving (Eq, Show, Generic)
instance NFData Point2D
unqPoint2D :: Int -> Int -> Point2D
unqPoint2D x y = Point2D (UnqCoordinate x) (UnqCoordinate y)
-- | Positive position or length in EMUs, maximu allowed value is 27273042316900.
-- see 20.1.10.41 "ST_PositiveCoordinate (Positive Coordinate)" (p. 2942)
newtype PositiveCoordinate =
PositiveCoordinate Integer
deriving (Eq, Ord, Show, Generic)
instance NFData PositiveCoordinate
data PositiveSize2D = PositiveSize2D
{ _ps2dX :: PositiveCoordinate
, _ps2dY :: PositiveCoordinate
} deriving (Eq, Show, Generic)
instance NFData PositiveSize2D
positiveSize2D :: Integer -> Integer -> PositiveSize2D
positiveSize2D x y =
PositiveSize2D (PositiveCoordinate x) (PositiveCoordinate y)
cmSize2D :: Integer -> Integer -> PositiveSize2D
cmSize2D x y = positiveSize2D (cm2emu x) (cm2emu y)
cm2emu :: Integer -> Integer
cm2emu cm = 360000 * cm
-- See 20.1.7.6 "xfrm (2D Transform for Individual Objects)" (p. 2849)
data Transform2D = Transform2D
{ _trRot :: Angle
-- ^ Specifies the rotation of the Graphic Frame.
, _trFlipH :: Bool
-- ^ Specifies a horizontal flip. When true, this attribute defines
-- that the shape is flipped horizontally about the center of its bounding box.
, _trFlipV :: Bool
-- ^ Specifies a vertical flip. When true, this attribute defines
-- that the shape is flipped vetically about the center of its bounding box.
, _trOffset :: Maybe Point2D
-- ^ See 20.1.7.4 "off (Offset)" (p. 2847)
, _trExtents :: Maybe PositiveSize2D
-- ^ See 20.1.7.3 "ext (Extents)" (p. 2846) or
-- 20.5.2.14 "ext (Shape Extent)" (p. 3165)
} deriving (Eq, Show, Generic)
instance NFData Transform2D
-- TODO: custGeom
data Geometry =
PresetGeometry
-- TODO: prst, avList
-- currently uses "rect" with empty avList
deriving (Eq, Show, Generic)
instance NFData Geometry
-- See 20.1.2.2.35 "spPr (Shape Properties)" (p. 2751)
data ShapeProperties = ShapeProperties
{ _spXfrm :: Maybe Transform2D
, _spGeometry :: Maybe Geometry
, _spFill :: Maybe FillProperties
, _spOutline :: Maybe LineProperties
-- TODO: bwMode, a_EG_EffectProperties, scene3d, sp3d, extLst
} deriving (Eq, Show, Generic)
instance NFData ShapeProperties
-- | Specifies an outline style that can be applied to a number of
-- different objects such as shapes and text.
--
-- TODO: cap, cmpd, algn, a_EG_LineDashProperties,
-- a_EG_LineJoinProperties, headEnd, tailEnd, extLst
--
-- See 20.1.2.2.24 "ln (Outline)" (p. 2744)
data LineProperties = LineProperties
{ _lnFill :: Maybe FillProperties
, _lnWidth :: Int
-- ^ Specifies the width to be used for the underline stroke. The
-- value is in EMU, is greater of equal to 0 and maximum value is
-- 20116800.
} deriving (Eq, Show, Generic)
instance NFData LineProperties
-- | Color choice for some drawing element
--
-- TODO: scrgbClr, hslClr, sysClr, schemeClr, prstClr
--
-- See @EG_ColorChoice@ (p. 3996)
data ColorChoice =
RgbColor Text
-- ^ Specifies a color using the red, green, blue RGB color
-- model. Red, green, and blue is expressed as sequence of hex
-- digits, RRGGBB. A perceptual gamma of 2.2 is used.
--
-- See 20.1.2.3.32 "srgbClr (RGB Color Model - Hex Variant)" (p. 2773)
deriving (Eq, Show, Generic)
instance NFData ColorChoice
-- TODO: gradFill, pattFill
data FillProperties =
NoFill
-- ^ See 20.1.8.44 "noFill (No Fill)" (p. 2872)
| SolidFill (Maybe ColorChoice)
-- ^ Solid fill
-- See 20.1.8.54 "solidFill (Solid Fill)" (p. 2879)
deriving (Eq, Show, Generic)
instance NFData FillProperties
-- | solid fill with color specified by hexadecimal RGB color
solidRgb :: Text -> FillProperties
solidRgb t = SolidFill . Just $ RgbColor t
makeLenses ''ShapeProperties
{-------------------------------------------------------------------------------
Default instances
-------------------------------------------------------------------------------}
instance Default ShapeProperties where
def = ShapeProperties Nothing Nothing Nothing Nothing
instance Default LineProperties where
def = LineProperties Nothing 0
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
instance FromCursor TextBody where
fromCursor cur = do
cur' <- cur $/ element (a_ "bodyPr")
_txbdRotation <- fromAttributeDef "rot" (Angle 0) cur'
_txbdSpcFirstLastPara <- fromAttributeDef "spcFirstLastPara" False cur'
_txbdVertOverflow <- fromAttributeDef "vertOverflow" TextVertOverflow cur'
_txbdVertical <- fromAttributeDef "vert" TextVerticalHorz cur'
_txbdWrap <- fromAttributeDef "wrap" TextWrapSquare cur'
_txbdAnchor <- fromAttributeDef "anchor" TextAnchoringTop cur'
_txbdAnchorCenter <- fromAttributeDef "anchorCtr" False cur'
let _txbdParagraphs = cur $/ element (a_ "p") >=> fromCursor
return TextBody {..}
instance FromCursor TextParagraph where
fromCursor cur = do
let _txpaDefCharProps =
join . listToMaybe $
cur $/ element (a_ "pPr") >=> maybeFromElement (a_ "defRPr")
_txpaRuns = cur $/ element (a_ "r") >=> fromCursor
return TextParagraph {..}
instance FromCursor TextCharacterProperties where
fromCursor cur = do
_txchBold <- fromAttributeDef "b" False cur
_txchItalic <- fromAttributeDef "i" False cur
_txchUnderline <- fromAttributeDef "u" False cur
return TextCharacterProperties {..}
instance FromCursor TextRun where
fromCursor cur = do
_txrCharProps <- maybeFromElement (a_ "rPr") cur
_txrText <- cur $/ element (a_ "t") &/ content
return RegularRun {..}
-- See 20.1.10.3 "ST_Angle (Angle)" (p. 2912)
instance FromAttrVal Angle where
fromAttrVal t = first Angle <$> fromAttrVal t
-- See 20.1.10.83 "ST_TextVertOverflowType (Text Vertical Overflow)" (p. 3083)
instance FromAttrVal TextVertOverflow where
fromAttrVal "overflow" = readSuccess TextVertOverflow
fromAttrVal "ellipsis" = readSuccess TextVertOverflowEllipsis
fromAttrVal "clip" = readSuccess TextVertOverflowClip
fromAttrVal t = invalidText "TextVertOverflow" t
instance FromAttrVal TextVertical where
fromAttrVal "horz" = readSuccess TextVerticalHorz
fromAttrVal "vert" = readSuccess TextVertical
fromAttrVal "vert270" = readSuccess TextVertical270
fromAttrVal "wordArtVert" = readSuccess TextVerticalWordArt
fromAttrVal "eaVert" = readSuccess TextVerticalEA
fromAttrVal "mongolianVert" = readSuccess TextVerticalMongolian
fromAttrVal "wordArtVertRtl" = readSuccess TextVerticalWordArtRtl
fromAttrVal t = invalidText "TextVertical" t
instance FromAttrVal TextWrap where
fromAttrVal "none" = readSuccess TextWrapNone
fromAttrVal "square" = readSuccess TextWrapSquare
fromAttrVal t = invalidText "TextWrap" t
-- See 20.1.10.59 "ST_TextAnchoringType (Text Anchoring Types)" (p. 3058)
instance FromAttrVal TextAnchoring where
fromAttrVal "t" = readSuccess TextAnchoringTop
fromAttrVal "ctr" = readSuccess TextAnchoringCenter
fromAttrVal "b" = readSuccess TextAnchoringBottom
fromAttrVal "just" = readSuccess TextAnchoringJustified
fromAttrVal "dist" = readSuccess TextAnchoringDistributed
fromAttrVal t = invalidText "TextAnchoring" t
instance FromCursor ShapeProperties where
fromCursor cur = do
_spXfrm <- maybeFromElement (a_ "xfrm") cur
let _spGeometry = listToMaybe $ cur $/ anyElement >=> fromCursor
_spFill = listToMaybe $ cur $/ anyElement >=> fillPropsFromNode . node
_spOutline <- maybeFromElement (a_ "ln") cur
return ShapeProperties {..}
instance FromCursor Transform2D where
fromCursor cur = do
_trRot <- fromAttributeDef "rot" (Angle 0) cur
_trFlipH <- fromAttributeDef "flipH" False cur
_trFlipV <- fromAttributeDef "flipV" False cur
_trOffset <- maybeFromElement (a_ "off") cur
_trExtents <- maybeFromElement (a_ "ext") cur
return Transform2D{..}
instance FromCursor Geometry where
fromCursor = geometryFromNode . node
geometryFromNode :: Node -> [Geometry]
geometryFromNode n | n `nodeElNameIs` a_ "prstGeom" =
return PresetGeometry
| otherwise = fail "no matching geometry node"
instance FromCursor LineProperties where
fromCursor cur = do
let _lnFill = listToMaybe $ cur $/ anyElement >=> fromCursor
_lnWidth <- fromAttributeDef "w" 0 cur
return LineProperties{..}
instance FromCursor Point2D where
fromCursor cur = do
x <- coordinate =<< fromAttribute "x" cur
y <- coordinate =<< fromAttribute "y" cur
return $ Point2D x y
instance FromCursor PositiveSize2D where
fromCursor cur = do
cx <- PositiveCoordinate <$> fromAttribute "cx" cur
cy <- PositiveCoordinate <$> fromAttribute "cy" cur
return $ PositiveSize2D cx cy
instance FromCursor FillProperties where
fromCursor = fillPropsFromNode . node
fillPropsFromNode :: Node -> [FillProperties]
fillPropsFromNode n
| n `nodeElNameIs` a_ "noFill" = return NoFill
| n `nodeElNameIs` a_ "solidFill" = do
let color =
listToMaybe $ fromNode n $/ anyElement >=> colorChoiceFromNode . node
return $ SolidFill color
| otherwise = fail "no matching line fill node"
colorChoiceFromNode :: Node -> [ColorChoice]
colorChoiceFromNode n
| n `nodeElNameIs` a_ "srgbClr" = do
val <- fromAttribute "val" $ fromNode n
return $ RgbColor val
| otherwise = fail "no matching color choice node"
coordinate :: MonadFail m => Text -> m Coordinate
coordinate t = case T.decimal t of
Right (d, leftover) | leftover == T.empty ->
return $ UnqCoordinate d
_ ->
case T.rational t of
Right (r, "cm") -> return $ UniversalMeasure UnitCm r
Right (r, "mm") -> return $ UniversalMeasure UnitMm r
Right (r, "in") -> return $ UniversalMeasure UnitIn r
Right (r, "pt") -> return $ UniversalMeasure UnitPt r
Right (r, "pc") -> return $ UniversalMeasure UnitPc r
Right (r, "pi") -> return $ UniversalMeasure UnitPi r
_ -> fail $ "invalid coordinate: " ++ show t
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
instance ToElement TextBody where
toElement nm TextBody {..} = elementListSimple nm (bodyPr : paragraphs)
where
bodyPr = leafElement (a_ "bodyPr") bodyPrAttrs
bodyPrAttrs =
catMaybes
[ "rot" .=? justNonDef (Angle 0) _txbdRotation
, "spcFirstLastPara" .=? justTrue _txbdSpcFirstLastPara
, "vertOverflow" .=? justNonDef TextVertOverflow _txbdVertOverflow
, "vert" .=? justNonDef TextVerticalHorz _txbdVertical
, "wrap" .=? justNonDef TextWrapSquare _txbdWrap
, "anchor" .=? justNonDef TextAnchoringTop _txbdAnchor
, "anchorCtr" .=? justTrue _txbdAnchorCenter
]
paragraphs = map (toElement (a_ "p")) _txbdParagraphs
instance ToElement TextParagraph where
toElement nm TextParagraph {..} = elementListSimple nm elements
where
elements =
case _txpaDefCharProps of
Just props -> (defRPr props) : runs
Nothing -> runs
defRPr props =
elementListSimple (a_ "pPr") [toElement (a_ "defRPr") props]
runs = map (toElement (a_ "r")) _txpaRuns
instance ToElement TextCharacterProperties where
toElement nm TextCharacterProperties {..} = leafElement nm attrs
where
attrs = ["b" .= _txchBold, "i" .= _txchItalic, "u" .= _txchUnderline]
instance ToElement TextRun where
toElement nm RegularRun {..} = elementListSimple nm elements
where
elements =
catMaybes
[ toElement (a_ "rPr") <$> _txrCharProps
, Just $ elementContent (a_ "t") _txrText
]
instance ToAttrVal TextVertOverflow where
toAttrVal TextVertOverflow = "overflow"
toAttrVal TextVertOverflowEllipsis = "ellipsis"
toAttrVal TextVertOverflowClip = "clip"
instance ToAttrVal TextVertical where
toAttrVal TextVerticalHorz = "horz"
toAttrVal TextVertical = "vert"
toAttrVal TextVertical270 = "vert270"
toAttrVal TextVerticalWordArt = "wordArtVert"
toAttrVal TextVerticalEA = "eaVert"
toAttrVal TextVerticalMongolian = "mongolianVert"
toAttrVal TextVerticalWordArtRtl = "wordArtVertRtl"
instance ToAttrVal TextWrap where
toAttrVal TextWrapNone = "none"
toAttrVal TextWrapSquare = "square"
-- See 20.1.10.59 "ST_TextAnchoringType (Text Anchoring Types)" (p. 3058)
instance ToAttrVal TextAnchoring where
toAttrVal TextAnchoringTop = "t"
toAttrVal TextAnchoringCenter = "ctr"
toAttrVal TextAnchoringBottom = "b"
toAttrVal TextAnchoringJustified = "just"
toAttrVal TextAnchoringDistributed = "dist"
instance ToAttrVal Angle where
toAttrVal (Angle x) = toAttrVal x
instance ToElement ShapeProperties where
toElement nm ShapeProperties{..} = elementListSimple nm elements
where
elements = catMaybes [ toElement (a_ "xfrm") <$> _spXfrm
, geometryToElement <$> _spGeometry
, fillPropsToElement <$> _spFill
, toElement (a_ "ln") <$> _spOutline ]
instance ToElement Point2D where
toElement nm Point2D{..} = leafElement nm [ "x" .= _pt2dX
, "y" .= _pt2dY
]
instance ToElement PositiveSize2D where
toElement nm PositiveSize2D{..} = leafElement nm [ "cx" .= _ps2dX
, "cy" .= _ps2dY ]
instance ToAttrVal Coordinate where
toAttrVal (UnqCoordinate x) = toAttrVal x
toAttrVal (UniversalMeasure unit x) = toAttrVal x <> unitToText unit
where
unitToText UnitCm = "cm"
unitToText UnitMm = "mm"
unitToText UnitIn = "in"
unitToText UnitPt = "pt"
unitToText UnitPc = "pc"
unitToText UnitPi = "pi"
instance ToAttrVal PositiveCoordinate where
toAttrVal (PositiveCoordinate x) = toAttrVal x
instance ToElement Transform2D where
toElement nm Transform2D{..} = elementList nm attrs elements
where
attrs = catMaybes [ "rot" .=? justNonDef (Angle 0) _trRot
, "flipH" .=? justTrue _trFlipH
, "flipV" .=? justTrue _trFlipV ]
elements = catMaybes [ toElement (a_ "off") <$> _trOffset
, toElement (a_ "ext") <$> _trExtents ]
geometryToElement :: Geometry -> Element
geometryToElement PresetGeometry =
leafElement (a_ "prstGeom") ["prst" .= ("rect" :: Text)]
instance ToElement LineProperties where
toElement nm LineProperties {..} = elementList nm attrs elements
where
attrs = catMaybes ["w" .=? justNonDef 0 _lnWidth]
elements = catMaybes [fillPropsToElement <$> _lnFill]
fillPropsToElement :: FillProperties -> Element
fillPropsToElement NoFill = emptyElement (a_ "noFill")
fillPropsToElement (SolidFill color) =
elementListSimple (a_ "solidFill") $ catMaybes [colorChoiceToElement <$> color]
colorChoiceToElement :: ColorChoice -> Element
colorChoiceToElement (RgbColor color) =
leafElement (a_ "srgbClr") ["val" .= color]
-- | Add DrawingML namespace to name
a_ :: Text -> Name
a_ x =
Name {nameLocalName = x, nameNamespace = Just drawingNs, namePrefix = Just "a"}
drawingNs :: Text
drawingNs = "http://schemas.openxmlformats.org/drawingml/2006/main"
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Internal.hs 0000644 0000000 0000000 00000001212 14551273353 017021 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Codec.Xlsx.Types.Internal where
import Control.Arrow
import Data.Monoid ((<>))
import Data.Text (Text)
import GHC.Generics (Generic)
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Writer.Internal
newtype RefId = RefId { unRefId :: Text } deriving (Eq, Ord, Show, Generic)
instance ToAttrVal RefId where
toAttrVal = toAttrVal . unRefId
instance FromAttrVal RefId where
fromAttrVal t = first RefId <$> fromAttrVal t
instance FromAttrBs RefId where
fromAttrBs = fmap RefId . fromAttrBs
unsafeRefId :: Int -> RefId
unsafeRefId num = RefId $ "rId" <> txti num
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Internal/CfPair.hs 0000644 0000000 0000000 00000002361 14551273353 020173 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Internal.CfPair where
import GHC.Generics (Generic)
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, Generic)
instance FromCursor CfPair where
fromCursor cur = do
sqref <- fromAttribute "sqref" cur
let cfRules = cur $/ element (n_ "cfRule") >=> fromCursor
return $ CfPair (sqref, cfRules)
instance FromXenoNode CfPair where
fromXenoNode root = do
sqref <- parseAttributes root $ fromAttr "sqref"
cfRules <- collectChildren root $ fromChildList "cfRule"
return $ CfPair (sqref, cfRules)
instance ToElement CfPair where
toElement nm (CfPair (sqRef, cfRules)) =
elementList nm [ "sqref" .= toAttrVal sqRef ]
(map (toElement "cfRule") cfRules)
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Internal/CommentTable.hs 0000644 0000000 0000000 00000012174 14551273353 021404 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Internal.CommentTable where
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as LBC8
import Data.List.Extra (nubOrd)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Lazy (toStrict)
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B
import GHC.Generics (Generic)
import Safe
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Comment
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Writer.Internal
newtype CommentTable = CommentTable
{ _commentsTable :: Map CellRef Comment }
deriving (Eq, Show, Generic)
tshow :: Show a => a -> Text
tshow = Text.pack . show
fromList :: [(CellRef, Comment)] -> CommentTable
fromList = CommentTable . M.fromList
toList :: CommentTable -> [(CellRef, Comment)]
toList = M.toList . _commentsTable
lookupComment :: CellRef -> CommentTable -> Maybe Comment
lookupComment ref = M.lookup ref . _commentsTable
instance ToDocument CommentTable where
toDocument = documentFromElement "Sheet comments generated by xlsx"
. toElement "comments"
instance ToElement CommentTable where
toElement nm (CommentTable m) = Element
{ elementName = nm
, elementAttributes = M.empty
, elementNodes = [ NodeElement $ elementListSimple "authors" authorNodes
, NodeElement . elementListSimple "commentList" $ map commentToEl (M.toList m) ]
}
where
commentToEl (ref, Comment{..}) = Element
{ elementName = "comment"
, elementAttributes = M.fromList [ ("ref" .= ref)
, ("authorId" .= lookupAuthor _commentAuthor)
, ("visible" .= tshow _commentVisible)]
, elementNodes = [NodeElement $ toElement "text" _commentText]
}
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 = 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") >=> contentOrEmpty
authors = M.fromList $ zip [0..] authorNames
items = cur $/ element (n_ "commentList") &/ element (n_ "comment") >=> parseComment authors
return . CommentTable $ M.fromList items
parseComment :: Map Int Text -> Cursor -> [(CellRef, Comment)]
parseComment authors cur = do
ref <- fromAttribute "ref" cur
txt <- cur $/ element (n_ "text") >=> fromCursor
authorId <- cur $| attribute "authorId" >=> decimal
visible <- (read . Text.unpack :: Text -> Bool)
<$> (fromAttribute "visible" cur :: [Text])
let author = fromJustNote "authorId" $ M.lookup authorId authors
return (ref, Comment txt author visible)
-- | helper to render comment baloons vml file,
-- currently uses fixed shape
renderShapes :: CommentTable -> ByteString
renderShapes (CommentTable m) = LB.concat
[ ""
, commentShapeType
, LB.concat commentShapes
, ""
]
where
commentShapeType = LB.concat
[ ""
, ""
, ""
, ""
]
fromRef cr =
fromJustNote ("Invalid comment ref: " <> show cr) $ fromSingleCellRef cr
commentShapes = [ commentShape (fromRef ref) (_commentVisible cmnt)
| (ref, cmnt) <- M.toList m ]
commentShape (r, c) v = LB.concat
[ ""
, ""
, ""
, ""
, ""
, ""
, "4, 15, 0, 7, 6, 31, 5, 1False"
, ""
, LBC8.pack $ show (r - 1)
, ""
, ""
, LBC8.pack $ show (c - 1)
, ""
, ""
, ""
]
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Internal/ContentTypes.hs 0000644 0000000 0000000 00000004413 14551273353 021466 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Internal.ContentTypes where
import Control.Arrow
import Data.Foldable (asum)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import System.FilePath.Posix (takeExtension)
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
data CtDefault = CtDefault
{ dfltExtension :: FilePath
, dfltContentType :: Text
} deriving (Eq, Show, Generic)
data Override = Override
{ ovrPartName :: FilePath
, ovrContentType :: Text
} deriving (Eq, Show, Generic)
data ContentTypes = ContentTypes
{ ctDefaults :: Map FilePath Text
, ctTypes :: Map FilePath Text
} deriving (Eq, Show, Generic)
lookup :: FilePath -> ContentTypes -> Maybe Text
lookup path ContentTypes{..} =
asum [ flip M.lookup ctDefaults =<< ext, M.lookup path ctTypes ]
where
ext = case takeExtension path of
'.':e -> Just e
_ -> Nothing
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
instance FromCursor ContentTypes where
fromCursor cur = do
let ds = M.fromList . map (dfltExtension &&& dfltContentType) $
cur $/ element (ct"Default") >=> fromCursor
ts = M.fromList . map (ovrPartName &&& ovrContentType) $
cur $/ element (ct"Override") >=> fromCursor
return (ContentTypes ds ts)
instance FromCursor CtDefault where
fromCursor cur = do
dfltExtension <- T.unpack <$> attribute "Extension" cur
dfltContentType <- attribute "ContentType" cur
return CtDefault{..}
instance FromCursor Override where
fromCursor cur = do
ovrPartName <- T.unpack <$> attribute "PartName" cur
ovrContentType <- attribute "ContentType" cur
return Override{..}
-- | Add package relationship namespace to name
ct :: Text -> Name
ct x = Name
{ nameLocalName = x
, nameNamespace = Just contentTypesNs
, namePrefix = Nothing
}
contentTypesNs :: Text
contentTypesNs = "http://schemas.openxmlformats.org/package/2006/content-types"
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Internal/CustomProperties.hs 0000644 0000000 0000000 00000005272 14551273353 022362 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Internal.CustomProperties where
import Data.Map (Map)
import qualified Data.Map as M
import Data.Text (Text)
import GHC.Generics (Generic)
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Variant
import Codec.Xlsx.Writer.Internal
newtype CustomProperties = CustomProperties (Map Text Variant)
deriving (Eq, Show, Generic)
fromList :: [(Text, Variant)] -> CustomProperties
fromList = CustomProperties . M.fromList
empty :: CustomProperties
empty = CustomProperties M.empty
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
instance FromCursor CustomProperties where
fromCursor cur = do
let items = cur $/ element (cpr"property") >=> parseCustomPropertyEntry
return (fromList items)
parseCustomPropertyEntry :: Cursor -> [(Text, Variant)]
parseCustomPropertyEntry cur = do
name <- attribute "name" cur
value <- cur $/ anyElement >=> fromCursor
return (name, value)
-- | Add custom properties namespace to name
cpr :: Text -> Name
cpr x = Name
{ nameLocalName = x
, nameNamespace = Just custPropNs
, namePrefix = Nothing
}
custPropNs :: Text
custPropNs = "http://schemas.openxmlformats.org/officeDocument/2006/custom-properties"
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
instance ToDocument CustomProperties where
toDocument =
documentFromNsElement "Custom properties generated by xlsx"
"http://schemas.openxmlformats.org/officeDocument/2006/custom-properties"
. toElement "Properties"
instance ToElement CustomProperties where
toElement nm (CustomProperties m) = Element
{ elementName = nm
, elementAttributes = M.empty
, elementNodes = map (NodeElement . toElement "property" . CustomProperty)
. zip [2..] $ M.toList m
}
newtype CustomProperty = CustomProperty (Int, (Text, Variant))
instance ToElement CustomProperty where
toElement nm (CustomProperty (i, (key, val))) = Element
{ elementName = nm
, elementAttributes = M.fromList [ "name" .= key
, "fmtid" .= userDefinedFmtID
, "pid" .= txti i ]
, elementNodes = [ NodeElement $ variantToElement val ]
}
-- | FMTID_UserDefinedProperties
userDefinedFmtID :: Text
userDefinedFmtID = "{D5CDD505-2E9C-101B-9397-08002B2CF9AE}"
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Internal/DvPair.hs 0000644 0000000 0000000 00000002141 14551273353 020210 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Internal.DvPair where
import qualified Data.Map as M
import GHC.Generics (Generic)
import Text.XML (Element(..))
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Types.DataValidation
import Codec.Xlsx.Writer.Internal
-- | Internal helper type for parsing data validation records
--
-- See 18.3.1.32 "dataValidation (Data Validation)" (p. 1614/1624)
newtype DvPair = DvPair
{ unDvPair :: (SqRef, DataValidation)
} deriving (Eq, Show, Generic)
instance FromCursor DvPair where
fromCursor cur = do
sqref <- fromAttribute "sqref" cur
dv <- fromCursor cur
return $ DvPair (sqref, dv)
instance FromXenoNode DvPair where
fromXenoNode root = do
sqref <- parseAttributes root $ fromAttr "sqref"
dv <- fromXenoNode root
return $ DvPair (sqref, dv)
instance ToElement DvPair where
toElement nm (DvPair (sqRef,dv)) = e
{elementAttributes = M.insert "sqref" (toAttrVal sqRef) $ elementAttributes e}
where
e = toElement nm dv
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Internal/FormulaData.hs 0000644 0000000 0000000 00000003173 14551273353 021230 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Codec.Xlsx.Types.Internal.FormulaData where
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Cell
import Codec.Xlsx.Types.Common
data FormulaData = FormulaData
{ frmdFormula :: CellFormula
, frmdShared :: Maybe (SharedFormulaIndex, SharedFormulaOptions)
} deriving Generic
defaultFormulaType :: Text
defaultFormulaType = "normal"
instance FromXenoNode FormulaData where
fromXenoNode n = do
(bx, ca, t, mSi, mRef) <-
parseAttributes n $
(,,,,) <$> fromAttrDef "bx" False
<*> fromAttrDef "ca" False
<*> fromAttrDef "t" defaultFormulaType
<*> maybeAttr "si"
<*> maybeAttr "ref"
(expr, shared) <-
case t of
d | d == defaultFormulaType -> do
formula <- contentX n
return (NormalFormula $ Formula formula, Nothing)
"shared" -> do
si <-
maybe
(Left "missing si attribute for shared formula")
return
mSi
formula <- Formula <$> contentX n
return
( SharedFormula si
, mRef >>= \ref -> return (si, (SharedFormulaOptions ref formula)))
unexpected -> Left $ "Unexpected formula type" <> T.pack (show unexpected)
let f =
CellFormula
{ _cellfAssignsToName = bx
, _cellfCalculate = ca
, _cellfExpression = expr
}
return $ FormulaData f shared
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Internal/Relationships.hs 0000644 0000000 0000000 00000011305 14551273353 021651 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Internal.Relationships where
import Data.List (find)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Network.URI hiding (path)
import Prelude hiding (abs, lookup)
import Safe
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Internal
import Codec.Xlsx.Writer.Internal
data Relationship = Relationship
{ relType :: Text
, relTarget :: FilePath
} deriving (Eq, Show, Generic)
-- | Describes relationships according to Open Packaging Convention
--
-- See ECMA-376, 4th Edition Office Open XML File Formats — Open Packaging
-- Conventions
newtype Relationships = Relationships
{ relMap :: Map RefId Relationship
} deriving (Eq, Show, Generic)
fromList :: [(RefId, Relationship)] -> Relationships
fromList = Relationships . Map.fromList
empty :: Relationships
empty = fromList []
size :: Relationships -> Int
size = Map.size . relMap
relEntry :: RefId -> Text -> FilePath -> (RefId, Relationship)
relEntry rId typ trg = (rId, Relationship (stdRelType typ) trg)
lookup :: RefId -> Relationships -> Maybe Relationship
lookup ref = Map.lookup ref . relMap
setTargetsFrom :: FilePath -> Relationships -> Relationships
setTargetsFrom fp (Relationships m) = Relationships (Map.map fixPath m)
where
fixPath rel = rel{ relTarget = fp `joinRel` relTarget rel}
-- | joins relative URI (actually a file path as an internal relation target)
joinRel :: FilePath -> FilePath -> FilePath
joinRel abs rel = uriToString id (relPath `nonStrictRelativeTo` base) ""
where
base = fromJustNote "joinRel base path" $ parseURIReference abs
relPath = fromJustNote "joinRel relative path" $ parseURIReference rel
relFrom :: FilePath -> FilePath -> FilePath
relFrom path base = uriToString id (pathURI `relativeFrom` baseURI) ""
where
baseURI = fromJustNote "joinRel base path" $ parseURIReference base
pathURI = fromJustNote "joinRel relative path" $ parseURIReference path
findRelByType :: Text -> Relationships -> Maybe Relationship
findRelByType t (Relationships m) = find ((==t) . relType) (Map.elems m)
allByType :: Text -> Relationships -> [Relationship]
allByType t (Relationships m) = filter ((==t) . relType) (Map.elems m)
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
instance ToDocument Relationships where
toDocument = documentFromNsElement "Relationships generated by xlsx" pkgRelNs
. toElement "Relationships"
instance ToElement Relationships where
toElement nm Relationships{..} = Element
{ elementName = nm
, elementAttributes = Map.empty
, elementNodes = map (NodeElement . relToEl "Relationship") $
Map.toList relMap
}
where
relToEl nm' (relId, rel) = setAttr "Id" relId (toElement nm' rel)
instance ToElement Relationship where
toElement nm Relationship{..} = Element
{ elementName = nm
, elementAttributes = Map.fromList [ "Target" .= relTarget
, "Type" .= relType ]
, elementNodes = []
}
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
instance FromCursor Relationships where
fromCursor cur = do
let items = cur $/ element (pr"Relationship") >=> parseRelEntry
return . Relationships $ Map.fromList items
parseRelEntry :: Cursor -> [(RefId, Relationship)]
parseRelEntry cur = do
rel <- fromCursor cur
rId <- attribute "Id" cur
return (RefId rId, rel)
instance FromCursor Relationship where
fromCursor cur = do
ty <- attribute "Type" cur
trg <- T.unpack <$> attribute "Target" cur
return $ Relationship ty trg
-- | Add package relationship namespace to name
pr :: Text -> Name
pr x = Name
{ nameLocalName = x
, nameNamespace = Just pkgRelNs
, namePrefix = Nothing
}
-- | Add office document relationship namespace to name
odr :: Text -> Name
odr x = Name
{ nameLocalName = x
, nameNamespace = Just odRelNs
, namePrefix = Nothing
}
odRelNs :: Text
odRelNs = "http://schemas.openxmlformats.org/officeDocument/2006/relationships"
pkgRelNs :: Text
pkgRelNs = "http://schemas.openxmlformats.org/package/2006/relationships"
stdRelType :: Text -> Text
stdRelType t = stdPart <> t
where
stdPart = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/"
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs 0000644 0000000 0000000 00000010331 14551553042 022364 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Internal.SharedStringTable (
-- * Main types
SharedStringTable(..)
, sstConstruct
, sstLookupText
, sstLookupRich
, sstItem
, sstEmpty
) where
import Control.Monad
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 GHC.Generics (Generic)
import Numeric.Search.Range (searchFromTo)
import Safe (fromJustNote)
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types
import Codec.Xlsx.Writer.Internal
-- | Shared string table
--
-- A workbook can contain thousands of cells containing string (non-numeric)
-- data. Furthermore this data is very likely to be repeated across many rows or
-- columns. The goal of implementing a single string table that is shared across
-- the workbook is to improve performance in opening and saving the file by only
-- reading and writing the repetitive information once.
--
-- Relevant parts of the EMCA standard (2nd edition, part 1,
-- ),
-- page numbers refer to the page in the PDF rather than the page number as
-- printed on the page):
--
-- * Section 18.4, "Shared String Table" (p. 1712)
-- in particular subsection 18.4.9, "sst (Shared String Table)" (p. 1726)
--
-- TODO: The @extLst@ child element is currently unsupported.
newtype SharedStringTable = SharedStringTable {
sstTable :: Vector XlsxText
}
deriving (Eq, Ord, Show, Generic)
sstEmpty :: SharedStringTable
sstEmpty = SharedStringTable V.empty
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
instance ToDocument SharedStringTable where
toDocument = documentFromElement "Shared string table generated by xlsx"
. toElement "sst"
-- | See @CT_Sst@, p. 3902.
--
-- TODO: The @count@ and @uniqCount@ attributes are currently unsupported.
instance ToElement SharedStringTable where
toElement nm SharedStringTable{..} = Element {
elementName = nm
, elementAttributes = Map.empty
, elementNodes = map (NodeElement . toElement "si")
$ V.toList sstTable
}
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
-- | See @CT_Sst@, p. 3902
--
-- The optional attributes @count@ and @uniqCount@ are being ignored at least currently
instance FromCursor SharedStringTable where
fromCursor cur = do
let
items = cur $/ element (n_ "si") >=> fromCursor
return (SharedStringTable (V.fromList items))
{-------------------------------------------------------------------------------
Extract shared strings
-------------------------------------------------------------------------------}
-- | Construct the 'SharedStringsTable' from an existing document
sstConstruct :: [Worksheet] -> SharedStringTable
sstConstruct =
SharedStringTable . V.fromList . uniq . concatMap goSheet
where
goSheet :: Worksheet -> [XlsxText]
goSheet = mapMaybe (_cellValue >=> sstEntry) . Map.elems . _wsCells
sstEntry :: CellValue -> Maybe XlsxText
sstEntry (CellText text) = Just $ XlsxText text
sstEntry (CellRich rich) = Just $ XlsxRichText rich
sstEntry _ = Nothing
uniq :: Ord a => [a] -> [a]
uniq = Set.elems . Set.fromList
sstLookupText :: SharedStringTable -> Text -> Int
sstLookupText sst = sstLookup sst . XlsxText
sstLookupRich :: SharedStringTable -> [RichTextRun] -> Int
sstLookupRich sst = sstLookup sst . XlsxRichText
-- | Internal generalization used by 'sstLookupText' and 'sstLookupRich'
sstLookup :: SharedStringTable -> XlsxText -> Int
sstLookup SharedStringTable{sstTable = shared} si =
fromJustNote ("SST entry for " ++ show si ++ " not found") $
searchFromTo (\p -> shared V.! p >= si) 0 (V.length shared - 1)
sstItem :: SharedStringTable -> Int -> Maybe XlsxText
sstItem (SharedStringTable shared) = (V.!?) shared
xlsx-1.1.2.2/src/Codec/Xlsx/Types/PageSetup.hs 0000644 0000000 0000000 00000071036 14551273353 017155 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.PageSetup (
-- * Main types
PageSetup(..)
-- * Enumerations
, CellComments(..)
, PrintErrors(..)
, Orientation(..)
, PageOrder(..)
, PaperSize(..)
-- * Lenses
-- ** PageSetup
, pageSetupBlackAndWhite
, pageSetupCellComments
, pageSetupCopies
, pageSetupDraft
, pageSetupErrors
, pageSetupFirstPageNumber
, pageSetupFitToHeight
, pageSetupFitToWidth
, pageSetupHorizontalDpi
, pageSetupId
, pageSetupOrientation
, pageSetupPageOrder
, pageSetupPaperHeight
, pageSetupPaperSize
, pageSetupPaperWidth
, pageSetupScale
, pageSetupUseFirstPageNumber
, pageSetupUsePrinterDefaults
, pageSetupVerticalDpi
) where
#ifdef USE_MICROLENS
import Lens.Micro.TH (makeLenses)
#else
import Control.Lens (makeLenses)
#endif
import Control.DeepSeq (NFData)
import Data.Default
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import Data.Text (Text)
import GHC.Generics (Generic)
import Text.XML
import Codec.Xlsx.Writer.Internal
import Codec.Xlsx.Parser.Internal
{-------------------------------------------------------------------------------
Main types
-------------------------------------------------------------------------------}
data PageSetup = PageSetup {
-- | Print black and white.
_pageSetupBlackAndWhite :: Maybe Bool
-- | This attribute specifies how to print cell comments.
, _pageSetupCellComments :: Maybe CellComments
-- | Number of copies to print.
, _pageSetupCopies :: Maybe Int
-- | Print without graphics.
, _pageSetupDraft :: Maybe Bool
-- | Specifies how to print cell values for cells with errors.
, _pageSetupErrors :: Maybe PrintErrors
-- | Page number for first printed page. If no value is specified, then
-- 'automatic' is assumed.
, _pageSetupFirstPageNumber :: Maybe Int
-- | Number of vertical pages to fit on.
, _pageSetupFitToHeight :: Maybe Int
-- | Number of horizontal pages to fit on.
, _pageSetupFitToWidth :: Maybe Int
-- | Horizontal print resolution of the device.
, _pageSetupHorizontalDpi :: Maybe Int
-- | Relationship Id of the devMode printer settings part.
--
-- (Explicit reference to a parent XML element.)
--
-- See 22.8.2.1 "ST_RelationshipId (Explicit Relationship ID)" (p. 3784)
, _pageSetupId :: Maybe Text
-- | Orientation of the page.
, _pageSetupOrientation :: Maybe Orientation
-- | Order of printed pages
, _pageSetupPageOrder :: Maybe PageOrder
-- | Height of custom paper as a number followed by a unit identifier.
--
-- When paperHeight and paperWidth are specified, paperSize shall be ignored.
-- Examples: @"297mm"@, @"11in"@.
--
-- See 22.9.2.12 "ST_PositiveUniversalMeasure (Positive Universal Measurement)" (p. 3792)
, _pageSetupPaperHeight :: Maybe Text
-- | Pager size
--
-- When paperHeight, paperWidth, and paperUnits are specified, paperSize
-- should be ignored.
, _pageSetupPaperSize :: Maybe PaperSize
-- | Width of custom paper as a number followed by a unit identifier
--
-- Examples: @21cm@, @8.5in@
--
-- When paperHeight and paperWidth are specified, paperSize shall be
-- ignored.
, _pageSetupPaperWidth :: Maybe Text
-- | Print scaling.
--
-- This attribute is restricted to values ranging from 10 to 400.
-- This setting is overridden when fitToWidth and/or fitToHeight are in
-- use.
, _pageSetupScale :: Maybe Int
-- | Use '_pageSetupFirstPageNumber' value for first page number, and do
-- not auto number the pages.
, _pageSetupUseFirstPageNumber :: Maybe Bool
-- | Use the printer’s defaults settings for page setup values and don't
-- use the default values specified in the schema.
--
-- Example: If dpi is not present or specified in the XML, the application
-- must not assume 600dpi as specified in the schema as a default and
-- instead must let the printer specify the default dpi.
, _pageSetupUsePrinterDefaults :: Maybe Bool
-- | Vertical print resolution of the device.
, _pageSetupVerticalDpi :: Maybe Int
}
deriving (Eq, Ord, Show, Generic)
instance NFData PageSetup
{-------------------------------------------------------------------------------
Enumerations
-------------------------------------------------------------------------------}
-- | Cell comments
--
-- These enumerations specify how cell comments shall be displayed for paper
-- printing purposes.
--
-- See 18.18.5 "ST_CellComments (Cell Comments)" (p. 2441).
data CellComments =
-- | Print cell comments as displayed
CellCommentsAsDisplayed
-- | Print cell comments at end of document
| CellCommentsAtEnd
-- | Do not print cell comments
| CellCommentsNone
deriving (Eq, Ord, Show, Generic)
instance NFData CellComments
-- | Print errors
--
-- This enumeration specifies how to display cells with errors when printing the
-- worksheet.
data PrintErrors =
-- | Display cell errors as blank
PrintErrorsBlank
-- | Display cell errors as dashes
| PrintErrorsDash
-- | Display cell errors as displayed on screen
| PrintErrorsDisplayed
-- | Display cell errors as @#N/A@
| PrintErrorsNA
deriving (Eq, Ord, Show, Generic)
instance NFData PrintErrors
-- | Print orientation for this sheet
data Orientation =
OrientationDefault
| OrientationLandscape
| OrientationPortrait
deriving (Eq, Ord, Show, Generic)
instance NFData Orientation
-- | Specifies printed page order
data PageOrder =
-- | Order pages vertically first, then move horizontally
PageOrderDownThenOver
-- | Order pages horizontally first, then move vertically
| PageOrderOverThenDown
deriving (Eq, Ord, Show, Generic)
instance NFData PageOrder
-- | Paper size
data PaperSize =
PaperA2 -- ^ A2 paper (420 mm by 594 mm)
| PaperA3 -- ^ A3 paper (297 mm by 420 mm)
| PaperA3Extra -- ^ A3 extra paper (322 mm by 445 mm)
| PaperA3ExtraTransverse -- ^ A3 extra transverse paper (322 mm by 445 mm)
| PaperA3Transverse -- ^ A3 transverse paper (297 mm by 420 mm)
| PaperA4 -- ^ A4 paper (210 mm by 297 mm)
| PaperA4Extra -- ^ A4 extra paper (236 mm by 322 mm)
| PaperA4Plus -- ^ A4 plus paper (210 mm by 330 mm)
| PaperA4Small -- ^ A4 small paper (210 mm by 297 mm)
| PaperA4Transverse -- ^ A4 transverse paper (210 mm by 297 mm)
| PaperA5 -- ^ A5 paper (148 mm by 210 mm)
| PaperA5Extra -- ^ A5 extra paper (174 mm by 235 mm)
| PaperA5Transverse -- ^ A5 transverse paper (148 mm by 210 mm)
| PaperB4 -- ^ B4 paper (250 mm by 353 mm)
| PaperB5 -- ^ B5 paper (176 mm by 250 mm)
| PaperC -- ^ C paper (17 in. by 22 in.)
| PaperD -- ^ D paper (22 in. by 34 in.)
| PaperE -- ^ E paper (34 in. by 44 in.)
| PaperExecutive -- ^ Executive paper (7.25 in. by 10.5 in.)
| PaperFanfoldGermanLegal -- ^ German legal fanfold (8.5 in. by 13 in.)
| PaperFanfoldGermanStandard -- ^ German standard fanfold (8.5 in. by 12 in.)
| PaperFanfoldUsStandard -- ^ US standard fanfold (14.875 in. by 11 in.)
| PaperFolio -- ^ Folio paper (8.5 in. by 13 in.)
| PaperIsoB4 -- ^ ISO B4 (250 mm by 353 mm)
| PaperIsoB5Extra -- ^ ISO B5 extra paper (201 mm by 276 mm)
| PaperJapaneseDoublePostcard -- ^ Japanese double postcard (200 mm by 148 mm)
| PaperJisB5Transverse -- ^ JIS B5 transverse paper (182 mm by 257 mm)
| PaperLedger -- ^ Ledger paper (17 in. by 11 in.)
| PaperLegal -- ^ Legal paper (8.5 in. by 14 in.)
| PaperLegalExtra -- ^ Legal extra paper (9.275 in. by 15 in.)
| PaperLetter -- ^ Letter paper (8.5 in. by 11 in.)
| PaperLetterExtra -- ^ Letter extra paper (9.275 in. by 12 in.)
| PaperLetterExtraTransverse -- ^ Letter extra transverse paper (9.275 in. by 12 in.)
| PaperLetterPlus -- ^ Letter plus paper (8.5 in. by 12.69 in.)
| PaperLetterSmall -- ^ Letter small paper (8.5 in. by 11 in.)
| PaperLetterTransverse -- ^ Letter transverse paper (8.275 in. by 11 in.)
| PaperNote -- ^ Note paper (8.5 in. by 11 in.)
| PaperQuarto -- ^ Quarto paper (215 mm by 275 mm)
| PaperStandard9_11 -- ^ Standard paper (9 in. by 11 in.)
| PaperStandard10_11 -- ^ Standard paper (10 in. by 11 in.)
| PaperStandard10_14 -- ^ Standard paper (10 in. by 14 in.)
| PaperStandard11_17 -- ^ Standard paper (11 in. by 17 in.)
| PaperStandard15_11 -- ^ Standard paper (15 in. by 11 in.)
| PaperStatement -- ^ Statement paper (5.5 in. by 8.5 in.)
| PaperSuperA -- ^ SuperA/SuperA/A4 paper (227 mm by 356 mm)
| PaperSuperB -- ^ SuperB/SuperB/A3 paper (305 mm by 487 mm)
| PaperTabloid -- ^ Tabloid paper (11 in. by 17 in.)
| PaperTabloidExtra -- ^ Tabloid extra paper (11.69 in. by 18 in.)
| Envelope6_3_4 -- ^ 6 3/4 envelope (3.625 in. by 6.5 in.)
| Envelope9 -- ^ #9 envelope (3.875 in. by 8.875 in.)
| Envelope10 -- ^ #10 envelope (4.125 in. by 9.5 in.)
| Envelope11 -- ^ #11 envelope (4.5 in. by 10.375 in.)
| Envelope12 -- ^ #12 envelope (4.75 in. by 11 in.)
| Envelope14 -- ^ #14 envelope (5 in. by 11.5 in.)
| EnvelopeB4 -- ^ B4 envelope (250 mm by 353 mm)
| EnvelopeB5 -- ^ B5 envelope (176 mm by 250 mm)
| EnvelopeB6 -- ^ B6 envelope (176 mm by 125 mm)
| EnvelopeC3 -- ^ C3 envelope (324 mm by 458 mm)
| EnvelopeC4 -- ^ C4 envelope (229 mm by 324 mm)
| EnvelopeC5 -- ^ C5 envelope (162 mm by 229 mm)
| EnvelopeC6 -- ^ C6 envelope (114 mm by 162 mm)
| EnvelopeC65 -- ^ C65 envelope (114 mm by 229 mm)
| EnvelopeDL -- ^ DL envelope (110 mm by 220 mm)
| EnvelopeInvite -- ^ Invite envelope (220 mm by 220 mm)
| EnvelopeItaly -- ^ Italy envelope (110 mm by 230 mm)
| EnvelopeMonarch -- ^ Monarch envelope (3.875 in. by 7.5 in.).
deriving (Eq, Ord, Show, Generic)
instance NFData PaperSize
{-------------------------------------------------------------------------------
Default instances
-------------------------------------------------------------------------------}
instance Default PageSetup where
def = PageSetup {
_pageSetupBlackAndWhite = Nothing
, _pageSetupCellComments = Nothing
, _pageSetupCopies = Nothing
, _pageSetupDraft = Nothing
, _pageSetupErrors = Nothing
, _pageSetupFirstPageNumber = Nothing
, _pageSetupFitToHeight = Nothing
, _pageSetupFitToWidth = Nothing
, _pageSetupHorizontalDpi = Nothing
, _pageSetupId = Nothing
, _pageSetupOrientation = Nothing
, _pageSetupPageOrder = Nothing
, _pageSetupPaperHeight = Nothing
, _pageSetupPaperSize = Nothing
, _pageSetupPaperWidth = Nothing
, _pageSetupScale = Nothing
, _pageSetupUseFirstPageNumber = Nothing
, _pageSetupUsePrinterDefaults = Nothing
, _pageSetupVerticalDpi = Nothing
}
{-------------------------------------------------------------------------------
Lenses
-------------------------------------------------------------------------------}
makeLenses ''PageSetup
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
-- | See @CT_PageSetup@, p. 3922
instance ToElement PageSetup where
toElement nm PageSetup{..} = Element {
elementName = nm
, elementNodes = []
, elementAttributes = Map.fromList . catMaybes $ [
"paperSize" .=? _pageSetupPaperSize
, "paperHeight" .=? _pageSetupPaperHeight
, "paperWidth" .=? _pageSetupPaperWidth
, "scale" .=? _pageSetupScale
, "firstPageNumber" .=? _pageSetupFirstPageNumber
, "fitToWidth" .=? _pageSetupFitToWidth
, "fitToHeight" .=? _pageSetupFitToHeight
, "pageOrder" .=? _pageSetupPageOrder
, "orientation" .=? _pageSetupOrientation
, "usePrinterDefaults" .=? _pageSetupUsePrinterDefaults
, "blackAndWhite" .=? _pageSetupBlackAndWhite
, "draft" .=? _pageSetupDraft
, "cellComments" .=? _pageSetupCellComments
, "useFirstPageNumber" .=? _pageSetupUseFirstPageNumber
, "errors" .=? _pageSetupErrors
, "horizontalDpi" .=? _pageSetupHorizontalDpi
, "verticalDpi" .=? _pageSetupVerticalDpi
, "copies" .=? _pageSetupCopies
, "id" .=? _pageSetupId
]
}
-- | See @ST_CellComments@, p. 3923
instance ToAttrVal CellComments where
toAttrVal CellCommentsNone = "none"
toAttrVal CellCommentsAsDisplayed = "asDisplayed"
toAttrVal CellCommentsAtEnd = "atEnd"
-- | See @ST_PrintError@, p. 3923
instance ToAttrVal PrintErrors where
toAttrVal PrintErrorsDisplayed = "displayed"
toAttrVal PrintErrorsBlank = "blank"
toAttrVal PrintErrorsDash = "dash"
toAttrVal PrintErrorsNA = "NA"
-- | See @ST_Orientation@, p. 3923
instance ToAttrVal Orientation where
toAttrVal OrientationDefault = "default"
toAttrVal OrientationPortrait = "portrait"
toAttrVal OrientationLandscape = "landscape"
-- | See @ST_PageOrder@, p. 3923
instance ToAttrVal PageOrder where
toAttrVal PageOrderDownThenOver = "downThenOver"
toAttrVal PageOrderOverThenDown = "overThenDown"
-- | See @paperSize@ (attribute of @pageSetup@), p. 1659
instance ToAttrVal PaperSize where
toAttrVal PaperLetter = "1"
toAttrVal PaperLetterSmall = "2"
toAttrVal PaperTabloid = "3"
toAttrVal PaperLedger = "4"
toAttrVal PaperLegal = "5"
toAttrVal PaperStatement = "6"
toAttrVal PaperExecutive = "7"
toAttrVal PaperA3 = "8"
toAttrVal PaperA4 = "9"
toAttrVal PaperA4Small = "10"
toAttrVal PaperA5 = "11"
toAttrVal PaperB4 = "12"
toAttrVal PaperB5 = "13"
toAttrVal PaperFolio = "14"
toAttrVal PaperQuarto = "15"
toAttrVal PaperStandard10_14 = "16"
toAttrVal PaperStandard11_17 = "17"
toAttrVal PaperNote = "18"
toAttrVal Envelope9 = "19"
toAttrVal Envelope10 = "20"
toAttrVal Envelope11 = "21"
toAttrVal Envelope12 = "22"
toAttrVal Envelope14 = "23"
toAttrVal PaperC = "24"
toAttrVal PaperD = "25"
toAttrVal PaperE = "26"
toAttrVal EnvelopeDL = "27"
toAttrVal EnvelopeC5 = "28"
toAttrVal EnvelopeC3 = "29"
toAttrVal EnvelopeC4 = "30"
toAttrVal EnvelopeC6 = "31"
toAttrVal EnvelopeC65 = "32"
toAttrVal EnvelopeB4 = "33"
toAttrVal EnvelopeB5 = "34"
toAttrVal EnvelopeB6 = "35"
toAttrVal EnvelopeItaly = "36"
toAttrVal EnvelopeMonarch = "37"
toAttrVal Envelope6_3_4 = "38"
toAttrVal PaperFanfoldUsStandard = "39"
toAttrVal PaperFanfoldGermanStandard = "40"
toAttrVal PaperFanfoldGermanLegal = "41"
toAttrVal PaperIsoB4 = "42"
toAttrVal PaperJapaneseDoublePostcard = "43"
toAttrVal PaperStandard9_11 = "44"
toAttrVal PaperStandard10_11 = "45"
toAttrVal PaperStandard15_11 = "46"
toAttrVal EnvelopeInvite = "47"
toAttrVal PaperLetterExtra = "50"
toAttrVal PaperLegalExtra = "51"
toAttrVal PaperTabloidExtra = "52"
toAttrVal PaperA4Extra = "53"
toAttrVal PaperLetterTransverse = "54"
toAttrVal PaperA4Transverse = "55"
toAttrVal PaperLetterExtraTransverse = "56"
toAttrVal PaperSuperA = "57"
toAttrVal PaperSuperB = "58"
toAttrVal PaperLetterPlus = "59"
toAttrVal PaperA4Plus = "60"
toAttrVal PaperA5Transverse = "61"
toAttrVal PaperJisB5Transverse = "62"
toAttrVal PaperA3Extra = "63"
toAttrVal PaperA5Extra = "64"
toAttrVal PaperIsoB5Extra = "65"
toAttrVal PaperA2 = "66"
toAttrVal PaperA3Transverse = "67"
toAttrVal PaperA3ExtraTransverse = "68"
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
-- | See @CT_PageSetup@, p. 3922
instance FromCursor PageSetup where
fromCursor cur = do
_pageSetupPaperSize <- maybeAttribute "paperSize" cur
_pageSetupPaperHeight <- maybeAttribute "paperHeight" cur
_pageSetupPaperWidth <- maybeAttribute "paperWidth" cur
_pageSetupScale <- maybeAttribute "scale" cur
_pageSetupFirstPageNumber <- maybeAttribute "firstPageNumber" cur
_pageSetupFitToWidth <- maybeAttribute "fitToWidth" cur
_pageSetupFitToHeight <- maybeAttribute "fitToHeight" cur
_pageSetupPageOrder <- maybeAttribute "pageOrder" cur
_pageSetupOrientation <- maybeAttribute "orientation" cur
_pageSetupUsePrinterDefaults <- maybeAttribute "usePrinterDefaults" cur
_pageSetupBlackAndWhite <- maybeAttribute "blackAndWhite" cur
_pageSetupDraft <- maybeAttribute "draft" cur
_pageSetupCellComments <- maybeAttribute "cellComments" cur
_pageSetupUseFirstPageNumber <- maybeAttribute "useFirstPageNumber" cur
_pageSetupErrors <- maybeAttribute "errors" cur
_pageSetupHorizontalDpi <- maybeAttribute "horizontalDpi" cur
_pageSetupVerticalDpi <- maybeAttribute "verticalDpi" cur
_pageSetupCopies <- maybeAttribute "copies" cur
_pageSetupId <- maybeAttribute "id" cur
return PageSetup{..}
instance FromXenoNode PageSetup where
fromXenoNode root =
parseAttributes root $ do
_pageSetupPaperSize <- maybeAttr "paperSize"
_pageSetupPaperHeight <- maybeAttr "paperHeight"
_pageSetupPaperWidth <- maybeAttr "paperWidth"
_pageSetupScale <- maybeAttr "scale"
_pageSetupFirstPageNumber <- maybeAttr "firstPageNumber"
_pageSetupFitToWidth <- maybeAttr "fitToWidth"
_pageSetupFitToHeight <- maybeAttr "fitToHeight"
_pageSetupPageOrder <- maybeAttr "pageOrder"
_pageSetupOrientation <- maybeAttr "orientation"
_pageSetupUsePrinterDefaults <- maybeAttr "usePrinterDefaults"
_pageSetupBlackAndWhite <- maybeAttr "blackAndWhite"
_pageSetupDraft <- maybeAttr "draft"
_pageSetupCellComments <- maybeAttr "cellComments"
_pageSetupUseFirstPageNumber <- maybeAttr "useFirstPageNumber"
_pageSetupErrors <- maybeAttr "errors"
_pageSetupHorizontalDpi <- maybeAttr "horizontalDpi"
_pageSetupVerticalDpi <- maybeAttr "verticalDpi"
_pageSetupCopies <- maybeAttr "copies"
_pageSetupId <- maybeAttr "id"
return PageSetup {..}
-- | See @paperSize@ (attribute of @pageSetup@), p. 1659
instance FromAttrVal PaperSize where
fromAttrVal "1" = readSuccess PaperLetter
fromAttrVal "2" = readSuccess PaperLetterSmall
fromAttrVal "3" = readSuccess PaperTabloid
fromAttrVal "4" = readSuccess PaperLedger
fromAttrVal "5" = readSuccess PaperLegal
fromAttrVal "6" = readSuccess PaperStatement
fromAttrVal "7" = readSuccess PaperExecutive
fromAttrVal "8" = readSuccess PaperA3
fromAttrVal "9" = readSuccess PaperA4
fromAttrVal "10" = readSuccess PaperA4Small
fromAttrVal "11" = readSuccess PaperA5
fromAttrVal "12" = readSuccess PaperB4
fromAttrVal "13" = readSuccess PaperB5
fromAttrVal "14" = readSuccess PaperFolio
fromAttrVal "15" = readSuccess PaperQuarto
fromAttrVal "16" = readSuccess PaperStandard10_14
fromAttrVal "17" = readSuccess PaperStandard11_17
fromAttrVal "18" = readSuccess PaperNote
fromAttrVal "19" = readSuccess Envelope9
fromAttrVal "20" = readSuccess Envelope10
fromAttrVal "21" = readSuccess Envelope11
fromAttrVal "22" = readSuccess Envelope12
fromAttrVal "23" = readSuccess Envelope14
fromAttrVal "24" = readSuccess PaperC
fromAttrVal "25" = readSuccess PaperD
fromAttrVal "26" = readSuccess PaperE
fromAttrVal "27" = readSuccess EnvelopeDL
fromAttrVal "28" = readSuccess EnvelopeC5
fromAttrVal "29" = readSuccess EnvelopeC3
fromAttrVal "30" = readSuccess EnvelopeC4
fromAttrVal "31" = readSuccess EnvelopeC6
fromAttrVal "32" = readSuccess EnvelopeC65
fromAttrVal "33" = readSuccess EnvelopeB4
fromAttrVal "34" = readSuccess EnvelopeB5
fromAttrVal "35" = readSuccess EnvelopeB6
fromAttrVal "36" = readSuccess EnvelopeItaly
fromAttrVal "37" = readSuccess EnvelopeMonarch
fromAttrVal "38" = readSuccess Envelope6_3_4
fromAttrVal "39" = readSuccess PaperFanfoldUsStandard
fromAttrVal "40" = readSuccess PaperFanfoldGermanStandard
fromAttrVal "41" = readSuccess PaperFanfoldGermanLegal
fromAttrVal "42" = readSuccess PaperIsoB4
fromAttrVal "43" = readSuccess PaperJapaneseDoublePostcard
fromAttrVal "44" = readSuccess PaperStandard9_11
fromAttrVal "45" = readSuccess PaperStandard10_11
fromAttrVal "46" = readSuccess PaperStandard15_11
fromAttrVal "47" = readSuccess EnvelopeInvite
fromAttrVal "50" = readSuccess PaperLetterExtra
fromAttrVal "51" = readSuccess PaperLegalExtra
fromAttrVal "52" = readSuccess PaperTabloidExtra
fromAttrVal "53" = readSuccess PaperA4Extra
fromAttrVal "54" = readSuccess PaperLetterTransverse
fromAttrVal "55" = readSuccess PaperA4Transverse
fromAttrVal "56" = readSuccess PaperLetterExtraTransverse
fromAttrVal "57" = readSuccess PaperSuperA
fromAttrVal "58" = readSuccess PaperSuperB
fromAttrVal "59" = readSuccess PaperLetterPlus
fromAttrVal "60" = readSuccess PaperA4Plus
fromAttrVal "61" = readSuccess PaperA5Transverse
fromAttrVal "62" = readSuccess PaperJisB5Transverse
fromAttrVal "63" = readSuccess PaperA3Extra
fromAttrVal "64" = readSuccess PaperA5Extra
fromAttrVal "65" = readSuccess PaperIsoB5Extra
fromAttrVal "66" = readSuccess PaperA2
fromAttrVal "67" = readSuccess PaperA3Transverse
fromAttrVal "68" = readSuccess PaperA3ExtraTransverse
fromAttrVal t = invalidText "PaperSize" t
instance FromAttrBs PaperSize where
fromAttrBs "1" = return PaperLetter
fromAttrBs "2" = return PaperLetterSmall
fromAttrBs "3" = return PaperTabloid
fromAttrBs "4" = return PaperLedger
fromAttrBs "5" = return PaperLegal
fromAttrBs "6" = return PaperStatement
fromAttrBs "7" = return PaperExecutive
fromAttrBs "8" = return PaperA3
fromAttrBs "9" = return PaperA4
fromAttrBs "10" = return PaperA4Small
fromAttrBs "11" = return PaperA5
fromAttrBs "12" = return PaperB4
fromAttrBs "13" = return PaperB5
fromAttrBs "14" = return PaperFolio
fromAttrBs "15" = return PaperQuarto
fromAttrBs "16" = return PaperStandard10_14
fromAttrBs "17" = return PaperStandard11_17
fromAttrBs "18" = return PaperNote
fromAttrBs "19" = return Envelope9
fromAttrBs "20" = return Envelope10
fromAttrBs "21" = return Envelope11
fromAttrBs "22" = return Envelope12
fromAttrBs "23" = return Envelope14
fromAttrBs "24" = return PaperC
fromAttrBs "25" = return PaperD
fromAttrBs "26" = return PaperE
fromAttrBs "27" = return EnvelopeDL
fromAttrBs "28" = return EnvelopeC5
fromAttrBs "29" = return EnvelopeC3
fromAttrBs "30" = return EnvelopeC4
fromAttrBs "31" = return EnvelopeC6
fromAttrBs "32" = return EnvelopeC65
fromAttrBs "33" = return EnvelopeB4
fromAttrBs "34" = return EnvelopeB5
fromAttrBs "35" = return EnvelopeB6
fromAttrBs "36" = return EnvelopeItaly
fromAttrBs "37" = return EnvelopeMonarch
fromAttrBs "38" = return Envelope6_3_4
fromAttrBs "39" = return PaperFanfoldUsStandard
fromAttrBs "40" = return PaperFanfoldGermanStandard
fromAttrBs "41" = return PaperFanfoldGermanLegal
fromAttrBs "42" = return PaperIsoB4
fromAttrBs "43" = return PaperJapaneseDoublePostcard
fromAttrBs "44" = return PaperStandard9_11
fromAttrBs "45" = return PaperStandard10_11
fromAttrBs "46" = return PaperStandard15_11
fromAttrBs "47" = return EnvelopeInvite
fromAttrBs "50" = return PaperLetterExtra
fromAttrBs "51" = return PaperLegalExtra
fromAttrBs "52" = return PaperTabloidExtra
fromAttrBs "53" = return PaperA4Extra
fromAttrBs "54" = return PaperLetterTransverse
fromAttrBs "55" = return PaperA4Transverse
fromAttrBs "56" = return PaperLetterExtraTransverse
fromAttrBs "57" = return PaperSuperA
fromAttrBs "58" = return PaperSuperB
fromAttrBs "59" = return PaperLetterPlus
fromAttrBs "60" = return PaperA4Plus
fromAttrBs "61" = return PaperA5Transverse
fromAttrBs "62" = return PaperJisB5Transverse
fromAttrBs "63" = return PaperA3Extra
fromAttrBs "64" = return PaperA5Extra
fromAttrBs "65" = return PaperIsoB5Extra
fromAttrBs "66" = return PaperA2
fromAttrBs "67" = return PaperA3Transverse
fromAttrBs "68" = return PaperA3ExtraTransverse
fromAttrBs x = unexpectedAttrBs "PaperSize" x
-- | See @ST_PageOrder@, p. 3923
instance FromAttrVal PageOrder where
fromAttrVal "downThenOver" = readSuccess PageOrderDownThenOver
fromAttrVal "overThenDown" = readSuccess PageOrderOverThenDown
fromAttrVal t = invalidText "PageOrder" t
instance FromAttrBs PageOrder where
fromAttrBs "downThenOver" = return PageOrderDownThenOver
fromAttrBs "overThenDown" = return PageOrderOverThenDown
fromAttrBs x = unexpectedAttrBs "PageOrder" x
-- | See @ST_CellComments@, p. 3923
instance FromAttrVal CellComments where
fromAttrVal "none" = readSuccess CellCommentsNone
fromAttrVal "asDisplayed" = readSuccess CellCommentsAsDisplayed
fromAttrVal "atEnd" = readSuccess CellCommentsAtEnd
fromAttrVal t = invalidText "CellComments" t
instance FromAttrBs CellComments where
fromAttrBs "none" = return CellCommentsNone
fromAttrBs "asDisplayed" = return CellCommentsAsDisplayed
fromAttrBs "atEnd" = return CellCommentsAtEnd
fromAttrBs x = unexpectedAttrBs "CellComments" x
-- | See @ST_PrintError@, p. 3923
instance FromAttrVal PrintErrors where
fromAttrVal "displayed" = readSuccess PrintErrorsDisplayed
fromAttrVal "blank" = readSuccess PrintErrorsBlank
fromAttrVal "dash" = readSuccess PrintErrorsDash
fromAttrVal "NA" = readSuccess PrintErrorsNA
fromAttrVal t = invalidText "PrintErrors" t
instance FromAttrBs PrintErrors where
fromAttrBs "displayed" = return PrintErrorsDisplayed
fromAttrBs "blank" = return PrintErrorsBlank
fromAttrBs "dash" = return PrintErrorsDash
fromAttrBs "NA" = return PrintErrorsNA
fromAttrBs x = unexpectedAttrBs "PrintErrors" x
-- | See @ST_Orientation@, p. 3923
instance FromAttrVal Orientation where
fromAttrVal "default" = readSuccess OrientationDefault
fromAttrVal "portrait" = readSuccess OrientationPortrait
fromAttrVal "landscape" = readSuccess OrientationLandscape
fromAttrVal t = invalidText "Orientation" t
instance FromAttrBs Orientation where
fromAttrBs "default" = return OrientationDefault
fromAttrBs "portrait" = return OrientationPortrait
fromAttrBs "landscape" = return OrientationLandscape
fromAttrBs x = unexpectedAttrBs "Orientation" x
xlsx-1.1.2.2/src/Codec/Xlsx/Types/PivotTable.hs 0000644 0000000 0000000 00000012642 14551273353 017327 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.PivotTable
( PivotTable(..)
, PivotFieldName(..)
, PivotFieldInfo(..)
, FieldSortType(..)
, PositionedField(..)
, DataField(..)
, ConsolidateFunction(..)
) where
import Control.Arrow (first)
import Control.DeepSeq (NFData)
import Data.Text (Text)
import GHC.Generics (Generic)
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Writer.Internal
data PivotTable = PivotTable
{ _pvtName :: Text
, _pvtDataCaption :: Text
, _pvtRowFields :: [PositionedField]
, _pvtColumnFields :: [PositionedField]
, _pvtDataFields :: [DataField]
, _pvtFields :: [PivotFieldInfo]
, _pvtRowGrandTotals :: Bool
, _pvtColumnGrandTotals :: Bool
, _pvtOutline :: Bool
, _pvtOutlineData :: Bool
, _pvtLocation :: CellRef
, _pvtSrcSheet :: Text
, _pvtSrcRef :: Range
} deriving (Eq, Show, Generic)
instance NFData PivotTable
data PivotFieldInfo = PivotFieldInfo
{ _pfiName :: Maybe PivotFieldName
, _pfiOutline :: Bool
, _pfiSortType :: FieldSortType
, _pfiHiddenItems :: [CellValue]
} deriving (Eq, Show, Generic)
instance NFData PivotFieldInfo
-- | Sort orders that can be applied to fields in a PivotTable
--
-- See 18.18.28 "ST_FieldSortType (Field Sort Type)" (p. 2454)
data FieldSortType
= FieldSortAscending
| FieldSortDescending
| FieldSortManual
deriving (Eq, Ord, Show, Generic)
instance NFData FieldSortType
newtype PivotFieldName =
PivotFieldName Text
deriving (Eq, Ord, Show, Generic)
instance NFData PivotFieldName
data PositionedField
= DataPosition
| FieldPosition PivotFieldName
deriving (Eq, Ord, Show, Generic)
instance NFData PositionedField
data DataField = DataField
{ _dfField :: PivotFieldName
, _dfName :: Text
, _dfFunction :: ConsolidateFunction
} deriving (Eq, Show, Generic)
instance NFData DataField
-- | Data consolidation functions specified by the user and used to
-- consolidate ranges of data
--
-- See 18.18.17 "ST_DataConsolidateFunction (Data Consolidation
-- Functions)" (p. 2447)
data ConsolidateFunction
= ConsolidateAverage
-- ^ The average of the values.
| ConsolidateCount
-- ^ The number of data values. The Count consolidation function
-- works the same as the COUNTA worksheet function.
| ConsolidateCountNums
-- ^ The number of data values that are numbers. The Count Nums
-- consolidation function works the same as the COUNT worksheet
-- function.
| ConsolidateMaximum
-- ^ The largest value.
| ConsolidateMinimum
-- ^ The smallest value.
| ConsolidateProduct
-- ^ The product of the values.
| ConsolidateStdDev
-- ^ An estimate of the standard deviation of a population, where
-- the sample is a subset of the entire population.
| ConsolidateStdDevP
-- ^ The standard deviation of a population, where the population
-- is all of the data to be summarized.
| ConsolidateSum
-- ^ The sum of the values.
| ConsolidateVariance
-- ^ An estimate of the variance of a population, where the sample
-- is a subset of the entire population.
| ConsolidateVarP
-- ^ The variance of a population, where the population is all of
-- the data to be summarized.
deriving (Eq, Show, Generic)
instance NFData ConsolidateFunction
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
instance ToAttrVal ConsolidateFunction where
toAttrVal ConsolidateAverage = "average"
toAttrVal ConsolidateCount = "count"
toAttrVal ConsolidateCountNums = "countNums"
toAttrVal ConsolidateMaximum = "max"
toAttrVal ConsolidateMinimum = "min"
toAttrVal ConsolidateProduct = "product"
toAttrVal ConsolidateStdDev = "stdDev"
toAttrVal ConsolidateStdDevP = "stdDevp"
toAttrVal ConsolidateSum = "sum"
toAttrVal ConsolidateVariance = "var"
toAttrVal ConsolidateVarP = "varp"
instance ToAttrVal PivotFieldName where
toAttrVal (PivotFieldName n) = toAttrVal n
instance ToAttrVal FieldSortType where
toAttrVal FieldSortManual = "manual"
toAttrVal FieldSortAscending = "ascending"
toAttrVal FieldSortDescending = "descending"
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
instance FromAttrVal ConsolidateFunction where
fromAttrVal "average" = readSuccess ConsolidateAverage
fromAttrVal "count" = readSuccess ConsolidateCount
fromAttrVal "countNums" = readSuccess ConsolidateCountNums
fromAttrVal "max" = readSuccess ConsolidateMaximum
fromAttrVal "min" = readSuccess ConsolidateMinimum
fromAttrVal "product" = readSuccess ConsolidateProduct
fromAttrVal "stdDev" = readSuccess ConsolidateStdDev
fromAttrVal "stdDevp" = readSuccess ConsolidateStdDevP
fromAttrVal "sum" = readSuccess ConsolidateSum
fromAttrVal "var" = readSuccess ConsolidateVariance
fromAttrVal "varp" = readSuccess ConsolidateVarP
fromAttrVal t = invalidText "ConsolidateFunction" t
instance FromAttrVal PivotFieldName where
fromAttrVal = fmap (first PivotFieldName) . fromAttrVal
instance FromAttrVal FieldSortType where
fromAttrVal "manual" = readSuccess FieldSortManual
fromAttrVal "ascending" = readSuccess FieldSortAscending
fromAttrVal "descending" = readSuccess FieldSortDescending
fromAttrVal t = invalidText "FieldSortType" t
xlsx-1.1.2.2/src/Codec/Xlsx/Types/PivotTable/Internal.hs 0000644 0000000 0000000 00000006361 14551273353 021104 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.PivotTable.Internal
( CacheId(..)
, CacheField(..)
, CacheRecordValue(..)
, CacheRecord
, recordValueFromNode
) where
import GHC.Generics (Generic)
import Control.Arrow (first)
import Data.Maybe (catMaybes)
import Data.Text (Text)
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Types.PivotTable
import Codec.Xlsx.Writer.Internal
newtype CacheId = CacheId Int deriving (Eq, Generic)
data CacheField = CacheField
{ cfName :: PivotFieldName
, cfItems :: [CellValue]
} deriving (Eq, Show, Generic)
data CacheRecordValue
= CacheText Text
| CacheNumber Double
| CacheIndex Int
deriving (Eq, Show, Generic)
type CacheRecord = [CacheRecordValue]
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
instance FromAttrVal CacheId where
fromAttrVal = fmap (first CacheId) . fromAttrVal
instance FromCursor CacheField where
fromCursor cur = do
cfName <- fromAttribute "name" cur
let cfItems =
cur $/ element (n_ "sharedItems") &/ anyElement >=>
cellValueFromNode . node
return CacheField {..}
cellValueFromNode :: Node -> [CellValue]
cellValueFromNode n
| n `nodeElNameIs` (n_ "s") = CellText <$> attributeV
| n `nodeElNameIs` (n_ "n") = CellDouble <$> attributeV
| otherwise = fail "no matching shared item"
where
cur = fromNode n
attributeV :: FromAttrVal a => [a]
attributeV = fromAttribute "v" cur
recordValueFromNode :: Node -> [CacheRecordValue]
recordValueFromNode n
| n `nodeElNameIs` (n_ "s") = CacheText <$> attributeV
| n `nodeElNameIs` (n_ "n") = CacheNumber <$> attributeV
| n `nodeElNameIs` (n_ "x") = CacheIndex <$> attributeV
| otherwise = fail "not valid cache record value"
where
cur = fromNode n
attributeV :: FromAttrVal a => [a]
attributeV = fromAttribute "v" cur
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
instance ToElement CacheField where
toElement nm CacheField {..} =
elementList nm ["name" .= cfName] [sharedItems]
where
-- Excel doesn't like embedded integer sharedImes in cache
sharedItems = elementList "sharedItems" typeAttrs $
if containsString then map cvToItem cfItems else []
cvToItem (CellText t) = leafElement "s" ["v" .= t]
cvToItem (CellDouble n) = leafElement "n" ["v" .= n]
cvToItem _ = error "Only string and number values are currently supported"
typeAttrs =
catMaybes
[ "containsNumber" .=? justTrue containsNumber
, "containsString" .=? justFalse containsString
, "containsSemiMixedTypes" .=? justFalse containsString
, "containsMixedTypes" .=? justTrue (containsNumber && containsString)
]
containsNumber = any isNumber cfItems
isNumber (CellDouble _) = True
isNumber _ = False
containsString = any isString cfItems
isString (CellText _) = True
isString _ = False
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Protection.hs 0000644 0000000 0000000 00000023407 14551273353 017405 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Protection
( SheetProtection(..)
, fullSheetProtection
, noSheetProtection
, LegacyPassword
, legacyPassword
-- * Lenses
, sprLegacyPassword
, sprSheet
, sprObjects
, sprScenarios
, sprFormatCells
, sprFormatColumns
, sprFormatRows
, sprInsertColumns
, sprInsertRows
, sprInsertHyperlinks
, sprDeleteColumns
, sprDeleteRows
, sprSelectLockedCells
, sprSort
, sprAutoFilter
, sprPivotTables
, sprSelectUnlockedCells
) where
import GHC.Generics (Generic)
import Control.Arrow (first)
#ifdef USE_MICROLENS
import Lens.Micro.TH (makeLenses)
#else
import Control.Lens (makeLenses)
#endif
import Control.DeepSeq (NFData)
import Data.Bits
import Data.Char
import Data.Maybe (catMaybes)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.Builder.Int (hexadecimal)
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Writer.Internal
newtype LegacyPassword =
LegacyPassword Text
deriving (Eq, Show, Generic)
instance NFData LegacyPassword
-- | Creates legacy @XOR@ hashed password.
--
-- /Note:/ The implementation is known to work only for ASCII symbols,
-- if you know how to encode properly others - an email or a PR will
-- be highly apperciated
--
-- See Part 4, 14.7.1 "Legacy Password Hash Algorithm" (p. 73) and
-- Part 4, 15.2.3 "Additional attributes for workbookProtection
-- element (Part 1, §18.2.29)" (p. 220) and Par 4, 15.3.1.6
-- "Additional attribute for sheetProtection element (Part 1,
-- §18.3.1.85)" (p. 229)
legacyPassword :: Text -> LegacyPassword
legacyPassword = LegacyPassword . hex . legacyHash . map ord . T.unpack
where
hex = toStrict . toLazyText . hexadecimal
legacyHash bs =
mutHash (foldr (\b hash -> b `xor` mutHash hash) 0 bs) `xor` (length bs) `xor`
0xCE4B
mutHash ph = ((ph `shiftR` 14) .&. 1) .|. ((ph `shiftL` 1) .&. 0x7fff)
-- | Sheet protection options to enforce and specify that it needs to
-- be protected
--
-- TODO: algorithms specified in the spec with hashes, salts and spin
-- counts
--
-- See 18.3.1.85 "sheetProtection (Sheet Protection Options)" (p. 1694)
data SheetProtection = SheetProtection
{ _sprLegacyPassword :: Maybe LegacyPassword
-- ^ Specifies the legacy hash of the password required for editing
-- this worksheet.
--
-- See Part 4, 15.3.1.6 "Additional attribute for sheetProtection
-- element (Part 1, §18.3.1.85)" (p. 229)
, _sprSheet :: Bool
-- ^ the value of this attribute dictates whether the other
-- attributes of 'SheetProtection' should be applied
, _sprAutoFilter :: Bool
-- ^ AutoFilters should not be allowed to operate when the sheet
-- is protected
, _sprDeleteColumns :: Bool
-- ^ deleting columns should not be allowed when the sheet is
-- protected
, _sprDeleteRows :: Bool
-- ^ deleting rows should not be allowed when the sheet is
-- protected
, _sprFormatCells :: Bool
-- ^ formatting cells should not be allowed when the sheet is
-- protected
, _sprFormatColumns :: Bool
-- ^ formatting columns should not be allowed when the sheet is
-- protected
, _sprFormatRows :: Bool
-- ^ formatting rows should not be allowed when the sheet is
-- protected
, _sprInsertColumns :: Bool
-- ^ inserting columns should not be allowed when the sheet is
-- protected
, _sprInsertHyperlinks :: Bool
-- ^ inserting hyperlinks should not be allowed when the sheet is
-- protected
, _sprInsertRows :: Bool
-- ^ inserting rows should not be allowed when the sheet is
-- protected
, _sprObjects :: Bool
-- ^ editing of objects should not be allowed when the sheet is
-- protected
, _sprPivotTables :: Bool
-- ^ PivotTables should not be allowed to operate when the sheet
-- is protected
, _sprScenarios :: Bool
-- ^ Scenarios should not be edited when the sheet is protected
, _sprSelectLockedCells :: Bool
-- ^ selection of locked cells should not be allowed when the
-- sheet is protected
, _sprSelectUnlockedCells :: Bool
-- ^ selection of unlocked cells should not be allowed when the
-- sheet is protected
, _sprSort :: Bool
-- ^ sorting should not be allowed when the sheet is protected
} deriving (Eq, Show, Generic)
instance NFData SheetProtection
makeLenses ''SheetProtection
{-------------------------------------------------------------------------------
Base instances
-------------------------------------------------------------------------------}
-- | no sheet protection at all
noSheetProtection :: SheetProtection
noSheetProtection =
SheetProtection
{ _sprLegacyPassword = Nothing
, _sprSheet = False
, _sprAutoFilter = False
, _sprDeleteColumns = False
, _sprDeleteRows = False
, _sprFormatCells = False
, _sprFormatColumns = False
, _sprFormatRows = False
, _sprInsertColumns = False
, _sprInsertHyperlinks = False
, _sprInsertRows = False
, _sprObjects = False
, _sprPivotTables = False
, _sprScenarios = False
, _sprSelectLockedCells = False
, _sprSelectUnlockedCells = False
, _sprSort = False
}
-- | protection of all sheet features which could be protected
fullSheetProtection :: SheetProtection
fullSheetProtection =
SheetProtection
{ _sprLegacyPassword = Nothing
, _sprSheet = True
, _sprAutoFilter = True
, _sprDeleteColumns = True
, _sprDeleteRows = True
, _sprFormatCells = True
, _sprFormatColumns = True
, _sprFormatRows = True
, _sprInsertColumns = True
, _sprInsertHyperlinks = True
, _sprInsertRows = True
, _sprObjects = True
, _sprPivotTables = True
, _sprScenarios = True
, _sprSelectLockedCells = True
, _sprSelectUnlockedCells = True
, _sprSort = True
}
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
instance FromCursor SheetProtection where
fromCursor cur = do
_sprLegacyPassword <- maybeAttribute "password" cur
_sprSheet <- fromAttributeDef "sheet" False cur
_sprAutoFilter <- fromAttributeDef "autoFilter" True cur
_sprDeleteColumns <- fromAttributeDef "deleteColumns" True cur
_sprDeleteRows <- fromAttributeDef "deleteRows" True cur
_sprFormatCells <- fromAttributeDef "formatCells" True cur
_sprFormatColumns <- fromAttributeDef "formatColumns" True cur
_sprFormatRows <- fromAttributeDef "formatRows" True cur
_sprInsertColumns <- fromAttributeDef "insertColumns" True cur
_sprInsertHyperlinks <- fromAttributeDef "insertHyperlinks" True cur
_sprInsertRows <- fromAttributeDef "insertRows" True cur
_sprObjects <- fromAttributeDef "objects" False cur
_sprPivotTables <- fromAttributeDef "pivotTables" True cur
_sprScenarios <- fromAttributeDef "scenarios" False cur
_sprSelectLockedCells <- fromAttributeDef "selectLockedCells" False cur
_sprSelectUnlockedCells <- fromAttributeDef "selectUnlockedCells" False cur
_sprSort <- fromAttributeDef "sort" True cur
return SheetProtection {..}
instance FromXenoNode SheetProtection where
fromXenoNode root =
parseAttributes root $ do
_sprLegacyPassword <- maybeAttr "password"
_sprSheet <- fromAttrDef "sheet" False
_sprAutoFilter <- fromAttrDef "autoFilter" True
_sprDeleteColumns <- fromAttrDef "deleteColumns" True
_sprDeleteRows <- fromAttrDef "deleteRows" True
_sprFormatCells <- fromAttrDef "formatCells" True
_sprFormatColumns <- fromAttrDef "formatColumns" True
_sprFormatRows <- fromAttrDef "formatRows" True
_sprInsertColumns <- fromAttrDef "insertColumns" True
_sprInsertHyperlinks <- fromAttrDef "insertHyperlinks" True
_sprInsertRows <- fromAttrDef "insertRows" True
_sprObjects <- fromAttrDef "objects" False
_sprPivotTables <- fromAttrDef "pivotTables" True
_sprScenarios <- fromAttrDef "scenarios" False
_sprSelectLockedCells <- fromAttrDef "selectLockedCells" False
_sprSelectUnlockedCells <- fromAttrDef "selectUnlockedCells" False
_sprSort <- fromAttrDef "sort" True
return SheetProtection {..}
instance FromAttrVal LegacyPassword where
fromAttrVal = fmap (first LegacyPassword) . fromAttrVal
instance FromAttrBs LegacyPassword where
fromAttrBs = fmap LegacyPassword . fromAttrBs
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
instance ToElement SheetProtection where
toElement nm SheetProtection {..} =
leafElement nm $
catMaybes
[ "password" .=? _sprLegacyPassword
, "sheet" .=? justTrue _sprSheet
, "autoFilter" .=? justFalse _sprAutoFilter
, "deleteColumns" .=? justFalse _sprDeleteColumns
, "deleteRows" .=? justFalse _sprDeleteRows
, "formatCells" .=? justFalse _sprFormatCells
, "formatColumns" .=? justFalse _sprFormatColumns
, "formatRows" .=? justFalse _sprFormatRows
, "insertColumns" .=? justFalse _sprInsertColumns
, "insertHyperlinks" .=? justFalse _sprInsertHyperlinks
, "insertRows" .=? justFalse _sprInsertRows
, "objects" .=? justTrue _sprObjects
, "pivotTables" .=? justFalse _sprPivotTables
, "scenarios" .=? justTrue _sprScenarios
, "selectLockedCells" .=? justTrue _sprSelectLockedCells
, "selectUnlockedCells" .=? justTrue _sprSelectUnlockedCells
, "sort" .=? justFalse _sprSort
]
instance ToAttrVal LegacyPassword where
toAttrVal (LegacyPassword hash) = hash
xlsx-1.1.2.2/src/Codec/Xlsx/Types/RichText.hs 0000644 0000000 0000000 00000036301 14551273353 017006 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.RichText (
-- * Main types
RichTextRun(..)
, RunProperties(..)
, applyRunProperties
-- * Lenses
-- ** RichTextRun
, richTextRunProperties
, richTextRunText
-- ** RunProperties
, runPropertiesBold
, runPropertiesCharset
, runPropertiesColor
, runPropertiesCondense
, runPropertiesExtend
, runPropertiesFontFamily
, runPropertiesItalic
, runPropertiesOutline
, runPropertiesFont
, runPropertiesScheme
, runPropertiesShadow
, runPropertiesStrikeThrough
, runPropertiesSize
, runPropertiesUnderline
, runPropertiesVertAlign
) where
import GHC.Generics (Generic)
#ifdef USE_MICROLENS
import Lens.Micro.TH (makeLenses)
#else
import Control.Lens hiding (element)
#endif
import Control.Monad
import Control.DeepSeq (NFData)
import Data.Default
import Data.Maybe (catMaybes)
import Data.Text (Text)
import Text.XML
import Text.XML.Cursor
import qualified Data.Map as Map
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.StyleSheet
import Codec.Xlsx.Writer.Internal
-- | Rich Text Run
--
-- This element represents a run of rich text. A rich text run is a region of
-- text that share a common set of properties, such as formatting properties.
--
-- Section 18.4.4, "r (Rich Text Run)" (p. 1724)
data RichTextRun = RichTextRun {
-- | This element represents a set of properties to apply to the contents of
-- this rich text run.
_richTextRunProperties :: Maybe RunProperties
-- | This element represents the text content shown as part of a string.
--
-- NOTE: 'RichTextRun' elements with an empty text field will result in
-- an error when opening the file in Excel.
--
-- Section 18.4.12, "t (Text)" (p. 1727)
, _richTextRunText :: Text
}
deriving (Eq, Ord, Show, Generic)
instance NFData RichTextRun
-- | Run properties
--
-- Section 18.4.7, "rPr (Run Properties)" (p. 1725)
data RunProperties = RunProperties {
-- | Displays characters in bold face font style.
--
-- Section 18.8.2, "b (Bold)" (p. 1757)
_runPropertiesBold :: Maybe Bool
-- | This element defines the font character set of this font.
--
-- Section 18.4.1, "charset (Character Set)" (p. 1721)
, _runPropertiesCharset :: Maybe Int
-- | One of the colors associated with the data bar or color scale.
--
-- Section 18.3.1.15, "color (Data Bar Color)" (p. 1608)
, _runPropertiesColor :: Maybe Color
-- | Macintosh compatibility setting. Represents special word/character
-- rendering on Macintosh, when this flag is set. The effect is to condense
-- the text (squeeze it together).
--
-- Section 18.8.12, "condense (Condense)" (p. 1764)
, _runPropertiesCondense :: Maybe Bool
-- | This element specifies a compatibility setting used for previous
-- spreadsheet applications, resulting in special word/character rendering
-- on those legacy applications, when this flag is set. The effect extends
-- or stretches out the text.
--
-- Section 18.8.17, "extend (Extend)" (p. 1766)
, _runPropertiesExtend :: Maybe Bool
-- | The font family this font belongs to. A font family is a set of fonts
-- having common stroke width and serif characteristics. This is system
-- level font information. The font name overrides when there are
-- conflicting values.
--
-- Section 18.8.18, "family (Font Family)" (p. 1766)
, _runPropertiesFontFamily :: Maybe FontFamily
-- | Displays characters in italic font style. The italic style is defined
-- by the font at a system level and is not specified by ECMA-376.
--
-- Section 18.8.26, "i (Italic)" (p. 1773)
, _runPropertiesItalic :: Maybe Bool
-- | This element displays only the inner and outer borders of each
-- character. This is very similar to Bold in behavior.
--
-- Section 18.4.2, "outline (Outline)" (p. 1722)
, _runPropertiesOutline :: Maybe Bool
-- | This element is a string representing the name of the font assigned to
-- display this run.
--
-- Section 18.4.5, "rFont (Font)" (p. 1724)
, _runPropertiesFont :: Maybe Text
-- | Defines the font scheme, if any, to which this font belongs. When a
-- font definition is part of a theme definition, then the font is
-- categorized as either a major or minor font scheme component. When a new
-- theme is chosen, every font that is part of a theme definition is updated
-- to use the new major or minor font definition for that theme. Usually
-- major fonts are used for styles like headings, and minor fonts are used
-- for body and paragraph text.
--
-- Section 18.8.35, "scheme (Scheme)" (p. 1794)
, _runPropertiesScheme :: Maybe FontScheme
-- | Macintosh compatibility setting. Represents special word/character
-- rendering on Macintosh, when this flag is set. The effect is to render a
-- shadow behind, beneath and to the right of the text.
--
-- Section 18.8.36, "shadow (Shadow)" (p. 1795)
, _runPropertiesShadow :: Maybe Bool
-- | This element draws a strikethrough line through the horizontal middle
-- of the text.
--
-- Section 18.4.10, "strike (Strike Through)" (p. 1726)
, _runPropertiesStrikeThrough :: Maybe Bool
-- | This element represents the point size (1/72 of an inch) of the Latin
-- and East Asian text.
--
-- Section 18.4.11, "sz (Font Size)" (p. 1727)
, _runPropertiesSize :: Maybe Double
-- | This element represents the underline formatting style.
--
-- Section 18.4.13, "u (Underline)" (p. 1728)
, _runPropertiesUnderline :: Maybe FontUnderline
-- | This element adjusts the vertical position of the text relative to the
-- text's default appearance for this run. It is used to get 'superscript'
-- or 'subscript' texts, and shall reduce the font size (if a smaller size
-- is available) accordingly.
--
-- Section 18.4.14, "vertAlign (Vertical Alignment)" (p. 1728)
, _runPropertiesVertAlign :: Maybe FontVerticalAlignment
}
deriving (Eq, Ord, Show, Generic)
instance NFData RunProperties
{-------------------------------------------------------------------------------
Lenses
-------------------------------------------------------------------------------}
makeLenses ''RichTextRun
makeLenses ''RunProperties
{-------------------------------------------------------------------------------
Default instances
-------------------------------------------------------------------------------}
instance Default RichTextRun where
def = RichTextRun {
_richTextRunProperties = Nothing
, _richTextRunText = ""
}
instance Default RunProperties where
def = RunProperties {
_runPropertiesBold = Nothing
, _runPropertiesCharset = Nothing
, _runPropertiesColor = Nothing
, _runPropertiesCondense = Nothing
, _runPropertiesExtend = Nothing
, _runPropertiesFontFamily = Nothing
, _runPropertiesItalic = Nothing
, _runPropertiesOutline = Nothing
, _runPropertiesFont = Nothing
, _runPropertiesScheme = Nothing
, _runPropertiesShadow = Nothing
, _runPropertiesStrikeThrough = Nothing
, _runPropertiesSize = Nothing
, _runPropertiesUnderline = Nothing
, _runPropertiesVertAlign = Nothing
}
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
-- | See @CT_RElt@, p. 3903
instance ToElement RichTextRun where
toElement nm RichTextRun{..} = Element {
elementName = nm
, elementAttributes = Map.empty
, elementNodes = map NodeElement . catMaybes $ [
toElement "rPr" <$> _richTextRunProperties
, Just $ elementContentPreserved "t" _richTextRunText
]
}
-- | See @CT_RPrElt@, p. 3903
instance ToElement RunProperties where
toElement nm RunProperties{..} = Element {
elementName = nm
, elementAttributes = Map.empty
, elementNodes = map NodeElement . catMaybes $ [
elementValue "rFont" <$> _runPropertiesFont
, elementValue "charset" <$> _runPropertiesCharset
, elementValue "family" <$> _runPropertiesFontFamily
, elementValue "b" <$> _runPropertiesBold
, elementValue "i" <$> _runPropertiesItalic
, elementValue "strike" <$> _runPropertiesStrikeThrough
, elementValue "outline" <$> _runPropertiesOutline
, elementValue "shadow" <$> _runPropertiesShadow
, elementValue "condense" <$> _runPropertiesCondense
, elementValue "extend" <$> _runPropertiesExtend
, toElement "color" <$> _runPropertiesColor
, elementValue "sz" <$> _runPropertiesSize
, elementValueDef "u" FontUnderlineSingle
<$> _runPropertiesUnderline
, elementValue "vertAlign" <$> _runPropertiesVertAlign
, elementValue "scheme" <$> _runPropertiesScheme
]
}
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
-- | See @CT_RElt@, p. 3903
instance FromCursor RichTextRun where
fromCursor cur = do
_richTextRunText <- cur $/ element (n_ "t") &/ content
_richTextRunProperties <- maybeFromElement (n_ "rPr") cur
return RichTextRun{..}
instance FromXenoNode RichTextRun where
fromXenoNode root = do
(prNode, tNode) <- collectChildren root $ (,) <$> maybeChild "rPr" <*> requireChild "t"
_richTextRunProperties <- mapM fromXenoNode prNode
_richTextRunText <- contentX tNode
return RichTextRun {..}
-- | See @CT_RPrElt@, p. 3903
instance FromCursor RunProperties where
fromCursor cur = do
_runPropertiesFont <- maybeElementValue (n_ "rFont") cur
_runPropertiesCharset <- maybeElementValue (n_ "charset") cur
_runPropertiesFontFamily <- maybeElementValue (n_ "family") cur
_runPropertiesBold <- maybeBoolElementValue (n_ "b") cur
_runPropertiesItalic <- maybeBoolElementValue (n_ "i") cur
_runPropertiesStrikeThrough <- maybeBoolElementValue (n_ "strike") cur
_runPropertiesOutline <- maybeBoolElementValue (n_ "outline") cur
_runPropertiesShadow <- maybeBoolElementValue (n_ "shadow") cur
_runPropertiesCondense <- maybeBoolElementValue (n_ "condense") cur
_runPropertiesExtend <- maybeBoolElementValue (n_ "extend") cur
_runPropertiesColor <- maybeFromElement (n_ "color") cur
_runPropertiesSize <- maybeElementValue (n_ "sz") cur
_runPropertiesUnderline <- maybeElementValueDef (n_ "u") FontUnderlineSingle cur
_runPropertiesVertAlign <- maybeElementValue (n_ "vertAlign") cur
_runPropertiesScheme <- maybeElementValue (n_ "scheme") cur
return RunProperties{..}
instance FromXenoNode RunProperties where
fromXenoNode root = collectChildren root $ do
_runPropertiesFont <- maybeElementVal "rFont"
_runPropertiesCharset <- maybeElementVal "charset"
_runPropertiesFontFamily <- maybeElementVal "family"
_runPropertiesBold <- maybeElementVal "b"
_runPropertiesItalic <- maybeElementVal "i"
_runPropertiesStrikeThrough <- maybeElementVal "strike"
_runPropertiesOutline <- maybeElementVal "outline"
_runPropertiesShadow <- maybeElementVal "shadow"
_runPropertiesCondense <- maybeElementVal "condense"
_runPropertiesExtend <- maybeElementVal "extend"
_runPropertiesColor <- maybeFromChild "color"
_runPropertiesSize <- maybeElementVal "sz"
_runPropertiesUnderline <- maybeElementVal "u"
_runPropertiesVertAlign <- maybeElementVal "vertAlign"
_runPropertiesScheme <- maybeElementVal "scheme"
return RunProperties{..}
{-------------------------------------------------------------------------------
Applying formatting
-------------------------------------------------------------------------------}
#if (MIN_VERSION_base(4,11,0))
instance Semigroup RunProperties where
a <> b = RunProperties {
_runPropertiesBold = override _runPropertiesBold
, _runPropertiesCharset = override _runPropertiesCharset
, _runPropertiesColor = override _runPropertiesColor
, _runPropertiesCondense = override _runPropertiesCondense
, _runPropertiesExtend = override _runPropertiesExtend
, _runPropertiesFontFamily = override _runPropertiesFontFamily
, _runPropertiesItalic = override _runPropertiesItalic
, _runPropertiesOutline = override _runPropertiesOutline
, _runPropertiesFont = override _runPropertiesFont
, _runPropertiesScheme = override _runPropertiesScheme
, _runPropertiesShadow = override _runPropertiesShadow
, _runPropertiesStrikeThrough = override _runPropertiesStrikeThrough
, _runPropertiesSize = override _runPropertiesSize
, _runPropertiesUnderline = override _runPropertiesUnderline
, _runPropertiesVertAlign = override _runPropertiesVertAlign
}
where
override :: (RunProperties -> Maybe x) -> Maybe x
override f = f b `mplus` f a
#endif
-- | The 'Monoid' instance for 'RunProperties' is biased: later properties
-- override earlier ones.
instance Monoid RunProperties where
mempty = def
a `mappend` b = RunProperties {
_runPropertiesBold = override _runPropertiesBold
, _runPropertiesCharset = override _runPropertiesCharset
, _runPropertiesColor = override _runPropertiesColor
, _runPropertiesCondense = override _runPropertiesCondense
, _runPropertiesExtend = override _runPropertiesExtend
, _runPropertiesFontFamily = override _runPropertiesFontFamily
, _runPropertiesItalic = override _runPropertiesItalic
, _runPropertiesOutline = override _runPropertiesOutline
, _runPropertiesFont = override _runPropertiesFont
, _runPropertiesScheme = override _runPropertiesScheme
, _runPropertiesShadow = override _runPropertiesShadow
, _runPropertiesStrikeThrough = override _runPropertiesStrikeThrough
, _runPropertiesSize = override _runPropertiesSize
, _runPropertiesUnderline = override _runPropertiesUnderline
, _runPropertiesVertAlign = override _runPropertiesVertAlign
}
where
override :: (RunProperties -> Maybe x) -> Maybe x
override f = f b `mplus` f a
-- | Apply properties to a 'RichTextRun'
--
-- If the 'RichTextRun' specifies its own properties, then these overrule the
-- properties specified here. For example, adding @bold@ to a 'RichTextRun'
-- which is already @italic@ will make the 'RichTextRun' both @bold and @italic@
-- but adding it to one that that is explicitly _not_ bold will leave the
-- 'RichTextRun' unchanged.
applyRunProperties :: RunProperties -> RichTextRun -> RichTextRun
applyRunProperties p (RichTextRun Nothing t) = RichTextRun (Just p) t
applyRunProperties p (RichTextRun (Just p') t) = RichTextRun (Just (p `mappend` p')) t
xlsx-1.1.2.2/src/Codec/Xlsx/Types/SheetViews.hs 0000644 0000000 0000000 00000055614 14551273353 017352 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.SheetViews (
-- * Structured type to construct 'SheetViews'
SheetView(..)
, Selection(..)
, Pane(..)
, SheetViewType(..)
, PaneType(..)
, PaneState(..)
-- * Lenses
-- ** SheetView
, sheetViewColorId
, sheetViewDefaultGridColor
, sheetViewRightToLeft
, sheetViewShowFormulas
, sheetViewShowGridLines
, sheetViewShowOutlineSymbols
, sheetViewShowRowColHeaders
, sheetViewShowRuler
, sheetViewShowWhiteSpace
, sheetViewShowZeros
, sheetViewTabSelected
, sheetViewTopLeftCell
, sheetViewType
, sheetViewWindowProtection
, sheetViewWorkbookViewId
, sheetViewZoomScale
, sheetViewZoomScaleNormal
, sheetViewZoomScalePageLayoutView
, sheetViewZoomScaleSheetLayoutView
, sheetViewPane
, sheetViewSelection
-- ** Selection
, selectionActiveCell
, selectionActiveCellId
, selectionPane
, selectionSqref
-- ** Pane
, paneActivePane
, paneState
, paneTopLeftCell
, paneXSplit
, paneYSplit
) where
import GHC.Generics (Generic)
#ifdef USE_MICROLENS
import Lens.Micro.TH (makeLenses)
#else
import Control.Lens (makeLenses)
#endif
import Control.DeepSeq (NFData)
import Data.Default
import Data.Maybe (catMaybes, maybeToList, listToMaybe)
import Text.XML
import Text.XML.Cursor
import qualified Data.Map as Map
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Writer.Internal
{-------------------------------------------------------------------------------
Main types
-------------------------------------------------------------------------------}
-- | Worksheet view
--
-- A single sheet view definition. When more than one sheet view is defined in
-- the file, it means that when opening the workbook, each sheet view
-- corresponds to a separate window within the spreadsheet application, where
-- each window is showing the particular sheet containing the same
-- workbookViewId value, the last sheetView definition is loaded, and the others
-- are discarded. When multiple windows are viewing the same sheet, multiple
-- sheetView elements (with corresponding workbookView entries) are saved.
--
-- TODO: The @pivotSelection@ and @extLst@ child elements are unsupported.
--
-- See Section 18.3.1.87 "sheetView (Worksheet View)" (p. 1880)
data SheetView = SheetView {
-- | Index to the color value for row/column text headings and gridlines.
-- This is an 'index color value' (ICV) rather than rgb value.
_sheetViewColorId :: Maybe Int
-- | Flag indicating that the consuming application should use the default
-- grid lines color (system dependent). Overrides any color specified in
-- colorId.
, _sheetViewDefaultGridColor :: Maybe Bool
-- | Flag indicating whether the sheet is in 'right to left' display mode.
-- When in this mode, Column A is on the far right, Column B ;is one column
-- left of Column A, and so on. Also, information in cells is displayed in
-- the Right to Left format.
, _sheetViewRightToLeft :: Maybe Bool
-- | Flag indicating whether this sheet should display formulas.
, _sheetViewShowFormulas :: Maybe Bool
-- | Flag indicating whether this sheet should display gridlines.
, _sheetViewShowGridLines :: Maybe Bool
-- | Flag indicating whether the sheet has outline symbols visible. This
-- flag shall always override SheetPr element's outlinePr child element
-- whose attribute is named showOutlineSymbols when there is a conflict.
, _sheetViewShowOutlineSymbols :: Maybe Bool
-- | Flag indicating whether the sheet should display row and column headings.
, _sheetViewShowRowColHeaders :: Maybe Bool
-- | Show the ruler in Page Layout View.
, _sheetViewShowRuler :: Maybe Bool
-- | Flag indicating whether page layout view shall display margins. False
-- means do not display left, right, top (header), and bottom (footer)
-- margins (even when there is data in the header or footer).
, _sheetViewShowWhiteSpace :: Maybe Bool
-- | Flag indicating whether the window should show 0 (zero) in cells
-- containing zero value. When false, cells with zero value appear blank
-- instead of showing the number zero.
, _sheetViewShowZeros :: Maybe Bool
-- | Flag indicating whether this sheet is selected. When only 1 sheet is
-- selected and active, this value should be in synch with the activeTab
-- value. In case of a conflict, the Start Part setting wins and sets the
-- active sheet tab.
--
-- Multiple sheets can be selected, but only one sheet shall be active at
-- one time.
, _sheetViewTabSelected :: Maybe Bool
-- | Location of the top left visible cell Location of the top left visible
-- cell in the bottom right pane (when in Left-to-Right mode).
, _sheetViewTopLeftCell :: Maybe CellRef
-- | Indicates the view type.
, _sheetViewType :: Maybe SheetViewType
-- | Flag indicating whether the panes in the window are locked due to
-- workbook protection. This is an option when the workbook structure is
-- protected.
, _sheetViewWindowProtection :: Maybe Bool
-- | Zero-based index of this workbook view, pointing to a workbookView
-- element in the bookViews collection.
--
-- NOTE: This attribute is required.
, _sheetViewWorkbookViewId :: Int
-- | Window zoom magnification for current view representing percent values.
-- This attribute is restricted to values ranging from 10 to 400. Horizontal &
-- Vertical scale together.
, _sheetViewZoomScale :: Maybe Int
-- | Zoom magnification to use when in normal view, representing percent
-- values. This attribute is restricted to values ranging from 10 to 400.
-- Horizontal & Vertical scale together.
, _sheetViewZoomScaleNormal :: Maybe Int
-- | Zoom magnification to use when in page layout view, representing
-- percent values. This attribute is restricted to values ranging from 10 to
-- 400. Horizontal & Vertical scale together.
, _sheetViewZoomScalePageLayoutView :: Maybe Int
-- | Zoom magnification to use when in page break preview, representing
-- percent values. This attribute is restricted to values ranging from 10 to
-- 400. Horizontal & Vertical scale together.
, _sheetViewZoomScaleSheetLayoutView :: Maybe Int
-- | Worksheet view pane
, _sheetViewPane :: Maybe Pane
-- | Worksheet view selection
--
-- Minimum of 0, maximum of 4 elements
, _sheetViewSelection :: [Selection]
}
deriving (Eq, Ord, Show, Generic)
instance NFData SheetView
-- | Worksheet view selection.
--
-- Section 18.3.1.78 "selection (Selection)" (p. 1864)
data Selection = Selection {
-- | Location of the active cell
_selectionActiveCell :: Maybe CellRef
-- | 0-based index of the range reference (in the array of references listed
-- in sqref) containing the active cell. Only used when the selection in
-- sqref is not contiguous. Therefore, this value needs to be aware of the
-- order in which the range references are written in sqref.
--
-- When this value is out of range then activeCell can be used.
, _selectionActiveCellId :: Maybe Int
-- | The pane to which this selection belongs.
, _selectionPane :: Maybe PaneType
-- | Range of the selection. Can be non-contiguous set of ranges.
, _selectionSqref :: Maybe SqRef
}
deriving (Eq, Ord, Show, Generic)
instance NFData Selection
-- | Worksheet view pane
--
-- Section 18.3.1.66 "pane (View Pane)" (p. 1843)
data Pane = Pane {
-- | The pane that is active.
_paneActivePane :: Maybe PaneType
-- | Indicates whether the pane has horizontal / vertical splits, and
-- whether those splits are frozen.
, _paneState :: Maybe PaneState
-- | Location of the top left visible cell in the bottom right pane (when in
-- Left-To-Right mode).
, _paneTopLeftCell :: Maybe CellRef
-- | Horizontal position of the split, in 1/20th of a point; 0 (zero) if
-- none. If the pane is frozen, this value indicates the number of columns
-- visible in the top pane.
, _paneXSplit :: Maybe Double
-- | Vertical position of the split, in 1/20th of a point; 0 (zero) if none.
-- If the pane is frozen, this value indicates the number of rows visible in
-- the left pane.
, _paneYSplit :: Maybe Double
}
deriving (Eq, Ord, Show, Generic)
instance NFData Pane
{-------------------------------------------------------------------------------
Enumerations
-------------------------------------------------------------------------------}
-- | View setting of the sheet
--
-- Section 18.18.69 "ST_SheetViewType (Sheet View Type)" (p. 2726)
data SheetViewType =
-- | Normal view
SheetViewTypeNormal
-- | Page break preview
| SheetViewTypePageBreakPreview
-- | Page layout view
| SheetViewTypePageLayout
deriving (Eq, Ord, Show, Generic)
instance NFData SheetViewType
-- | Pane type
--
-- Section 18.18.52 "ST_Pane (Pane Types)" (p. 2710)
data PaneType =
-- | Bottom left pane, when both vertical and horizontal splits are applied.
--
-- This value is also used when only a horizontal split has been applied,
-- dividing the pane into upper and lower regions. In that case, this value
-- specifies the bottom pane.
PaneTypeBottomLeft
-- Bottom right pane, when both vertical and horizontal splits are applied.
| PaneTypeBottomRight
-- | Top left pane, when both vertical and horizontal splits are applied.
--
-- This value is also used when only a horizontal split has been applied,
-- dividing the pane into upper and lower regions. In that case, this value
-- specifies the top pane.
--
-- This value is also used when only a vertical split has been applied,
-- dividing the pane into right and left regions. In that case, this value
-- specifies the left pane
| PaneTypeTopLeft
-- | Top right pane, when both vertical and horizontal splits are applied.
--
-- This value is also used when only a vertical split has been applied,
-- dividing the pane into right and left regions. In that case, this value
-- specifies the right pane.
| PaneTypeTopRight
deriving (Eq, Ord, Show, Generic)
instance NFData PaneType
-- | State of the sheet's pane.
--
-- Section 18.18.53 "ST_PaneState (Pane State)" (p. 2711)
data PaneState =
-- | Panes are frozen, but were not split being frozen. In this state, when
-- the panes are unfrozen again, a single pane results, with no split. In
-- this state, the split bars are not adjustable.
PaneStateFrozen
-- | Panes are frozen and were split before being frozen. In this state,
-- when the panes are unfrozen again, the split remains, but is adjustable.
| PaneStateFrozenSplit
-- | Panes are split, but not frozen. In this state, the split bars are
-- adjustable by the user.
| PaneStateSplit
deriving (Eq, Ord, Show, Generic)
instance NFData PaneState
{-------------------------------------------------------------------------------
Lenses
-------------------------------------------------------------------------------}
makeLenses ''SheetView
makeLenses ''Selection
makeLenses ''Pane
{-------------------------------------------------------------------------------
Default instances
-------------------------------------------------------------------------------}
-- | NOTE: The 'Default' instance for 'SheetView' sets the required attribute
-- '_sheetViewWorkbookViewId' to @0@.
instance Default SheetView where
def = SheetView {
_sheetViewColorId = Nothing
, _sheetViewDefaultGridColor = Nothing
, _sheetViewRightToLeft = Nothing
, _sheetViewShowFormulas = Nothing
, _sheetViewShowGridLines = Nothing
, _sheetViewShowOutlineSymbols = Nothing
, _sheetViewShowRowColHeaders = Nothing
, _sheetViewShowRuler = Nothing
, _sheetViewShowWhiteSpace = Nothing
, _sheetViewShowZeros = Nothing
, _sheetViewTabSelected = Nothing
, _sheetViewTopLeftCell = Nothing
, _sheetViewType = Nothing
, _sheetViewWindowProtection = Nothing
, _sheetViewWorkbookViewId = 0
, _sheetViewZoomScale = Nothing
, _sheetViewZoomScaleNormal = Nothing
, _sheetViewZoomScalePageLayoutView = Nothing
, _sheetViewZoomScaleSheetLayoutView = Nothing
, _sheetViewPane = Nothing
, _sheetViewSelection = []
}
instance Default Selection where
def = Selection {
_selectionActiveCell = Nothing
, _selectionActiveCellId = Nothing
, _selectionPane = Nothing
, _selectionSqref = Nothing
}
instance Default Pane where
def = Pane {
_paneActivePane = Nothing
, _paneState = Nothing
, _paneTopLeftCell = Nothing
, _paneXSplit = Nothing
, _paneYSplit = Nothing
}
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
-- | See @CT_SheetView@, p. 3913
instance ToElement SheetView where
toElement nm SheetView{..} = Element {
elementName = nm
, elementNodes = map NodeElement . concat $ [
map (toElement "pane") (maybeToList _sheetViewPane)
, map (toElement "selection") _sheetViewSelection
-- TODO: pivotSelection
-- TODO: extLst
]
, elementAttributes = Map.fromList . catMaybes $ [
"windowProtection" .=? _sheetViewWindowProtection
, "showFormulas" .=? _sheetViewShowFormulas
, "showGridLines" .=? _sheetViewShowGridLines
, "showRowColHeaders" .=? _sheetViewShowRowColHeaders
, "showZeros" .=? _sheetViewShowZeros
, "rightToLeft" .=? _sheetViewRightToLeft
, "tabSelected" .=? _sheetViewTabSelected
, "showRuler" .=? _sheetViewShowRuler
, "showOutlineSymbols" .=? _sheetViewShowOutlineSymbols
, "defaultGridColor" .=? _sheetViewDefaultGridColor
, "showWhiteSpace" .=? _sheetViewShowWhiteSpace
, "view" .=? _sheetViewType
, "topLeftCell" .=? _sheetViewTopLeftCell
, "colorId" .=? _sheetViewColorId
, "zoomScale" .=? _sheetViewZoomScale
, "zoomScaleNormal" .=? _sheetViewZoomScaleNormal
, "zoomScaleSheetLayoutView" .=? _sheetViewZoomScaleSheetLayoutView
, "zoomScalePageLayoutView" .=? _sheetViewZoomScalePageLayoutView
, Just $ "workbookViewId" .= _sheetViewWorkbookViewId
]
}
-- | See @CT_Selection@, p. 3914
instance ToElement Selection where
toElement nm Selection{..} = Element {
elementName = nm
, elementNodes = []
, elementAttributes = Map.fromList . catMaybes $ [
"pane" .=? _selectionPane
, "activeCell" .=? _selectionActiveCell
, "activeCellId" .=? _selectionActiveCellId
, "sqref" .=? _selectionSqref
]
}
-- | See @CT_Pane@, p. 3913
instance ToElement Pane where
toElement nm Pane{..} = Element {
elementName = nm
, elementNodes = []
, elementAttributes = Map.fromList . catMaybes $ [
"xSplit" .=? _paneXSplit
, "ySplit" .=? _paneYSplit
, "topLeftCell" .=? _paneTopLeftCell
, "activePane" .=? _paneActivePane
, "state" .=? _paneState
]
}
-- | See @ST_SheetViewType@, p. 3913
instance ToAttrVal SheetViewType where
toAttrVal SheetViewTypeNormal = "normal"
toAttrVal SheetViewTypePageBreakPreview = "pageBreakPreview"
toAttrVal SheetViewTypePageLayout = "pageLayout"
-- | See @ST_Pane@, p. 3914
instance ToAttrVal PaneType where
toAttrVal PaneTypeBottomRight = "bottomRight"
toAttrVal PaneTypeTopRight = "topRight"
toAttrVal PaneTypeBottomLeft = "bottomLeft"
toAttrVal PaneTypeTopLeft = "topLeft"
-- | See @ST_PaneState@, p. 3929
instance ToAttrVal PaneState where
toAttrVal PaneStateSplit = "split"
toAttrVal PaneStateFrozen = "frozen"
toAttrVal PaneStateFrozenSplit = "frozenSplit"
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
-- | See @CT_SheetView@, p. 3913
instance FromCursor SheetView where
fromCursor cur = do
_sheetViewWindowProtection <- maybeAttribute "windowProtection" cur
_sheetViewShowFormulas <- maybeAttribute "showFormulas" cur
_sheetViewShowGridLines <- maybeAttribute "showGridLines" cur
_sheetViewShowRowColHeaders <- maybeAttribute "showRowColHeaders"cur
_sheetViewShowZeros <- maybeAttribute "showZeros" cur
_sheetViewRightToLeft <- maybeAttribute "rightToLeft" cur
_sheetViewTabSelected <- maybeAttribute "tabSelected" cur
_sheetViewShowRuler <- maybeAttribute "showRuler" cur
_sheetViewShowOutlineSymbols <- maybeAttribute "showOutlineSymbols" cur
_sheetViewDefaultGridColor <- maybeAttribute "defaultGridColor" cur
_sheetViewShowWhiteSpace <- maybeAttribute "showWhiteSpace" cur
_sheetViewType <- maybeAttribute "view" cur
_sheetViewTopLeftCell <- maybeAttribute "topLeftCell" cur
_sheetViewColorId <- maybeAttribute "colorId" cur
_sheetViewZoomScale <- maybeAttribute "zoomScale" cur
_sheetViewZoomScaleNormal <- maybeAttribute "zoomScaleNormal" cur
_sheetViewZoomScaleSheetLayoutView <- maybeAttribute "zoomScaleSheetLayoutView" cur
_sheetViewZoomScalePageLayoutView <- maybeAttribute "zoomScalePageLayoutView" cur
_sheetViewWorkbookViewId <- fromAttribute "workbookViewId" cur
let _sheetViewPane = listToMaybe $ cur $/ element (n_ "pane") >=> fromCursor
_sheetViewSelection = cur $/ element (n_ "selection") >=> fromCursor
return SheetView{..}
instance FromXenoNode SheetView where
fromXenoNode root = parseAttributes root $ do
_sheetViewWindowProtection <- maybeAttr "windowProtection"
_sheetViewShowFormulas <- maybeAttr "showFormulas"
_sheetViewShowGridLines <- maybeAttr "showGridLines"
_sheetViewShowRowColHeaders <- maybeAttr "showRowColHeaders"
_sheetViewShowZeros <- maybeAttr "showZeros"
_sheetViewRightToLeft <- maybeAttr "rightToLeft"
_sheetViewTabSelected <- maybeAttr "tabSelected"
_sheetViewShowRuler <- maybeAttr "showRuler"
_sheetViewShowOutlineSymbols <- maybeAttr "showOutlineSymbols"
_sheetViewDefaultGridColor <- maybeAttr "defaultGridColor"
_sheetViewShowWhiteSpace <- maybeAttr "showWhiteSpace"
_sheetViewType <- maybeAttr "view"
_sheetViewTopLeftCell <- maybeAttr "topLeftCell"
_sheetViewColorId <- maybeAttr "colorId"
_sheetViewZoomScale <- maybeAttr "zoomScale"
_sheetViewZoomScaleNormal <- maybeAttr "zoomScaleNormal"
_sheetViewZoomScaleSheetLayoutView <- maybeAttr "zoomScaleSheetLayoutView"
_sheetViewZoomScalePageLayoutView <- maybeAttr "zoomScalePageLayoutView"
_sheetViewWorkbookViewId <- fromAttr "workbookViewId"
(_sheetViewPane, _sheetViewSelection) <-
toAttrParser . collectChildren root $
(,) <$> maybeFromChild "pane" <*> fromChildList "selection"
return SheetView {..}
-- | See @CT_Pane@, p. 3913
instance FromCursor Pane where
fromCursor cur = do
_paneXSplit <- maybeAttribute "xSplit" cur
_paneYSplit <- maybeAttribute "ySplit" cur
_paneTopLeftCell <- maybeAttribute "topLeftCell" cur
_paneActivePane <- maybeAttribute "activePane" cur
_paneState <- maybeAttribute "state" cur
return Pane{..}
instance FromXenoNode Pane where
fromXenoNode root =
parseAttributes root $ do
_paneXSplit <- maybeAttr "xSplit"
_paneYSplit <- maybeAttr "ySplit"
_paneTopLeftCell <- maybeAttr "topLeftCell"
_paneActivePane <- maybeAttr "activePane"
_paneState <- maybeAttr "state"
return Pane {..}
-- | See @CT_Selection@, p. 3914
instance FromCursor Selection where
fromCursor cur = do
_selectionPane <- maybeAttribute "pane" cur
_selectionActiveCell <- maybeAttribute "activeCell" cur
_selectionActiveCellId <- maybeAttribute "activeCellId" cur
_selectionSqref <- maybeAttribute "sqref" cur
return Selection{..}
instance FromXenoNode Selection where
fromXenoNode root =
parseAttributes root $ do
_selectionPane <- maybeAttr "pane"
_selectionActiveCell <- maybeAttr "activeCell"
_selectionActiveCellId <- maybeAttr "activeCellId"
_selectionSqref <- maybeAttr "sqref"
return Selection {..}
-- | See @ST_SheetViewType@, p. 3913
instance FromAttrVal SheetViewType where
fromAttrVal "normal" = readSuccess SheetViewTypeNormal
fromAttrVal "pageBreakPreview" = readSuccess SheetViewTypePageBreakPreview
fromAttrVal "pageLayout" = readSuccess SheetViewTypePageLayout
fromAttrVal t = invalidText "SheetViewType" t
instance FromAttrBs SheetViewType where
fromAttrBs "normal" = return SheetViewTypeNormal
fromAttrBs "pageBreakPreview" = return SheetViewTypePageBreakPreview
fromAttrBs "pageLayout" = return SheetViewTypePageLayout
fromAttrBs x = unexpectedAttrBs "SheetViewType" x
-- | See @ST_Pane@, p. 3914
instance FromAttrVal PaneType where
fromAttrVal "bottomRight" = readSuccess PaneTypeBottomRight
fromAttrVal "topRight" = readSuccess PaneTypeTopRight
fromAttrVal "bottomLeft" = readSuccess PaneTypeBottomLeft
fromAttrVal "topLeft" = readSuccess PaneTypeTopLeft
fromAttrVal t = invalidText "PaneType" t
instance FromAttrBs PaneType where
fromAttrBs "bottomRight" = return PaneTypeBottomRight
fromAttrBs "topRight" = return PaneTypeTopRight
fromAttrBs "bottomLeft" = return PaneTypeBottomLeft
fromAttrBs "topLeft" = return PaneTypeTopLeft
fromAttrBs x = unexpectedAttrBs "PaneType" x
-- | See @ST_PaneState@, p. 3929
instance FromAttrVal PaneState where
fromAttrVal "split" = readSuccess PaneStateSplit
fromAttrVal "frozen" = readSuccess PaneStateFrozen
fromAttrVal "frozenSplit" = readSuccess PaneStateFrozenSplit
fromAttrVal t = invalidText "PaneState" t
instance FromAttrBs PaneState where
fromAttrBs "split" = return PaneStateSplit
fromAttrBs "frozen" = return PaneStateFrozen
fromAttrBs "frozenSplit" = return PaneStateFrozenSplit
fromAttrBs x = unexpectedAttrBs "PaneState" x
xlsx-1.1.2.2/src/Codec/Xlsx/Types/StyleSheet.hs 0000644 0000000 0000000 00000201350 14551552756 017352 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
-- | Support for writing (but not reading) style sheets
module Codec.Xlsx.Types.StyleSheet (
-- * The main two types
StyleSheet(..)
, CellXf(..)
, minimalStyleSheet
-- * Supporting record types
, Alignment(..)
, Border(..)
, BorderStyle(..)
, Color(..)
, Dxf(..)
, Fill(..)
, FillPattern(..)
, Font(..)
, NumberFormat(..)
, NumFmt(..)
, ImpliedNumberFormat (..)
, FormatCode
, Protection(..)
-- * Supporting enumerations
, CellHorizontalAlignment(..)
, CellVerticalAlignment(..)
, FontFamily(..)
, FontScheme(..)
, FontUnderline(..)
, FontVerticalAlignment(..)
, LineStyle(..)
, PatternType(..)
, ReadingOrder(..)
-- * Lenses
-- ** StyleSheet
, styleSheetBorders
, styleSheetFonts
, styleSheetFills
, styleSheetCellXfs
, styleSheetDxfs
, styleSheetNumFmts
-- ** CellXf
, cellXfApplyAlignment
, cellXfApplyBorder
, cellXfApplyFill
, cellXfApplyFont
, cellXfApplyNumberFormat
, cellXfApplyProtection
, cellXfBorderId
, cellXfFillId
, cellXfFontId
, cellXfNumFmtId
, cellXfPivotButton
, cellXfQuotePrefix
, cellXfId
, cellXfAlignment
, cellXfProtection
-- ** Dxf
, dxfAlignment
, dxfBorder
, dxfFill
, dxfFont
, dxfNumFmt
, dxfProtection
-- ** Alignment
, alignmentHorizontal
, alignmentIndent
, alignmentJustifyLastLine
, alignmentReadingOrder
, alignmentRelativeIndent
, alignmentShrinkToFit
, alignmentTextRotation
, alignmentVertical
, alignmentWrapText
-- ** Border
, borderDiagonalDown
, borderDiagonalUp
, borderOutline
, borderBottom
, borderDiagonal
, borderEnd
, borderHorizontal
, borderStart
, borderTop
, borderVertical
, borderLeft
, borderRight
-- ** BorderStyle
, borderStyleColor
, borderStyleLine
-- ** Color
, colorAutomatic
, colorARGB
, colorTheme
, colorTint
-- ** Fill
, fillPattern
-- ** FillPattern
, fillPatternBgColor
, fillPatternFgColor
, fillPatternType
-- ** Font
, fontBold
, fontCharset
, fontColor
, fontCondense
, fontExtend
, fontFamily
, fontItalic
, fontName
, fontOutline
, fontScheme
, fontShadow
, fontStrikeThrough
, fontSize
, fontUnderline
, fontVertAlign
-- ** Protection
, protectionHidden
, protectionLocked
-- * Helpers
-- ** Number formats
, fmtDecimals
, fmtDecimalsZeroes
, stdNumberFormatId
, idToStdNumberFormat
, firstUserNumFmtId
) where
#ifdef USE_MICROLENS
import Lens.Micro
import Lens.Micro.TH (makeLenses)
#else
import Control.Lens hiding (element, elements, (.=))
#endif
import Control.DeepSeq (NFData)
import Data.Default
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, maybeToList)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Writer.Internal
{-------------------------------------------------------------------------------
The main types
-------------------------------------------------------------------------------}
-- | StyleSheet for an XML document
--
-- Relevant parts of the EMCA standard (4th edition, part 1,
-- ),
-- page numbers refer to the page in the PDF rather than the page number as
-- printed on the page):
--
-- * Chapter 12, \"SpreadsheetML\" (p. 74)
-- In particular Section 12.3.20, "Styles Part" (p. 104)
-- * Chapter 18, \"SpreadsheetML Reference Material\" (p. 1528)
-- In particular Section 18.8, \"Styles\" (p. 1754) and Section 18.8.39
-- \"styleSheet\" (Style Sheet)\" (p. 1796); it is the latter section that
-- specifies the top-level style sheet format.
--
-- TODO: the following child elements:
--
-- * cellStyles
-- * cellStyleXfs
-- * colors
-- * extLst
-- * tableStyles
--
-- NOTE: Because of undocumented Excel requirements you will probably want to base
-- your style sheet on 'minimalStyleSheet' (a proper style sheet should have some
-- contents for details see
-- ).
-- 'def' for 'StyleSheet' includes no contents at all and this could be a problem
-- for Excel.
--
-- See also:
--
-- * 'Codec.Xlsx.Types.renderStyleSheet' to translate a 'StyleSheet' to 'Styles'
-- * 'Codec.Xlsx.Formatted.formatted' for a higher level interface.
-- * 'Codec.Xlsx.Types.parseStyleSheet' to translate a raw 'StyleSheet' into 'Styles'
data StyleSheet = StyleSheet
{ _styleSheetBorders :: [Border]
-- ^ This element contains borders formatting information, specifying all
-- border definitions for all cells in the workbook.
--
-- Section 18.8.5, "borders (Borders)" (p. 1760)
, _styleSheetCellXfs :: [CellXf]
-- ^ Cell formats
--
-- 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.
--
-- Section 18.8.10, "cellXfs (Cell Formats)" (p. 1764)
, _styleSheetFills :: [Fill]
-- ^ This element defines the cell fills portion of the Styles part,
-- consisting of a sequence of fill records. A cell fill consists of a
-- background color, foreground color, and pattern to be applied across the
-- cell.
--
-- Section 18.8.21, "fills (Fills)" (p. 1768)
, _styleSheetFonts :: [Font]
-- ^ This element contains all font definitions for this workbook.
--
-- Section 18.8.23 "fonts (Fonts)" (p. 1769)
, _styleSheetDxfs :: [Dxf]
-- ^ 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)
, _styleSheetNumFmts :: Map Int FormatCode
-- ^ Number formats
--
-- This element contains custom number formats defined in this style sheet
--
-- Section 18.8.31, "numFmts (Number Formats)" (p. 1784)
} deriving (Eq, Ord, Show, Generic)
instance NFData StyleSheet
-- | Cell formatting
--
-- TODO: The @extLst@ field is currently unsupported.
--
-- Section 18.8.45 "xf (Format)" (p. 1800)
data CellXf = CellXf {
-- | A boolean value indicating whether the alignment formatting specified
-- for this xf should be applied.
_cellXfApplyAlignment :: Maybe Bool
-- | A boolean value indicating whether the border formatting specified for
-- this xf should be applied.
, _cellXfApplyBorder :: Maybe Bool
-- | A boolean value indicating whether the fill formatting specified for
-- this xf should be applied.
, _cellXfApplyFill :: Maybe Bool
-- | A boolean value indicating whether the font formatting specified for
-- this xf should be applied.
, _cellXfApplyFont :: Maybe Bool
-- | A boolean value indicating whether the number formatting specified for
-- this xf should be applied.
, _cellXfApplyNumberFormat :: Maybe Bool
-- | A boolean value indicating whether the protection formatting specified
-- for this xf should be applied.
, _cellXfApplyProtection :: Maybe Bool
-- | Zero-based index of the border record used by this cell format.
--
-- (18.18.2, p. 2437).
, _cellXfBorderId :: Maybe Int
-- | Zero-based index of the fill record used by this cell format.
--
-- (18.18.30, p. 2455)
, _cellXfFillId :: Maybe Int
-- | Zero-based index of the font record used by this cell format.
--
-- An integer that represents a zero based index into the `styleSheetFonts`
-- collection in the style sheet (18.18.32, p. 2456).
, _cellXfFontId :: Maybe Int
-- | Id of the number format (numFmt) record used by this cell format.
--
-- This simple type defines the identifier to a style sheet number format
-- entry in CT_NumFmts. Number formats are written to the styles part
-- (18.18.47, p. 2468). See also 18.8.31 (p. 1784) for more information on
-- number formats.
--
, _cellXfNumFmtId :: Maybe Int
-- | A boolean value indicating whether the cell rendering includes a pivot
-- table dropdown button.
, _cellXfPivotButton :: Maybe Bool
-- | A boolean value indicating whether the text string in a cell should be
-- prefixed by a single quote mark (e.g., 'text). In these cases, the quote
-- is not stored in the Shared Strings Part.
, _cellXfQuotePrefix :: Maybe Bool
-- | For xf records contained in cellXfs this is the zero-based index of an
-- xf record contained in cellStyleXfs corresponding to the cell style
-- applied to the cell.
--
-- Not present for xf records contained in cellStyleXfs.
--
-- Used by xf records and cellStyle records to reference xf records defined
-- in the cellStyleXfs collection. (18.18.10, p. 2442)
-- TODO: the cellStyleXfs field of a style sheet not currently implemented.
, _cellXfId :: Maybe Int
-- | Formatting information pertaining to text alignment in cells. There are
-- a variety of choices for how text is aligned both horizontally and
-- vertically, as well as indentation settings, and so on.
, _cellXfAlignment :: Maybe Alignment
-- | Contains protection properties associated with the cell. Each cell has
-- protection properties that can be set. The cell protection properties do
-- not take effect unless the sheet has been protected.
, _cellXfProtection :: Maybe Protection
}
deriving (Eq, Ord, Show, Generic)
instance NFData CellXf
{-------------------------------------------------------------------------------
Supporting record types
-------------------------------------------------------------------------------}
-- | Alignment
--
-- See 18.8.1 "alignment (Alignment)" (p. 1754)
data Alignment = Alignment {
-- | Specifies the type of horizontal alignment in cells.
_alignmentHorizontal :: Maybe CellHorizontalAlignment
-- | An integer value, where an increment of 1 represents 3 spaces.
-- Indicates the number of spaces (of the normal style font) of indentation
-- for text in a cell.
, _alignmentIndent :: Maybe Int
-- | A boolean value indicating if the cells justified or distributed
-- alignment should be used on the last line of text. (This is typical for
-- East Asian alignments but not typical in other contexts.)
, _alignmentJustifyLastLine :: Maybe Bool
-- | An integer value indicating whether the reading order
-- (bidirectionality) of the cell is leftto- right, right-to-left, or
-- context dependent.
, _alignmentReadingOrder :: Maybe ReadingOrder
-- | An integer value (used only in a dxf element) to indicate the
-- additional number of spaces of indentation to adjust for text in a cell.
, _alignmentRelativeIndent :: Maybe Int
-- | A boolean value indicating if the displayed text in the cell should be
-- shrunk to fit the cell width. Not applicable when a cell contains
-- multiple lines of text.
, _alignmentShrinkToFit :: Maybe Bool
-- | Text rotation in cells. Expressed in degrees. Values range from 0 to
-- 180. The first letter of the text is considered the center-point of the
-- arc.
, _alignmentTextRotation :: Maybe Int
-- | Vertical alignment in cells.
, _alignmentVertical :: Maybe CellVerticalAlignment
-- | A boolean value indicating if the text in a cell should be line-wrapped
-- within the cell.
, _alignmentWrapText :: Maybe Bool
}
deriving (Eq, Ord, Show, Generic)
instance NFData Alignment
-- | Expresses a single set of cell border formats (left, right, top, bottom,
-- diagonal). Color is optional. When missing, 'automatic' is implied.
--
-- See 18.8.4 "border (Border)" (p. 1759)
data Border = Border {
-- | A boolean value indicating if the cell's diagonal border includes a
-- diagonal line, starting at the top left corner of the cell and moving
-- down to the bottom right corner of the cell.
_borderDiagonalDown :: Maybe Bool
-- | A boolean value indicating if the cell's diagonal border includes a
-- diagonal line, starting at the bottom left corner of the cell and moving
-- up to the top right corner of the cell.
, _borderDiagonalUp :: Maybe Bool
-- | A boolean value indicating if left, right, top, and bottom borders
-- should be applied only to outside borders of a cell range.
, _borderOutline :: Maybe Bool
-- | Bottom border
, _borderBottom :: Maybe BorderStyle
-- | Diagonal
, _borderDiagonal :: Maybe BorderStyle
-- | Trailing edge border
--
-- See also 'borderRight'
, _borderEnd :: Maybe BorderStyle
-- | Horizontal inner borders
, _borderHorizontal :: Maybe BorderStyle
-- | Left border
--
-- NOTE: The spec does not formally list a 'left' border element, but the
-- examples do mention 'left' and the scheme contains it too. See also 'borderStart'.
, _borderLeft :: Maybe BorderStyle
-- | Right border
--
-- NOTE: The spec does not formally list a 'right' border element, but the
-- examples do mention 'right' and the scheme contains it too. See also 'borderEnd'.
, _borderRight :: Maybe BorderStyle
-- | Leading edge border
--
-- See also 'borderLeft'
, _borderStart :: Maybe BorderStyle
-- | Top border
, _borderTop :: Maybe BorderStyle
-- | Vertical inner border
, _borderVertical :: Maybe BorderStyle
}
deriving (Eq, Ord, Show, Generic)
instance NFData Border
-- | Border style
-- See @CT_BorderPr@ (p. 3934)
data BorderStyle = BorderStyle {
_borderStyleColor :: Maybe Color
, _borderStyleLine :: Maybe LineStyle
}
deriving (Eq, Ord, Show, Generic)
instance NFData BorderStyle
-- | One of the colors associated with the data bar or color scale.
--
-- The 'indexed' attribute (used for backwards compatibility only) is not
-- modelled here.
--
-- See 18.3.1.15 "color (Data Bar Color)" (p. 1608)
data Color = Color {
-- | A boolean value indicating the color is automatic and system color
-- dependent.
_colorAutomatic :: Maybe Bool
-- | Standard Alpha Red Green Blue color value (ARGB).
--
-- This simple type's contents have a length of exactly 8 hexadecimal
-- digit(s); see "18.18.86 ST_UnsignedIntHex (Hex Unsigned Integer)" (p.
-- 2511).
, _colorARGB :: Maybe Text
-- | A zero-based index into the collection (20.1.6.2),
-- referencing a particular or value expressed in the
-- Theme part.
, _colorTheme :: Maybe Int
-- | Specifies the tint value applied to the color.
--
-- If tint is supplied, then it is applied to the RGB value of the color to
-- determine the final color applied.
--
-- The tint value is stored as a double from -1.0 .. 1.0, where -1.0 means
-- 100% darken and 1.0 means 100% lighten. Also, 0.0 means no change.
, _colorTint :: Maybe Double
}
deriving (Eq, Ord, Show, Generic)
instance NFData Color
-- | This element specifies fill formatting.
--
-- TODO: Gradient fills (18.8.4) are currently unsupported. If we add them,
-- then the spec says (@CT_Fill@, p. 3935), _either_ a gradient _or_ a solid
-- fill pattern should be specified.
--
-- Section 18.8.20, "fill (Fill)" (p. 1768)
data Fill = Fill {
_fillPattern :: Maybe FillPattern
}
deriving (Eq, Ord, Show, Generic)
instance NFData Fill
-- | This element is used to specify cell fill information for pattern and solid
-- color cell fills. For solid cell fills (no pattern), fgColor is used. For
-- cell fills with patterns specified, then the cell fill color is specified by
-- the bgColor element.
--
-- Section 18.8.32 "patternFill (Pattern)" (p. 1793)
data FillPattern = FillPattern {
_fillPatternBgColor :: Maybe Color
, _fillPatternFgColor :: Maybe Color
, _fillPatternType :: Maybe PatternType
}
deriving (Eq, Ord, Show, Generic)
instance NFData FillPattern
-- | This element defines the properties for one of the fonts used in this
-- workbook.
--
-- Section 18.2.22 "font (Font)" (p. 1769)
data Font = Font {
-- | Displays characters in bold face font style.
_fontBold :: Maybe Bool
-- | This element defines the font character set of this font.
--
-- This field is used in font creation and selection if a font of the given
-- facename is not available on the system. Although it is not required to
-- have around when resolving font facename, the information can be stored
-- for when needed to help resolve which font face to use of all available
-- fonts on a system.
--
-- Charset represents the basic set of characters associated with a font
-- (that it can display), and roughly corresponds to the ANSI codepage
-- (8-bit or DBCS) of that character set used by a given language. Given
-- more common use of Unicode where many fonts support more than one of the
-- traditional charset categories, and the use of font linking, using
-- charset to resolve font name is less and less common, but still can be
-- useful.
--
-- These are operating-system-dependent values.
--
-- Section 18.4.1 "charset (Character Set)" provides some example values.
, _fontCharset :: Maybe Int
-- | Color
, _fontColor :: Maybe Color
-- | Macintosh compatibility setting. Represents special word/character
-- rendering on Macintosh, when this flag is set. The effect is to condense
-- the text (squeeze it together). SpreadsheetML applications are not
-- required to render according to this flag.
, _fontCondense :: Maybe Bool
-- | This element specifies a compatibility setting used for previous
-- spreadsheet applications, resulting in special word/character rendering
-- on those legacy applications, when this flag is set. The effect extends
-- or stretches out the text. SpreadsheetML applications are not required to
-- render according to this flag.
, _fontExtend :: Maybe Bool
-- | The font family this font belongs to. A font family is a set of fonts
-- having common stroke width and serif characteristics. This is system
-- level font information. The font name overrides when there are
-- conflicting values.
, _fontFamily :: Maybe FontFamily
-- | Displays characters in italic font style. The italic style is defined
-- by the font at a system level and is not specified by ECMA-376.
, _fontItalic :: Maybe Bool
-- | This element specifies the face name of this font.
--
-- A string representing the name of the font. If the font doesn't exist
-- (because it isn't installed on the system), or the charset not supported
-- by that font, then another font should be substituted.
--
-- The string length for this attribute shall be 0 to 31 characters.
, _fontName :: Maybe Text
-- | This element displays only the inner and outer borders of each
-- character. This is very similar to Bold in behavior.
, _fontOutline :: Maybe Bool
-- | Defines the font scheme, if any, to which this font belongs. When a
-- font definition is part of a theme definition, then the font is
-- categorized as either a major or minor font scheme component. When a new
-- theme is chosen, every font that is part of a theme definition is updated
-- to use the new major or minor font definition for that theme. Usually
-- major fonts are used for styles like headings, and minor fonts are used
-- for body and paragraph text.
, _fontScheme :: Maybe FontScheme
-- | Macintosh compatibility setting. Represents special word/character
-- rendering on Macintosh, when this flag is set. The effect is to render a
-- shadow behind, beneath and to the right of the text. SpreadsheetML
-- applications are not required to render according to this flag.
, _fontShadow :: Maybe Bool
-- | This element draws a strikethrough line through the horizontal middle
-- of the text.
, _fontStrikeThrough :: Maybe Bool
-- | This element represents the point size (1/72 of an inch) of the Latin
-- and East Asian text.
, _fontSize :: Maybe Double
-- | This element represents the underline formatting style.
, _fontUnderline :: Maybe FontUnderline
-- | This element adjusts the vertical position of the text relative to the
-- text's default appearance for this run. It is used to get 'superscript'
-- or 'subscript' texts, and shall reduce the font size (if a smaller size
-- is available) accordingly.
, _fontVertAlign :: Maybe FontVerticalAlignment
}
deriving (Eq, Ord, Show, Generic)
instance NFData Font
-- | A single dxf record, expressing incremental formatting to be applied.
--
-- Section 18.8.14, "dxf (Formatting)" (p. 1765)
data Dxf = Dxf
{ _dxfFont :: Maybe Font
-- | It seems to be required that this number format entry is duplicated
-- in '_styleSheetNumFmts' of the style sheet, though the spec says
-- nothing explicitly about it.
, _dxfNumFmt :: Maybe NumFmt
, _dxfFill :: Maybe Fill
, _dxfAlignment :: Maybe Alignment
, _dxfBorder :: Maybe Border
, _dxfProtection :: Maybe Protection
-- TODO: extList
} deriving (Eq, Ord, Show, Generic)
instance NFData Dxf
-- | A number format code.
--
-- Section 18.8.30, "numFmt (Number Format)" (p. 1777)
type FormatCode = Text
-- | This element specifies number format properties which indicate
-- how to format and render the numeric value of a cell.
--
-- Section 18.8.30 "numFmt (Number Format)" (p. 1777)
data NumFmt = NumFmt
{ _numFmtId :: Int
, _numFmtCode :: FormatCode
} deriving (Eq, Ord, Show, Generic)
instance NFData NumFmt
mkNumFmtPair :: NumFmt -> (Int, FormatCode)
mkNumFmtPair NumFmt{..} = (_numFmtId, _numFmtCode)
-- | This type gives a high-level version of representation of number format
-- used in 'Codec.Xlsx.Formatted.Format'.
data NumberFormat
= StdNumberFormat ImpliedNumberFormat
| UserNumberFormat FormatCode
deriving (Eq, Ord, Show, Generic)
instance NFData NumberFormat
-- | Basic number format with predefined number of decimals
-- as format code of number format in xlsx should be less than 255 characters
-- number of decimals shouldn't be more than 253
fmtDecimals :: Int -> NumberFormat
fmtDecimals k = UserNumberFormat $ "0." <> T.replicate k "#"
-- | Basic number format with predefined number of decimals.
-- Works like 'fmtDecimals' with the only difference that extra zeroes are
-- displayed when number of digits after the point is less than the number
-- of digits specified in the format
fmtDecimalsZeroes :: Int -> NumberFormat
fmtDecimalsZeroes k = UserNumberFormat $ "0." <> T.replicate k "0"
-- | Implied number formats
--
-- /Note:/ This only implements the predefined values for 18.2.30 "All Languages",
-- other built-in format ids (with id < 'firstUserNumFmtId') are stored in 'NfOtherBuiltin'
data ImpliedNumberFormat =
NfGeneral -- ^> 0 General
| NfZero -- ^> 1 0
| Nf2Decimal -- ^> 2 0.00
| NfMax3Decimal -- ^> 3 #,##0
| NfThousandSeparator2Decimal -- ^> 4 #,##0.00
| NfPercent -- ^> 9 0%
| NfPercent2Decimal -- ^> 10 0.00%
| NfExponent2Decimal -- ^> 11 0.00E+00
| NfSingleSpacedFraction -- ^> 12 # ?/?
| NfDoubleSpacedFraction -- ^> 13 # ??/??
| NfMmDdYy -- ^> 14 mm-dd-yy
| NfDMmmYy -- ^> 15 d-mmm-yy
| NfDMmm -- ^> 16 d-mmm
| NfMmmYy -- ^> 17 mmm-yy
| NfHMm12Hr -- ^> 18 h:mm AM/PM
| NfHMmSs12Hr -- ^> 19 h:mm:ss AM/PM
| NfHMm -- ^> 20 h:mm
| NfHMmSs -- ^> 21 h:mm:ss
| NfMdyHMm -- ^> 22 m/d/yy h:mm
| NfThousandsNegativeParens -- ^> 37 #,##0 ;(#,##0)
| NfThousandsNegativeRed -- ^> 38 #,##0 ;[Red](#,##0)
| NfThousands2DecimalNegativeParens -- ^> 39 #,##0.00;(#,##0.00)
| NfThousands2DecimalNegativeRed -- ^> 40 #,##0.00;[Red](#,##0.00)
| NfMmSs -- ^> 45 mm:ss
| NfOptHMmSs -- ^> 46 [h]:mm:ss
| NfMmSs1Decimal -- ^> 47 mmss.0
| NfExponent1Decimal -- ^> 48 ##0.0E+0
| NfTextPlaceHolder -- ^> 49 @
| NfOtherImplied Int -- ^ other (non local-neutral?) built-in format (id < 164)
deriving (Eq, Ord, Show, Generic)
instance NFData ImpliedNumberFormat
stdNumberFormatId :: ImpliedNumberFormat -> Int
stdNumberFormatId NfGeneral = 0 -- General
stdNumberFormatId NfZero = 1 -- 0
stdNumberFormatId Nf2Decimal = 2 -- 0.00
stdNumberFormatId NfMax3Decimal = 3 -- #,##0
stdNumberFormatId NfThousandSeparator2Decimal = 4 -- #,##0.00
stdNumberFormatId NfPercent = 9 -- 0%
stdNumberFormatId NfPercent2Decimal = 10 -- 0.00%
stdNumberFormatId NfExponent2Decimal = 11 -- 0.00E+00
stdNumberFormatId NfSingleSpacedFraction = 12 -- # ?/?
stdNumberFormatId NfDoubleSpacedFraction = 13 -- # ??/??
stdNumberFormatId NfMmDdYy = 14 -- mm-dd-yy
stdNumberFormatId NfDMmmYy = 15 -- d-mmm-yy
stdNumberFormatId NfDMmm = 16 -- d-mmm
stdNumberFormatId NfMmmYy = 17 -- mmm-yy
stdNumberFormatId NfHMm12Hr = 18 -- h:mm AM/PM
stdNumberFormatId NfHMmSs12Hr = 19 -- h:mm:ss AM/PM
stdNumberFormatId NfHMm = 20 -- h:mm
stdNumberFormatId NfHMmSs = 21 -- h:mm:ss
stdNumberFormatId NfMdyHMm = 22 -- m/d/yy h:mm
stdNumberFormatId NfThousandsNegativeParens = 37 -- #,##0 ;(#,##0)
stdNumberFormatId NfThousandsNegativeRed = 38 -- #,##0 ;[Red](#,##0)
stdNumberFormatId NfThousands2DecimalNegativeParens = 39 -- #,##0.00;(#,##0.00)
stdNumberFormatId NfThousands2DecimalNegativeRed = 40 -- #,##0.00;[Red](#,##0.00)
stdNumberFormatId NfMmSs = 45 -- mm:ss
stdNumberFormatId NfOptHMmSs = 46 -- [h]:mm:ss
stdNumberFormatId NfMmSs1Decimal = 47 -- mmss.0
stdNumberFormatId NfExponent1Decimal = 48 -- ##0.0E+0
stdNumberFormatId NfTextPlaceHolder = 49 -- @
stdNumberFormatId (NfOtherImplied i) = i
idToStdNumberFormat :: Int -> Maybe ImpliedNumberFormat
idToStdNumberFormat 0 = Just NfGeneral -- General
idToStdNumberFormat 1 = Just NfZero -- 0
idToStdNumberFormat 2 = Just Nf2Decimal -- 0.00
idToStdNumberFormat 3 = Just NfMax3Decimal -- #,##0
idToStdNumberFormat 4 = Just NfThousandSeparator2Decimal -- #,##0.00
idToStdNumberFormat 9 = Just NfPercent -- 0%
idToStdNumberFormat 10 = Just NfPercent2Decimal -- 0.00%
idToStdNumberFormat 11 = Just NfExponent2Decimal -- 0.00E+00
idToStdNumberFormat 12 = Just NfSingleSpacedFraction -- # ?/?
idToStdNumberFormat 13 = Just NfDoubleSpacedFraction -- # ??/??
idToStdNumberFormat 14 = Just NfMmDdYy -- mm-dd-yy
idToStdNumberFormat 15 = Just NfDMmmYy -- d-mmm-yy
idToStdNumberFormat 16 = Just NfDMmm -- d-mmm
idToStdNumberFormat 17 = Just NfMmmYy -- mmm-yy
idToStdNumberFormat 18 = Just NfHMm12Hr -- h:mm AM/PM
idToStdNumberFormat 19 = Just NfHMmSs12Hr -- h:mm:ss AM/PM
idToStdNumberFormat 20 = Just NfHMm -- h:mm
idToStdNumberFormat 21 = Just NfHMmSs -- h:mm:ss
idToStdNumberFormat 22 = Just NfMdyHMm -- m/d/yy h:mm
idToStdNumberFormat 37 = Just NfThousandsNegativeParens -- #,##0 ;(#,##0)
idToStdNumberFormat 38 = Just NfThousandsNegativeRed -- #,##0 ;[Red](#,##0)
idToStdNumberFormat 39 = Just NfThousands2DecimalNegativeParens -- #,##0.00;(#,##0.00)
idToStdNumberFormat 40 = Just NfThousands2DecimalNegativeRed -- #,##0.00;[Red](#,##0.00)
idToStdNumberFormat 45 = Just NfMmSs -- mm:ss
idToStdNumberFormat 46 = Just NfOptHMmSs -- [h]:mm:ss
idToStdNumberFormat 47 = Just NfMmSs1Decimal -- mmss.0
idToStdNumberFormat 48 = Just NfExponent1Decimal -- ##0.0E+0
idToStdNumberFormat 49 = Just NfTextPlaceHolder -- @
idToStdNumberFormat i = if i < firstUserNumFmtId then Just (NfOtherImplied i) else Nothing
firstUserNumFmtId :: Int
firstUserNumFmtId = 164
-- | Protection properties
--
-- Contains protection properties associated with the cell. Each cell has
-- protection properties that can be set. The cell protection properties do not
-- take effect unless the sheet has been protected.
--
-- Section 18.8.33, "protection (Protection Properties)", p. 1793
data Protection = Protection {
_protectionHidden :: Maybe Bool
, _protectionLocked :: Maybe Bool
}
deriving (Eq, Ord, Show, Generic)
instance NFData Protection
{-------------------------------------------------------------------------------
Enumerations
-------------------------------------------------------------------------------}
-- | Horizontal alignment in cells
--
-- See 18.18.40 "ST_HorizontalAlignment (Horizontal Alignment Type)" (p. 2459)
data CellHorizontalAlignment =
CellHorizontalAlignmentCenter
| CellHorizontalAlignmentCenterContinuous
| CellHorizontalAlignmentDistributed
| CellHorizontalAlignmentFill
| CellHorizontalAlignmentGeneral
| CellHorizontalAlignmentJustify
| CellHorizontalAlignmentLeft
| CellHorizontalAlignmentRight
deriving (Eq, Ord, Show, Generic)
instance NFData CellHorizontalAlignment
-- | Vertical alignment in cells
--
-- See 18.18.88 "ST_VerticalAlignment (Vertical Alignment Types)" (p. 2512)
data CellVerticalAlignment =
CellVerticalAlignmentBottom
| CellVerticalAlignmentCenter
| CellVerticalAlignmentDistributed
| CellVerticalAlignmentJustify
| CellVerticalAlignmentTop
deriving (Eq, Ord, Show, Generic)
instance NFData CellVerticalAlignment
-- | Font family
--
-- See 18.8.18 "family (Font Family)" (p. 1766)
-- and 17.18.30 "ST_FontFamily (Font Family Value)" (p. 1388)
data FontFamily =
-- | Family is not applicable
FontFamilyNotApplicable
-- | Proportional font with serifs
| FontFamilyRoman
-- | Proportional font without serifs
| FontFamilySwiss
-- | Monospace font with or without serifs
| FontFamilyModern
-- | Script font designed to mimic the appearance of handwriting
| FontFamilyScript
-- | Novelty font
| FontFamilyDecorative
deriving (Eq, Ord, Show, Generic)
instance NFData FontFamily
-- | Font scheme
--
-- See 18.18.33 "ST_FontScheme (Font scheme Styles)" (p. 2456)
data FontScheme =
-- | This font is the major font for this theme.
FontSchemeMajor
-- | This font is the minor font for this theme.
| FontSchemeMinor
-- | This font is not a theme font.
| FontSchemeNone
deriving (Eq, Ord, Show, Generic)
instance NFData FontScheme
-- | Font underline property
--
-- See 18.4.13 "u (Underline)", p 1728
data FontUnderline =
FontUnderlineSingle
| FontUnderlineDouble
| FontUnderlineSingleAccounting
| FontUnderlineDoubleAccounting
| FontUnderlineNone
deriving (Eq, Ord, Show, Generic)
instance NFData FontUnderline
-- | Vertical alignment
--
-- See 22.9.2.17 "ST_VerticalAlignRun (Vertical Positioning Location)" (p. 3794)
data FontVerticalAlignment =
FontVerticalAlignmentBaseline
| FontVerticalAlignmentSubscript
| FontVerticalAlignmentSuperscript
deriving (Eq, Ord, Show, Generic)
instance NFData FontVerticalAlignment
data LineStyle =
LineStyleDashDot
| LineStyleDashDotDot
| LineStyleDashed
| LineStyleDotted
| LineStyleDouble
| LineStyleHair
| LineStyleMedium
| LineStyleMediumDashDot
| LineStyleMediumDashDotDot
| LineStyleMediumDashed
| LineStyleNone
| LineStyleSlantDashDot
| LineStyleThick
| LineStyleThin
deriving (Eq, Ord, Show, Generic)
instance NFData LineStyle
-- | Indicates the style of fill pattern being used for a cell format.
--
-- Section 18.18.55 "ST_PatternType (Pattern Type)" (p. 2472)
data PatternType =
PatternTypeDarkDown
| PatternTypeDarkGray
| PatternTypeDarkGrid
| PatternTypeDarkHorizontal
| PatternTypeDarkTrellis
| PatternTypeDarkUp
| PatternTypeDarkVertical
| PatternTypeGray0625
| PatternTypeGray125
| PatternTypeLightDown
| PatternTypeLightGray
| PatternTypeLightGrid
| PatternTypeLightHorizontal
| PatternTypeLightTrellis
| PatternTypeLightUp
| PatternTypeLightVertical
| PatternTypeMediumGray
| PatternTypeNone
| PatternTypeSolid
deriving (Eq, Ord, Show, Generic)
instance NFData PatternType
-- | Reading order
--
-- See 18.8.1 "alignment (Alignment)" (p. 1754, esp. p. 1755)
data ReadingOrder =
ReadingOrderContextDependent
| ReadingOrderLeftToRight
| ReadingOrderRightToLeft
deriving (Eq, Ord, Show, Generic)
instance NFData ReadingOrder
{-------------------------------------------------------------------------------
Lenses
-------------------------------------------------------------------------------}
makeLenses ''StyleSheet
makeLenses ''CellXf
makeLenses ''Dxf
makeLenses ''Alignment
makeLenses ''Border
makeLenses ''BorderStyle
makeLenses ''Color
makeLenses ''Fill
makeLenses ''FillPattern
makeLenses ''Font
makeLenses ''Protection
{-------------------------------------------------------------------------------
Minimal stylesheet
-------------------------------------------------------------------------------}
-- | Minimal style sheet
--
-- Excel expects some minimal definitions in the stylesheet; you probably want
-- to define your own stylesheets based on this one.
--
-- This more-or-less follows the recommendations at
-- ,
-- but with some additions based on experimental evidence.
minimalStyleSheet :: StyleSheet
minimalStyleSheet = def
& styleSheetBorders .~ [defaultBorder]
& styleSheetFonts .~ [defaultFont]
& styleSheetFills .~ [fillNone, fillGray125]
& styleSheetCellXfs .~ [defaultCellXf]
where
-- The 'Default' instance for 'Border' uses 'left' and 'right' rather than
-- 'start' and 'end', because this is what Excel does (even though the spec
-- says different)
defaultBorder :: Border
defaultBorder = def
& borderBottom .~ Just def
& borderTop .~ Just def
& borderLeft .~ Just def
& borderRight .~ Just def
defaultFont :: Font
defaultFont = def
& fontFamily .~ Just FontFamilySwiss
& fontSize .~ Just 11
fillNone, fillGray125 :: Fill
fillNone = def
& fillPattern .~ Just (def & fillPatternType .~ Just PatternTypeNone)
fillGray125 = def
& fillPattern .~ Just (def & fillPatternType .~ Just PatternTypeGray125)
defaultCellXf :: CellXf
defaultCellXf = def
& cellXfBorderId .~ Just 0
& cellXfFillId .~ Just 0
& cellXfFontId .~ Just 0
{-------------------------------------------------------------------------------
Default instances
-------------------------------------------------------------------------------}
instance Default StyleSheet where
def = StyleSheet {
_styleSheetBorders = []
, _styleSheetFonts = []
, _styleSheetFills = []
, _styleSheetCellXfs = []
, _styleSheetDxfs = []
, _styleSheetNumFmts = M.empty
}
instance Default CellXf where
def = CellXf {
_cellXfApplyAlignment = Nothing
, _cellXfApplyBorder = Nothing
, _cellXfApplyFill = Nothing
, _cellXfApplyFont = Nothing
, _cellXfApplyNumberFormat = Nothing
, _cellXfApplyProtection = Nothing
, _cellXfBorderId = Nothing
, _cellXfFillId = Nothing
, _cellXfFontId = Nothing
, _cellXfNumFmtId = Nothing
, _cellXfPivotButton = Nothing
, _cellXfQuotePrefix = Nothing
, _cellXfId = Nothing
, _cellXfAlignment = Nothing
, _cellXfProtection = Nothing
}
instance Default Dxf where
def = Dxf
{ _dxfFont = Nothing
, _dxfNumFmt = Nothing
, _dxfFill = Nothing
, _dxfAlignment = Nothing
, _dxfBorder = Nothing
, _dxfProtection = Nothing
}
instance Default Alignment where
def = Alignment {
_alignmentHorizontal = Nothing
, _alignmentIndent = Nothing
, _alignmentJustifyLastLine = Nothing
, _alignmentReadingOrder = Nothing
, _alignmentRelativeIndent = Nothing
, _alignmentShrinkToFit = Nothing
, _alignmentTextRotation = Nothing
, _alignmentVertical = Nothing
, _alignmentWrapText = Nothing
}
instance Default Border where
def = Border {
_borderDiagonalDown = Nothing
, _borderDiagonalUp = Nothing
, _borderOutline = Nothing
, _borderBottom = Nothing
, _borderDiagonal = Nothing
, _borderEnd = Nothing
, _borderHorizontal = Nothing
, _borderStart = Nothing
, _borderTop = Nothing
, _borderVertical = Nothing
, _borderLeft = Nothing
, _borderRight = Nothing
}
instance Default BorderStyle where
def = BorderStyle {
_borderStyleColor = Nothing
, _borderStyleLine = Nothing
}
instance Default Color where
def = Color {
_colorAutomatic = Nothing
, _colorARGB = Nothing
, _colorTheme = Nothing
, _colorTint = Nothing
}
instance Default Fill where
def = Fill {
_fillPattern = Nothing
}
instance Default FillPattern where
def = FillPattern {
_fillPatternBgColor = Nothing
, _fillPatternFgColor = Nothing
, _fillPatternType = Nothing
}
instance Default Font where
def = Font {
_fontBold = Nothing
, _fontCharset = Nothing
, _fontColor = Nothing
, _fontCondense = Nothing
, _fontExtend = Nothing
, _fontFamily = Nothing
, _fontItalic = Nothing
, _fontName = Nothing
, _fontOutline = Nothing
, _fontScheme = Nothing
, _fontShadow = Nothing
, _fontStrikeThrough = Nothing
, _fontSize = Nothing
, _fontUnderline = Nothing
, _fontVertAlign = Nothing
}
instance Default Protection where
def = Protection {
_protectionHidden = Nothing
, _protectionLocked = Nothing
}
{-------------------------------------------------------------------------------
Rendering record types
NOTE: Excel is sensitive to the order of the child nodes, so we are careful
to follow the XML schema here. We are also careful to follow the ordering
for attributes, although this is actually pointless, as xml-conduit stores
these as a Map, so we lose the ordering. But if we change representation,
at least they are in the right order (hopefully) in the source code.
-------------------------------------------------------------------------------}
instance ToDocument StyleSheet where
toDocument = documentFromElement "Stylesheet generated by xlsx"
. toElement "styleSheet"
-- | See @CT_Stylesheet@, p. 4482
instance ToElement StyleSheet where
toElement nm StyleSheet{..} = elementListSimple nm elements
where
countedElementList' nm' xs = maybeToList $ nonEmptyCountedElementList nm' xs
elements = countedElementList' "numFmts" (map (toElement "numFmt") numFmts) ++
countedElementList' "fonts" (map (toElement "font") _styleSheetFonts) ++
countedElementList' "fills" (map (toElement "fill") _styleSheetFills) ++
countedElementList' "borders" (map (toElement "border") _styleSheetBorders) ++
-- TODO: cellStyleXfs
countedElementList' "cellXfs" (map (toElement "xf") _styleSheetCellXfs) ++
-- TODO: cellStyles
countedElementList' "dxfs" (map (toElement "dxf") _styleSheetDxfs)
-- TODO: tableStyles
-- TODO: colors
-- TODO: extLst
numFmts = map (uncurry NumFmt) $ M.toList _styleSheetNumFmts
-- | See @CT_Xf@, p. 4486
instance ToElement CellXf where
toElement nm CellXf{..} = Element {
elementName = nm
, elementNodes = map NodeElement . catMaybes $ [
toElement "alignment" <$> _cellXfAlignment
, toElement "protection" <$> _cellXfProtection
-- TODO: extLst
]
, elementAttributes = M.fromList . catMaybes $ [
"numFmtId" .=? _cellXfNumFmtId
, "fontId" .=? _cellXfFontId
, "fillId" .=? _cellXfFillId
, "borderId" .=? _cellXfBorderId
, "xfId" .=? _cellXfId
, "quotePrefix" .=? _cellXfQuotePrefix
, "pivotButton" .=? _cellXfPivotButton
, "applyNumberFormat" .=? _cellXfApplyNumberFormat
, "applyFont" .=? _cellXfApplyFont
, "applyFill" .=? _cellXfApplyFill
, "applyBorder" .=? _cellXfApplyBorder
, "applyAlignment" .=? _cellXfApplyAlignment
, "applyProtection" .=? _cellXfApplyProtection
]
}
-- | See @CT_Dxf@, p. 3937
instance ToElement Dxf where
toElement nm Dxf{..} = Element
{ elementName = nm
, elementNodes = map NodeElement $
catMaybes [ toElement "font" <$> _dxfFont
, toElement "numFmt" <$> _dxfNumFmt
, toElement "fill" <$> _dxfFill
, toElement "alignment" <$> _dxfAlignment
, toElement "border" <$> _dxfBorder
, toElement "protection" <$> _dxfProtection
]
, elementAttributes = M.empty
}
-- | See @CT_CellAlignment@, p. 4482
instance ToElement Alignment where
toElement nm Alignment{..} = Element {
elementName = nm
, elementNodes = []
, elementAttributes = M.fromList . catMaybes $ [
"horizontal" .=? _alignmentHorizontal
, "vertical" .=? _alignmentVertical
, "textRotation" .=? _alignmentTextRotation
, "wrapText" .=? _alignmentWrapText
, "relativeIndent" .=? _alignmentRelativeIndent
, "indent" .=? _alignmentIndent
, "justifyLastLine" .=? _alignmentJustifyLastLine
, "shrinkToFit" .=? _alignmentShrinkToFit
, "readingOrder" .=? _alignmentReadingOrder
]
}
-- | See @CT_Border@, p. 4483
instance ToElement Border where
toElement nm Border{..} = Element {
elementName = nm
, elementAttributes = M.fromList . catMaybes $ [
"diagonalUp" .=? _borderDiagonalUp
, "diagonalDown" .=? _borderDiagonalDown
, "outline" .=? _borderOutline
]
, elementNodes = map NodeElement . catMaybes $ [
toElement "start" <$> _borderStart
, toElement "end" <$> _borderEnd
, toElement "left" <$> _borderLeft
, toElement "right" <$> _borderRight
, toElement "top" <$> _borderTop
, toElement "bottom" <$> _borderBottom
, toElement "diagonal" <$> _borderDiagonal
, toElement "vertical" <$> _borderVertical
, toElement "horizontal" <$> _borderHorizontal
]
}
-- | See @CT_BorderPr@, p. 4483
instance ToElement BorderStyle where
toElement nm BorderStyle{..} = Element {
elementName = nm
, elementAttributes = M.fromList . catMaybes $ [
"style" .=? _borderStyleLine
]
, elementNodes = map NodeElement . catMaybes $ [
toElement "color" <$> _borderStyleColor
]
}
-- | See @CT_Color@, p. 4484
instance ToElement Color where
toElement nm Color{..} = Element {
elementName = nm
, elementNodes = []
, elementAttributes = M.fromList . catMaybes $ [
"auto" .=? _colorAutomatic
, "rgb" .=? _colorARGB
, "theme" .=? _colorTheme
, "tint" .=? _colorTint
]
}
-- | See @CT_Fill@, p. 4484
instance ToElement Fill where
toElement nm Fill{..} = Element {
elementName = nm
, elementAttributes = M.empty
, elementNodes = map NodeElement . catMaybes $ [
toElement "patternFill" <$> _fillPattern
]
}
-- | See @CT_PatternFill@, p. 4484
instance ToElement FillPattern where
toElement nm FillPattern{..} = Element {
elementName = nm
, elementAttributes = M.fromList . catMaybes $ [
"patternType" .=? _fillPatternType
]
, elementNodes = map NodeElement . catMaybes $ [
toElement "fgColor" <$> _fillPatternFgColor
, toElement "bgColor" <$> _fillPatternBgColor
]
}
-- | See @CT_Font@, p. 4489
instance ToElement Font where
toElement nm Font{..} = Element {
elementName = nm
, elementAttributes = M.empty -- all properties specified as child nodes
, elementNodes = map NodeElement . catMaybes $ [
elementValue "name" <$> _fontName
, elementValue "charset" <$> _fontCharset
, elementValue "family" <$> _fontFamily
, elementValue "b" <$> _fontBold
, elementValue "i" <$> _fontItalic
, elementValue "strike" <$> _fontStrikeThrough
, elementValue "outline" <$> _fontOutline
, elementValue "shadow" <$> _fontShadow
, elementValue "condense" <$> _fontCondense
, elementValue "extend" <$> _fontExtend
, toElement "color" <$> _fontColor
, elementValue "sz" <$> _fontSize
, elementValue "u" <$> _fontUnderline
, elementValue "vertAlign" <$> _fontVertAlign
, elementValue "scheme" <$> _fontScheme
]
}
-- | See @CT_NumFmt@, p. 3936
instance ToElement NumFmt where
toElement nm (NumFmt {..}) =
leafElement nm
[ "numFmtId" .= toAttrVal _numFmtId
, "formatCode" .= toAttrVal _numFmtCode
]
-- | See @CT_CellProtection@, p. 4484
instance ToElement Protection where
toElement nm Protection{..} = Element {
elementName = nm
, elementNodes = []
, elementAttributes = M.fromList . catMaybes $ [
"locked" .=? _protectionLocked
, "hidden" .=? _protectionHidden
]
}
{-------------------------------------------------------------------------------
Rendering attribute values
-------------------------------------------------------------------------------}
instance ToAttrVal CellHorizontalAlignment where
toAttrVal CellHorizontalAlignmentCenter = "center"
toAttrVal CellHorizontalAlignmentCenterContinuous = "centerContinuous"
toAttrVal CellHorizontalAlignmentDistributed = "distributed"
toAttrVal CellHorizontalAlignmentFill = "fill"
toAttrVal CellHorizontalAlignmentGeneral = "general"
toAttrVal CellHorizontalAlignmentJustify = "justify"
toAttrVal CellHorizontalAlignmentLeft = "left"
toAttrVal CellHorizontalAlignmentRight = "right"
instance ToAttrVal CellVerticalAlignment where
toAttrVal CellVerticalAlignmentBottom = "bottom"
toAttrVal CellVerticalAlignmentCenter = "center"
toAttrVal CellVerticalAlignmentDistributed = "distributed"
toAttrVal CellVerticalAlignmentJustify = "justify"
toAttrVal CellVerticalAlignmentTop = "top"
instance ToAttrVal FontFamily where
toAttrVal FontFamilyNotApplicable = "0"
toAttrVal FontFamilyRoman = "1"
toAttrVal FontFamilySwiss = "2"
toAttrVal FontFamilyModern = "3"
toAttrVal FontFamilyScript = "4"
toAttrVal FontFamilyDecorative = "5"
instance ToAttrVal FontScheme where
toAttrVal FontSchemeMajor = "major"
toAttrVal FontSchemeMinor = "minor"
toAttrVal FontSchemeNone = "none"
-- See @ST_UnderlineValues@, p. 3940
instance ToAttrVal FontUnderline where
toAttrVal FontUnderlineSingle = "single"
toAttrVal FontUnderlineDouble = "double"
toAttrVal FontUnderlineSingleAccounting = "singleAccounting"
toAttrVal FontUnderlineDoubleAccounting = "doubleAccounting"
toAttrVal FontUnderlineNone = "none"
instance ToAttrVal FontVerticalAlignment where
toAttrVal FontVerticalAlignmentBaseline = "baseline"
toAttrVal FontVerticalAlignmentSubscript = "subscript"
toAttrVal FontVerticalAlignmentSuperscript = "superscript"
instance ToAttrVal LineStyle where
toAttrVal LineStyleDashDot = "dashDot"
toAttrVal LineStyleDashDotDot = "dashDotDot"
toAttrVal LineStyleDashed = "dashed"
toAttrVal LineStyleDotted = "dotted"
toAttrVal LineStyleDouble = "double"
toAttrVal LineStyleHair = "hair"
toAttrVal LineStyleMedium = "medium"
toAttrVal LineStyleMediumDashDot = "mediumDashDot"
toAttrVal LineStyleMediumDashDotDot = "mediumDashDotDot"
toAttrVal LineStyleMediumDashed = "mediumDashed"
toAttrVal LineStyleNone = "none"
toAttrVal LineStyleSlantDashDot = "slantDashDot"
toAttrVal LineStyleThick = "thick"
toAttrVal LineStyleThin = "thin"
instance ToAttrVal PatternType where
toAttrVal PatternTypeDarkDown = "darkDown"
toAttrVal PatternTypeDarkGray = "darkGray"
toAttrVal PatternTypeDarkGrid = "darkGrid"
toAttrVal PatternTypeDarkHorizontal = "darkHorizontal"
toAttrVal PatternTypeDarkTrellis = "darkTrellis"
toAttrVal PatternTypeDarkUp = "darkUp"
toAttrVal PatternTypeDarkVertical = "darkVertical"
toAttrVal PatternTypeGray0625 = "gray0625"
toAttrVal PatternTypeGray125 = "gray125"
toAttrVal PatternTypeLightDown = "lightDown"
toAttrVal PatternTypeLightGray = "lightGray"
toAttrVal PatternTypeLightGrid = "lightGrid"
toAttrVal PatternTypeLightHorizontal = "lightHorizontal"
toAttrVal PatternTypeLightTrellis = "lightTrellis"
toAttrVal PatternTypeLightUp = "lightUp"
toAttrVal PatternTypeLightVertical = "lightVertical"
toAttrVal PatternTypeMediumGray = "mediumGray"
toAttrVal PatternTypeNone = "none"
toAttrVal PatternTypeSolid = "solid"
instance ToAttrVal ReadingOrder where
toAttrVal ReadingOrderContextDependent = "0"
toAttrVal ReadingOrderLeftToRight = "1"
toAttrVal ReadingOrderRightToLeft = "2"
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
-- | See @CT_Stylesheet@, p. 4482
instance FromCursor StyleSheet where
fromCursor cur = do
let
_styleSheetFonts = cur $/ element (n_ "fonts") &/ element (n_ "font") >=> fromCursor
_styleSheetFills = cur $/ element (n_ "fills") &/ element (n_ "fill") >=> fromCursor
_styleSheetBorders = cur $/ element (n_ "borders") &/ element (n_ "border") >=> fromCursor
-- TODO: cellStyleXfs
_styleSheetCellXfs = cur $/ element (n_ "cellXfs") &/ element (n_ "xf") >=> fromCursor
-- TODO: cellStyles
_styleSheetDxfs = cur $/ element (n_ "dxfs") &/ element (n_ "dxf") >=> fromCursor
_styleSheetNumFmts = M.fromList . map mkNumFmtPair $
cur $/ element (n_ "numFmts")&/ element (n_ "numFmt") >=> fromCursor
-- TODO: tableStyles
-- TODO: colors
-- TODO: extLst
return StyleSheet{..}
-- | See @CT_Font@, p. 4489
instance FromCursor Font where
fromCursor cur = do
_fontName <- maybeElementValue (n_ "name") cur
_fontCharset <- maybeElementValue (n_ "charset") cur
_fontFamily <- maybeElementValue (n_ "family") cur
_fontBold <- maybeBoolElementValue (n_ "b") cur
_fontItalic <- maybeBoolElementValue (n_ "i") cur
_fontStrikeThrough<- maybeBoolElementValue (n_ "strike") cur
_fontOutline <- maybeBoolElementValue (n_ "outline") cur
_fontShadow <- maybeBoolElementValue (n_ "shadow") cur
_fontCondense <- maybeBoolElementValue (n_ "condense") cur
_fontExtend <- maybeBoolElementValue (n_ "extend") cur
_fontColor <- maybeFromElement (n_ "color") cur
_fontSize <- maybeElementValue (n_ "sz") cur
_fontUnderline <- maybeElementValueDef (n_ "u") FontUnderlineSingle cur
_fontVertAlign <- maybeElementValue (n_ "vertAlign") cur
_fontScheme <- maybeElementValue (n_ "scheme") cur
return Font{..}
-- | See 18.18.94 "ST_FontFamily (Font Family)" (p. 2517)
instance FromAttrVal FontFamily where
fromAttrVal "0" = readSuccess FontFamilyNotApplicable
fromAttrVal "1" = readSuccess FontFamilyRoman
fromAttrVal "2" = readSuccess FontFamilySwiss
fromAttrVal "3" = readSuccess FontFamilyModern
fromAttrVal "4" = readSuccess FontFamilyScript
fromAttrVal "5" = readSuccess FontFamilyDecorative
fromAttrVal t = invalidText "FontFamily" t
instance FromAttrBs FontFamily where
fromAttrBs "0" = return FontFamilyNotApplicable
fromAttrBs "1" = return FontFamilyRoman
fromAttrBs "2" = return FontFamilySwiss
fromAttrBs "3" = return FontFamilyModern
fromAttrBs "4" = return FontFamilyScript
fromAttrBs "5" = return FontFamilyDecorative
fromAttrBs x = unexpectedAttrBs "FontFamily" x
-- | See @CT_Color@, p. 4484
instance FromCursor Color where
fromCursor cur = do
_colorAutomatic <- maybeAttribute "auto" cur
_colorARGB <- maybeAttribute "rgb" cur
_colorTheme <- maybeAttribute "theme" cur
_colorTint <- maybeAttribute "tint" cur
return Color{..}
instance FromXenoNode Color where
fromXenoNode root =
parseAttributes root $ do
_colorAutomatic <- maybeAttr "auto"
_colorARGB <- maybeAttr "rgb"
_colorTheme <- maybeAttr "theme"
_colorTint <- maybeAttr "tint"
return Color {..}
-- See @ST_UnderlineValues@, p. 3940
instance FromAttrVal FontUnderline where
fromAttrVal "single" = readSuccess FontUnderlineSingle
fromAttrVal "double" = readSuccess FontUnderlineDouble
fromAttrVal "singleAccounting" = readSuccess FontUnderlineSingleAccounting
fromAttrVal "doubleAccounting" = readSuccess FontUnderlineDoubleAccounting
fromAttrVal "none" = readSuccess FontUnderlineNone
fromAttrVal t = invalidText "FontUnderline" t
instance FromAttrBs FontUnderline where
fromAttrBs "single" = return FontUnderlineSingle
fromAttrBs "double" = return FontUnderlineDouble
fromAttrBs "singleAccounting" = return FontUnderlineSingleAccounting
fromAttrBs "doubleAccounting" = return FontUnderlineDoubleAccounting
fromAttrBs "none" = return FontUnderlineNone
fromAttrBs x = unexpectedAttrBs "FontUnderline" x
instance FromAttrVal FontVerticalAlignment where
fromAttrVal "baseline" = readSuccess FontVerticalAlignmentBaseline
fromAttrVal "subscript" = readSuccess FontVerticalAlignmentSubscript
fromAttrVal "superscript" = readSuccess FontVerticalAlignmentSuperscript
fromAttrVal t = invalidText "FontVerticalAlignment" t
instance FromAttrBs FontVerticalAlignment where
fromAttrBs "baseline" = return FontVerticalAlignmentBaseline
fromAttrBs "subscript" = return FontVerticalAlignmentSubscript
fromAttrBs "superscript" = return FontVerticalAlignmentSuperscript
fromAttrBs x = unexpectedAttrBs "FontVerticalAlignment" x
instance FromAttrVal FontScheme where
fromAttrVal "major" = readSuccess FontSchemeMajor
fromAttrVal "minor" = readSuccess FontSchemeMinor
fromAttrVal "none" = readSuccess FontSchemeNone
fromAttrVal t = invalidText "FontScheme" t
instance FromAttrBs FontScheme where
fromAttrBs "major" = return FontSchemeMajor
fromAttrBs "minor" = return FontSchemeMinor
fromAttrBs "none" = return FontSchemeNone
fromAttrBs x = unexpectedAttrBs "FontScheme" x
-- | See @CT_Fill@, p. 4484
instance FromCursor Fill where
fromCursor cur = do
_fillPattern <- maybeFromElement (n_ "patternFill") cur
return Fill{..}
-- | See @CT_PatternFill@, p. 4484
instance FromCursor FillPattern where
fromCursor cur = do
_fillPatternType <- maybeAttribute "patternType" cur
_fillPatternFgColor <- maybeFromElement (n_ "fgColor") cur
_fillPatternBgColor <- maybeFromElement (n_ "bgColor") cur
return FillPattern{..}
instance FromAttrVal PatternType where
fromAttrVal "darkDown" = readSuccess PatternTypeDarkDown
fromAttrVal "darkGray" = readSuccess PatternTypeDarkGray
fromAttrVal "darkGrid" = readSuccess PatternTypeDarkGrid
fromAttrVal "darkHorizontal" = readSuccess PatternTypeDarkHorizontal
fromAttrVal "darkTrellis" = readSuccess PatternTypeDarkTrellis
fromAttrVal "darkUp" = readSuccess PatternTypeDarkUp
fromAttrVal "darkVertical" = readSuccess PatternTypeDarkVertical
fromAttrVal "gray0625" = readSuccess PatternTypeGray0625
fromAttrVal "gray125" = readSuccess PatternTypeGray125
fromAttrVal "lightDown" = readSuccess PatternTypeLightDown
fromAttrVal "lightGray" = readSuccess PatternTypeLightGray
fromAttrVal "lightGrid" = readSuccess PatternTypeLightGrid
fromAttrVal "lightHorizontal" = readSuccess PatternTypeLightHorizontal
fromAttrVal "lightTrellis" = readSuccess PatternTypeLightTrellis
fromAttrVal "lightUp" = readSuccess PatternTypeLightUp
fromAttrVal "lightVertical" = readSuccess PatternTypeLightVertical
fromAttrVal "mediumGray" = readSuccess PatternTypeMediumGray
fromAttrVal "none" = readSuccess PatternTypeNone
fromAttrVal "solid" = readSuccess PatternTypeSolid
fromAttrVal t = invalidText "PatternType" t
-- | See @CT_Border@, p. 4483
instance FromCursor Border where
fromCursor cur = do
_borderDiagonalUp <- maybeAttribute "diagonalUp" cur
_borderDiagonalDown <- maybeAttribute "diagonalDown" cur
_borderOutline <- maybeAttribute "outline" cur
_borderStart <- maybeFromElement (n_ "start") cur
_borderEnd <- maybeFromElement (n_ "end") cur
_borderLeft <- maybeFromElement (n_ "left") cur
_borderRight <- maybeFromElement (n_ "right") cur
_borderTop <- maybeFromElement (n_ "top") cur
_borderBottom <- maybeFromElement (n_ "bottom") cur
_borderDiagonal <- maybeFromElement (n_ "diagonal") cur
_borderVertical <- maybeFromElement (n_ "vertical") cur
_borderHorizontal <- maybeFromElement (n_ "horizontal") cur
return Border{..}
instance FromCursor BorderStyle where
fromCursor cur = do
_borderStyleLine <- maybeAttribute "style" cur
_borderStyleColor <- maybeFromElement (n_ "color") cur
return BorderStyle{..}
instance FromAttrVal LineStyle where
fromAttrVal "dashDot" = readSuccess LineStyleDashDot
fromAttrVal "dashDotDot" = readSuccess LineStyleDashDotDot
fromAttrVal "dashed" = readSuccess LineStyleDashed
fromAttrVal "dotted" = readSuccess LineStyleDotted
fromAttrVal "double" = readSuccess LineStyleDouble
fromAttrVal "hair" = readSuccess LineStyleHair
fromAttrVal "medium" = readSuccess LineStyleMedium
fromAttrVal "mediumDashDot" = readSuccess LineStyleMediumDashDot
fromAttrVal "mediumDashDotDot" = readSuccess LineStyleMediumDashDotDot
fromAttrVal "mediumDashed" = readSuccess LineStyleMediumDashed
fromAttrVal "none" = readSuccess LineStyleNone
fromAttrVal "slantDashDot" = readSuccess LineStyleSlantDashDot
fromAttrVal "thick" = readSuccess LineStyleThick
fromAttrVal "thin" = readSuccess LineStyleThin
fromAttrVal t = invalidText "LineStyle" t
-- | See @CT_Xf@, p. 4486
instance FromCursor CellXf where
fromCursor cur = do
_cellXfAlignment <- maybeFromElement (n_ "alignment") cur
_cellXfProtection <- maybeFromElement (n_ "protection") cur
_cellXfNumFmtId <- maybeAttribute "numFmtId" cur
_cellXfFontId <- maybeAttribute "fontId" cur
_cellXfFillId <- maybeAttribute "fillId" cur
_cellXfBorderId <- maybeAttribute "borderId" cur
_cellXfId <- maybeAttribute "xfId" cur
_cellXfQuotePrefix <- maybeAttribute "quotePrefix" cur
_cellXfPivotButton <- maybeAttribute "pivotButton" cur
_cellXfApplyNumberFormat <- maybeAttribute "applyNumberFormat" cur
_cellXfApplyFont <- maybeAttribute "applyFont" cur
_cellXfApplyFill <- maybeAttribute "applyFill" cur
_cellXfApplyBorder <- maybeAttribute "applyBorder" cur
_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
_dxfNumFmt <- maybeFromElement (n_ "numFmt") 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_NumFmt@, p. 3936
instance FromCursor NumFmt where
fromCursor cur = do
_numFmtCode <- fromAttribute "formatCode" cur
_numFmtId <- fromAttribute "numFmtId" cur
return NumFmt{..}
-- | See @CT_CellAlignment@, p. 4482
instance FromCursor Alignment where
fromCursor cur = do
_alignmentHorizontal <- maybeAttribute "horizontal" cur
_alignmentVertical <- maybeAttribute "vertical" cur
_alignmentTextRotation <- maybeAttribute "textRotation" cur
_alignmentWrapText <- maybeAttribute "wrapText" cur
_alignmentRelativeIndent <- maybeAttribute "relativeIndent" cur
_alignmentIndent <- maybeAttribute "indent" cur
_alignmentJustifyLastLine <- maybeAttribute "justifyLastLine" cur
_alignmentShrinkToFit <- maybeAttribute "shrinkToFit" cur
_alignmentReadingOrder <- maybeAttribute "readingOrder" cur
return Alignment{..}
instance FromAttrVal CellHorizontalAlignment where
fromAttrVal "center" = readSuccess CellHorizontalAlignmentCenter
fromAttrVal "centerContinuous" = readSuccess CellHorizontalAlignmentCenterContinuous
fromAttrVal "distributed" = readSuccess CellHorizontalAlignmentDistributed
fromAttrVal "fill" = readSuccess CellHorizontalAlignmentFill
fromAttrVal "general" = readSuccess CellHorizontalAlignmentGeneral
fromAttrVal "justify" = readSuccess CellHorizontalAlignmentJustify
fromAttrVal "left" = readSuccess CellHorizontalAlignmentLeft
fromAttrVal "right" = readSuccess CellHorizontalAlignmentRight
fromAttrVal t = invalidText "CellHorizontalAlignment" t
instance FromAttrVal CellVerticalAlignment where
fromAttrVal "bottom" = readSuccess CellVerticalAlignmentBottom
fromAttrVal "center" = readSuccess CellVerticalAlignmentCenter
fromAttrVal "distributed" = readSuccess CellVerticalAlignmentDistributed
fromAttrVal "justify" = readSuccess CellVerticalAlignmentJustify
fromAttrVal "top" = readSuccess CellVerticalAlignmentTop
fromAttrVal t = invalidText "CellVerticalAlignment" t
instance FromAttrVal ReadingOrder where
fromAttrVal "0" = readSuccess ReadingOrderContextDependent
fromAttrVal "1" = readSuccess ReadingOrderLeftToRight
fromAttrVal "2" = readSuccess ReadingOrderRightToLeft
fromAttrVal t = invalidText "ReadingOrder" t
-- | See @CT_CellProtection@, p. 4484
instance FromCursor Protection where
fromCursor cur = do
_protectionLocked <- maybeAttribute "locked" cur
_protectionHidden <- maybeAttribute "hidden" cur
return Protection{..}
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Table.hs 0000644 0000000 0000000 00000011231 14551273353 016276 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Table where
#ifdef USE_MICROLENS
import Lens.Micro.TH (makeLenses)
#else
import Control.Lens (makeLenses)
#endif
import Control.DeepSeq (NFData)
import Data.Maybe (catMaybes, maybeToList)
import Data.Text (Text)
import GHC.Generics (Generic)
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.AutoFilter
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Writer.Internal
-- | Tables are ranges of data in the worksheet that have special
-- behavior applied which allow users to better sort, analyze, format,
-- manage, add, and delete data. Tables and table columns can also be
-- referenced through formulas by the spreadsheet application using
-- friendly names, making formula calculations that use tables much
-- easier to understand and maintain. Tables provide a natural way for
-- working with large sets of tabular data.
--
-- NOTE: as @headerRowCount@ property isn't yet supported it's
-- supposed that it's library user liability to guarantee that the 1st
-- row of 'tblRef' range contains cells with names specified in
-- `tblColumns`
--
-- Section 18.5 \"Tables\" (p. 1728)
-- Section 18.5.1 \"Tables\" (p. 1729)
-- Section 18.5.1.2 "table (Table)" (p. 1730)
data Table = Table
{ tblDisplayName :: Text
-- ^ A string representing the name of the table. This is the name
-- that shall be used in formula references, and displayed in the UI
-- to the spreadsheet user. This name shall not have any spaces in
-- it, and it shall be unique amongst all other displayNames and
-- definedNames in the workbook. The character lengths and
-- restrictions are the same as for definedNames .
, tblName :: Maybe Text
-- ^ A string representing the name of the table that is used to
-- reference the table programmatically through the spreadsheet
-- applications object model. This string shall be unique per table
-- per sheet. It has the same length and character restrictions as
-- for displayName. By default this should be the same as the
-- table's 'tblDisplayName' . This name should also be kept in synch with
-- the displayName when the displayName is updated in the UI by the
-- spreadsheet user.
, tblRef :: CellRef
-- ^ The range on the relevant sheet that the table occupies
-- expressed using A1 style referencing.
, tblColumns :: [TableColumn]
-- ^ columns of this table, specification requires any table to
-- include at least 1 column
, tblAutoFilter :: Maybe AutoFilter
} deriving (Eq, Show, Generic)
instance NFData Table
-- | Single table column
--
-- TODO: styling information
--
-- Section 18.5.1.3 "tableColumn (Table Column)" (p. 1735)
data TableColumn = TableColumn
{ tblcName :: Text
-- ^ A string representing the unique caption of the table
-- column. This is what shall be displayed in the header row in the
-- UI, and is referenced through functions. This name shall be
-- unique per table.
} deriving (Eq, Show, Generic)
instance NFData TableColumn
makeLenses ''Table
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
instance FromCursor Table where
fromCursor c = do
tblDisplayName <- fromAttribute "displayName" c
tblName <- maybeAttribute "name" c
tblRef <- fromAttribute "ref" c
tblAutoFilter <- maybeFromElement (n_ "autoFilter") c
let tblColumns =
c $/ element (n_ "tableColumns") &/ element (n_ "tableColumn") >=>
fmap TableColumn . fromAttribute "name"
return Table {..}
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
tableToDocument :: Table -> Int -> Document
tableToDocument tbl i =
documentFromElement "Table generated by xlsx" $
tableToElement "table" tbl i
tableToElement :: Name -> Table -> Int -> Element
tableToElement nm Table {..} i = elementList nm attrs subElements
where
attrs =
[ "id" .= i
, "displayName" .= tblDisplayName
, "ref" .= tblRef
] ++
catMaybes
[ "name" .=? tblName
]
subElements =
maybeToList (toElement "autoFilter" <$> tblAutoFilter) ++
maybeToList (nonEmptyCountedElementList
"tableColumns"
[ leafElement "tableColumn" ["id" .= i', "name" .= tblcName c]
| (i', c) <- zip [(1 :: Int) ..] tblColumns
]
)
xlsx-1.1.2.2/src/Codec/Xlsx/Types/Variant.hs 0000644 0000000 0000000 00000006167 14551273353 016667 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Variant where
import Control.DeepSeq (NFData)
import Control.Monad.Fail (MonadFail)
import Data.ByteString (ByteString)
import Data.ByteString.Base64 as B64
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import GHC.Generics (Generic)
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Writer.Internal
data Variant
= VtBlob ByteString
| VtBool Bool
| VtDecimal Double
| VtLpwstr Text
| VtInt Int
-- TODO: vt_vector, vt_array, vt_oblob, vt_empty, vt_null, vt_i1, vt_i2,
-- vt_i4, vt_i8, vt_ui1, vt_ui2, vt_ui4, vt_ui8, vt_uint, vt_r4, vt_r8,
-- vt_lpstr, vt_bstr, vt_date, vt_filetime, vt_cy, vt_error, vt_stream,
-- vt_ostream, vt_storage, vt_ostorage, vt_vstream, vt_clsid
deriving (Eq, Show, Generic)
instance NFData Variant
{-------------------------------------------------------------------------------
Parsing
-------------------------------------------------------------------------------}
instance FromCursor Variant where
fromCursor = variantFromNode . node
variantFromNode :: Node -> [Variant]
variantFromNode n@(NodeElement el) | elementName el == vt "lpwstr" =
fromNode n $/ content &| VtLpwstr
| elementName el == vt "bool" =
fromNode n $/ content >=> fmap VtBool . boolean
| elementName el == vt "int" =
fromNode n $/ content >=> fmap VtInt . decimal
| elementName el == vt "decimal" =
fromNode n $/ content >=> fmap VtDecimal . rational
| elementName el == vt "blob" =
fromNode n $/ content >=> fmap VtBlob . decodeBase64 . killWhitespace
variantFromNode _ = fail "no matching nodes"
killWhitespace :: Text -> Text
killWhitespace = T.filter (/=' ')
decodeBase64 :: MonadFail m => Text -> m ByteString
decodeBase64 t = case B64.decode (T.encodeUtf8 t) of
Right bs -> return bs
Left err -> fail $ "invalid base64 value: " ++ err
-- | Add doc props variant types namespace to name
vt :: Text -> Name
vt x = Name
{ nameLocalName = x
, nameNamespace = Just docPropsVtNs
, namePrefix = Nothing
}
docPropsVtNs :: Text
docPropsVtNs = "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes"
{-------------------------------------------------------------------------------
Rendering
-------------------------------------------------------------------------------}
variantToElement :: Variant -> Element
variantToElement (VtLpwstr t) = elementContent (vt"lpwstr") t
variantToElement (VtBlob bs) = elementContent (vt"blob") (T.decodeLatin1 $ B64.encode bs)
variantToElement (VtBool b) = elementContent (vt"bool") (txtb b)
variantToElement (VtDecimal d) = elementContent (vt"decimal") (txtd d)
variantToElement (VtInt i) = elementContent (vt"int") (txti i)
xlsx-1.1.2.2/src/Codec/Xlsx/Writer.hs 0000644 0000000 0000000 00000063303 14551273353 015426 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveGeneric #-}
-- | This module provides a function for serializing structured `Xlsx` into lazy bytestring
module Codec.Xlsx.Writer
( fromXlsx
) where
import qualified "zip-archive" Codec.Archive.Zip as Zip
import Control.Arrow (second)
#ifdef USE_MICROLENS
import Lens.Micro
#else
import Control.Lens hiding (transform, (.=))
#endif
import Control.Monad (forM)
import Control.Monad.ST
import Control.Monad.State (evalState, get, put)
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Lazy.Char8 ()
import Data.List (foldl', mapAccumL)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid ((<>))
import Data.STRef
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)
import Data.Time.Format (formatTime)
import Data.Time.Format (defaultTimeLocale)
import Data.Tuple.Extra (fst3, snd3, thd3)
import GHC.Generics (Generic)
import Safe
import Text.XML
import Codec.Xlsx.Types
import Codec.Xlsx.Types.Cell (applySharedFormulaOpts)
import Codec.Xlsx.Types.Internal
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.DvPair
import Codec.Xlsx.Types.Internal.Relationships as Relationships
hiding (lookup)
import Codec.Xlsx.Types.Internal.SharedStringTable
import Codec.Xlsx.Types.PivotTable.Internal
import Codec.Xlsx.Writer.Internal
import Codec.Xlsx.Writer.Internal.PivotTable
-- | Writes `Xlsx' to raw data (lazy bytestring)
fromXlsx :: POSIXTime -> Xlsx -> L.ByteString
fromXlsx pt xlsx =
Zip.fromArchive $ foldr Zip.addEntryToArchive Zip.emptyArchive entries
where
t = round pt
utcTime = posixSecondsToUTCTime pt
entries = Zip.toEntry "[Content_Types].xml" t (contentTypesXml files) :
map (\fd -> Zip.toEntry (fdPath fd) t (fdContents fd)) files
files = workbookFiles ++ customPropFiles ++
[ FileData "docProps/core.xml"
"application/vnd.openxmlformats-package.core-properties+xml"
"metadata/core-properties" $ coreXml utcTime "xlsxwriter"
, FileData "docProps/app.xml"
"application/vnd.openxmlformats-officedocument.extended-properties+xml"
"xtended-properties" $ appXml sheetNames
, FileData "_rels/.rels" "application/vnd.openxmlformats-package.relationships+xml"
"relationships" rootRelXml
]
rootRelXml = renderLBS def . toDocument $ Relationships.fromList rootRels
rootFiles = customPropFileRels ++
[ ("officeDocument", "xl/workbook.xml")
, ("metadata/core-properties", "docProps/core.xml")
, ("extended-properties", "docProps/app.xml") ]
rootRels = [ relEntry (unsafeRefId i) typ trg
| (i, (typ, trg)) <- zip [1..] rootFiles ]
customProps = xlsx ^. xlCustomProperties
(customPropFiles, customPropFileRels) = case M.null customProps of
True -> ([], [])
False -> ([ FileData "docProps/custom.xml"
"application/vnd.openxmlformats-officedocument.custom-properties+xml"
"custom-properties"
(customPropsXml (CustomProperties customProps)) ],
[ ("custom-properties", "docProps/custom.xml") ])
workbookFiles = bookFiles xlsx
sheetNames = xlsx ^. xlSheets & mapped %~ fst
singleSheetFiles :: Int
-> Cells
-> [FileData]
-> Worksheet
-> STRef s Int
-> ST s (FileData, [FileData])
singleSheetFiles n cells pivFileDatas ws tblIdRef = do
ref <- newSTRef 1
mCmntData <- genComments n cells ref
mDrawingData <- maybe (return Nothing) (fmap Just . genDrawing n ref) (ws ^. wsDrawing)
pivRefs <- forM pivFileDatas $ \fd -> do
refId <- nextRefId ref
return (refId, fd)
refTables <- forM (_wsTables ws) $ \tbl -> do
refId <- nextRefId ref
tblId <- readSTRef tblIdRef
modifySTRef' tblIdRef (+1)
return (refId, genTable tbl tblId)
let sheetFilePath = "xl/worksheets/sheet" <> show n <> ".xml"
sheetFile = FileData sheetFilePath
"application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml"
"worksheet" $
sheetXml
nss = [ ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ]
sheetXml= renderLBS def{rsNamespaces=nss} $ Document (Prologue [] Nothing []) root []
root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" Nothing $
elementListSimple "worksheet" rootEls
rootEls = catMaybes $
[ elementListSimple "sheetViews" . map (toElement "sheetView") <$> ws ^. wsSheetViews
, nonEmptyElListSimple "cols" . map (toElement "col") $ ws ^. wsColumnsProperties
, Just . elementListSimple "sheetData" $
sheetDataXml cells (ws ^. wsRowPropertiesMap) (ws ^. wsSharedFormulas)
, toElement "sheetProtection" <$> (ws ^. wsProtection)
, toElement "autoFilter" <$> (ws ^. wsAutoFilter)
, nonEmptyElListSimple "mergeCells" . map mergeE1 $ ws ^. wsMerges
] ++ map (Just . toElement "conditionalFormatting") cfPairs ++
[ nonEmptyElListSimple "dataValidations" $ map (toElement "dataValidation") dvPairs
, toElement "pageSetup" <$> ws ^. wsPageSetup
, fst3 <$> mDrawingData
, fst <$> mCmntData
, nonEmptyElListSimple "tableParts"
[leafElement "tablePart" [odr "id" .= rId] | (rId, _) <- refTables]
]
cfPairs = map CfPair . M.toList $ ws ^. wsConditionalFormattings
dvPairs = map DvPair . M.toList $ ws ^. wsDataValidations
mergeE1 r = leafElement "mergeCell" [("ref" .= r)]
sheetRels = if null referencedFiles
then []
else [ FileData ("xl/worksheets/_rels/sheet" <> show n <> ".xml.rels")
"application/vnd.openxmlformats-package.relationships+xml"
"relationships" sheetRelsXml ]
sheetRelsXml = renderLBS def . toDocument . Relationships.fromList $
[ relEntry i fdRelType (fdPath `relFrom` sheetFilePath)
| (i, FileData{..}) <- referenced ]
referenced = fromMaybe [] (snd <$> mCmntData) ++
catMaybes [ snd3 <$> mDrawingData ] ++
pivRefs ++
refTables
referencedFiles = map snd referenced
extraFiles = maybe [] thd3 mDrawingData
otherFiles = sheetRels ++ referencedFiles ++ extraFiles
return (sheetFile, otherFiles)
nextRefId :: STRef s Int -> ST s RefId
nextRefId r = do
num <- readSTRef r
modifySTRef' r (+1)
return (unsafeRefId num)
sheetDataXml ::
Cells
-> Map RowIndex RowProperties
-> Map SharedFormulaIndex SharedFormulaOptions
-> [Element]
sheetDataXml rows rh sharedFormulas =
evalState (mapM rowEl rows) sharedFormulas
where
rowEl (r, cells) = do
let mProps = M.lookup r rh
hasHeight = case rowHeight =<< mProps of
Just CustomHeight{} -> True
_ -> False
ht = do Just height <- [rowHeight =<< mProps]
let h = case height of CustomHeight x -> x
AutomaticHeight x -> x
return ("ht", txtd h)
s = do Just st <- [rowStyle =<< mProps]
return ("s", txti st)
hidden = fromMaybe False $ rowHidden <$> mProps
attrs = ht ++
s ++
[ ("r", txti r)
, ("hidden", txtb hidden)
, ("outlineLevel", "0")
, ("collapsed", "false")
, ("customFormat", "true")
, ("customHeight", txtb hasHeight)
]
cellEls <- mapM (cellEl r) cells
return $ elementList "row" attrs cellEls
cellEl r (icol, cell) = do
let cellAttrs ref c =
cellStyleAttr c ++ [("r" .= ref), ("t" .= xlsxCellType c)]
cellStyleAttr XlsxCell{xlsxCellStyle=Nothing} = []
cellStyleAttr XlsxCell{xlsxCellStyle=Just s} = [("s", txti s)]
formula = xlsxCellFormula cell
fEl0 = toElement "f" <$> formula
fEl <- case formula of
Just CellFormula{_cellfExpression=SharedFormula si} -> do
shared <- get
case M.lookup si shared of
Just fOpts -> do
put $ M.delete si shared
return $ applySharedFormulaOpts fOpts <$> fEl0
Nothing ->
return fEl0
_ ->
return fEl0
return $ elementList "c" (cellAttrs (singleCellRef (r, icol)) cell) $
catMaybes [fEl, elementContent "v" . value <$> xlsxCellValue cell]
genComments :: Int -> Cells -> STRef s Int -> ST s (Maybe (Element, [ReferencedFileData]))
genComments n cells ref =
if null comments
then do
return Nothing
else do
rId1 <- nextRefId ref
rId2 <- nextRefId ref
let el = refElement "legacyDrawing" rId2
return $ Just (el, [(rId1, commentsFile), (rId2, vmlDrawingFile)])
where
comments = concatMap (\(row, rowCells) -> mapMaybe (maybeCellComment row) rowCells) cells
maybeCellComment row (col, cell) = do
comment <- xlsxComment cell
return (singleCellRef (row, col), comment)
commentTable = CommentTable.fromList comments
commentsFile = FileData commentsPath
"application/vnd.openxmlformats-officedocument.spreadsheetml.comments+xml"
"comments"
commentsBS
commentsPath = "xl/comments" <> show n <> ".xml"
commentsBS = renderLBS def $ toDocument commentTable
vmlDrawingFile = FileData vmlPath
"application/vnd.openxmlformats-officedocument.vmlDrawing"
"vmlDrawing"
vmlDrawingBS
vmlPath = "xl/drawings/vmlDrawing" <> show n <> ".vml"
vmlDrawingBS = CommentTable.renderShapes commentTable
genDrawing :: Int -> STRef s Int -> Drawing -> ST s (Element, ReferencedFileData, [FileData])
genDrawing n ref dr = do
rId <- nextRefId ref
let el = refElement "drawing" rId
return (el, (rId, drawingFile), referenced)
where
drawingFilePath = "xl/drawings/drawing" <> show n <> ".xml"
drawingCT = "application/vnd.openxmlformats-officedocument.drawing+xml"
drawingFile = FileData drawingFilePath drawingCT "drawing" drawingXml
drawingXml = renderLBS def{rsNamespaces=nss} $ toDocument dr'
nss = [ ("xdr", "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing")
, ("a", "http://schemas.openxmlformats.org/drawingml/2006/main")
, ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ]
dr' = Drawing{ _xdrAnchors = reverse anchors' }
(anchors', images, charts, _) = foldl' collectFile ([], [], [], 1) (dr ^. xdrAnchors)
collectFile :: ([Anchor RefId RefId], [Maybe (Int, FileInfo)], [(Int, ChartSpace)], Int)
-> Anchor FileInfo ChartSpace
-> ([Anchor RefId RefId], [Maybe (Int, FileInfo)], [(Int, ChartSpace)], Int)
collectFile (as, fis, chs, i) anch0 =
case anch0 ^. anchObject of
Picture {..} ->
let fi = (i,) <$> _picBlipFill ^. bfpImageInfo
pic' =
Picture
{ _picMacro = _picMacro
, _picPublished = _picPublished
, _picNonVisual = _picNonVisual
, _picBlipFill =
(_picBlipFill & bfpImageInfo ?~ RefId ("rId" <> txti i))
, _picShapeProperties = _picShapeProperties
}
anch = anch0 {_anchObject = pic'}
in (anch : as, fi : fis, chs, i + 1)
Graphic nv ch tr ->
let gr' = Graphic nv (RefId ("rId" <> txti i)) tr
anch = anch0 {_anchObject = gr'}
in (anch : as, fis, (i, ch) : chs, i + 1)
imageFiles =
[ ( unsafeRefId i
, FileData ("xl/media/" <> _fiFilename) _fiContentType "image" _fiContents)
| (i, FileInfo {..}) <- reverse (catMaybes images)
]
chartFiles =
[ (unsafeRefId i, genChart n k chart)
| (k, (i, chart)) <- zip [1 ..] (reverse charts)
]
innerFiles = imageFiles ++ chartFiles
drawingRels =
FileData
("xl/drawings/_rels/drawing" <> show n <> ".xml.rels")
relsCT
"relationships"
drawingRelsXml
drawingRelsXml =
renderLBS def . toDocument . Relationships.fromList $
map (refFileDataToRel drawingFilePath) innerFiles
referenced =
case innerFiles of
[] -> []
_ -> drawingRels : (map snd innerFiles)
genChart :: Int -> Int -> ChartSpace -> FileData
genChart n i ch = FileData path contentType relType contents
where
path = "xl/charts/chart" <> show n <> "_" <> show i <> ".xml"
contentType =
"application/vnd.openxmlformats-officedocument.drawingml.chart+xml"
relType = "chart"
contents = renderLBS def {rsNamespaces = nss} $ toDocument ch
nss =
[ ("c", "http://schemas.openxmlformats.org/drawingml/2006/chart")
, ("a", "http://schemas.openxmlformats.org/drawingml/2006/main")
]
data PvGenerated = PvGenerated
{ pvgCacheFiles :: [(CacheId, FileData)]
, pvgSheetTableFiles :: [[FileData]]
, pvgOthers :: [FileData]
}
generatePivotFiles :: [(CellMap, [PivotTable])] -> PvGenerated
generatePivotFiles cmTables = PvGenerated cacheFiles shTableFiles others
where
cacheFiles = [cacheFile | (cacheFile, _, _) <- flatRendered]
shTableFiles = map (map (\(_, tableFile, _) -> tableFile)) rendered
others = concat [other | (_, _, other) <- flatRendered]
firstCacheId = 1
flatRendered = concat rendered
(_, rendered) =
mapAccumL
(\c (cm, ts) -> mapAccumL (\c' t -> (c' + 1, render cm c' t)) c ts)
firstCacheId
cmTables
render cm cacheIdRaw tbl =
let PivotTableFiles {..} = renderPivotTableFiles cm cacheIdRaw tbl
cacheId = CacheId cacheIdRaw
cacheIdStr = show cacheIdRaw
cachePath =
"xl/pivotCache/pivotCacheDefinition" <> cacheIdStr <> ".xml"
cacheFile =
FileData
cachePath
(smlCT "pivotCacheDefinition")
"pivotCacheDefinition"
pvtfCacheDefinition
recordsPath =
"xl/pivotCache/pivotCacheRecords" <> cacheIdStr <> ".xml"
recordsFile =
FileData
recordsPath
(smlCT "pivotCacheRecords")
"pivotCacheRecords"
pvtfCacheRecords
cacheRelsFile =
FileData
("xl/pivotCache/_rels/pivotCacheDefinition" <> cacheIdStr <> ".xml.rels")
relsCT
"relationships" $
renderRels [refFileDataToRel cachePath (unsafeRefId 1, recordsFile)]
renderRels = renderLBS def . toDocument . Relationships.fromList
tablePath = "xl/pivotTables/pivotTable" <> cacheIdStr <> ".xml"
tableFile =
FileData tablePath (smlCT "pivotTable") "pivotTable" pvtfTable
tableRels =
FileData
("xl/pivotTables/_rels/pivotTable" <> cacheIdStr <> ".xml.rels")
relsCT
"relationships" $
renderRels [refFileDataToRel tablePath (unsafeRefId 1, cacheFile)]
in ((cacheId, cacheFile), tableFile, [tableRels, cacheRelsFile, recordsFile])
genTable :: Table -> Int -> FileData
genTable tbl tblId = FileData{..}
where
fdPath = "xl/tables/table" <> show tblId <> ".xml"
fdContentType = smlCT "table"
fdRelType = "table"
fdContents = renderLBS def $ tableToDocument tbl tblId
data FileData = FileData { fdPath :: FilePath
, fdContentType :: Text
, fdRelType :: Text
, fdContents :: L.ByteString }
type ReferencedFileData = (RefId, FileData)
refFileDataToRel :: FilePath -> ReferencedFileData -> (RefId, Relationship)
refFileDataToRel basePath (i, FileData {..}) =
relEntry i fdRelType (fdPath `relFrom` basePath)
type Cells = [(RowIndex, [(ColumnIndex, XlsxCell)])]
coreXml :: UTCTime -> Text -> L.ByteString
coreXml created creator =
renderLBS def{rsNamespaces=nss} $ Document (Prologue [] Nothing []) root []
where
nss = [ ("cp", "http://schemas.openxmlformats.org/package/2006/metadata/core-properties")
, ("dc", "http://purl.org/dc/elements/1.1/")
, ("dcterms", "http://purl.org/dc/terms/")
, ("xsi","http://www.w3.org/2001/XMLSchema-instance")
]
namespaced = nsName nss
date = T.pack $ formatTime defaultTimeLocale "%FT%T%QZ" created
root = Element (namespaced "cp" "coreProperties") M.empty
[ nEl (namespaced "dcterms" "created")
(M.fromList [(namespaced "xsi" "type", "dcterms:W3CDTF")]) [NodeContent date]
, nEl (namespaced "dc" "creator") M.empty [NodeContent creator]
, nEl (namespaced "cp" "lastModifiedBy") M.empty [NodeContent creator]
]
appXml :: [Text] -> L.ByteString
appXml sheetNames =
renderLBS def $ Document (Prologue [] Nothing []) root []
where
sheetCount = length sheetNames
root = Element (extPropNm "Properties") nsAttrs
[ extPropEl "TotalTime" [NodeContent "0"]
, extPropEl "HeadingPairs" [
vTypeEl "vector" (M.fromList [ ("size", "2")
, ("baseType", "variant")])
[ vTypeEl0 "variant"
[vTypeEl0 "lpstr" [NodeContent "Worksheets"]]
, vTypeEl0 "variant"
[vTypeEl0 "i4" [NodeContent $ txti sheetCount]]
]
]
, extPropEl "TitlesOfParts" [
vTypeEl "vector" (M.fromList [ ("size", txti sheetCount)
, ("baseType", "lpstr")]) $
map (vTypeEl0 "lpstr" . return . NodeContent) sheetNames
]
]
nsAttrs = M.fromList [("xmlns:vt", "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes")]
extPropNm n = nm "http://schemas.openxmlformats.org/officeDocument/2006/extended-properties" n
extPropEl n = nEl (extPropNm n) M.empty
vTypeEl0 n = vTypeEl n M.empty
vTypeEl = nEl . nm "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes"
data XlsxCellData
= XlsxSS Int
| XlsxDouble Double
| XlsxBool Bool
| XlsxError ErrorType
deriving (Eq, Show, Generic)
data XlsxCell = XlsxCell
{ xlsxCellStyle :: Maybe Int
, xlsxCellValue :: Maybe XlsxCellData
, xlsxComment :: Maybe Comment
, xlsxCellFormula :: Maybe CellFormula
} deriving (Eq, Show, Generic)
xlsxCellType :: XlsxCell -> Text
xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxSS _)} = "s"
xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxBool _)} = "b"
xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxError _)} = "e"
xlsxCellType _ = "n" -- default in SpreadsheetML schema, TODO: add other types
value :: XlsxCellData -> Text
value (XlsxSS i) = txti i
value (XlsxDouble d) = txtd d
value (XlsxBool True) = "1"
value (XlsxBool False) = "0"
value (XlsxError eType) = toAttrVal eType
transformSheetData :: SharedStringTable -> Worksheet -> Cells
transformSheetData shared ws = map transformRow $ toRows (ws ^. wsCells)
where
transformRow = second (map transformCell)
transformCell (c, Cell{..}) =
(c, XlsxCell _cellStyle (fmap transformValue _cellValue) _cellComment _cellFormula)
transformValue (CellText t) = XlsxSS (sstLookupText shared t)
transformValue (CellDouble dbl) = XlsxDouble dbl
transformValue (CellBool b) = XlsxBool b
transformValue (CellRich r) = XlsxSS (sstLookupRich shared r)
transformValue (CellError e) = XlsxError e
bookFiles :: Xlsx -> [FileData]
bookFiles xlsx = runST $ do
ref <- newSTRef 1
ssRId <- nextRefId ref
let sheets = xlsx ^. xlSheets & mapped %~ snd
shared = sstConstruct sheets
sharedStrings =
(ssRId, FileData "xl/sharedStrings.xml" (smlCT "sharedStrings") "sharedStrings" $
ssXml shared)
stRId <- nextRefId ref
let style =
(stRId, FileData "xl/styles.xml" (smlCT "styles") "styles" $
unStyles (xlsx ^. xlStyles))
let PvGenerated { pvgCacheFiles = cacheIdFiles
, pvgOthers = pivotOtherFiles
, pvgSheetTableFiles = sheetPivotTables
} =
generatePivotFiles
[ (_wsCells, _wsPivotTables)
| (_, Worksheet {..}) <- xlsx ^. xlSheets
]
sheetCells = map (transformSheetData shared) sheets
sheetInputs = zip3 sheetCells sheetPivotTables sheets
tblIdRef <- newSTRef 1
allSheetFiles <- forM (zip [1..] sheetInputs) $ \(i, (cells, pvTables, sheet)) -> do
rId <- nextRefId ref
(sheetFile, others) <- singleSheetFiles i cells pvTables sheet tblIdRef
return ((rId, sheetFile), others)
let sheetFiles = map fst allSheetFiles
sheetAttrsByRId =
zipWith (\(rId, _) (name, sheet) -> (rId, name, sheet ^. wsState))
sheetFiles
(xlsx ^. xlSheets)
sheetOthers = concatMap snd allSheetFiles
cacheRefFDsById <- forM cacheIdFiles $ \(cacheId, fd) -> do
refId <- nextRefId ref
return (cacheId, (refId, fd))
let cacheRefsById = [ (cId, rId) | (cId, (rId, _)) <- cacheRefFDsById ]
cacheRefs = map snd cacheRefFDsById
bookFile = FileData "xl/workbook.xml" (smlCT "sheet.main") "officeDocument" $
bookXml sheetAttrsByRId (xlsx ^. xlDefinedNames) cacheRefsById (xlsx ^. xlDateBase)
rels = FileData "xl/_rels/workbook.xml.rels"
"application/vnd.openxmlformats-package.relationships+xml"
"relationships" relsXml
relsXml = renderLBS def . toDocument . Relationships.fromList $
[ relEntry i fdRelType (fdPath `relFrom` "xl/workbook.xml")
| (i, FileData{..}) <- referenced ]
referenced = sharedStrings:style:sheetFiles ++ cacheRefs
otherFiles = concat [rels:(map snd referenced), pivotOtherFiles, sheetOthers]
return $ bookFile:otherFiles
bookXml :: [(RefId, Text, SheetState)]
-> DefinedNames
-> [(CacheId, RefId)]
-> DateBase
-> L.ByteString
bookXml rIdAttrs (DefinedNames names) cacheIdRefs dateBase =
renderLBS def {rsNamespaces = nss} $ Document (Prologue [] Nothing []) root []
where
nss = [ ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ]
-- The @bookViews@ element is not required according to the schema, but its
-- absence can cause Excel to crash when opening the print preview
-- (see ). It suffices however
-- to define a bookViews with a single empty @workbookView@ element
-- (the @bookViews@ must contain at least one @wookbookView@).
root =
addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" Nothing $
elementListSimple
"workbook"
( [ leafElement "workbookPr" (catMaybes ["date1904" .=? justTrue (dateBase == DateBase1904) ])
, elementListSimple "bookViews" [emptyElement "workbookView"]
, elementListSimple
"sheets"
[ leafElement
"sheet"
["name" .= name, "sheetId" .= i, "state" .= state, (odr "id") .= rId]
| (i, (rId, name, state)) <- zip [(1 :: Int) ..] rIdAttrs
]
, elementListSimple
"definedNames"
[ elementContent0 "definedName" (definedName name lsId) val
| (name, lsId, val) <- names
]
] ++
maybeToList
(nonEmptyElListSimple "pivotCaches" $ map pivotCacheEl cacheIdRefs)
)
pivotCacheEl (CacheId cId, refId) =
leafElement "pivotCache" ["cacheId" .= cId, (odr "id") .= refId]
definedName :: Text -> Maybe Text -> [(Name, Text)]
definedName name Nothing = ["name" .= name]
definedName name (Just lsId) = ["name" .= name, "localSheetId" .= lsId]
ssXml :: SharedStringTable -> L.ByteString
ssXml = renderLBS def . toDocument
customPropsXml :: CustomProperties -> L.ByteString
customPropsXml = renderLBS def . toDocument
contentTypesXml :: [FileData] -> L.ByteString
contentTypesXml fds = renderLBS def $ Document (Prologue [] Nothing []) root []
where
root = addNS "http://schemas.openxmlformats.org/package/2006/content-types" Nothing $
Element "Types" M.empty $
map (\fd -> nEl "Override" (M.fromList [("PartName", T.concat ["/", T.pack $ fdPath fd]),
("ContentType", fdContentType fd)]) []) fds
-- | fully qualified XML name
qName :: Text -> Text -> Text -> Name
qName n ns p =
Name
{ nameLocalName = n
, nameNamespace = Just ns
, namePrefix = Just p
}
-- | fully qualified XML name from prefix to ns URL mapping
nsName :: [(Text, Text)] -> Text -> Text -> Name
nsName nss p n = qName n ns p
where
ns = fromJustNote "ns name lookup" $ lookup p nss
nm :: Text -> Text -> Name
nm ns n = Name
{ nameLocalName = n
, nameNamespace = Just ns
, namePrefix = Nothing}
nEl :: Name -> Map Name Text -> [Node] -> Node
nEl name attrs nodes = NodeElement $ Element name attrs nodes
-- | Creates element holding reference to some linked file
refElement :: Name -> RefId -> Element
refElement name rId = leafElement name [ odr "id" .= rId ]
smlCT :: Text -> Text
smlCT t =
"application/vnd.openxmlformats-officedocument.spreadsheetml." <> t <> "+xml"
relsCT :: Text
relsCT = "application/vnd.openxmlformats-package.relationships+xml"
xlsx-1.1.2.2/src/Codec/Xlsx/Writer/Internal.hs 0000644 0000000 0000000 00000015232 14551273353 017200 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Writer.Internal (
-- * Rendering documents
ToDocument(..)
, documentFromElement
, documentFromNsElement
, documentFromNsPrefElement
-- * Rendering elements
, ToElement(..)
, countedElementList
, nonEmptyCountedElementList
, elementList
, elementListSimple
, nonEmptyElListSimple
, leafElement
, emptyElement
, elementContent0
, elementContent
, elementContentPreserved
, elementValue
, elementValueDef
-- * Rendering attributes
, ToAttrVal(..)
, (.=)
, (.=?)
, setAttr
-- * Dealing with namespaces
, addNS
, mainNamespace
-- * Misc
, txti
, txtb
, txtd
, justNonDef
, justTrue
, justFalse
) where
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.Builder.Int
import Data.Text.Lazy.Builder.RealFloat
import Text.XML
{-------------------------------------------------------------------------------
Rendering documents
-------------------------------------------------------------------------------}
class ToDocument a where
toDocument :: a -> Document
documentFromElement :: Text -> Element -> Document
documentFromElement comment e =
documentFromNsElement comment mainNamespace e
documentFromNsElement :: Text -> Text -> Element -> Document
documentFromNsElement comment ns e =
documentFromNsPrefElement comment ns Nothing e
documentFromNsPrefElement :: Text -> Text -> Maybe Text -> Element -> Document
documentFromNsPrefElement comment ns prefix e = Document {
documentRoot = addNS ns prefix e
, documentEpilogue = []
, documentPrologue = Prologue {
prologueBefore = [MiscComment comment]
, prologueDoctype = Nothing
, prologueAfter = []
}
}
{-------------------------------------------------------------------------------
Rendering elements
-------------------------------------------------------------------------------}
class ToElement a where
toElement :: Name -> a -> Element
countedElementList :: Name -> [Element] -> Element
countedElementList nm as = elementList nm [ "count" .= length as ] as
nonEmptyCountedElementList :: Name -> [Element] -> Maybe Element
nonEmptyCountedElementList nm as = case as of
[] -> Nothing
_ -> Just $ countedElementList nm as
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 = elementList nm [] els
nonEmptyElListSimple :: Name -> [Element] -> Maybe Element
nonEmptyElListSimple _ [] = Nothing
nonEmptyElListSimple nm els = Just $ elementListSimple nm els
leafElement :: Name -> [(Name, Text)] -> Element
leafElement nm attrs = elementList nm attrs []
emptyElement :: Name -> Element
emptyElement nm = elementList nm [] []
elementContent0 :: Name -> [(Name, Text)] -> Text -> Element
elementContent0 nm attrs txt = Element {
elementName = nm
, elementAttributes = Map.fromList attrs
, elementNodes = [NodeContent txt]
}
elementContent :: Name -> Text -> Element
elementContent nm txt = elementContent0 nm [] txt
elementContentPreserved :: Name -> Text -> Element
elementContentPreserved nm txt = elementContent0 nm [ preserveSpace ] txt
where
preserveSpace = (
Name { nameLocalName = "space"
, nameNamespace = Just "http://www.w3.org/XML/1998/namespace"
, namePrefix = Nothing
}
, "preserve"
)
{-------------------------------------------------------------------------------
Rendering attributes
-------------------------------------------------------------------------------}
class ToAttrVal a where
toAttrVal :: a -> Text
instance ToAttrVal Text where toAttrVal = id
instance ToAttrVal String where toAttrVal = fromString
instance ToAttrVal Int where toAttrVal = txti
instance ToAttrVal Integer where toAttrVal = txti
instance ToAttrVal Double where toAttrVal = txtd
instance ToAttrVal Bool where
toAttrVal True = "1"
toAttrVal False = "0"
elementValue :: ToAttrVal a => Name -> a -> Element
elementValue nm a = leafElement nm [ "val" .= a ]
elementValueDef :: (Eq a, ToAttrVal a) => Name -> a -> a -> Element
elementValueDef nm defVal a =
leafElement nm $ catMaybes [ "val" .=? justNonDef defVal a ]
(.=) :: ToAttrVal a => Name -> a -> (Name, Text)
nm .= a = (nm, toAttrVal a)
(.=?) :: ToAttrVal a => Name -> Maybe a -> Maybe (Name, Text)
_ .=? Nothing = Nothing
nm .=? (Just a) = Just (nm .= a)
setAttr :: ToAttrVal a => Name -> a -> Element -> Element
setAttr nm a el@Element{..} = el{ elementAttributes = attrs' }
where
attrs' = Map.insert nm (toAttrVal a) elementAttributes
{-------------------------------------------------------------------------------
Dealing with namespaces
-------------------------------------------------------------------------------}
-- | Set the namespace for the entire document
--
-- This follows the same policy that the rest of the xlsx package uses.
addNS :: Text -> Maybe Text -> Element -> Element
addNS ns prefix Element{..} = Element{
elementName = goName elementName
, elementAttributes = elementAttributes
, elementNodes = map goNode elementNodes
}
where
goName :: Name -> Name
goName n@Name{..} =
case nameNamespace of
Just _ -> n -- If a namespace was explicitly set, leave it
Nothing -> Name{
nameLocalName = nameLocalName
, nameNamespace = Just ns
, namePrefix = prefix
}
goNode :: Node -> Node
goNode (NodeElement e) = NodeElement $ addNS ns prefix e
goNode n = n
-- | The main namespace for Excel
mainNamespace :: Text
mainNamespace = "http://schemas.openxmlformats.org/spreadsheetml/2006/main"
txtd :: Double -> Text
txtd v
| v - fromInteger v' == 0 = txti v'
| otherwise = toStrict . toLazyText $ realFloat v
where
v' = floor v
txtb :: Bool -> Text
txtb = T.toLower . T.pack . show
txti :: (Integral a) => a -> Text
txti = toStrict . toLazyText . decimal
justNonDef :: (Eq a) => a -> a -> Maybe a
justNonDef defVal a | a == defVal = Nothing
| otherwise = Just a
justFalse :: Bool -> Maybe Bool
justFalse = justNonDef True
justTrue :: Bool -> Maybe Bool
justTrue = justNonDef False
xlsx-1.1.2.2/src/Codec/Xlsx/Writer/Internal/PivotTable.hs 0000644 0000000 0000000 00000017034 14551273353 021253 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Writer.Internal.PivotTable
( PivotTableFiles(..)
, renderPivotTableFiles
) where
import Data.ByteString.Lazy (ByteString)
import Data.List (elemIndex, transpose)
import Data.List.Extra (nubOrd)
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Data.Text (Text)
import GHC.Generics (Generic)
import Safe (fromJustNote)
import Text.XML
import Codec.Xlsx.Types.Cell
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Types.Internal
import Codec.Xlsx.Types.Internal.Relationships (odr)
import Codec.Xlsx.Types.PivotTable
import Codec.Xlsx.Types.PivotTable.Internal
import Codec.Xlsx.Writer.Internal
data PivotTableFiles = PivotTableFiles
{ pvtfTable :: ByteString
, pvtfCacheDefinition :: ByteString
, pvtfCacheRecords :: ByteString
} deriving (Eq, Show, Generic)
data CacheDefinition = CacheDefinition
{ cdSourceRef :: CellRef
, cdSourceSheet :: Text
, cdFields :: [CacheField]
} deriving (Eq, Show, Generic)
renderPivotTableFiles :: CellMap -> Int -> PivotTable -> PivotTableFiles
renderPivotTableFiles cm cacheId t = PivotTableFiles {..}
where
pvtfTable = renderLBS def $ ptDefinitionDocument cacheId cache t
cache = generateCache cm t
(cacheDoc, cacheRecordsDoc) = writeCache cache
pvtfCacheDefinition = renderLBS def cacheDoc
pvtfCacheRecords = renderLBS def cacheRecordsDoc
ptDefinitionDocument :: Int -> CacheDefinition -> PivotTable -> Document
ptDefinitionDocument cacheId cache t =
documentFromElement "Pivot table generated by xlsx" $
ptDefinitionElement "pivotTableDefinition" cacheId cache t
ptDefinitionElement :: Name -> Int -> CacheDefinition -> PivotTable -> Element
ptDefinitionElement nm cacheId cache PivotTable {..} =
elementList nm attrs elements
where
attrs =
catMaybes
[ "colGrandTotals" .=? justFalse _pvtColumnGrandTotals
, "rowGrandTotals" .=? justFalse _pvtRowGrandTotals
, "outline" .=? justTrue _pvtOutline
, "outlineData" .=? justTrue _pvtOutlineData
] ++
[ "name" .= _pvtName
, "dataCaption" .= _pvtDataCaption
, "cacheId" .= cacheId
, "dataOnRows" .= (DataPosition `elem` _pvtRowFields)
]
elements = [location, pivotFields, rowFields, colFields, dataFields]
location =
leafElement
"location"
[ "ref" .= _pvtLocation
-- TODO : set proper
, "firstHeaderRow" .= (1 :: Int)
, "firstDataRow" .= (2 :: Int)
, "firstDataCol" .= (1 :: Int)
]
name2x = M.fromList $ zip (mapMaybe _pfiName _pvtFields) [0 ..]
mapFieldToX f = fromJustNote "no field" $ M.lookup f name2x
pivotFields = elementListSimple "pivotFields" $ map pFieldEl _pvtFields
maybeFieldIn Nothing _ = False
maybeFieldIn (Just name) positions = FieldPosition name `elem` positions
pFieldEl PivotFieldInfo { _pfiName = fName
, _pfiOutline = outline
, _pfiSortType = sortType
, _pfiHiddenItems = hidden
}
| fName `maybeFieldIn` _pvtRowFields =
pFieldEl' fName outline ("axisRow" :: Text) hidden sortType
| fName `maybeFieldIn` _pvtColumnFields =
pFieldEl' fName outline ("axisCol" :: Text) hidden sortType
| otherwise =
leafElement "pivotField" $
[ "dataField" .= True
, "showAll" .= False
, "outline" .= outline] ++
catMaybes ["name" .=? fName]
pFieldEl' fName outline axis hidden sortType =
elementList
"pivotField"
([ "axis" .= axis
, "showAll" .= False
, "outline" .= outline
] ++
catMaybes [ "name" .=? fName
, "sortType" .=? justNonDef FieldSortManual sortType])
[ elementListSimple "items" $
items fName hidden ++
[leafElement "item" ["t" .= ("default" :: Text)]]
]
items Nothing _ = []
items (Just fName) hidden =
[ itemEl x item hidden
| (x, item) <- zip [0 ..] . fromMaybe [] $ M.lookup fName cachedItems
]
itemEl x item hidden =
leafElement "item" $
["x" .= (x :: Int)] ++ catMaybes ["h" .=? justTrue (item `elem` hidden)]
cachedItems =
M.fromList $ [(cfName, cfItems) | CacheField {..} <- cdFields cache]
rowFields =
elementListSimple "rowFields" . map fieldEl $
if length _pvtDataFields > 1
then _pvtRowFields
else filter (/= DataPosition) _pvtRowFields
colFields = elementListSimple "colFields" $ map fieldEl _pvtColumnFields
fieldEl p = leafElement "field" ["x" .= fieldPos p]
fieldPos DataPosition = (-2) :: Int
fieldPos (FieldPosition f) = mapFieldToX f
dataFields = elementListSimple "dataFields" $ map dFieldEl _pvtDataFields
dFieldEl DataField {..} =
leafElement "dataField" $
catMaybes
[ "name" .=? Just _dfName
, "fld" .=? Just (mapFieldToX _dfField)
, "subtotal" .=? justNonDef ConsolidateSum _dfFunction
]
generateCache :: CellMap -> PivotTable -> CacheDefinition
generateCache cm PivotTable {..} =
CacheDefinition
{ cdSourceRef = _pvtSrcRef
, cdSourceSheet = _pvtSrcSheet
, cdFields = cachedFields
}
where
cachedFields = mapMaybe (fmap cache . _pfiName) _pvtFields
cache name =
CacheField
{ cfName = name
, cfItems =
fromJustNote "specified pivot table field does not exist" $
M.lookup name itemsByName
}
((r1, c1), (r2, c2)) =
fromJustNote "Invalid src ref of pivot table " $ fromRange _pvtSrcRef
getCellValue ix = M.lookup ix cm >>= _cellValue
itemsByName =
M.fromList $
flip mapMaybe [c1 .. c2] $ \c -> do
CellText nm <- getCellValue (r1, c)
let values = mapMaybe (\r -> getCellValue (r, c)) [(r1 + 1) .. r2]
return (PivotFieldName nm, nubOrd values)
writeCache :: CacheDefinition -> (Document, Document)
writeCache CacheDefinition {..} = (cacheDefDoc, cacheRecordsDoc)
where
cacheDefDoc =
documentFromElement "Pivot cache definition generated by xlsx" $
elementList "pivotCacheDefinition" attrs elements
attrs = ["invalid" .= True, "refreshOnLoad" .= True, odr "id" .= unsafeRefId 1]
elements = [worksheetSource, cacheFields]
worksheetSource =
elementList
"cacheSource"
["type" .= ("worksheet" :: Text)]
[ leafElement
"worksheetSource"
["ref" .= cdSourceRef, "sheet" .= cdSourceSheet]
]
cacheFields =
elementListSimple "cacheFields" $ map (toElement "cacheField") cdFields
cacheRecordsDoc =
documentFromElement "Pivot cache records generated by xlsx" .
elementListSimple "pivotCacheRecords" $
map (elementListSimple "r" . map recordValueToEl) cacheRecords
recordValueToEl (CacheText t) = leafElement "s" ["v" .= t]
recordValueToEl (CacheNumber n) = leafElement "n" ["v" .= n]
recordValueToEl (CacheIndex i) = leafElement "x" ["v" .= i]
cacheRecords = transpose $ map (itemsToRecordValues . cfItems) cdFields
itemsToRecordValues vals =
if all isText vals
then indexes vals
else map itemToRecordValue vals
isText (CellText _) = True
isText _ = False
indexes vals =
[ CacheIndex . fromJustNote "inconsistend definition" $ elemIndex v vals
| v <- vals
]
itemToRecordValue (CellDouble d) = CacheNumber d
itemToRecordValue (CellText t) = CacheText t
itemToRecordValue v = error $ "Unsupported value for pivot tables: " ++ show v
xlsx-1.1.2.2/src/Codec/Xlsx/Parser/Stream.hs 0000644 0000000 0000000 00000062215 14551273353 016642 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module : Codex.Xlsx.Parser.Stream
-- Description : Stream parser for xlsx files
-- Copyright :
-- (c) Adam, 2021
-- (c) Supercede, 2021
-- License : MIT
-- Stability : experimental
-- Portability : POSIX
--
-- Parse @.xlsx@ sheets in constant memory.
--
-- All actions on an xlsx file run inside the 'XlsxM' monad, and must
-- be run with 'runXlsxM'. XlsxM is not a monad transformer, a design
-- inherited from the "zip" package's ZipArchive monad.
--
-- Inside the XlsxM monad, you can stream 'SheetItem's (a row) from a
-- particular sheet, using 'readSheetByIndex', which is callback-based and tied to IO.
--
module Codec.Xlsx.Parser.Stream
( XlsxM
, runXlsxM
, WorkbookInfo(..)
, SheetInfo(..)
, wiSheets
, getWorkbookInfo
, CellRow
, readSheet
, countRowsInSheet
, collectItems
-- ** Index
, SheetIndex
, makeIndex
, makeIndexFromName
-- ** SheetItem
, SheetItem(..)
, si_sheet_index
, si_row
-- ** Row
, Row(..)
, ri_row_index
, ri_cell_row
-- * Errors
, SheetErrors(..)
, AddCellErrors(..)
, CoordinateErrors(..)
, TypeError(..)
, WorkbookError(..)
) where
import qualified "zip" Codec.Archive.Zip as Zip
import Codec.Xlsx.Types.Cell
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Types.Internal (RefId (..))
import Codec.Xlsx.Types.Internal.Relationships (Relationship (..),
Relationships (..))
import Conduit (PrimMonad, (.|))
import qualified Conduit as C
import qualified Data.Vector as V
#ifdef USE_MICROLENS
import Lens.Micro
import Lens.Micro.GHC ()
import Lens.Micro.Mtl
import Lens.Micro.Platform
import Lens.Micro.TH
#else
import Control.Lens
#endif
import Codec.Xlsx.Parser.Internal
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Bifunctor
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Conduit (ConduitT)
import qualified Data.DList as DL
import Data.Foldable
import Data.IORef
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import qualified Data.Map.Strict as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as TB
import qualified Data.Text.Read as Read
import Data.Traversable (for)
import Data.XML.Types
import GHC.Generics
import Control.DeepSeq
import Codec.Xlsx.Parser.Internal.Memoize
import qualified Codec.Xlsx.Parser.Stream.HexpatInternal as HexpatInternal
import Control.Monad.Base
import Control.Monad.Trans.Control
import Text.XML.Expat.Internal.IO as Hexpat
import Text.XML.Expat.SAX as Hexpat
#ifdef USE_MICROLENS
(<>=) :: (MonadState s m, Monoid a) => ASetter' s a -> a -> m ()
l <>= a = modify (l <>~ a)
#else
#endif
type CellRow = IntMap Cell
-- | Sheet item
--
-- The current sheet at a time, every sheet is constructed of these items.
data SheetItem = MkSheetItem
{ _si_sheet_index :: Int -- ^ The sheet number
, _si_row :: ~Row
} deriving stock (Generic, Show)
deriving anyclass NFData
data Row = MkRow
{ _ri_row_index :: RowIndex -- ^ Row number
, _ri_cell_row :: ~CellRow -- ^ Row itself
} deriving stock (Generic, Show)
deriving anyclass NFData
makeLenses 'MkSheetItem
makeLenses 'MkRow
type SharedStringsMap = V.Vector Text
-- | Type of the excel value
--
-- Note: Some values are untyped and rules of their type resolution are not known.
-- They may be treated simply as strings as well as they may be context-dependent.
-- By far we do not bother with it.
data ExcelValueType
= TS -- ^ shared string
| TStr -- ^ either an inline string ("inlineStr") or a formula string ("str")
| TN -- ^ number
| TB -- ^ boolean
| TE -- ^ excell error, the sheet can contain error values, for example if =1/0, causes division by zero
| Untyped -- ^ Not all values have types
deriving stock (Generic, Show)
-- | State for parsing sheets
data SheetState = MkSheetState
{ _ps_row :: ~CellRow -- ^ Current row
, _ps_sheet_index :: Int -- ^ Current sheet ID (AKA 'sheetInfoSheetId')
, _ps_cell_row_index :: RowIndex -- ^ Current row number
, _ps_cell_col_index :: ColumnIndex -- ^ Current column number
, _ps_cell_style :: Maybe Int
, _ps_is_in_val :: Bool -- ^ Flag for indexing wheter the parser is in value or not
, _ps_shared_strings :: SharedStringsMap -- ^ Shared string map
, _ps_type :: ExcelValueType -- ^ The last detected value type
, _ps_text_buf :: Text
-- ^ for hexpat only, which can break up char data into multiple events
, _ps_worksheet_ended :: Bool
-- ^ For hexpat only, which can throw errors right at the end of the sheet
-- rather than ending gracefully.
} deriving stock (Generic, Show)
makeLenses 'MkSheetState
-- | State for parsing shared strings
data SharedStringsState = MkSharedStringsState
{ _ss_string :: TB.Builder -- ^ String we are parsing
, _ss_list :: DL.DList Text -- ^ list of shared strings
} deriving stock (Generic, Show)
makeLenses 'MkSharedStringsState
type HasSheetState = MonadState SheetState
type HasSharedStringsState = MonadState SharedStringsState
-- | Represents sheets from the workbook.xml file. E.g.
-- HexpatEvent -> m (Maybe Text)
parseSharedStrings = \case
StartElement "t" _ -> Nothing <$ (ss_string .= mempty)
EndElement "t" -> Just . LT.toStrict . TB.toLazyText <$> gets _ss_string
CharacterData txt -> Nothing <$ (ss_string <>= TB.fromText txt)
_ -> pure Nothing
-- | Run a series of actions on an Xlsx file
runXlsxM :: MonadIO m => FilePath -> XlsxM a -> m a
runXlsxM xlsxFile (XlsxM act) = liftIO $ do
-- TODO: don't run the withArchive multiple times but use liftWith or runInIO instead
_xs_workbook_info <- memoizeRef (Zip.withArchive xlsxFile readWorkbookInfo)
_xs_relationships <- memoizeRef (Zip.withArchive xlsxFile readWorkbookRelationships)
_xs_shared_strings <- memoizeRef (Zip.withArchive xlsxFile parseSharedStringss)
Zip.withArchive xlsxFile $ runReaderT act $ MkXlsxMState{..}
liftZip :: Zip.ZipArchive a -> XlsxM a
liftZip = XlsxM . ReaderT . const
parseSharedStringss :: Zip.ZipArchive (V.Vector Text)
parseSharedStringss = do
sharedStrsSel <- Zip.mkEntrySelector "xl/sharedStrings.xml"
hasSharedStrs <- Zip.doesEntryExist sharedStrsSel
if not hasSharedStrs
then pure mempty
else do
let state0 = initialSharedStrings
byteSrc <- Zip.getEntrySource sharedStrsSel
st <- liftIO $ runExpat state0 byteSrc $ \evs -> forM_ evs $ \ev -> do
mTxt <- parseSharedStrings ev
for_ mTxt $ \txt ->
ss_list %= (`DL.snoc` txt)
pure $ V.fromList $ DL.toList $ _ss_list st
{-# SCC getOrParseSharedStringss #-}
getOrParseSharedStringss :: XlsxM (V.Vector Text)
getOrParseSharedStringss = runMemoized =<< asks _xs_shared_strings
readWorkbookInfo :: Zip.ZipArchive WorkbookInfo
readWorkbookInfo = do
sel <- Zip.mkEntrySelector "xl/workbook.xml"
src <- Zip.getEntrySource sel
sheets <- liftIO $ runExpat [] src $ \evs -> forM_ evs $ \case
StartElement ("sheet" :: ByteString) attrs -> do
nm <- lookupBy "name" attrs
sheetId <- lookupBy "sheetId" attrs
rId <- lookupBy "r:id" attrs
sheetNum <- either (throwM . ParseDecimalError sheetId) pure $ eitherDecimal sheetId
modify' (SheetInfo nm (RefId rId) sheetNum :)
_ -> pure ()
pure $ WorkbookInfo sheets
lookupBy :: MonadThrow m => ByteString -> [(ByteString, Text)] -> m Text
lookupBy fields attrs = maybe (throwM $ LookupError attrs fields) pure $ lookup fields attrs
-- | Returns information about the workbook, found in
-- xl/workbook.xml. The result is cached so the XML will only be
-- decompressed and parsed once inside a larger XlsxM action.
getWorkbookInfo :: XlsxM WorkbookInfo
getWorkbookInfo = runMemoized =<< asks _xs_workbook_info
readWorkbookRelationships :: Zip.ZipArchive Relationships
readWorkbookRelationships = do
sel <- Zip.mkEntrySelector "xl/_rels/workbook.xml.rels"
src <- Zip.getEntrySource sel
liftIO $ fmap Relationships $ runExpat mempty src $ \evs -> forM_ evs $ \case
StartElement ("Relationship" :: ByteString) attrs -> do
rId <- lookupBy "Id" attrs
rTarget <- lookupBy "Target" attrs
rType <- lookupBy "Type" attrs
modify' $ M.insert (RefId rId) $
Relationship { relType = rType,
relTarget = T.unpack rTarget
}
_ -> pure ()
-- | Gets relationships for the workbook (this means the filenames in
-- the relationships map are relative to "xl/" base path within the
-- zip file.
--
-- The relationships xml file will only be parsed once when called
-- multiple times within a larger XlsxM action.
getWorkbookRelationships :: XlsxM Relationships
getWorkbookRelationships = runMemoized =<< asks _xs_relationships
type HexpatEvent = SAXEvent ByteString Text
relIdToEntrySelector :: RefId -> XlsxM (Maybe Zip.EntrySelector)
relIdToEntrySelector rid = do
Relationships rels <- getWorkbookRelationships
for (M.lookup rid rels) $ \rel -> do
Zip.mkEntrySelector $ "xl/" <> relTarget rel
sheetIdToRelId :: Int -> XlsxM (Maybe RefId)
sheetIdToRelId sheetId = do
WorkbookInfo sheets <- getWorkbookInfo
pure $ sheetInfoRelId <$> find ((== sheetId) . sheetInfoSheetId) sheets
sheetIdToEntrySelector :: Int -> XlsxM (Maybe Zip.EntrySelector)
sheetIdToEntrySelector sheetId = do
sheetIdToRelId sheetId >>= \case
Nothing -> pure Nothing
Just rid -> relIdToEntrySelector rid
-- If the given sheet number exists, returns Just a conduit source of the stream
-- of XML events in a particular sheet. Returns Nothing when the sheet doesn't
-- exist.
{-# SCC getSheetXmlSource #-}
getSheetXmlSource ::
(PrimMonad m, MonadThrow m, C.MonadResource m) =>
Int ->
XlsxM (Maybe (ConduitT () ByteString m ()))
getSheetXmlSource sheetId = do
-- TODO: The Zip library may throw exceptions that aren't exposed from this
-- module, so downstream library users would need to add the 'zip' package to
-- handle them. Consider re-wrapping zip library exceptions, or just
-- re-export them?
mSheetSel <- sheetIdToEntrySelector sheetId
sheetExists <- maybe (pure False) (liftZip . Zip.doesEntryExist) mSheetSel
case mSheetSel of
Just sheetSel
| sheetExists ->
Just <$> liftZip (Zip.getEntrySource sheetSel)
_ -> pure Nothing
{-# SCC runExpat #-}
runExpat :: forall state tag text.
(GenericXMLString tag, GenericXMLString text) =>
state ->
ConduitT () ByteString (C.ResourceT IO) () ->
([SAXEvent tag text] -> StateT state IO ()) ->
IO state
runExpat initialState byteSource handler = do
-- Set up state
ref <- newIORef initialState
-- Set up parser and callbacks
(parseChunk, _getLoc) <- Hexpat.hexpatNewParser Nothing Nothing False
let noExtra _ offset = pure ((), offset)
{-# SCC processChunk #-}
{-# INLINE processChunk #-}
processChunk isFinalChunk chunk = do
(buf, len, mError) <- parseChunk chunk isFinalChunk
saxen <- HexpatInternal.parseBuf buf len noExtra
case mError of
Just err -> error $ "expat error: " <> show err
Nothing -> do
state0 <- liftIO $ readIORef ref
state1 <-
{-# SCC "runExpat_runStateT_call" #-}
execStateT (handler $ map fst saxen) state0
writeIORef ref state1
C.runConduitRes $
byteSource .|
C.awaitForever (liftIO . processChunk False)
processChunk True BS.empty
readIORef ref
runExpatForSheet ::
SheetState ->
ConduitT () ByteString (C.ResourceT IO) () ->
(SheetItem -> IO ()) ->
XlsxM ()
runExpatForSheet initState byteSource inner =
void $ liftIO $ runExpat initState byteSource handler
where
sheetName = _ps_sheet_index initState
handler evs = forM_ evs $ \ev -> do
parseRes <- runExceptT $ matchHexpatEvent ev
case parseRes of
Left err -> throwM err
Right (Just cellRow)
| not (IntMap.null cellRow) -> do
rowNum <- use ps_cell_row_index
liftIO $ inner $ MkSheetItem sheetName $ MkRow rowNum cellRow
_ -> pure ()
-- | this will collect the sheetitems in a list.
-- useful for cases were memory is of no concern but a sheetitem
-- type in a list is needed.
collectItems ::
SheetIndex ->
XlsxM [SheetItem]
collectItems sheetId = do
res <- liftIO $ newIORef []
void $ readSheet sheetId $ \item ->
liftIO (modifyIORef' res (item :))
fmap reverse $ liftIO $ readIORef res
-- | datatype representing a sheet index, looking it up by name
-- can be done with 'makeIndexFromName', which is the preferred approach.
-- although 'makeIndex' is available in case it's already known.
newtype SheetIndex = MkSheetIndex Int
deriving newtype NFData
-- | This does *no* checking if the index exists or not.
-- you could have index out of bounds issues because of this.
makeIndex :: Int -> SheetIndex
makeIndex = MkSheetIndex
-- | Look up the index of a case insensitive sheet name
makeIndexFromName :: Text -> XlsxM (Maybe SheetIndex)
makeIndexFromName sheetName = do
wi <- getWorkbookInfo
-- The Excel UI does not allow a user to create two sheets whose
-- names differ only in alphabetic case (at least for ascii...)
let sheetNameCI = T.toLower sheetName
findRes :: Maybe SheetInfo
findRes = find ((== sheetNameCI) . T.toLower . sheetInfoName) $ _wiSheets wi
pure $ makeIndex . sheetInfoSheetId <$> findRes
readSheet ::
SheetIndex ->
-- | Function to consume the sheet's rows
(SheetItem -> IO ()) ->
-- | Returns False if sheet doesn't exist, or True otherwise
XlsxM Bool
readSheet (MkSheetIndex sheetId) inner = do
mSrc :: Maybe (ConduitT () ByteString (C.ResourceT IO) ()) <-
getSheetXmlSource sheetId
let
case mSrc of
Nothing -> pure False
Just sourceSheetXml -> do
sharedStrs <- getOrParseSharedStringss
let sheetState0 = initialSheetState
& ps_shared_strings .~ sharedStrs
& ps_sheet_index .~ sheetId
runExpatForSheet sheetState0 sourceSheetXml inner
pure True
-- | Returns number of rows in the given sheet (identified by the
-- sheet's ID, AKA the sheetId attribute, AKA 'sheetInfoSheetId'), or Nothing
-- if the sheet does not exist. Does not perform a full parse of the
-- XML into 'SheetItem's, so it should be more efficient than counting
-- via 'readSheetByIndex'.
countRowsInSheet :: SheetIndex -> XlsxM (Maybe Int)
countRowsInSheet (MkSheetIndex sheetId) = do
mSrc :: Maybe (ConduitT () ByteString (C.ResourceT IO) ()) <-
getSheetXmlSource sheetId
for mSrc $ \sourceSheetXml -> do
liftIO $ runExpat @Int @ByteString @ByteString 0 sourceSheetXml $ \evs ->
forM_ evs $ \case
StartElement "row" _ -> modify' (+1)
_ -> pure ()
-- | Return row from the state and empty it
popRow :: HasSheetState m => m CellRow
popRow = do
row <- use ps_row
ps_row .= mempty
pure row
data AddCellErrors
= ReadError -- ^ Could not read current cell value
Text -- ^ Original value
String -- ^ Error message
| SharedStringsNotFound -- ^ Could not find string by index in shared string table
Int -- ^ Given index
(V.Vector Text) -- ^ Given shared strings to lookup in
deriving Show
-- | Parse the given value
--
-- If it's a string, we try to get it our of a shared string table
{-# SCC parseValue #-}
parseValue :: SharedStringsMap -> Text -> ExcelValueType -> Either AddCellErrors CellValue
parseValue sstrings txt = \case
TS -> do
(idx, _) <- ReadError txt `first` Read.decimal @Int txt
string <- maybe (Left $ SharedStringsNotFound idx sstrings) Right $ {-# SCC "sstrings_lookup_scc" #-} (sstrings ^? ix idx)
Right $ CellText string
TStr -> pure $ CellText txt
TN -> bimap (ReadError txt) (CellDouble . fst) $ Read.double txt
TE -> bimap (ReadError txt) (CellError . fst) $ fromAttrVal txt
TB | txt == "1" -> Right $ CellBool True
| txt == "0" -> Right $ CellBool False
| otherwise -> Left $ ReadError txt "Could not read Excel boolean value (expected 0 or 1)"
Untyped -> Right (parseUntypedValue txt)
-- TODO: some of the cells are untyped and we need to test whether
-- they all are strings or something more complicated
parseUntypedValue :: Text -> CellValue
parseUntypedValue = CellText
-- | Adds a cell to row in state monad
{-# SCC addCellToRow #-}
addCellToRow
:: ( MonadError SheetErrors m
, HasSheetState m
)
=> Text -> m ()
addCellToRow txt = do
st <- get
style <- use ps_cell_style
when (_ps_is_in_val st) $ do
val <- liftEither $ first ParseCellError $ parseValue (_ps_shared_strings st) txt (_ps_type st)
put $ st { _ps_row = IntMap.insert (unColumnIndex $ _ps_cell_col_index st)
(Cell { _cellStyle = style
, _cellValue = Just val
, _cellComment = Nothing
, _cellFormula = Nothing
}) $ _ps_row st}
data SheetErrors
= ParseCoordinateError CoordinateErrors -- ^ Error while parsing coordinates
| ParseTypeError TypeError -- ^ Error while parsing types
| ParseCellError AddCellErrors -- ^ Error while parsing cells
| ParseStyleErrors StyleError
| HexpatParseError Hexpat.XMLParseError
deriving stock Show
deriving anyclass Exception
type SheetValue = (ByteString, Text)
type SheetValues = [SheetValue]
data CoordinateErrors
= CoordinateNotFound SheetValues -- ^ If the coordinate was not specified in "r" attribute
| NoListElement SheetValue SheetValues -- ^ If the value is empty for some reason
| NoTextContent Content SheetValues -- ^ If the value has something besides @ContentText@ inside
| DecodeFailure Text SheetValues -- ^ If malformed coordinate text was passed
deriving stock Show
deriving anyclass Exception
data TypeError
= TypeNotFound SheetValues
| TypeNoListElement SheetValue SheetValues
| UnkownType Text SheetValues
| TypeNoTextContent Content SheetValues
deriving Show
deriving anyclass Exception
data WorkbookError = LookupError { lookup_attrs :: [(ByteString, Text)], lookup_field :: ByteString }
| ParseDecimalError Text String
deriving Show
deriving anyclass Exception
{-# SCC matchHexpatEvent #-}
matchHexpatEvent ::
( MonadError SheetErrors m,
HasSheetState m
) =>
HexpatEvent ->
m (Maybe CellRow)
matchHexpatEvent ev = case ev of
CharacterData txt -> {-# SCC "handle_CharData" #-} do
inVal <- use ps_is_in_val
when inVal $
{-# SCC "append_text_buf" #-} (ps_text_buf <>= txt)
pure Nothing
StartElement "c" attrs -> Nothing <$ (setCoord attrs *> setType attrs *> setStyle attrs)
StartElement "is" _ -> Nothing <$ (ps_is_in_val .= True)
EndElement "is" -> Nothing <$ finaliseCellValue
StartElement "v" _ -> Nothing <$ (ps_is_in_val .= True)
EndElement "v" -> Nothing <$ finaliseCellValue
-- If beginning of row, empty the state and return nothing.
-- We don't know if there is anything in the state, the user may have
-- decided to (not closing). In any case it's the beginning of a new row
-- so we clear the state.
StartElement "row" _ -> Nothing <$ popRow
-- If at the end of the row, we have collected the whole row into
-- the current state. Empty the state and return the row.
EndElement "row" -> Just <$> popRow
StartElement "worksheet" _ -> ps_worksheet_ended .= False >> pure Nothing
EndElement "worksheet" -> ps_worksheet_ended .= True >> pure Nothing
-- Skip everything else, e.g. the formula elements
FailDocument err -> do
-- this event is emitted at the end the xml stream (possibly
-- because the xml files in xlsx archives don't end in a
-- newline, but that's a guess), so we use state to determine if
-- it's expected.
finished <- use ps_worksheet_ended
unless finished $
throwError $ HexpatParseError err
pure Nothing
_ -> pure Nothing
{-# INLINE finaliseCellValue #-}
finaliseCellValue ::
( MonadError SheetErrors m, HasSheetState m ) => m ()
finaliseCellValue = do
txt <- gets _ps_text_buf
addCellToRow txt
modify' $ \st ->
st { _ps_is_in_val = False
, _ps_text_buf = mempty
}
-- | Update state coordinates accordingly to @parseCoordinates@
{-# SCC setCoord #-}
setCoord
:: ( MonadError SheetErrors m
, HasSheetState m
)
=> SheetValues -> m ()
setCoord list = do
coordinates <- liftEither $ first ParseCoordinateError $ parseCoordinates list
ps_cell_col_index .= (coordinates ^. _2)
ps_cell_row_index .= (coordinates ^. _1)
-- | Parse type from values and update state accordingly
setType
:: ( MonadError SheetErrors m
, HasSheetState m
)
=> SheetValues -> m ()
setType list = do
type' <- liftEither $ first ParseTypeError $ parseType list
ps_type .= type'
-- | Find sheet value by its name
findName :: ByteString -> SheetValues -> Maybe SheetValue
findName name = find ((name ==) . fst)
{-# INLINE findName #-}
setStyle :: (MonadError SheetErrors m, HasSheetState m) => SheetValues -> m ()
setStyle list = do
style <- liftEither $ first ParseStyleErrors $ parseStyle list
ps_cell_style .= style
data StyleError = InvalidStyleRef { seInput:: Text, seErrorMsg :: String}
deriving Show
parseStyle :: SheetValues -> Either StyleError (Maybe Int)
parseStyle list =
case findName "s" list of
Nothing -> pure Nothing
Just (_nm, valTex) -> case Read.decimal valTex of
Left err -> Left (InvalidStyleRef valTex err)
Right (i, _rem) -> pure $ Just i
-- | Parse value type
{-# SCC parseType #-}
parseType :: SheetValues -> Either TypeError ExcelValueType
parseType list =
case findName "t" list of
-- NB: According to format specification default value for cells without
-- `t` attribute is a `n` - number.
--
--
-- ..
--
--
Nothing -> Right TN
Just (_nm, valText)->
case valText of
"n" -> Right TN
"s" -> Right TS
-- "Cell containing a formula string". Probably shouldn't be TStr..
"str" -> Right TStr
"inlineStr" -> Right TStr
"b" -> Right TB
"e" -> Right TE
other -> Left $ UnkownType other list
-- | Parse coordinates from a list of xml elements if such were found on "r" key
{-# SCC parseCoordinates #-}
parseCoordinates :: SheetValues -> Either CoordinateErrors (RowIndex, ColumnIndex)
parseCoordinates list = do
(_nm, valText) <- maybe (Left $ CoordinateNotFound list) Right $ findName "r" list
maybe (Left $ DecodeFailure valText list) Right $ fromSingleCellRef $ CellRef valText
xlsx-1.1.2.2/src/Codec/Xlsx/Writer/Stream.hs 0000644 0000000 0000000 00000034662 14551273353 016667 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
-- | Writes Excel files from a stream, which allows creation of
-- large Excel files while remaining in constant memory.
module Codec.Xlsx.Writer.Stream
( writeXlsx
, writeXlsxWithSharedStrings
, SheetWriteSettings(..)
, defaultSettings
, wsSheetView
, wsZip
, wsColumnProperties
, wsRowProperties
, wsStyles
-- *** Shared strings
, sharedStrings
, sharedStringsStream
) where
import Codec.Archive.Zip.Conduit.UnZip
import Codec.Archive.Zip.Conduit.Zip
import Codec.Xlsx.Parser.Internal (n_)
import Codec.Xlsx.Parser.Stream
import Codec.Xlsx.Types (ColumnsProperties (..), RowProperties (..),
Styles (..), _AutomaticHeight, _CustomHeight,
emptyStyles, rowHeightLens)
import Codec.Xlsx.Types.Cell
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Types.Internal.Relationships (odr, pr)
import Codec.Xlsx.Types.SheetViews
import Codec.Xlsx.Writer.Internal (nonEmptyElListSimple, toAttrVal, toElement,
txtd, txti)
import Codec.Xlsx.Writer.Internal.Stream
import Conduit (PrimMonad, yield, (.|))
import qualified Conduit as C
#ifdef USE_MICROLENS
import Data.Traversable.WithIndex
import Lens.Micro.Platform
#else
import Control.Lens
#endif
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Reader.Class
import Control.Monad.State.Strict
import Data.ByteString (ByteString)
import Data.ByteString.Builder (Builder)
import Data.Coerce
import Data.Conduit (ConduitT)
import qualified Data.Conduit.List as CL
import Data.Foldable (fold, traverse_)
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time
import Data.Word
import Data.XML.Types
import Text.Printf
import Text.XML (toXMLElement)
import qualified Text.XML as TXML
import Text.XML.Stream.Render
import Text.XML.Unresolved (elementToEvents)
upsertSharedStrings :: MonadState SharedStringState m => Row -> m [(Text,Int)]
upsertSharedStrings row =
traverse upsertSharedString items
where
items :: [Text]
items = row ^.. ri_cell_row . traversed . cellValue . _Just . _CellText
-- | Process sheetItems into shared strings structure to be put into
-- 'writeXlsxWithSharedStrings'
sharedStrings :: Monad m => ConduitT Row b m (Map Text Int)
sharedStrings = void sharedStringsStream .| CL.foldMap (uncurry Map.singleton)
-- | creates a unique number for every encountered string in the stream
-- This is used for creating a required structure in the xlsx format
-- called shared strings. Every string get's transformed into a number
--
-- exposed to allow further processing, we also know the map after processing
-- but I don't think conduit provides a way of getting that out.
-- use 'sharedStrings' to just get the map
sharedStringsStream :: Monad m =>
ConduitT Row (Text, Int) m (Map Text Int)
sharedStringsStream = fmap (view string_map) $ C.execStateC initialSharedString $
CL.mapFoldableM upsertSharedStrings
-- | Settings for writing a single sheet.
data SheetWriteSettings = MkSheetWriteSettings
{ _wsSheetView :: [SheetView]
, _wsZip :: ZipOptions -- ^ Enable zipOpt64=True if you intend writing large xlsx files, zip needs 64bit for files over 4gb.
, _wsColumnProperties :: [ColumnsProperties]
, _wsRowProperties :: Map Int RowProperties
, _wsStyles :: Styles
}
instance Show SheetWriteSettings where
-- ZipOptions lacks a show instance-}
show (MkSheetWriteSettings s _ y r _) = printf "MkSheetWriteSettings{ _wsSheetView=%s, _wsColumnProperties=%s, _wsZip=defaultZipOptions, _wsRowProperties=%s }" (show s) (show y) (show r)
makeLenses ''SheetWriteSettings
defaultSettings :: SheetWriteSettings
defaultSettings = MkSheetWriteSettings
{ _wsSheetView = []
, _wsColumnProperties = []
, _wsRowProperties = mempty
, _wsStyles = emptyStyles
, _wsZip = defaultZipOptions {
zipOpt64 = False
-- There is a magick number in the zip archive package,
-- https://hackage.haskell.org/package/zip-archive-0.4.1/docs/src/Codec.Archive.Zip.html#local-6989586621679055672
-- if we enable 64bit the number doesn't align causing the test to fail.
}
}
-- | Transform a 'Row' stream into a stream that creates the xlsx file format
-- (to be consumed by sinkfile for example)
-- This first runs 'sharedStrings' and then 'writeXlsxWithSharedStrings'.
-- If you want xlsx files this is the most obvious function to use.
-- the others are exposed in case you can cache the shared strings for example.
--
-- Note that the current implementation concatenates everything into a single sheet.
-- In other words there is no support for writing multiple sheets
writeXlsx :: MonadThrow m
=> PrimMonad m
=> SheetWriteSettings -- ^ use 'defaultSettings'
-> ConduitT () Row m () -- ^ the conduit producing sheetitems
-> ConduitT () ByteString m Word64 -- ^ result conduit producing xlsx files
writeXlsx settings sheetC = do
sstrings <- sheetC .| sharedStrings
writeXlsxWithSharedStrings settings sstrings sheetC
-- TODO maybe should use bimap instead: https://hackage.haskell.org/package/bimap-0.4.0/docs/Data-Bimap.html
-- it guarantees uniqueness of both text and int
-- | This write Excel file with a shared strings lookup table.
-- It appears that it is optional.
-- Failed lookups will result in valid xlsx.
-- There are several conditions on shared strings,
--
-- 1. Every text to int is unique on both text and int.
-- 2. Every Int should have a gap no greater than 1. [("xx", 3), ("yy", 4)] is okay, whereas [("xx", 3), ("yy", 5)] is not.
-- 3. It's expected this starts from 0.
--
-- Use 'sharedStringsStream' to get a good shared strings table.
-- This is provided because the user may have a more efficient way of
-- constructing this table than the library can provide,
-- for example through database operations.
writeXlsxWithSharedStrings :: MonadThrow m => PrimMonad m
=> SheetWriteSettings
-> Map Text Int -- ^ shared strings table
-> ConduitT () Row m ()
-> ConduitT () ByteString m Word64
writeXlsxWithSharedStrings settings sharedStrings' items =
combinedFiles settings sharedStrings' items .| zipStream (settings ^. wsZip)
-- massive amount of boilerplate needed for excel to function
boilerplate :: forall m . PrimMonad m => SheetWriteSettings -> Map Text Int -> [(ZipEntry, ZipData m)]
boilerplate settings sharedStrings' =
[ (zipEntry "xl/sharedStrings.xml", ZipDataSource $ writeSst sharedStrings' .| eventsToBS)
, (zipEntry "[Content_Types].xml", ZipDataSource $ writeContentTypes .| eventsToBS)
, (zipEntry "xl/workbook.xml", ZipDataSource $ writeWorkbook .| eventsToBS)
, (zipEntry "xl/styles.xml", ZipDataByteString $ coerce $ settings ^. wsStyles)
, (zipEntry "xl/_rels/workbook.xml.rels", ZipDataSource $ writeWorkbookRels .| eventsToBS)
, (zipEntry "_rels/.rels", ZipDataSource $ writeRootRels .| eventsToBS)
]
combinedFiles :: PrimMonad m
=> SheetWriteSettings
-> Map Text Int
-> ConduitT () Row m ()
-> ConduitT () (ZipEntry, ZipData m) m ()
combinedFiles settings sharedStrings' items =
C.yieldMany $
boilerplate settings sharedStrings' <>
[(zipEntry "xl/worksheets/sheet1.xml", ZipDataSource $
items .| C.runReaderC settings (writeWorkSheet sharedStrings') .| eventsToBS )]
el :: Monad m => Name -> Monad m => forall i. ConduitT i Event m () -> ConduitT i Event m ()
el x = tag x mempty
-- Clark notation is used a lot for xml namespaces in this module:
--
-- Name has an IsString instance which parses it
override :: Monad m => Text -> Text -> forall i. ConduitT i Event m ()
override content' part =
tag "{http://schemas.openxmlformats.org/package/2006/content-types}Override"
(attr "ContentType" content'
<> attr "PartName" part) $ pure ()
-- | required by Excel.
writeContentTypes :: Monad m => forall i. ConduitT i Event m ()
writeContentTypes = doc "{http://schemas.openxmlformats.org/package/2006/content-types}Types" $ do
override "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml" "/xl/workbook.xml"
override "application/vnd.openxmlformats-officedocument.spreadsheetml.sharedStrings+xml" "/xl/sharedStrings.xml"
override "application/vnd.openxmlformats-officedocument.spreadsheetml.styles+xml" "/xl/styles.xml"
override "application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml" "/xl/worksheets/sheet1.xml"
override "application/vnd.openxmlformats-package.relationships+xml" "/xl/_rels/workbook.xml.rels"
override "application/vnd.openxmlformats-package.relationships+xml" "/_rels/.rels"
-- | required by Excel.
writeWorkbook :: Monad m => forall i. ConduitT i Event m ()
writeWorkbook = doc (n_ "workbook") $ do
el (n_ "sheets") $ do
tag (n_ "sheet")
(attr "name" "Sheet1"
<> attr "sheetId" "1" <>
attr (odr "id") "rId3") $
pure ()
doc :: Monad m => Name -> forall i. ConduitT i Event m () -> ConduitT i Event m ()
doc root docM = do
yield EventBeginDocument
el root docM
yield EventEndDocument
relationship :: Monad m => Text -> Int -> Text -> forall i. ConduitT i Event m ()
relationship target id' type' =
tag (pr "Relationship")
(attr "Type" type'
<> attr "Id" (Text.pack $ "rId" <> show id')
<> attr "Target" target
) $ pure ()
writeWorkbookRels :: Monad m => forall i. ConduitT i Event m ()
writeWorkbookRels = doc (pr "Relationships") $ do
relationship "sharedStrings.xml" 1 "http://schemas.openxmlformats.org/officeDocument/2006/relationships/sharedStrings"
relationship "worksheets/sheet1.xml" 3 "http://schemas.openxmlformats.org/officeDocument/2006/relationships/worksheet"
relationship "styles.xml" 2 "http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles"
writeRootRels :: Monad m => forall i. ConduitT i Event m ()
writeRootRels = doc (pr "Relationships") $
relationship "xl/workbook.xml" 1 "http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument"
zipEntry :: Text -> ZipEntry
zipEntry x = ZipEntry
{ zipEntryName = Left x
, zipEntryTime = LocalTime (toEnum 0) midnight
, zipEntrySize = Nothing
, zipEntryExternalAttributes = Nothing
}
eventsToBS :: PrimMonad m => ConduitT Event ByteString m ()
eventsToBS = writeEvents .| C.builderToByteString
writeSst :: Monad m => Map Text Int -> forall i. ConduitT i Event m ()
writeSst sharedStrings' = doc (n_ "sst") $
void $ traverse (el (n_ "si") . el (n_ "t") . content . fst
) $ sortBy (\(_, i) (_, y :: Int) -> compare i y) $ Map.toList sharedStrings'
writeEvents :: PrimMonad m => ConduitT Event Builder m ()
writeEvents = renderBuilder (def {rsPretty=False})
sheetViews :: forall m . MonadReader SheetWriteSettings m => forall i . ConduitT i Event m ()
sheetViews = do
sheetView <- view wsSheetView
unless (null sheetView) $ el (n_ "sheetViews") $ do
let
view' :: [Element]
view' = setNameSpaceRec spreadSheetNS . toXMLElement . toElement (n_ "sheetView") <$> sheetView
C.yieldMany $ elementToEvents =<< view'
spreadSheetNS :: Text
spreadSheetNS = fold $ nameNamespace $ n_ ""
setNameSpaceRec :: Text -> Element -> Element
setNameSpaceRec space xelm =
xelm {elementName = ((elementName xelm ){nameNamespace =
Just space })
, elementNodes = elementNodes xelm <&> \case
NodeElement x -> NodeElement (setNameSpaceRec space x)
y -> y
}
columns :: MonadReader SheetWriteSettings m => ConduitT Row Event m ()
columns = do
colProps <- view wsColumnProperties
let cols :: Maybe TXML.Element
cols = nonEmptyElListSimple (n_ "cols") $ map (toElement (n_ "col")) colProps
traverse_ (C.yieldMany . elementToEvents . toXMLElement) cols
writeWorkSheet :: MonadReader SheetWriteSettings m => Map Text Int -> ConduitT Row Event m ()
writeWorkSheet sharedStrings' = doc (n_ "worksheet") $ do
sheetViews
columns
el (n_ "sheetData") $ C.awaitForever (mapRow sharedStrings')
mapRow :: MonadReader SheetWriteSettings m => Map Text Int -> Row -> ConduitT Row Event m ()
mapRow sharedStrings' sheetItem = do
mRowProp <- preview $ wsRowProperties . ix (unRowIndex rowIx) . rowHeightLens . _Just . failing _CustomHeight _AutomaticHeight
let rowAttr :: Attributes
rowAttr = ixAttr <> fold (attr "ht" . txtd <$> mRowProp)
tag (n_ "row") rowAttr $
void $ itraverse (mapCell sharedStrings' rowIx) (sheetItem ^. ri_cell_row)
where
rowIx = sheetItem ^. ri_row_index
ixAttr = attr "r" $ toAttrVal rowIx
mapCell ::
Monad m => Map Text Int -> RowIndex -> Int -> Cell -> ConduitT Row Event m ()
mapCell sharedStrings' rix cix' cell =
when (has (cellValue . _Just) cell || has (cellStyle . _Just) cell) $
tag (n_ "c") celAttr $
when (has (cellValue . _Just) cell) $
el (n_ "v") $
content $ renderCell sharedStrings' cell
where
cix = ColumnIndex cix'
celAttr = attr "r" ref <>
renderCellType sharedStrings' cell
<> foldMap (attr "s" . txti) (cell ^. cellStyle)
ref :: Text
ref = coerce $ singleCellRef (rix, cix)
renderCellType :: Map Text Int -> Cell -> Attributes
renderCellType sharedStrings' cell =
maybe mempty
(attr "t" . renderType sharedStrings')
$ cell ^? cellValue . _Just
renderCell :: Map Text Int -> Cell -> Text
renderCell sharedStrings' cell = renderValue sharedStrings' val
where
val :: CellValue
val = fromMaybe (CellText mempty) $ cell ^? cellValue . _Just
renderValue :: Map Text Int -> CellValue -> Text
renderValue sharedStrings' = \case
CellText x ->
-- if we can't find it in the sst, print the string
maybe x toAttrVal $ sharedStrings' ^? ix x
CellDouble x -> toAttrVal x
CellBool b -> toAttrVal b
CellRich _ -> error "rich text is not supported yet"
CellError err -> toAttrVal err
renderType :: Map Text Int -> CellValue -> Text
renderType sharedStrings' = \case
CellText x ->
maybe "str" (const "s") $ sharedStrings' ^? ix x
CellDouble _ -> "n"
CellBool _ -> "b"
CellRich _ -> "r"
CellError _ -> "e"
xlsx-1.1.2.2/src/Codec/Xlsx/Writer/Internal/Stream.hs 0000644 0000000 0000000 00000002334 14551273353 020432 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
-- | Internal stream related functions.
-- These are exported because they're tested like this.
-- It's not expected a user would need this.
module Codec.Xlsx.Writer.Internal.Stream
( upsertSharedString
, initialSharedString
, string_map
, SharedStringState(..)
) where
#ifdef USE_MICROLENS
import Lens.Micro.Platform
#else
import Control.Lens
#endif
import Control.Monad.State.Strict
import Data.Map.Strict (Map)
import Data.Maybe
import Data.Text (Text)
newtype SharedStringState = MkSharedStringState
{ _string_map :: Map Text Int
}
makeLenses 'MkSharedStringState
initialSharedString :: SharedStringState
initialSharedString = MkSharedStringState mempty
-- properties:
-- for a list of [text], every unique text gets a unique number.
upsertSharedString :: MonadState SharedStringState m => Text -> m (Text,Int)
upsertSharedString current = do
strings <- use string_map
let mIdx :: Maybe Int
mIdx = strings ^? ix current
idx :: Int
idx = fromMaybe (length strings) mIdx
newMap :: Map Text Int
newMap = at current ?~ idx $ strings
string_map .= newMap
pure (current, idx)
xlsx-1.1.2.2/src/Codec/Xlsx/Parser/Stream/HexpatInternal.hs 0000644 0000000 0000000 00000012214 14551273353 021562 0 ustar 00 0000000 0000000 {-
Under BSD 3-Clause license, (c) 2009 Doug Beardsley , (c) 2009-2012 Stephen Blackheath , (c) 2009 Gregory Collins, (c) 2008 Evan Martin , (c) 2009 Matthew Pocock , (c) 2007-2009 Galois Inc., (c) 2010 Kevin Jardine, (c) 2012 Simon Hengel
From https://hackage.haskell.org/package/hexpat-0.20.13
https://github.com/the-real-blackh/hexpat/blob/master/Text/XML/Expat/SAX.hs#L227
copied over because the upstream library doesn't expose this function.
-}
module Codec.Xlsx.Parser.Stream.HexpatInternal (parseBuf) where
import Control.Monad
import Text.XML.Expat.SAX
import qualified Data.ByteString.Internal as I
import Data.Bits
import Data.Int
import Data.ByteString.Internal (c_strlen)
import Data.Word
import Foreign.C
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable
{-# SCC parseBuf #-}
parseBuf :: (GenericXMLString tag, GenericXMLString text) =>
ForeignPtr Word8 -> CInt -> (Ptr Word8 -> Int -> IO (a, Int)) -> IO [(SAXEvent tag text, a)]
parseBuf buf _ processExtra = withForeignPtr buf $ \pBuf -> doit [] pBuf 0
where
roundUp32 offset = (offset + 3) .&. complement 3
doit acc pBuf offset0 = offset0 `seq` do
typ <- peek (pBuf `plusPtr` offset0 :: Ptr Word32)
(a, offset) <- processExtra pBuf (offset0 + 4)
case typ of
0 -> return (reverse acc)
1 -> do
nAtts <- peek (pBuf `plusPtr` offset :: Ptr Word32)
let pName = pBuf `plusPtr` (offset + 4)
lName <- fromIntegral <$> c_strlen pName
let name = gxFromByteString $ I.fromForeignPtr buf (offset + 4) lName
(atts, offset') <- foldM (\(atts, offset) _ -> do
let pAtt = pBuf `plusPtr` offset
lAtt <- fromIntegral <$> c_strlen pAtt
let att = gxFromByteString $ I.fromForeignPtr buf offset lAtt
offset' = offset + lAtt + 1
pValue = pBuf `plusPtr` offset'
lValue <- fromIntegral <$> c_strlen pValue
let value = gxFromByteString $ I.fromForeignPtr buf offset' lValue
return ((att, value):atts, offset' + lValue + 1)
) ([], offset + 4 + lName + 1) [1,3..nAtts]
doit ((StartElement name (reverse atts), a) : acc) pBuf (roundUp32 offset')
2 -> do
let pName = pBuf `plusPtr` offset
lName <- fromIntegral <$> c_strlen pName
let name = gxFromByteString $ I.fromForeignPtr buf offset lName
offset' = offset + lName + 1
doit ((EndElement name, a) : acc) pBuf (roundUp32 offset')
3 -> do
len <- fromIntegral <$> peek (pBuf `plusPtr` offset :: Ptr Word32)
let text = gxFromByteString $ I.fromForeignPtr buf (offset + 4) len
offset' = offset + 4 + len
doit ((CharacterData text, a) : acc) pBuf (roundUp32 offset')
4 -> do
let pEnc = pBuf `plusPtr` offset
lEnc <- fromIntegral <$> c_strlen pEnc
let enc = gxFromByteString $ I.fromForeignPtr buf offset lEnc
offset' = offset + lEnc + 1
pVer = pBuf `plusPtr` offset'
pVerFirst <- peek (castPtr pVer :: Ptr Word8)
(mVer, offset'') <- case pVerFirst of
0 -> return (Nothing, offset' + 1)
1 -> do
lVer <- fromIntegral <$> c_strlen (pVer `plusPtr` 1)
return (Just $ gxFromByteString $ I.fromForeignPtr buf (offset' + 1) lVer, offset' + 1 + lVer + 1)
_ -> error "hexpat: bad data from C land"
cSta <- peek (pBuf `plusPtr` offset'' :: Ptr Int8)
let sta = if cSta < 0 then Nothing else
if cSta == 0 then Just False else
Just True
doit ((XMLDeclaration enc mVer sta, a) : acc) pBuf (roundUp32 (offset'' + 1))
5 -> doit ((StartCData, a) : acc) pBuf offset
6 -> doit ((EndCData, a) : acc) pBuf offset
7 -> do
let pTarget = pBuf `plusPtr` offset
lTarget <- fromIntegral <$> c_strlen pTarget
let target = gxFromByteString $ I.fromForeignPtr buf offset lTarget
offset' = offset + lTarget + 1
pData = pBuf `plusPtr` offset'
lData <- fromIntegral <$> c_strlen pData
let dat = gxFromByteString $ I.fromForeignPtr buf offset' lData
doit ((ProcessingInstruction target dat, a) : acc) pBuf (roundUp32 (offset' + lData + 1))
8 -> do
let pText = pBuf `plusPtr` offset
lText <- fromIntegral <$> c_strlen pText
let text = gxFromByteString $ I.fromForeignPtr buf offset lText
doit ((Comment text, a) : acc) pBuf (roundUp32 (offset + lText + 1))
_ -> error "hexpat: bad data from C land"
xlsx-1.1.2.2/src/Codec/Xlsx/Parser/Internal/Memoize.hs 0000644 0000000 0000000 00000003444 14551273353 020567 0 ustar 00 0000000 0000000 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
-- | I rewrote: https://hackage.haskell.org/package/unliftio-0.2.20/docs/src/UnliftIO.Memoize.html#Memoized
-- for monad trans basecontrol
-- we don't need a generic `m` anyway. it's good enough in base IO.
module Codec.Xlsx.Parser.Internal.Memoize
( Memoized
, runMemoized
, memoizeRef
) where
import Control.Applicative as A
import Control.Monad (join)
import Control.Monad.IO.Class
import Data.IORef
import Control.Exception
-- | A \"run once\" value, with results saved. Extract the value with
-- 'runMemoized'. For single-threaded usage, you can use 'memoizeRef' to
-- create a value. If you need guarantees that only one thread will run the
-- action at a time, use 'memoizeMVar'.
--
-- Note that this type provides a 'Show' instance for convenience, but not
-- useful information can be provided.
newtype Memoized a = Memoized (IO a)
deriving (Functor, A.Applicative, Monad)
instance Show (Memoized a) where
show _ = "<>"
-- | Extract a value from a 'Memoized', running an action if no cached value is
-- available.
runMemoized :: MonadIO m => Memoized a -> m a
runMemoized (Memoized m) = liftIO m
{-# INLINE runMemoized #-}
-- | Create a new 'Memoized' value using an 'IORef' under the surface. Note that
-- the action may be run in multiple threads simultaneously, so this may not be
-- thread safe (depending on the underlying action).
memoizeRef :: IO a -> IO (Memoized a)
memoizeRef action = do
ref <- newIORef Nothing
pure $ Memoized $ do
mres <- readIORef ref
res <-
case mres of
Just res -> pure res
Nothing -> do
res <- try @SomeException action
writeIORef ref $ Just res
pure res
either throwIO pure res
xlsx-1.1.2.2/test/Main.hs 0000644 0000000 0000000 00000013131 14551273353 013245 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
module Main
( main
) where
#ifdef USE_MICROLENS
import Lens.Micro
#else
import Control.Lens
#endif
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as LB
import qualified Data.Map as M
import Data.Maybe (listToMaybe)
import Data.Text (Text)
import qualified StreamTests
import Text.XML
import Test.Tasty (defaultMain, testGroup)
import Test.Tasty.HUnit (testCase, (@=?))
import Test.Tasty.SmallCheck (testProperty)
import TestXlsx
import Codec.Xlsx
import Codec.Xlsx.Formatted
import AutoFilterTests
import Common
import CommonTests
import CondFmtTests
import Diff
import DrawingTests
import PivotTableTests
main :: IO ()
main = defaultMain $
testGroup "Tests"
[
testCase "write . read == id" $ do
let bs = fromXlsx testTime testXlsx
LB.writeFile "data-test.xlsx" bs
testXlsx @==? toXlsx (fromXlsx testTime testXlsx)
, testCase "write . fast-read == id" $ do
let bs = fromXlsx testTime testXlsx
LB.writeFile "data-test.xlsx" bs
testXlsx @==? toXlsxFast (fromXlsx testTime testXlsx)
, testCase "fromRows . toRows == id" $
testCellMap1 @=? fromRows (toRows testCellMap1)
, testCase "fromRight . parseStyleSheet . renderStyleSheet == id" $
testStyleSheet @==? fromRight (parseStyleSheet (renderStyleSheet testStyleSheet))
, testCase "correct shared strings parsing" $
[testSharedStringTable] @=? parseBS testStrings
, testCase "correct shared strings parsing: single underline" $
[withSingleUnderline testSharedStringTable] @=? parseBS testStringsWithSingleUnderline
, testCase "correct shared strings parsing: double underline" $
[withDoubleUnderline testSharedStringTable] @=? parseBS testStringsWithDoubleUnderline
, testCase "correct shared strings parsing even when one of the shared strings entry is just " $
[testSharedStringTableWithEmpty] @=? parseBS testStringsWithEmpty
, testCase "correct comments parsing" $
[testCommentTable] @=? parseBS testComments
, testCase "correct custom properties parsing" $
[testCustomProperties] @==? parseBS testCustomPropertiesXml
, testCase "proper results from `formatted`" $
testFormattedResult @==? testRunFormatted
, testCase "proper results from `formatWorkbook`" $
testFormatWorkbookResult @==? testFormatWorkbook
, testCase "formatted . toFormattedCells = id" $ do
let fmtd = formatted testFormattedCells minimalStyleSheet
testFormattedCells @==? toFormattedCells (formattedCellMap fmtd) (formattedMerges fmtd)
(formattedStyleSheet fmtd)
, testCase "proper results from `conditionallyFormatted`" $
testCondFormattedResult @==? testRunCondFormatted
, testCase "toXlsxEither: properly formatted" $
Right testXlsx @==? toXlsxEither (fromXlsx testTime testXlsx)
, testCase "toXlsxEither: invalid format" $
Left (InvalidZipArchive "Did not find end of central directory signature") @==? toXlsxEither "this is not a valid XLSX file"
, testCase "toXlsx: correct floats parsing (typed and untyped cells are floats by default)"
$ floatsParsingTests toXlsx
, testCase "toXlsxFast: correct floats parsing (typed and untyped cells are floats by default)"
$ floatsParsingTests toXlsxFast
, testGroup "Codec: sheet state visibility"
[ testGroup "toXlsxEitherFast"
[ testProperty "pure state == toXlsxEitherFast (fromXlsx (defXlsxWithState state))" $
\state ->
(Right (Just state) ==) $
fmap sheetStateOfDefXlsx $
toXlsxEitherFast . fromXlsx testTime $
defXlsxWithState state
, testCase "should otherwise infer visible state by default" $
Right (Just Visible) @=? (fmap sheetStateOfDefXlsx . toXlsxEitherFast) (fromXlsx testTime defXlsx)
]
, testGroup "toXlsxEither"
[ testProperty "pure state == toXlsxEither (fromXlsx (defXlsxWithState state))" $
\state ->
(Right (Just state) ==) $
fmap sheetStateOfDefXlsx $
toXlsxEither . fromXlsx testTime $
defXlsxWithState state
, testCase "should otherwise infer visible state by default" $
Right (Just Visible) @=? (fmap sheetStateOfDefXlsx . toXlsxEither) (fromXlsx testTime defXlsx)
]
]
, CommonTests.tests
, CondFmtTests.tests
, PivotTableTests.tests
, DrawingTests.tests
, AutoFilterTests.tests
, StreamTests.tests
]
floatsParsingTests :: (ByteString -> Xlsx) -> IO ()
floatsParsingTests parser = do
bs <- LB.readFile "data/floats.xlsx"
let xlsx = parser bs
parsedCells = maybe mempty (_wsCells . snd) $ listToMaybe $ xlsx ^. xlSheets
expectedCells = M.fromList
[ ((1,1), def & cellValue ?~ CellDouble 12.0)
, ((2,1), def & cellValue ?~ CellDouble 13.0)
, ((3,1), def & cellValue ?~ CellDouble 14.0 & cellStyle ?~ 1)
, ((4,1), def & cellValue ?~ CellDouble 15.0)
]
expectedCells @==? parsedCells
constSheetName :: Text
constSheetName = "sheet1"
defXlsx :: Xlsx
defXlsx = def & atSheet constSheetName ?~ def
defXlsxWithState :: SheetState -> Xlsx
defXlsxWithState state =
def & atSheet constSheetName ?~ (wsState .~ state $ def)
sheetStateOfDefXlsx :: Xlsx -> Maybe SheetState
sheetStateOfDefXlsx xlsx =
xlsx ^. atSheet constSheetName & mapped %~ _wsState
xlsx-1.1.2.2/test/AutoFilterTests.hs 0000644 0000000 0000000 00000001164 14551273353 015465 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module AutoFilterTests
( tests
) where
import Test.SmallCheck.Series
import Test.Tasty (testGroup, TestTree)
import Test.Tasty.SmallCheck (testProperty)
import Codec.Xlsx
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Writer.Internal
import Common
import Test.SmallCheck.Series.Instances ()
tests :: TestTree
tests =
testGroup
"Types.AutFilter tests"
[ testProperty "fromCursor . toElement == id" $ \(autoFilter :: AutoFilter) ->
[autoFilter] == fromCursor (cursorFromElement $ toElement (n_ "autoFilter") autoFilter)
]
xlsx-1.1.2.2/test/Common.hs 0000644 0000000 0000000 00000001223 14551273353 013610 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Common
( parseBS
, cursorFromElement
) where
import Data.ByteString.Lazy (ByteString)
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types (SheetState (..))
import Codec.Xlsx.Writer.Internal
import Test.SmallCheck.Series (Serial)
parseBS :: FromCursor a => ByteString -> [a]
parseBS = fromCursor . fromDocument . parseLBS_ def
cursorFromElement :: Element -> Cursor
cursorFromElement = fromNode . NodeElement . addNS mainNamespace Nothing
instance Monad m => Serial m SheetState
xlsx-1.1.2.2/test/CommonTests.hs 0000644 0000000 0000000 00000005651 14551273353 014644 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module CommonTests
( tests
) where
import Data.Fixed (Pico, Fixed(..), E12)
import Data.Time.Calendar (fromGregorian)
import Data.Time.Clock (UTCTime(..))
import Test.Tasty.SmallCheck (testProperty)
import Test.SmallCheck.Series as Series
( Positive(..)
, Serial(..)
, newtypeCons
, cons0
, (\/)
)
import Test.Tasty (testGroup, TestTree)
import Test.Tasty.HUnit (testCase, (@?=))
import Codec.Xlsx.Types.Common
import qualified CommonTests.CellRefTests as CellRefTests
tests :: TestTree
tests =
testGroup
"Types.Common tests"
[ testCase "date conversions" $ do
dateFromNumber DateBase1900 (- 2338.0) @?= read "1893-08-06 00:00:00 UTC"
dateFromNumber DateBase1900 2.0 @?= read "1900-01-02 00:00:00 UTC"
dateFromNumber DateBase1900 3687.0 @?= read "1910-02-03 00:00:00 UTC"
dateFromNumber DateBase1900 38749.0 @?= read "2006-02-01 00:00:00 UTC"
dateFromNumber DateBase1900 2958465.0 @?= read "9999-12-31 00:00:00 UTC"
dateFromNumber DateBase1900 59.0 @?= read "1900-02-28 00:00:00 UTC"
dateFromNumber DateBase1900 59.5 @?= read "1900-02-28 12:00:00 UTC"
dateFromNumber DateBase1900 60.0 @?= read "1900-03-01 00:00:00 UTC"
dateFromNumber DateBase1900 60.5 @?= read "1900-03-01 00:00:00 UTC"
dateFromNumber DateBase1900 61 @?= read "1900-03-01 00:00:00 UTC"
dateFromNumber DateBase1900 61.5 @?= read "1900-03-01 12:00:00 UTC"
dateFromNumber DateBase1900 62 @?= read "1900-03-02 00:00:00 UTC"
dateFromNumber DateBase1904 (-3800.0) @?= read "1893-08-05 00:00:00 UTC"
dateFromNumber DateBase1904 0.0 @?= read "1904-01-01 00:00:00 UTC"
dateFromNumber DateBase1904 2225.0 @?= read "1910-02-03 00:00:00 UTC"
dateFromNumber DateBase1904 37287.0 @?= read "2006-02-01 00:00:00 UTC"
dateFromNumber DateBase1904 2957003.0 @?= read "9999-12-31 00:00:00 UTC"
, testCase "Converting dates in the vicinity of 1900-03-01 to numbers" $ do
-- Note how the fact that 1900-02-29 exists for Excel forces us to skip 60
dateToNumber DateBase1900 (UTCTime (fromGregorian 1900 2 28) 0) @?= (59 :: Double)
dateToNumber DateBase1900 (UTCTime (fromGregorian 1900 3 1) 0) @?= (61 :: Double)
, testProperty "dateToNumber . dateFromNumber == id" $
-- Because excel treats 1900 as a leap year, dateToNumber and dateFromNumber
-- aren't inverses of each other in the range n E [60, 61[ for DateBase1900
\b (n :: Pico) -> (n >= 60 && n < 61 && b == DateBase1900) || n == dateToNumber b (dateFromNumber b $ n)
, CellRefTests.tests
]
instance Monad m => Serial m (Fixed E12) where
series = newtypeCons MkFixed
instance Monad m => Serial m DateBase where
series = cons0 DateBase1900 \/ cons0 DateBase1904 xlsx-1.1.2.2/test/CommonTests/CellRefTests.hs 0000644 0000000 0000000 00000020670 14551273353 017201 0 ustar 00 0000000 0000000
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module CommonTests.CellRefTests
( tests
) where
import qualified Control.Applicative as Alt
import Control.Monad
import Data.Char (chr, isPrint)
import qualified Data.List as L
import Data.Text (Text)
import qualified Data.Text as T
import Data.Word (Word8)
import Test.SmallCheck.Series as Series (NonEmpty (..), Positive (..),
Serial (..), cons1, cons2, generate,
(\/))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, (@?=))
import Test.Tasty.SmallCheck (testProperty)
import Codec.Xlsx.Types.Common
tests :: TestTree
tests =
testGroup
"Types.Common CellRef tests"
[ testProperty "textToColumnIndex . columnIndexToText == id" $
\(Positive i) -> i == textToColumnIndex (columnIndexToText i)
, testProperty "row2coord . coord2row = id" $
\(r :: RowCoord) -> r == row2coord (coord2row r)
, testProperty "col2coord . coord2col = id" $
\(c :: ColumnCoord) -> c == col2coord (coord2col c)
, testProperty "fromSingleCellRef' . singleCellRef' = pure" $
\(cellCoord :: CellCoord) -> pure cellCoord == fromSingleCellRef' (singleCellRef' cellCoord)
, testProperty "fromRange' . mkRange' = pure" $
\(range :: RangeCoord) -> pure range == fromRange' (uncurry mkRange' range)
, testProperty "fromForeignSingleCellRef . mkForeignSingleCellRef = pure" $
\(viewForeignCellParams -> params) ->
pure params == fromForeignSingleCellRef (uncurry mkForeignSingleCellRef params)
, testProperty "fromSingleCellRef' . mkForeignSingleCellRef = pure . snd" $
\(viewForeignCellParams -> (nStr, cellCoord)) ->
pure cellCoord == fromSingleCellRef' (mkForeignSingleCellRef nStr cellCoord)
, testProperty "fromForeignSingleCellRef . singleCellRef' = const empty" $
\(cellCoord :: CellCoord) ->
Alt.empty == fromForeignSingleCellRef (singleCellRef' cellCoord)
, testProperty "fromForeignRange . mkForeignRange = pure" $
\(viewForeignRangeParams -> params@(nStr, (start, end))) ->
pure params == fromForeignRange (mkForeignRange nStr start end)
, testProperty "fromRange' . mkForeignRange = pure . snd" $
\(viewForeignRangeParams -> (nStr, range@(start, end))) ->
pure range == fromRange' (mkForeignRange nStr start end)
, testProperty "fromForeignRange . mkRange' = const empty" $
\(range :: RangeCoord) ->
Alt.empty == fromForeignRange (uncurry mkRange' range)
, testCase "building single CellRefs" $ do
singleCellRef' (RowRel 5, ColumnRel 25) @?= CellRef "Y5"
singleCellRef' (RowRel 5, ColumnAbs 25) @?= CellRef "$Y5"
singleCellRef' (RowAbs 5, ColumnRel 25) @?= CellRef "Y$5"
singleCellRef' (RowAbs 5, ColumnAbs 25) @?= CellRef "$Y$5"
singleCellRef (5, 25) @?= CellRef "Y5"
, testCase "parsing single CellRefs as abstract coordinates" $ do
fromSingleCellRef (CellRef "Y5") @?= Just (5, 25)
fromSingleCellRef (CellRef "$Y5") @?= Just (5, 25)
fromSingleCellRef (CellRef "Y$5") @?= Just (5, 25)
fromSingleCellRef (CellRef "$Y$5") @?= Just (5, 25)
, testCase "parsing single CellRefs as potentially absolute coordinates" $ do
fromSingleCellRef' (CellRef "Y5") @?= Just (RowRel 5, ColumnRel 25)
fromSingleCellRef' (CellRef "$Y5") @?= Just (RowRel 5, ColumnAbs 25)
fromSingleCellRef' (CellRef "Y$5") @?= Just (RowAbs 5, ColumnRel 25)
fromSingleCellRef' (CellRef "$Y$5") @?= Just (RowAbs 5, ColumnAbs 25)
fromSingleCellRef' (CellRef "$Y$50") @?= Just (RowAbs 50, ColumnAbs 25)
fromSingleCellRef' (CellRef "$Y$5$0") @?= Nothing
fromSingleCellRef' (CellRef "Y5:Z10") @?= Nothing
, testCase "building ranges" $ do
mkRange (5, 25) (10, 26) @?= CellRef "Y5:Z10"
mkRange' (RowRel 5, ColumnRel 25) (RowRel 10, ColumnRel 26) @?= CellRef "Y5:Z10"
mkRange' (RowAbs 5, ColumnAbs 25) (RowAbs 10, ColumnAbs 26) @?= CellRef "$Y$5:$Z$10"
mkRange' (RowRel 5, ColumnAbs 25) (RowAbs 10, ColumnRel 26) @?= CellRef "$Y5:Z$10"
mkForeignRange "myWorksheet" (RowRel 5, ColumnAbs 25) (RowAbs 10, ColumnRel 26) @?= CellRef "'myWorksheet'!$Y5:Z$10"
mkForeignRange "my sheet" (RowRel 5, ColumnAbs 25) (RowAbs 10, ColumnRel 26) @?= CellRef "'my sheet'!$Y5:Z$10"
, testCase "parsing ranges CellRefs as abstract coordinates" $ do
fromRange (CellRef "Y5:Z10") @?= Just ((5, 25), (10, 26))
fromRange (CellRef "$Y$5:$Z$10") @?= Just ((5, 25), (10, 26))
fromRange (CellRef "myWorksheet!$Y5:Z$10") @?= Just ((5, 25), (10, 26))
, testCase "parsing ranges CellRefs as potentially absolute coordinates" $ do
fromRange' (CellRef "Y5:Z10") @?= Just ((RowRel 5, ColumnRel 25), (RowRel 10, ColumnRel 26))
fromRange' (CellRef "$Y$5:$Z$10") @?= Just ((RowAbs 5, ColumnAbs 25), (RowAbs 10, ColumnAbs 26))
fromRange' (CellRef "myWorksheet!$Y5:Z$10") @?= Just ((RowRel 5, ColumnAbs 25), (RowAbs 10, ColumnRel 26))
fromForeignRange (CellRef "myWorksheet!$Y5:Z$10") @?= Just ("myWorksheet", ((RowRel 5, ColumnAbs 25), (RowAbs 10, ColumnRel 26)))
fromForeignRange (CellRef "'myWorksheet'!Y5:Z10") @?= Just ("myWorksheet", ((RowRel 5, ColumnRel 25), (RowRel 10, ColumnRel 26)))
fromForeignRange (CellRef "'my sheet'!Y5:Z10") @?= Just ("my sheet", ((RowRel 5, ColumnRel 25), (RowRel 10, ColumnRel 26)))
fromForeignRange (CellRef "$Y5:Z$10") @?= Nothing
]
instance Monad m => Serial m RowIndex where
series = cons1 (RowIndex . getPositive)
instance Monad m => Serial m ColumnIndex where
series = cons1 (ColumnIndex . getPositive)
instance Monad m => Serial m RowCoord where
series = cons1 (RowAbs . getPositive) \/ cons1 (RowRel . getPositive)
instance Monad m => Serial m ColumnCoord where
series = cons1 (ColumnAbs . getPositive) \/ cons1 (ColumnRel . getPositive)
-- | Allow defining an instance to generate valid foreign range params
data MkForeignRangeRef =
MkForeignRangeRef NameString RangeCoord
deriving (Show)
viewForeignRangeParams :: MkForeignRangeRef -> (Text, RangeCoord)
viewForeignRangeParams (MkForeignRangeRef nameStr range) = (nameString nameStr, range)
instance Monad m => Serial m MkForeignRangeRef where
series = cons2 MkForeignRangeRef
-- | Allow defining an instance to generate valid foreign cellref params
data MkForeignCellRef =
MkForeignCellRef NameString CellCoord
deriving (Show)
viewForeignCellParams :: MkForeignCellRef -> (Text, CellCoord)
viewForeignCellParams (MkForeignCellRef nameStr coord) = (nameString nameStr, coord)
instance Monad m => Serial m MkForeignCellRef where
series = cons2 MkForeignCellRef
-- | Overload an instance for allowed sheet name chars
newtype NameChar =
NameChar { _unNCh :: Char }
deriving (Show, Eq)
-- | Instance for Char which broadens the pool to permitted ascii and some wchars
-- as @Serial m Char@ is only @[ 'A' .. 'Z' ]@
instance Monad m => Serial m NameChar where
series =
fmap NameChar $
let wChars = ['é', '€', '愛']
startSeq = "ab cd'" -- single quote is permitted as long as it's not 1st or last
authorizedAscii =
let asciiRange = L.map (chr . fromIntegral) [minBound @Word8 .. maxBound `div` 2]
forbiddenClass = "[]*:?/\\" :: String
isAuthorized c = isPrint c && not (c `L.elem` forbiddenClass)
isPlanned c = isAuthorized c && not (c `L.elem` startSeq)
in L.filter isPlanned asciiRange
in generate $ \d -> take (d + 1) $ startSeq ++ wChars ++ authorizedAscii
-- | Allow defining an instance to generate valid sheetnames (non-empty, valid char set, squote rule)
newtype NameString =
NameString { _unNS :: Series.NonEmpty NameChar }
deriving (Show)
nameString :: NameString -> Text
nameString = T.pack . L.map _unNCh . getNonEmpty . _unNS
instance Monad m => Serial m NameString where
series = fmap NameString $
series @m @(Series.NonEmpty NameChar) >>= \t -> t <$ guard (isOk t)
where
-- squote isn't permitted at the beginning and the end of a sheet's name
isOk (getNonEmpty -> s) =
head s /= NameChar '\'' &&
last s /= NameChar '\''
xlsx-1.1.2.2/test/CondFmtTests.hs 0000644 0000000 0000000 00000001105 14551273353 014734 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module CondFmtTests
( tests
) where
import Test.Tasty (testGroup, TestTree)
import Test.Tasty.SmallCheck (testProperty)
import Codec.Xlsx
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Writer.Internal
import Common
import Test.SmallCheck.Series.Instances ()
tests :: TestTree
tests =
testGroup
"Types.ConditionalFormatting tests"
[ testProperty "fromCursor . toElement == id" $ \(cFmt :: CfRule) ->
[cFmt] == fromCursor (cursorFromElement $ toElement (n_ "cfRule") cFmt)
]
xlsx-1.1.2.2/test/Diff.hs 0000644 0000000 0000000 00000001104 14551273353 013226 0 ustar 00 0000000 0000000 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-1.1.2.2/test/DrawingTests.hs 0000644 0000000 0000000 00000030423 14551273353 015002 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module DrawingTests
( tests
, testDrawing
, testLineChartSpace
) where
#ifdef USE_MICROLENS
import Lens.Micro
#else
import Control.Lens
#endif
import Data.ByteString.Lazy (ByteString)
import Test.Tasty (testGroup, TestTree)
import Test.Tasty.HUnit (testCase)
import Text.RawString.QQ
import Text.XML
import Codec.Xlsx
import Codec.Xlsx.Types.Internal
import Codec.Xlsx.Writer.Internal
import Common
import Diff
tests :: TestTree
tests =
testGroup
"Drawing tests"
[ testCase "correct drawing parsing" $
[testDrawing] @==? parseBS testDrawingFile
, testCase "write . read == id for Drawings" $
[testDrawing] @==? parseBS testWrittenDrawing
, testCase "correct chart parsing" $
[testLineChartSpace] @==? parseBS testLineChartFile
, testCase "parse . render == id for line Charts" $
[testLineChartSpace] @==? parseBS (renderChartSpace testLineChartSpace)
, testCase "parse . render == id for area Charts" $
[testAreaChartSpace] @==? parseBS (renderChartSpace testAreaChartSpace)
, testCase "parse . render == id for bar Charts" $
[testBarChartSpace] @==? parseBS (renderChartSpace testBarChartSpace)
, testCase "parse . render == id for pie Charts" $
[testPieChartSpace] @==? parseBS (renderChartSpace testPieChartSpace)
, testCase "parse . render == id for scatter Charts" $
[testScatterChartSpace] @==? parseBS (renderChartSpace testScatterChartSpace)
]
testDrawing :: UnresolvedDrawing
testDrawing = Drawing [anchor1, anchor2]
where
anchor1 =
Anchor
{_anchAnchoring = anchoring1, _anchObject = pic, _anchClientData = def}
anchoring1 =
TwoCellAnchor
{ tcaFrom = unqMarker (0, 0) (0, 0)
, tcaTo = unqMarker (12, 320760) (33, 38160)
, tcaEditAs = EditAsAbsolute
}
pic =
Picture
{ _picMacro = Nothing
, _picPublished = False
, _picNonVisual = nonVis1
, _picBlipFill = bfProps
, _picShapeProperties = shProps
}
nonVis1 =
PicNonVisual $
NonVisualDrawingProperties
{ _nvdpId = DrawingElementId 0
, _nvdpName = "Picture 1"
, _nvdpDescription = Just ""
, _nvdpHidden = False
, _nvdpTitle = Nothing
}
bfProps =
BlipFillProperties
{_bfpImageInfo = Just (RefId "rId1"), _bfpFillMode = Just FillStretch}
shProps =
ShapeProperties
{ _spXfrm = Just trnsfrm
, _spGeometry = Just PresetGeometry
, _spFill = Nothing
, _spOutline = Just $ def {_lnFill = Just NoFill}
}
trnsfrm =
Transform2D
{ _trRot = Angle 0
, _trFlipH = False
, _trFlipV = False
, _trOffset = Just (unqPoint2D 0 0)
, _trExtents =
Just
(PositiveSize2D
(PositiveCoordinate 10074240)
(PositiveCoordinate 5402520))
}
anchor2 =
Anchor
{ _anchAnchoring = anchoring2
, _anchObject = graphic
, _anchClientData = def
}
anchoring2 =
TwoCellAnchor
{ tcaFrom = unqMarker (0, 87840) (21, 131040)
, tcaTo = unqMarker (7, 580320) (38, 132480)
, tcaEditAs = EditAsOneCell
}
graphic =
Graphic
{ _grNonVisual = nonVis2
, _grChartSpace = RefId "rId2"
, _grTransform = transform
}
nonVis2 =
GraphNonVisual $
NonVisualDrawingProperties
{ _nvdpId = DrawingElementId 1
, _nvdpName = ""
, _nvdpDescription = Nothing
, _nvdpHidden = False
, _nvdpTitle = Nothing
}
transform =
Transform2D
{ _trRot = Angle 0
, _trFlipH = False
, _trFlipV = False
, _trOffset = Just (unqPoint2D 0 0)
, _trExtents =
Just
(PositiveSize2D
(PositiveCoordinate 10074240)
(PositiveCoordinate 5402520))
}
testDrawingFile :: ByteString
testDrawingFile = [r|
00
00
12320760
3338160
087840
21131040
7580320
38132480
|]
testWrittenDrawing :: ByteString
testWrittenDrawing = renderLBS def $ toDocument testDrawing
testLineChartFile :: ByteString
testLineChartFile = [r|
Line chart title
Sheet1!$A$1
Sheet1!$B$1:$D$1
Sheet1!$A$2
Sheet1!$B$2:$D$2
|]
oneChartChartSpace :: Chart -> ChartSpace
oneChartChartSpace chart =
ChartSpace
{ _chspTitle = Just $ ChartTitle (Just titleBody)
, _chspCharts = [chart]
, _chspLegend = Nothing
, _chspPlotVisOnly = Just True
, _chspDispBlanksAs = Just DispBlanksAsGap
}
where
titleBody =
TextBody
{ _txbdRotation = Angle 0
, _txbdSpcFirstLastPara = False
, _txbdVertOverflow = TextVertOverflow
, _txbdVertical = TextVerticalHorz
, _txbdWrap = TextWrapSquare
, _txbdAnchor = TextAnchoringBottom
, _txbdAnchorCenter = False
, _txbdParagraphs =
[TextParagraph Nothing [RegularRun Nothing "Line chart title"]]
}
renderChartSpace :: ChartSpace -> ByteString
renderChartSpace = renderLBS def {rsNamespaces = nss} . toDocument
where
nss =
[ ("c", "http://schemas.openxmlformats.org/drawingml/2006/chart")
, ("a", "http://schemas.openxmlformats.org/drawingml/2006/main")
]
testLineChartSpace :: ChartSpace
testLineChartSpace = oneChartChartSpace lineChart
where
lineChart =
LineChart
{ _lnchGrouping = StandardGrouping
, _lnchSeries = series
, _lnchMarker = Just False
, _lnchSmooth = Just False
}
series =
[ LineSeries
{ _lnserShared =
Series
{ _serTx = Just $ Formula "Sheet1!$A$1"
, _serShapeProperties = Just $ rgbShape "0000FF"
}
, _lnserMarker = Just markerNone
, _lnserDataLblProps = Nothing
, _lnserVal = Just $ Formula "Sheet1!$B$1:$D$1"
, _lnserSmooth = Just False
}
, LineSeries
{ _lnserShared =
Series
{ _serTx = Just $ Formula "Sheet1!$A$2"
, _serShapeProperties = Just $ rgbShape "FF0000"
}
, _lnserMarker = Just markerNone
, _lnserDataLblProps = Nothing
, _lnserVal = Just $ Formula "Sheet1!$B$2:$D$2"
, _lnserSmooth = Just False
}
]
rgbShape color =
def
{ _spFill = Just $ solidRgb color
, _spOutline =
Just $
LineProperties {_lnFill = Just $ solidRgb color, _lnWidth = 28800}
}
markerNone =
DataMarker {_dmrkSymbol = Just DataMarkerNone, _dmrkSize = Nothing}
testAreaChartSpace :: ChartSpace
testAreaChartSpace = oneChartChartSpace areaChart
where
areaChart =
AreaChart {_archGrouping = Just StandardGrouping, _archSeries = series}
series =
[ AreaSeries
{ _arserShared =
Series
{ _serTx = Just $ Formula "Sheet1!$A$1"
, _serShapeProperties =
Just $
def
{ _spFill = Just $ solidRgb "000088"
, _spOutline = Just $ def {_lnFill = Just NoFill}
}
}
, _arserDataLblProps = Nothing
, _arserVal = Just $ Formula "Sheet1!$B$1:$D$1"
}
]
testBarChartSpace :: ChartSpace
testBarChartSpace =
oneChartChartSpace
BarChart
{ _brchDirection = DirectionColumn
, _brchGrouping = Just BarStandardGrouping
, _brchSeries =
[ BarSeries
{ _brserShared =
Series
{ _serTx = Just $ Formula "Sheet1!$A$1"
, _serShapeProperties =
Just $
def
{ _spFill = Just $ solidRgb "000088"
, _spOutline = Just $ def {_lnFill = Just NoFill}
}
}
, _brserDataLblProps = Nothing
, _brserVal = Just $ Formula "Sheet1!$B$1:$D$1"
}
]
}
testPieChartSpace :: ChartSpace
testPieChartSpace =
oneChartChartSpace
PieChart
{ _pichSeries =
[ PieSeries
{ _piserShared =
Series
{ _serTx = Just $ Formula "Sheet1!$A$1"
, _serShapeProperties = Nothing
}
, _piserDataPoints =
[ def & dpShapeProperties ?~ solidFill "000088"
, def & dpShapeProperties ?~ solidFill "008800"
, def & dpShapeProperties ?~ solidFill "880000"
]
, _piserDataLblProps = Nothing
, _piserVal = Just $ Formula "Sheet1!$B$1:$D$1"
}
]
}
where
solidFill color = def & spFill ?~ solidRgb color
testScatterChartSpace :: ChartSpace
testScatterChartSpace =
oneChartChartSpace
ScatterChart
{ _scchStyle = ScatterMarker
, _scchSeries =
[ ScatterSeries
{ _scserShared =
Series
{ _serTx = Just $ Formula "Sheet1!$A$2"
, _serShapeProperties =
Just $ def {_spOutline = Just $ def {_lnFill = Just NoFill}}
}
, _scserMarker = Just $ DataMarker (Just DataMarkerSquare) Nothing
, _scserDataLblProps = Nothing
, _scserXVal = Just $ Formula "Sheet1!$B$1:$D$1"
, _scserYVal = Just $ Formula "Sheet1!$B$2:$D$2"
, _scserSmooth = Nothing
}
]
}
xlsx-1.1.2.2/test/PivotTableTests.hs 0000644 0000000 0000000 00000015552 14551273353 015466 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module PivotTableTests
( tests
, testPivotTable
, testPivotSrcCells
) where
#ifdef USE_MICROLENS
import Lens.Micro
#else
import Control.Lens
#endif
import Data.ByteString.Lazy (ByteString)
import qualified Data.Map as M
import Data.Maybe (mapMaybe)
import qualified Data.Text as T
import Test.Tasty (testGroup, TestTree)
import Test.Tasty.HUnit (testCase)
import Text.RawString.QQ
import Text.XML
import Codec.Xlsx
import Codec.Xlsx.Parser.Internal.PivotTable
import Codec.Xlsx.Types.Internal (unsafeRefId)
import Codec.Xlsx.Types.PivotTable.Internal
import Codec.Xlsx.Writer.Internal.PivotTable
import Diff
tests :: TestTree
tests =
testGroup
"Pivot table tests"
[ testCase "proper pivot table rendering" $ do
let ptFiles = renderPivotTableFiles testPivotSrcCells 3 testPivotTable
parseLBS_ def (pvtfTable ptFiles) @==?
stripContentSpaces (parseLBS_ def testPivotTableDefinition)
parseLBS_ def (pvtfCacheDefinition ptFiles) @==?
stripContentSpaces (parseLBS_ def testPivotCacheDefinition)
, testCase "proper pivot table parsing" $ do
let sheetName = "Sheet1"
ref = CellRef "A1:D5"
forCacheId (CacheId 3) = Just (sheetName, ref, testPivotCacheFields)
forCacheId _ = Nothing
-- fields with numeric values go into cache records
testPivotCacheFields' =
[ if cfName cf == PivotFieldName "Color"
then cf
else cf {cfItems = []}
| cf <- testPivotCacheFields
]
Just (sheetName, ref, testPivotCacheFields', Just (unsafeRefId 1)) @==?
parseCache testPivotCacheDefinition
Just testPivotTable @==?
parsePivotTable forCacheId testPivotTableDefinition
]
testPivotTable :: PivotTable
testPivotTable =
PivotTable
{ _pvtName = "PivotTable1"
, _pvtDataCaption = "Values"
, _pvtLocation = CellRef "A3:D12"
, _pvtSrcRef = CellRef "A1:D5"
, _pvtSrcSheet = "Sheet1"
, _pvtRowFields = [FieldPosition colorField, DataPosition]
, _pvtColumnFields = [FieldPosition yearField]
, _pvtDataFields =
[ DataField
{ _dfName = "Sum of field Price"
, _dfField = priceField
, _dfFunction = ConsolidateSum
}
, DataField
{ _dfName = "Sum of field Count"
, _dfField = countField
, _dfFunction = ConsolidateSum
}
]
, _pvtFields =
[ PivotFieldInfo (Just $ colorField) False FieldSortAscending [CellText "green"]
, PivotFieldInfo (Just $ yearField) True FieldSortManual []
, PivotFieldInfo (Just $ priceField) False FieldSortManual []
, PivotFieldInfo (Just $ countField) False FieldSortManual []
]
, _pvtRowGrandTotals = True
, _pvtColumnGrandTotals = False
, _pvtOutline = False
, _pvtOutlineData = False
}
where
colorField = PivotFieldName "Color"
yearField = PivotFieldName "Year"
priceField = PivotFieldName "Price"
countField = PivotFieldName "Count"
testPivotSrcCells :: CellMap
testPivotSrcCells =
M.fromList $
concat
[ [((row, col), def & cellValue ?~ v) | (col, v) <- zip [1 ..] cells]
| (row, cells) <- zip [1 ..] cellMap
]
where
cellMap =
[ [CellText "Color", CellText "Year", CellText "Price", CellText "Count"]
, [CellText "green", CellDouble 2012, CellDouble 12.23, CellDouble 17]
, [CellText "white", CellDouble 2011, CellDouble 73.99, CellDouble 21]
, [CellText "red", CellDouble 2012, CellDouble 10.19, CellDouble 172]
, [CellText "white", CellDouble 2012, CellDouble 34.99, CellDouble 49]
]
testPivotCacheFields :: [CacheField]
testPivotCacheFields =
[ CacheField
(PivotFieldName "Color")
[CellText "green", CellText "white", CellText "red"]
, CacheField (PivotFieldName "Year") [CellDouble 2012, CellDouble 2011]
, CacheField
(PivotFieldName "Price")
[CellDouble 12.23, CellDouble 73.99, CellDouble 10.19, CellDouble 34.99]
, CacheField
(PivotFieldName "Count")
[CellDouble 17, CellDouble 21, CellDouble 172, CellDouble 49]
]
testPivotTableDefinition :: ByteString
testPivotTableDefinition = [r|