diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,48 @@ +0.2.0 +----- +* added style sheet support (thanks to Edsko de Vries ) +* added high level interface for styling (thanks to Edsko de Vries ) +* added sheet views support (thanks to Edsko de Vries ) +* added page setup support (thanks to Edsko de Vries ) +* switched from `System.Time` to `Data.Time` +* added rich text support (thanks to Edsko de Vries ) including shared strings +* added a bit better internals for rendering (thanks to Edsko de Vries ) and parsing + +0.1.2 +----- +* added lenses to access cells both using RC and XY style coordinates, RC is used by default + +0.1.1.1 +------- +* fixed use of internal function for parsing shared strings, previous change was unused in practice + +0.1.1 +----- +* added support for rich text shared strings (thanks to Steve Bigham ) + +0.1.0.5 +------- +* loosened dependency on zlib package + +0.1.0.4 +------- +* fixed generated xml so it gets read by MS Excel with no warnings (thanks Dmitriy Nikitinskiy ) +* improved shared strings collection by using Vector (thanks Dmitriy Nikitinskiy ) +* empty xml elements don't get emmitted anymore (thanks Philipp Hausmann ) +* imporoved and cleaned up core.xml generation + +0.1.0.3 +------- +* added "str" cells content extraction as text +* added a notice that formulas in are not yet supported + +0.1.0 +----- +* better tests and documentation +* lenses for worksheets/cells +* removed streaming support as it needs better API and improved implementaion +* removed CellLocalTime as ambiguous, added CellBool + +0.0.1 +----- +* initial release diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,23 +0,0 @@ -0.1.2 - * added lenses to access cells both using RC and XY style coordinates, RC is used by default -0.1.1.1 - * fixed use of internal function for parsing shared strings, previous change was unused in practice -0.1.1 - * added support for rich text shared strings (thanks to Steve Bigham ) -0.1.0.5 - * loosened dependency on zlib package -0.1.0.4 - * fixed generated xml so it gets read by MS Excel with no warnings (thanks Dmitriy Nikitinskiy ) - * improved shared strings collection by using Vector (thanks Dmitriy Nikitinskiy ) - * empty xml elements don't get emmitted anymore (thanks Philipp Hausmann ) - * imporoved and cleaned up core.xml generation -0.1.0.3 - * added "str" cells content extraction as text - * added a notice that formulas in are not yet supported -0.1.0 - * better tests and documentation - * lenses for worksheets/cells - * removed streaming support as it needs better API and improved implementaion - * removed CellLocalTime as ambiguous, added CellBool -0.0.1 - * initial release diff --git a/src/Codec/Xlsx/Formatted.hs b/src/Codec/Xlsx/Formatted.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Formatted.hs @@ -0,0 +1,266 @@ +-- | Higher level interface for creating styled worksheets +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wall #-} +module Codec.Xlsx.Formatted ( + FormattedCell(..) + , Formatted(..) + , formatted + -- * Lenses + -- ** FormattedCell + , formattedAlignment + , formattedBorder + , formattedFill + , formattedFont + , formattedProtection + , formattedPivotButton + , formattedQuotePrefix + , formattedValue + , formattedColSpan + , formattedRowSpan + ) where + +import Prelude hiding (mapM) +import Control.Lens +import Control.Monad.State hiding (mapM, forM_) +import Data.Default +import Data.Foldable (forM_) +import Data.List (sortBy) +import Data.Map (Map) +import Data.Ord (comparing) +import Data.Traversable (mapM) +import Data.Tuple (swap) +import qualified Data.Map as Map + +import Codec.Xlsx.Types + +{------------------------------------------------------------------------------- + Internal: formatting state +-------------------------------------------------------------------------------} + +data FormattingState = FormattingState { + _formattingBorders :: Map Border Int + , _formattingCellXfs :: Map CellXf Int + , _formattingFills :: Map Fill Int + , _formattingFonts :: Map Font Int + , _formattingMerges :: [Range] -- ^ In reverse order + } + +makeLenses ''FormattingState + +stateFromStyleSheet :: StyleSheet -> FormattingState +stateFromStyleSheet StyleSheet{..} = FormattingState{ + _formattingBorders = fromList _styleSheetBorders + , _formattingCellXfs = fromList _styleSheetCellXfs + , _formattingFills = fromList _styleSheetFills + , _formattingFonts = fromList _styleSheetFonts + , _formattingMerges = [] + } + where + fromList :: Ord a => [a] -> Map a Int + fromList = Map.fromList . (`zip` [0..]) + +stateToStyleSheet :: FormattingState -> StyleSheet +stateToStyleSheet FormattingState{..} = StyleSheet{ + _styleSheetBorders = toList _formattingBorders + , _styleSheetCellXfs = toList _formattingCellXfs + , _styleSheetFills = toList _formattingFills + , _styleSheetFonts = toList _formattingFonts + } + where + toList :: Map a Int -> [a] + toList = map snd . sortBy (comparing fst) . map swap . Map.toList + +getId :: Ord a => Lens' FormattingState (Map a Int) -> a -> State FormattingState Int +getId f a = do + aMap <- use f + case Map.lookup a aMap of + Just aId -> return aId + Nothing -> do let aId = Map.size aMap + f %= Map.insert a aId + return aId + +{------------------------------------------------------------------------------- + Cell with formatting +-------------------------------------------------------------------------------} + +-- | Cell with formatting +-- +-- See 'formatted' for more details. +-- +-- TODOs: +-- +-- * Add a number format ('_cellXfApplyNumberFormat', '_cellXfNumFmtId') +-- * Add references to the named style sheets ('_cellXfId') +data FormattedCell = FormattedCell { + _formattedAlignment :: Maybe Alignment + , _formattedBorder :: Maybe Border + , _formattedFill :: Maybe Fill + , _formattedFont :: Maybe Font + , _formattedProtection :: Maybe Protection + , _formattedPivotButton :: Maybe Bool + , _formattedQuotePrefix :: Maybe Bool + , _formattedValue :: Maybe CellValue + , _formattedColSpan :: Int + , _formattedRowSpan :: Int + } + deriving (Show, Eq) + +makeLenses ''FormattedCell + +instance Default FormattedCell where + def = FormattedCell { + _formattedAlignment = Nothing + , _formattedBorder = Nothing + , _formattedFill = Nothing + , _formattedFont = Nothing + , _formattedProtection = Nothing + , _formattedPivotButton = Nothing + , _formattedQuotePrefix = Nothing + , _formattedValue = Nothing + , _formattedColSpan = 1 + , _formattedRowSpan = 1 + } + +{------------------------------------------------------------------------------- + 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] + } + +-- | 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 (Int, Int) FormattedCell -> StyleSheet -> Formatted +formatted cs styleSheet = + let initSt = stateFromStyleSheet styleSheet + (cs', finalSt) = runState (mapM (uncurry formatCell) (Map.toList cs)) initSt + styleSheet' = stateToStyleSheet finalSt + in Formatted { + formattedCellMap = Map.fromList (concat cs') + , formattedStyleSheet = styleSheet' + , formattedMerges = reverse (finalSt ^. formattingMerges) + } + +-- | Format a cell with (potentially) rowspan or colspan +formatCell :: (Int, Int) -> FormattedCell -> State FormattingState [((Int, Int), Cell)] +formatCell (row, col) cell = do + let (block, mMerge) = cellBlock (row, col) cell + forM_ mMerge $ \merge -> formattingMerges %= (:) merge + mapM go block + where + go :: ((Int, Int), FormattedCell) -> State FormattingState ((Int, Int), Cell) + go (pos, c) = do + styleId <- cellStyleId c + return (pos, Cell styleId (_formattedValue c)) + +-- | 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 :: (Int, Int) -> FormattedCell + -> ([((Int, Int), FormattedCell)], Maybe Range) +cellBlock (row, col) cell@FormattedCell{..} = (block, merge) + where + block :: [((Int, Int), FormattedCell)] + block = [ ((row', col'), cellAt (row', col')) + | row' <- [topRow .. bottomRow] + , col' <- [leftCol .. rightCol] + ] + + merge :: Maybe Range + merge = do guard (topRow /= bottomRow || leftCol /= rightCol) + return $ mkRange (topRow, leftCol) (bottomRow, rightCol) + + cellAt :: (Int, Int) -> FormattedCell + cellAt (row', col') = + if row' == row && col == col' + then cell + else def & formattedBorder .~ Just (borderAt (row', col')) + + borderAt :: (Int, Int) -> Border + borderAt (row', col') = def + & borderTop .~ do guard (row' == topRow) ; _borderTop =<< _formattedBorder + & borderBottom .~ do guard (row' == bottomRow) ; _borderBottom =<< _formattedBorder + & borderLeft .~ do guard (col' == leftCol) ; _borderLeft =<< _formattedBorder + & borderRight .~ do guard (col' == rightCol) ; _borderRight =<< _formattedBorder + + topRow, bottomRow, leftCol, rightCol :: Int + topRow = row + bottomRow = row + _formattedRowSpan - 1 + leftCol = col + rightCol = col + _formattedColSpan - 1 + +cellStyleId :: FormattedCell -> State FormattingState (Maybe Int) +cellStyleId c = mapM (getId formattingCellXfs) =<< cellXf c + +cellXf :: FormattedCell -> State FormattingState (Maybe CellXf) +cellXf FormattedCell{..} = do + mBorderId <- getId formattingBorders `mapM` _formattedBorder + mFillId <- getId formattingFills `mapM` _formattedFill + mFontId <- getId formattingFonts `mapM` _formattedFont + let xf = CellXf { + _cellXfApplyAlignment = apply _formattedAlignment + , _cellXfApplyBorder = apply mBorderId + , _cellXfApplyFill = apply mFillId + , _cellXfApplyFont = apply mFontId + , _cellXfApplyNumberFormat = Nothing -- TODO + , _cellXfApplyProtection = apply _formattedProtection + , _cellXfBorderId = mBorderId + , _cellXfFillId = mFillId + , _cellXfFontId = mFontId + , _cellXfNumFmtId = Nothing -- TODO + , _cellXfPivotButton = _formattedPivotButton + , _cellXfQuotePrefix = _formattedQuotePrefix + , _cellXfId = Nothing -- TODO + , _cellXfAlignment = _formattedAlignment + , _cellXfProtection = _formattedProtection + } + 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 diff --git a/src/Codec/Xlsx/Parser.hs b/src/Codec/Xlsx/Parser.hs --- a/src/Codec/Xlsx/Parser.hs +++ b/src/Codec/Xlsx/Parser.hs @@ -9,12 +9,9 @@ import qualified Codec.Archive.Zip as Zip import Control.Applicative import Control.Arrow ((&&&)) -import Control.Monad (liftM4) import Control.Monad.IO.Class() import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Char8() -import Data.IntMap (IntMap) -import qualified Data.IntMap as IM import Data.List import qualified Data.Map as M import Data.Maybe @@ -29,51 +26,47 @@ import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types +import Codec.Xlsx.Types.SharedStringTable -- | Reads `Xlsx' from raw data (lazy bytestring) toXlsx :: L.ByteString -> Xlsx -toXlsx bs = Xlsx sheets styles +toXlsx bs = Xlsx sheets styles names where ar = Zip.toArchive bs - ss = getSharedStrings ar + sst = getSharedStrings ar styles = getStyles ar - wfs = getWorksheetFiles ar - sheets = M.fromList $ map (wfName &&& extractSheet ar ss) wfs + (wfs, names) = readWorkbook ar + sheets = M.fromList $ map (wfName &&& extractSheet ar sst) wfs data WorksheetFile = WorksheetFile { wfName :: Text , wfPath :: FilePath } deriving Show -decimal :: Monad m => Text -> m Int -decimal t = case T.decimal t of - Right (d, _) -> return d - _ -> fail "invalid decimal" - -rational :: Monad m => Text -> m Double -rational t = case T.rational t of - Right (r, _) -> return r - _ -> fail "invalid rational" - extractSheet :: Zip.Archive - -> IM.IntMap Text + -> SharedStringTable -> WorksheetFile -> Worksheet -extractSheet ar ss wf = Worksheet cws rowProps cells merges +extractSheet ar sst wf = Worksheet cws rowProps cells merges sheetViews pageSetup where file = fromJust $ Zip.fromEntry <$> Zip.findEntryByPath (wfPath wf) ar cur = case parseLBS def file of Left _ -> error "could not read file" Right d -> fromDocument d - cws = cur $/ element (n"cols") &/ element (n"col") >=> - liftM4 ColumnsWidth <$> - (attribute "min" >=> decimal) <*> - (attribute "max" >=> decimal) <*> - (attribute "width" >=> rational) <*> - (attribute "style" >=> decimal) + -- 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) + sheetViewList = cur $/ element (n"sheetViews") &/ element (n"sheetView") >=> fromCursor + sheetViews = case sheetViewList of + [] -> Nothing + views -> Just views + -- Likewise, @pageSetup@ also occurs either 0 or 1 times + pageSetup = listToMaybe $ cur $/ element (n"pageSetup") >=> fromCursor + + cws = cur $/ element (n"cols") &/ element (n"col") >=> fromCursor + (rowProps, cells) = collect $ cur $/ element (n"sheetData") &/ element (n"row") >=> parseRow parseRow c = do r <- c $| attribute "r" >=> decimal @@ -92,7 +85,7 @@ let s = listToMaybe $ cell $| attribute "s" >=> decimal t = fromMaybe "n" $ listToMaybe $ cell $| attribute "t" - d = listToMaybe $ cell $/ element (n"v") &/ content >=> extractCellValue ss t + d = listToMaybe $ cell $/ element (n"v") &/ content >=> extractCellValue sst t (c, r) <- T.span (>'9') <$> (cell $| attribute "r") return (int r, col2int c, Cell s d) collect = foldr collectRow (M.empty, M.empty) @@ -107,11 +100,15 @@ parseMerges = element (n"mergeCells") &/ element (n"mergeCell") >=> parseMerge parseMerge c = c $| attribute "ref" -extractCellValue :: IntMap Text -> Text -> Text -> [CellValue] -extractCellValue ss "s" v = +extractCellValue :: SharedStringTable -> Text -> Text -> [CellValue] +extractCellValue sst "s" v = case T.decimal v of - Right (d, _) -> maybeToList $ fmap CellText $ IM.lookup d ss - _ -> [] + Right (d, _) -> + case sstItem sst d of + StringItemText txt -> [CellText txt] + StringItemRich rich -> [CellRich rich] + _ -> + [] extractCellValue _ "str" str = [CellText str] extractCellValue _ "n" v = case T.rational v of @@ -145,20 +142,22 @@ Left _ -> error "could not read file" Right d -> fromDocument d --- | Get shared strings (if there are some) into IntMap. -getSharedStrings :: Zip.Archive -> IM.IntMap Text +-- | Get shared string table +getSharedStrings :: Zip.Archive -> SharedStringTable getSharedStrings x = case xmlCursor x "xl/sharedStrings.xml" of - Nothing -> IM.empty - Just c -> parseSharedStrings c + Nothing -> + error "invalid shared strings" + Just c -> + let [sst] = fromCursor c in sst getStyles :: Zip.Archive -> Styles getStyles ar = case Zip.fromEntry <$> Zip.findEntryByPath "xl/styles.xml" ar of Nothing -> Styles L.empty Just xml -> Styles xml --- | getWorksheetFiles pulls the names of the sheets -getWorksheetFiles :: Zip.Archive -> [WorksheetFile] -getWorksheetFiles ar = case xmlCursor ar "xl/workbook.xml" of +-- | readWorkbook pulls the names of the sheets and the defined names +readWorkbook :: Zip.Archive -> ([WorksheetFile], DefinedNames) +readWorkbook ar = case xmlCursor ar "xl/workbook.xml" of Nothing -> error "invalid workbook" Just c -> @@ -166,7 +165,16 @@ sheetData = c $/ element (n"sheets") &/ element (n"sheet") >=> liftA2 (,) <$> attribute "name" <*> attribute (odr"id") wbRels = getWbRels ar - in [WorksheetFile name ("xl/" ++ T.unpack (fromJust $ lookup rId wbRels)) | (name, rId) <- sheetData] + names = c $/ element (n"definedNames") &/ element (n"definedName") >=> mkDefinedName + in ([WorksheetFile name ("xl/" ++ T.unpack (fromJust $ lookup rId wbRels)) | (name, rId) <- sheetData] + ,DefinedNames names) + where + -- Specification says the 'name' is required. + mkDefinedName :: Cursor -> [(Text, Maybe Text, Text)] + mkDefinedName c = return ( head $ attribute "name" c + , listToMaybe $ attribute "localSheetId" c + , T.concat $ c $/ content + ) getWbRels :: Zip.Archive -> [(Text, Text)] getWbRels ar = case xmlCursor ar "xl/_rels/workbook.xml.rels" of diff --git a/src/Codec/Xlsx/Parser/Internal.hs b/src/Codec/Xlsx/Parser/Internal.hs --- a/src/Codec/Xlsx/Parser/Internal.hs +++ b/src/Codec/Xlsx/Parser/Internal.hs @@ -1,16 +1,101 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Codec.Xlsx.Parser.Internal - ( n - , parseSharedStrings + ( ParseException(..) + , n + , FromCursor(..) + , FromAttrVal(..) + , fromAttribute + , maybeAttribute + , maybeElementValue + , maybeFromElement + , readSuccess + , readFailure + , invalidText + , defaultReadFailure + , decimal + , rational ) where -import qualified Data.IntMap as IM -import Data.Text (Text) +import Control.Exception (Exception) +import Data.Text (Text) import qualified Data.Text as T -import Data.XML.Types -import Text.XML.Cursor +import qualified Data.Text.Read as T +import Data.Typeable (Typeable) +import Data.XML.Types +import Text.XML.Cursor +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +data ParseException = ParseException String + deriving (Show, Typeable) + +instance Exception ParseException + +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.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 +maybeAttribute :: FromAttrVal a => Name -> Cursor -> [Maybe a] +maybeAttribute name cursor = + case attribute name cursor of + [attr] -> Just <$> runReader fromAttrVal attr + _ -> [Nothing] + +maybeElementValue :: FromAttrVal a => Name -> Cursor -> [Maybe a] +maybeElementValue name cursor = + case cursor $/ element name of + [cursor'] -> maybeAttribute "val" cursor' + _ -> [Nothing] + +maybeFromElement :: FromCursor a => Name -> Cursor -> [Maybe a] +maybeFromElement name cursor = case cursor $/ element name of + [cursor'] -> Just <$> fromCursor cursor' + _ -> [Nothing] + + +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, _) -> [r] + _ -> [] + -- | Add sml namespace to name n :: Text -> Name n x = Name @@ -19,8 +104,12 @@ , namePrefix = Nothing } -parseSharedStrings :: Cursor -> IM.IntMap Text -parseSharedStrings c = IM.fromAscList $ zip [0..] (c $/ element (n"si") >=> parseT) - where - -- it's either or s with inside - parseT c' = [T.concat $ c' $| orSelf (child >=> (element (n"r"))) &/ element (n"t") &/ content] +decimal :: Monad m => Text -> m Int +decimal t = case T.decimal t of + Right (d, _) -> return d + _ -> fail "invalid decimal" + +rational :: Monad m => Text -> m Double +rational t = case T.rational t of + Right (r, _) -> return r + _ -> fail "invalid rational" diff --git a/src/Codec/Xlsx/Types.hs b/src/Codec/Xlsx/Types.hs --- a/src/Codec/Xlsx/Types.hs +++ b/src/Codec/Xlsx/Types.hs @@ -1,23 +1,33 @@ +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Codec.Xlsx.Types - ( Xlsx(..), xlSheets, xlStyles + ( Xlsx(..), xlSheets, xlStyles, xlDefinedNames , def , Styles(..) , emptyStyles + , renderStyleSheet + , parseStyleSheet + , DefinedNames(..) , ColumnsWidth(..) - , Worksheet(..), wsColumns, wsRowPropertiesMap, wsCells, wsMerges + , PageSetup(..) + , Worksheet(..), wsColumns, wsRowPropertiesMap, wsCells, wsMerges, wsSheetViews, wsPageSetup , CellMap , CellValue(..) , Cell(..), cellValue, cellStyle , RowProperties (..) + , Range , int2col , col2int + , mkCellRef + , mkRange , toRows , fromRows + , module X ) where +import Control.Exception (SomeException, toException) import Control.Lens.TH import qualified Data.ByteString.Lazy as L import Data.Char @@ -28,7 +38,16 @@ import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T +import Text.XML (renderLBS, parseLBS) +import Text.XML.Cursor +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Common as X +import Codec.Xlsx.Types.PageSetup 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.Writer.Internal -- | Cell values include text, numbers and booleans, -- standard includes date format also but actually dates @@ -37,6 +56,7 @@ data CellValue = CellText Text | CellDouble Double | CellBool Bool + | CellRich [RichTextRun] deriving (Eq, Show) -- | Currently cell details include only cell values and style ids @@ -68,37 +88,100 @@ , cwStyle :: Int } deriving (Eq, Show) +instance FromCursor ColumnsWidth where + fromCursor c = do + cwMin <- decimal =<< attribute "min" c + cwMax <- decimal =<< attribute "max" c + cwWidth <- rational =<< attribute "width" c + cwStyle <- decimal =<< attribute "style" c + return ColumnsWidth{..} + +-- | Excel range (e.g. @D13:H14@) +type Range = Text + -- | Xlsx worksheet data Worksheet = Worksheet { _wsColumns :: [ColumnsWidth] -- ^ column widths , _wsRowPropertiesMap :: Map Int RowProperties -- ^ custom row properties (height, style) map , _wsCells :: CellMap -- ^ data mapped by (row, column) pairs - , _wsMerges :: [Text] -- ^ list of cell merges (entries of the form @D13:H14@) + , _wsMerges :: [Range] -- ^ list of cell merges + , _wsSheetViews :: Maybe [SheetView] + , _wsPageSetup :: Maybe PageSetup } deriving (Eq, Show) makeLenses ''Worksheet instance Default Worksheet where - def = Worksheet [] M.empty M.empty [] + def = Worksheet [] M.empty M.empty [] Nothing Nothing newtype Styles = Styles {unStyles :: L.ByteString} deriving (Eq, Show) -- | Structured representation of Xlsx file (currently a subset of its contents) data Xlsx = Xlsx - { _xlSheets :: Map Text Worksheet - , _xlStyles :: Styles + { _xlSheets :: Map Text Worksheet + , _xlStyles :: Styles + , _xlDefinedNames :: DefinedNames } deriving (Eq, Show) +-- | 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) + makeLenses ''Xlsx instance Default Xlsx where - def = Xlsx M.empty emptyStyles + def = Xlsx M.empty emptyStyles def +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" + -- | convert column number (starting from 1) to its textual form (e.g. 3 -> \"C\") int2col :: Int -> Text int2col = T.pack . reverse . map int2let . base26 @@ -131,3 +214,15 @@ fromRows rows = M.fromList $ concatMap mapRow rows where mapRow (r, cells) = map (\(c, v) -> ((r, c), v)) cells + +-- | Render position in @(row, col)@ format to an Excel reference. +-- +-- > mkCellRef (2, 4) == "D2" +mkCellRef :: (Int, Int) -> CellRef +mkCellRef (row, col) = T.concat [int2col col, T.pack (show row)] + +-- | Render range +-- +-- > mkRange (2, 4) (6, 8) == "D2:H6" +mkRange :: (Int, Int) -> (Int, Int) -> Range +mkRange fr to = T.concat [mkCellRef fr, T.pack ":", mkCellRef to] diff --git a/src/Codec/Xlsx/Types/Common.hs b/src/Codec/Xlsx/Types/Common.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Common.hs @@ -0,0 +1,9 @@ +module Codec.Xlsx.Types.Common + ( CellRef + ) where + +import Data.Text (Text) + +-- | Excel cell reference (e.g. @E3@) +-- see 18.18.62 @ST_Ref@ (p. 2482) +type CellRef = Text diff --git a/src/Codec/Xlsx/Types/PageSetup.hs b/src/Codec/Xlsx/Types/PageSetup.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/PageSetup.hs @@ -0,0 +1,550 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wall #-} +module Codec.Xlsx.Types.PageSetup ( + -- * Main types + PageSetup(..) +-- , renderPageSetup + -- * 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 + +import Control.Lens (makeLenses) +import Data.Default +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Text.XML +import qualified Data.Map as Map + +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 (Show, Eq, Ord) + +{------------------------------------------------------------------------------- + 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 (Show, Eq, Ord) + +-- | 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 (Show, Eq, Ord) + +-- | Print orientation for this sheet +data Orientation = + OrientationDefault + | OrientationLandscape + | OrientationPortrait + deriving (Show, Eq, Ord) + +-- | Specifies printed page order +data PageOrder = + -- | Order pages vertically first, then move horizontally + PageOrderDownThenOver + + -- | Order pages horizontally first, then move vertically + | PageOrderOverThenDown + deriving (Show, Eq, Ord) + +-- | 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 (Show, Eq, Ord) + +{------------------------------------------------------------------------------- + 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 +-------------------------------------------------------------------------------} + +---- | Render page setup +--renderPageSetup :: PageSetup -> RawPageSetup +--renderPageSetup = RawPageSetup . NodeElement . toElement "pageSetup" + +-- | 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{..} + +-- | 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 + +-- | See @ST_PageOrder@, p. 3923 +instance FromAttrVal PageOrder where + fromAttrVal "downThenOver" = readSuccess PageOrderDownThenOver + fromAttrVal "overThenDown" = readSuccess PageOrderOverThenDown + fromAttrVal t = invalidText "PageOrder" t + +-- | 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 + +-- | 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 + +-- | 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 diff --git a/src/Codec/Xlsx/Types/RichText.hs b/src/Codec/Xlsx/Types/RichText.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/RichText.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wall #-} +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 Control.Lens hiding (element) +import Control.Monad +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 + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Monoid +#endif + +-- | 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 (Show, Eq, Ord) + +-- | 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 (Show, Eq, Ord) + +{------------------------------------------------------------------------------- + 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 $ elementContent "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 + , elementValue "u" <$> _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{..} + +-- | 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 <- maybeElementValue (n"b") cur + _runPropertiesItalic <- maybeElementValue (n"i") cur + _runPropertiesStrikeThrough <- maybeElementValue (n"strike") cur + _runPropertiesOutline <- maybeElementValue (n"outline") cur + _runPropertiesShadow <- maybeElementValue (n"shadow") cur + _runPropertiesCondense <- maybeElementValue (n"condense") cur + _runPropertiesExtend <- maybeElementValue (n"extend") cur + _runPropertiesColor <- maybeFromElement (n"color") cur + _runPropertiesSize <- maybeElementValue (n"sz") cur + _runPropertiesUnderline <- maybeElementValue (n"u") cur + _runPropertiesVertAlign <- maybeElementValue (n"vertAlign") cur + _runPropertiesScheme <- maybeElementValue (n"scheme") cur + return RunProperties{..} + +{------------------------------------------------------------------------------- + Applying formatting +-------------------------------------------------------------------------------} + +-- | 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 diff --git a/src/Codec/Xlsx/Types/SharedStringTable.hs b/src/Codec/Xlsx/Types/SharedStringTable.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/SharedStringTable.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wall #-} +module Codec.Xlsx.Types.SharedStringTable ( + -- * Main types + SharedStringTable(..) + , StringItem(..) + , sstConstruct + , sstLookupText + , sstLookupRich + , sstItem + -- * Lenses + -- ** SharedStringTable + , sharedStringTable + ) where + +import Control.Lens hiding (element) +import Control.Monad + +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Vector (Vector) +import Numeric.Search.Range (searchFromTo) +import Text.XML +import Text.XML.Cursor +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Vector as V + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types +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. +data SharedStringTable = SharedStringTable { + _sharedStringTable :: Vector StringItem + } + deriving (Show, Eq, Ord) + +-- | String Item +-- +-- This element is the representation of an individual string in the Shared +-- String table. +-- +-- The 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) +data StringItem = + StringItemText Text + | StringItemRich [RichTextRun] + deriving (Show, Eq, Ord) + +{------------------------------------------------------------------------------- + Lenses +-------------------------------------------------------------------------------} + +makeLenses ''SharedStringTable + +{------------------------------------------------------------------------------- + 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 _sharedStringTable + } + +-- | See @CT_Rst@, p. 3903 +instance ToElement StringItem where + toElement nm si = Element { + elementName = nm + , elementAttributes = Map.empty + , elementNodes = map NodeElement $ + case si of + StringItemText text -> [elementContent "t" text] + StringItemRich rich -> map (toElement "r") rich + } + +{------------------------------------------------------------------------------- + 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)) + +-- | See @CT_Rst@, p. 3903 +instance FromCursor StringItem where + fromCursor cur = do + let + ts = cur $/ element (n"t") &/ content + rs = cur $/ element (n"r") >=> fromCursor + case (ts,rs) of + ([t], []) -> + return $ StringItemText t + ([], _:_) -> + return $ StringItemRich rs + _ -> + fail "invalid item" + +{------------------------------------------------------------------------------- + Extract shared strings +-------------------------------------------------------------------------------} + +-- | Construct the 'SharedStringsTable' from an existing document +sstConstruct :: [Worksheet] -> SharedStringTable +sstConstruct = + SharedStringTable . V.fromList . uniq . concatMap goSheet + where + goSheet :: Worksheet -> [StringItem] + goSheet = mapMaybe (_cellValue >=> sstEntry) . Map.elems . _wsCells + + sstEntry :: CellValue -> Maybe StringItem + sstEntry (CellText text) = Just $ StringItemText text + sstEntry (CellRich rich) = Just $ StringItemRich rich + sstEntry _ = Nothing + + uniq :: Ord a => [a] -> [a] + uniq = Set.elems . Set.fromList + +sstLookupText :: SharedStringTable -> Text -> Int +sstLookupText sst = sstLookup sst . StringItemText + +sstLookupRich :: SharedStringTable -> [RichTextRun] -> Int +sstLookupRich sst = sstLookup sst . StringItemRich + +-- | Internal generalization used by 'sstLookupText' and 'sstLookupRich' +sstLookup :: SharedStringTable -> StringItem -> Int +sstLookup SharedStringTable{_sharedStringTable = shared} si = + case searchFromTo (\p -> shared V.! p >= si) 0 (V.length shared - 1) of + Just i -> i + Nothing -> error $ "SST entry for " ++ show si ++ " not found" + +sstItem :: SharedStringTable -> Int -> StringItem +sstItem SharedStringTable{_sharedStringTable = shared} = (V.!) shared diff --git a/src/Codec/Xlsx/Types/SheetViews.hs b/src/Codec/Xlsx/Types/SheetViews.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/SheetViews.hs @@ -0,0 +1,532 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wall #-} +module Codec.Xlsx.Types.SheetViews ( + -- * Structured type to construct 'SheetViews' + SheetView(..) + , Selection(..) + , Pane(..) + , SheetViewType(..) + , PaneType(..) + , PaneState(..) + , renderSheetViews + -- * 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 Control.Lens (makeLenses) +import Data.Default +import Data.Maybe (catMaybes, maybeToList, listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Text.XML +import Text.XML.Cursor +import qualified Data.Map as Map +import qualified Data.Text as Text + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +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 (Show, Eq, Ord) + +-- | 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 [CellRef] + } + deriving (Show, Eq, Ord) + +-- | 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 (Show, Eq, Ord) + +{------------------------------------------------------------------------------- + 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 (Show, Eq, Ord) + +-- | 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, Show, Ord) + +-- | 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, Show, Ord) + +{------------------------------------------------------------------------------- + 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 +-------------------------------------------------------------------------------} + +-- | Render sheet views +-- +-- The list should be non-empty to be conform to the spec. +-- +-- See Section 18.3.1.88 "sheetViews (Sheet Views)" (p. 1704) +renderSheetViews :: [SheetView] -> Node +renderSheetViews views = NodeElement sheetViews + where + sheetViews :: Element + sheetViews = Element { + elementName = "sheetViews" + , elementAttributes = Map.empty + , elementNodes = map (NodeElement . toElement "sheetView") views + } + +-- | 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" .=? (spaceDelim <$> _selectionSqref) + ] + } + where + -- The @sqref@ is a space delimited list + -- See 18.18.76, "ST_Sqref (Reference Sequence)", p. 2488. + spaceDelim :: [Text] -> Text + spaceDelim = Text.intercalate " " + +-- | 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{..} + +-- | 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{..} + +-- | 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 <- fmap (T.split (== ' ')) <$> maybeAttribute "sqref" cur + 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 + +-- | 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 + +-- | 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 diff --git a/src/Codec/Xlsx/Types/StyleSheet.hs b/src/Codec/Xlsx/Types/StyleSheet.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/StyleSheet.hs @@ -0,0 +1,1370 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wall #-} +-- | Support for writing (but not reading) style sheets +module Codec.Xlsx.Types.StyleSheet ( + -- * The main two types + StyleSheet(..) + , CellXf(..) + , minimalStyleSheet + -- * Supporting record types + , Alignment(..) + , Border(..) + , BorderStyle(..) + , Color(..) + , Fill(..) + , FillPattern(..) + , Font(..) + , Protection(..) + -- * Supporting enumerations + , CellHorizontalAlignment(..) + , CellVerticalAlignment(..) + , FontFamily(..) + , FontScheme(..) + , FontUnderline(..) + , FontVerticalAlignment(..) + , LineStyle(..) + , PatternType(..) + , ReadingOrder(..) + -- * Lenses + -- ** StyleSheet + , styleSheetBorders + , styleSheetFonts + , styleSheetFills + , styleSheetCellXfs + -- ** CellXf + , cellXfApplyAlignment + , cellXfApplyBorder + , cellXfApplyFill + , cellXfApplyFont + , cellXfApplyNumberFormat + , cellXfApplyProtection + , cellXfBorderId + , cellXfFillId + , cellXfFontId + , cellXfNumFmtId + , cellXfPivotButton + , cellXfQuotePrefix + , cellXfId + , cellXfAlignment + , cellXfProtection + -- ** 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 + ) where + +import Control.Lens hiding ((.=), element) +import Data.Default +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Text.XML +import Text.XML.Cursor +import qualified Data.Map as Map + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Parser.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 +-- * dxfs +-- * extLst +-- * numFmts +-- * tableStyles +-- +-- NOTE: You will probably want to base your style sheet on 'minimalStyleSheet'. +-- 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 { + -- | This element contains borders formatting information, specifying all + -- border definitions for all cells in the workbook. + -- + -- Section 18.8.5, "borders (Borders)" (p. 1760) + _styleSheetBorders :: [Border] + + -- | 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) + , _styleSheetCellXfs :: [CellXf] + + -- | 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) + , _styleSheetFills :: [Fill] + + -- | This element contains all font definitions for this workbook. + -- + -- Section 18.8.23 "fonts (Fonts)" (p. 1769) + , _styleSheetFonts :: [Font] + } + deriving (Show, Eq, Ord) + +-- | 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. + -- + -- TODO: The numFmts part of the style sheet is currently not implemented. + , _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 (Show, Eq, Ord) + +{------------------------------------------------------------------------------- + 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 (Show, Eq, Ord) + +-- | 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 (Show, Eq, Ord) + +-- | Border style +-- See @CT_BorderPr@ (p. 3934) +data BorderStyle = BorderStyle { + _borderStyleColor :: Maybe Color + , _borderStyleLine :: Maybe LineStyle + } + deriving (Show, Eq, Ord) + +-- | 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 (Show, Eq, Ord) + +-- | 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 (Show, Eq, Ord) + +-- | 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 (Show, Eq, Ord) + +-- | 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 (Show, Eq, Ord) + +-- | 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 (Show, Eq, Ord) + +{------------------------------------------------------------------------------- + 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 (Show, Eq, Ord) + +-- | Vertical alignment in cells +-- +-- See 18.18.88 "ST_VerticalAlignment (Vertical Alignment Types)" (p. 2512) +data CellVerticalAlignment = + CellVerticalAlignmentBottom + | CellVerticalAlignmentCenter + | CellVerticalAlignmentDistributed + | CellVerticalAlignmentJustify + | CellVerticalAlignmentTop + deriving (Show, Eq, Ord) + +-- | 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 (Show, Eq, Ord) + +-- | 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 (Show, Eq, Ord) + +-- | Font underline property +-- +-- See 18.4.13 "u (Underline)", p 1728 +data FontUnderline = + FontUnderlineSingle + | FontUnderlineDouble + | FontUnderlineSingleAccounting + | FontUnderlineDoubleAccounting + | FontUnderlineNone + deriving (Show, Eq, Ord) + +-- | Vertical alignment +-- +-- See 22.9.2.17 "ST_VerticalAlignRun (Vertical Positioning Location)" (p. 3794) +data FontVerticalAlignment = + FontVerticalAlignmentBaseline + | FontVerticalAlignmentSubscript + | FontVerticalAlignmentSuperscript + deriving (Show, Eq, Ord) + +data LineStyle = + LineStyleDashDot + | LineStyleDashDotDot + | LineStyleDashed + | LineStyleDotted + | LineStyleDouble + | LineStyleHair + | LineStyleMedium + | LineStyleMediumDashDot + | LineStyleMediumDashDotDot + | LineStyleMediumDashed + | LineStyleNone + | LineStyleSlantDashDot + | LineStyleThick + | LineStyleThin + deriving (Show, Eq, Ord) + +-- | 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 (Show, Eq, Ord) + +-- | Reading order +-- +-- See 18.8.1 "alignment (Alignment)" (p. 1754, esp. p. 1755) +data ReadingOrder = + ReadingOrderContextDependent + | ReadingOrderLeftToRight + | ReadingOrderRightToLeft + deriving (Show, Eq, Ord) + +{------------------------------------------------------------------------------- + Lenses +-------------------------------------------------------------------------------} + +makeLenses ''StyleSheet +makeLenses ''CellXf + +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 = [] + } + +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 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{..} = Element { + elementName = nm + , elementAttributes = Map.empty + , elementNodes = map NodeElement $ [ + -- TODO: numFmts + elementList "fonts" $ map (toElement "font") _styleSheetFonts + , elementList "fills" $ map (toElement "fill") _styleSheetFills + , elementList "borders" $ map (toElement "border") _styleSheetBorders + -- TODO: cellStyleXfs + , elementList "cellXfs" $ map (toElement "xf") _styleSheetCellXfs + -- TODO: cellStyles + -- TODO: dxfs + -- TODO: tableStyles + -- TODO: colors + -- TODO: extLst + ] + } + +-- | 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 = Map.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_CellAlignment@, p. 4482 +instance ToElement Alignment where + toElement nm Alignment{..} = Element { + elementName = nm + , elementNodes = [] + , elementAttributes = Map.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 = Map.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 = Map.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 = Map.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 = Map.empty + , elementNodes = map NodeElement . catMaybes $ [ + toElement "patternFill" <$> _fillPattern + ] + } + +-- | See @CT_PatternFill@, p. 4484 +instance ToElement FillPattern where + toElement nm FillPattern{..} = Element { + elementName = nm + , elementAttributes = Map.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 = Map.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_CellProtection@, p. 4484 +instance ToElement Protection where + toElement nm Protection{..} = Element { + elementName = nm + , elementNodes = [] + , elementAttributes = Map.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 + -- TODO: numFmts + _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 + -- TODO: dxfs + -- 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 <- maybeElementValue (n"b") cur + _fontItalic <- maybeElementValue (n"i") cur + _fontStrikeThrough<- maybeElementValue (n"strike") cur + _fontOutline <- maybeElementValue (n"outline") cur + _fontShadow <- maybeElementValue (n"shadow") cur + _fontCondense <- maybeElementValue (n"condense") cur + _fontExtend <- maybeElementValue (n"extend") cur + _fontColor <- maybeFromElement (n"color") cur + _fontSize <- maybeElementValue (n"sz") cur + _fontUnderline <- maybeElementValue (n"u") cur + _fontVertAlign <- maybeElementValue (n"vertAlign") cur + _fontScheme <- maybeElementValue (n"scheme") cur + return Font{..} + +instance FromAttrVal FontFamily where + 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 + +-- | 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{..} + +-- 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 FromAttrVal FontVerticalAlignment where + fromAttrVal "baseline" = readSuccess FontVerticalAlignmentBaseline + fromAttrVal "subscript" = readSuccess FontVerticalAlignmentSubscript + fromAttrVal "superscript" = readSuccess FontVerticalAlignmentSuperscript + fromAttrVal t = invalidText "FontVerticalAlignment" t + +instance FromAttrVal FontScheme where + fromAttrVal "major" = readSuccess FontSchemeMajor + fromAttrVal "minor" = readSuccess FontSchemeMinor + fromAttrVal "none" = readSuccess FontSchemeNone + fromAttrVal t = invalidText "FontScheme" t + +-- | 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_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{..} diff --git a/src/Codec/Xlsx/Writer.hs b/src/Codec/Xlsx/Writer.hs --- a/src/Codec/Xlsx/Writer.hs +++ b/src/Codec/Xlsx/Writer.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} -- | This module provides a function for serializing structured `Xlsx` into lazy bytestring module Codec.Xlsx.Writer ( fromXlsx @@ -8,7 +9,7 @@ import Control.Arrow (second) import Control.Lens hiding (transform) import qualified Data.ByteString.Lazy as L -import Data.ByteString.Lazy.Char8() +import Data.ByteString.Lazy.Char8 () import Data.Map (Map) import qualified Data.Map as M import Data.Maybe @@ -19,36 +20,44 @@ import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Builder.Int import Data.Text.Lazy.Builder.RealFloat -import qualified Data.Set as S -import Data.Vector (Vector) -import qualified Data.Vector as V -import Numeric.Search.Range (searchFromTo) -import System.Locale -import System.Time +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) +import Data.Time.Format (formatTime) +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (defaultTimeLocale) +#else +import System.Locale (defaultTimeLocale) +#endif import Text.XML -import Codec.Xlsx.Types +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Codec.Xlsx.Types +import Codec.Xlsx.Types.SharedStringTable +import Codec.Xlsx.Writer.Internal -- | Writes `Xlsx' to raw data (lazy bytestring) -fromXlsx :: ClockTime -> Xlsx -> L.ByteString -fromXlsx ct xlsx = +fromXlsx :: POSIXTime -> Xlsx -> L.ByteString +fromXlsx pt xlsx = Zip.fromArchive $ foldr Zip.addEntryToArchive Zip.emptyArchive entries where - TOD t _ = ct + t = round pt + utcTime = posixSecondsToUTCTime pt entries = Zip.toEntry "[Content_Types].xml" t (contentTypesXml files) : map (\fd -> Zip.toEntry (T.unpack $ fdName fd) t (fdContents fd)) files files = sheetFiles ++ [ FileData "docProps/core.xml" - "application/vnd.openxmlformats-package.core-properties+xml" $ coreXml (toUTCTime ct) "xlsxwriter" + "application/vnd.openxmlformats-package.core-properties+xml" $ coreXml utcTime "xlsxwriter" , FileData "docProps/app.xml" "application/vnd.openxmlformats-officedocument.extended-properties+xml" $ appXml (xlsx ^. xlSheets) , FileData "xl/workbook.xml" - "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml" $ bookXml (xlsx ^. xlSheets) + "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml" $ bookXml (xlsx ^. xlSheets) (xlsx ^. xlDefinedNames) , FileData "xl/styles.xml" "application/vnd.openxmlformats-officedocument.spreadsheetml.styles+xml" $ unStyles (xlsx ^. xlStyles) , FileData "xl/sharedStrings.xml" - "application/vnd.openxmlformats-officedocument.spreadsheetml.sharedStrings+xml" $ ssXml $ V.toList shared + "application/vnd.openxmlformats-officedocument.spreadsheetml.sharedStrings+xml" $ ssXml shared , FileData "xl/_rels/workbook.xml.rels" "application/vnd.openxmlformats-package.relationships+xml" $ bookRelXml sheetCount , FileData "_rels/.rels" "application/vnd.openxmlformats-package.relationships+xml" rootRelXml @@ -56,21 +65,18 @@ sheetFiles = [ FileData ("xl/worksheets/sheet" <> txti n <> ".xml") "application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml" $ - sheetXml (w ^. wsColumns) (w ^. wsRowPropertiesMap) cells (w ^. wsMerges) | + sheetXml (w ^. wsColumns) (w ^. wsRowPropertiesMap) cells (w ^. wsMerges) (w ^. wsSheetViews) (w ^. wsPageSetup) | (n, cells, w) <- zip3 [1..] sheetCells sheets] sheets = xlsx ^. xlSheets . to M.elems sheetCount = length sheets - shared = V.fromList $ S.elems $ S.fromList $ concatMap (concatMap celltext . M.elems . _wsCells) sheets + shared = sstConstruct sheets sheetCells = map (transformSheetData shared) sheets - celltext (Cell{_cellValue=v}) = case v of - Just(CellText a) -> [a] - _ -> [] data FileData = FileData { fdName :: Text , fdContentType :: Text , fdContents :: L.ByteString} -coreXml :: CalendarTime -> Text -> L.ByteString +coreXml :: UTCTime -> Text -> L.ByteString coreXml created creator = renderLBS def{rsNamespaces=nss} $ Document (Prologue [] Nothing []) root [] where @@ -80,7 +86,7 @@ , ("xsi","http://www.w3.org/2001/XMLSchema-instance") ] namespaced = nsName nss - date = T.pack $ formatCalendarTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" created + 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] @@ -133,27 +139,28 @@ value XlsxCell{xlsxCellValue=Just(XlsxBool False)} = "0" value _ = error "value undefined" -transformSheetData :: Vector Text -> Worksheet -> [(Int, [(Int, XlsxCell)])] +transformSheetData :: SharedStringTable -> Worksheet -> [(Int, [(Int, XlsxCell)])] transformSheetData shared ws = map transformRow $ toRows (ws ^. wsCells) where transformRow = second (map transformCell) transformCell (c, Cell{_cellValue=v, _cellStyle=s}) = (c, XlsxCell s (fmap transformValue v)) - transformValue (CellText t) = - let Just i = searchFromTo (\p -> shared V.! p >= t) 0 (V.length shared - 1) - in XlsxSS i + transformValue (CellText t) = XlsxSS (sstLookupText shared t) transformValue (CellDouble dbl) = XlsxDouble dbl transformValue (CellBool b) = XlsxBool b + transformValue (CellRich r) = XlsxSS (sstLookupRich shared r) -sheetXml :: [ColumnsWidth] -> Map Int RowProperties -> [(Int, [(Int, XlsxCell)])] -> [Text]-> L.ByteString -sheetXml cws rh rows merges = renderLBS def $ Document (Prologue [] Nothing []) root [] +sheetXml :: [ColumnsWidth] -> Map Int RowProperties -> [(Int, [(Int, XlsxCell)])] -> [Text]-> Maybe [SheetView] -> Maybe PageSetup -> L.ByteString +sheetXml cws rh rows merges sheetViews pageSetup = renderLBS def $ Document (Prologue [] Nothing []) root [] where cType = xlsxCellType root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $ Element "worksheet" M.empty $ catMaybes - [nonEmptyNmEl "cols" M.empty $ map cwEl cws, + [renderSheetViews <$> sheetViews, + nonEmptyNmEl "cols" M.empty $ map cwEl cws, justNmEl "sheetData" M.empty $ map rowEl rows, - nonEmptyNmEl "mergeCells" M.empty $ map mergeE1 merges] + nonEmptyNmEl "mergeCells" M.empty $ map mergeE1 merges, + NodeElement . toElement "pageSetup" <$> pageSetup] cwEl cw = NodeElement $! Element "col" (M.fromList [("min", txti $ cwMin cw), ("max", txti $ cwMax cw), ("width", txtd $ cwWidth cw), ("style", txti $ cwStyle cw)]) [] rowEl (r, cells) = nEl "row" @@ -169,30 +176,41 @@ _ -> ([], False,[]) mergeE1 t = NodeElement $! Element "mergeCell" (M.fromList [("ref",t)]) [] cellEl r (icol, cell) = - nEl "c" (M.fromList (cellAttrs r (int2col icol) cell)) + nEl "c" (M.fromList (cellAttrs (mkCellRef (r, icol)) cell)) [nEl "v" M.empty [NodeContent $ value cell] | isJust $ xlsxCellValue cell] - cellAttrs r col cell = cellStyleAttr cell ++ [("r", T.concat [col, txti r]), ("t", cType cell)] + cellAttrs ref cell = cellStyleAttr cell ++ [("r", ref), ("t", cType cell)] cellStyleAttr XlsxCell{xlsxCellStyle=Nothing} = [] cellStyleAttr XlsxCell{xlsxCellStyle=Just s} = [("s", txti s)] -bookXml :: Map Text Worksheet -> L.ByteString -bookXml wss = renderLBS def $ Document (Prologue [] Nothing []) root [] +bookXml :: Map Text Worksheet -> DefinedNames -> L.ByteString +bookXml wss (DefinedNames names) = renderLBS def $ Document (Prologue [] Nothing []) root [] where numNames = [(txti i, name) | (i, name) <- zip [1..] (M.keys wss)] + + -- 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" $ Element "workbook" M.empty - [nEl "sheets" M.empty $ + [nEl "bookViews" M.empty [nEl "workbookView" M.empty []] + ,nEl "sheets" M.empty $ map (\(n, name) -> nEl "sheet" (M.fromList [("name", name), ("sheetId", n), ("state", "visible"), - (rId, T.concat ["rId", n])]) []) numNames] + (rId, T.concat ["rId", n])]) []) numNames + ,nEl "definedNames" M.empty $ map (\(name, lsId, val) -> + nEl "definedName" (definedName name lsId) [NodeContent val]) names + ] + rId = nm "http://schemas.openxmlformats.org/officeDocument/2006/relationships" "id" -ssXml :: [Text] -> L.ByteString -ssXml ss = - renderLBS def $ Document (Prologue [] Nothing []) root [] - where - root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $ Element "sst" M.empty $ - map (\s -> nEl "si" M.empty [nEl "t" M.empty [NodeContent s]]) ss + definedName :: Text -> Maybe Text -> Map Name Text + definedName name Nothing = M.fromList [("name", name)] + definedName name (Just lsId) = M.fromList [("name", name), ("localSheetId", lsId)] +ssXml :: SharedStringTable -> L.ByteString +ssXml = renderLBS def . toDocument + bookRelXml :: Int -> L.ByteString bookRelXml n = renderLBS def $ Document (Prologue [] Nothing []) root [] where @@ -207,8 +225,7 @@ ("Type", T.concat ["http://schemas.openxmlformats.org/officeDocument/2006/relationships/", typ])]) [] rootRelXml :: L.ByteString -rootRelXml = "\ -\" +rootRelXml = "" contentTypesXml :: [FileData] -> L.ByteString contentTypesXml fds = renderLBS def $ Document (Prologue [] Nothing []) root [] @@ -238,12 +255,6 @@ { nameLocalName = n , nameNamespace = Just ns , namePrefix = Nothing} - -addNS :: Text -> Element -> Element -addNS namespace (Element (Name ln _ _) as ns) = Element (Name ln (Just namespace) Nothing) as (map addNS' ns) - where - addNS' (NodeElement e) = NodeElement $ addNS namespace e - addNS' n = n -- | Creates an element with the given name, attributes and children, -- if there is at least one child. Otherwise returns `Nothing`. diff --git a/src/Codec/Xlsx/Writer/Internal.hs b/src/Codec/Xlsx/Writer/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Writer/Internal.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} +module Codec.Xlsx.Writer.Internal ( + -- * Rendering documents + ToDocument(..) + , documentFromElement + -- * Rendering elements + , ToElement(..) + , elementList + , elementContent + , elementValue + -- * Rendering attributes + , ToAttrVal(..) + , (.=) + , (.=?) + -- * Dealing with namespaces + , addNS + , mainNamespace + ) where + +import Data.Text (Text) +import Data.String (fromString) +import Text.XML +import qualified Data.Map as Map + +{------------------------------------------------------------------------------- + Rendering documents +-------------------------------------------------------------------------------} + +class ToDocument a where + toDocument :: a -> Document + +documentFromElement :: Text -> Element -> Document +documentFromElement comment e = Document { + documentRoot = addNS mainNamespace e + , documentEpilogue = [] + , documentPrologue = Prologue { + prologueBefore = [MiscComment comment] + , prologueDoctype = Nothing + , prologueAfter = [] + } + } + +{------------------------------------------------------------------------------- + Rendering elements +-------------------------------------------------------------------------------} + +class ToElement a where + toElement :: Name -> a -> Element + +elementList :: Name -> [Element] -> Element +elementList nm as = Element { + elementName = nm + , elementNodes = map NodeElement as + , elementAttributes = Map.fromList [ "count" .= length as ] + } + +elementContent :: Name -> Text -> Element +elementContent nm txt = Element { + elementName = nm + , elementAttributes = Map.fromList [ preserveSpace ] + , elementNodes = [NodeContent 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 = fromString . show +instance ToAttrVal Double where toAttrVal = fromString . show + +instance ToAttrVal Bool where + toAttrVal True = "true" + toAttrVal False = "false" + +elementValue :: ToAttrVal a => Name -> a -> Element +elementValue nm a = Element { + elementName = nm + , elementAttributes = Map.fromList [ "val" .= a ] + , elementNodes = [] + } + +(.=) :: 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) + +{------------------------------------------------------------------------------- + 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 -> Element -> Element +addNS ns 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 = Nothing + } + + goNode :: Node -> Node + goNode (NodeElement e) = NodeElement $ addNS ns e + goNode n = n + +-- | The main namespace for Excel +mainNamespace :: Text +mainNamespace = "http://schemas.openxmlformats.org/spreadsheetml/2006/main" diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -2,12 +2,13 @@ import Codec.Xlsx -import Control.Applicative ((<$>)) +import Control.Applicative import Control.Lens import qualified Data.ByteString.Lazy as L import qualified Data.Map as M import Data.Text (Text,pack) -import System.Time +import Data.Time.Clock.POSIX (getPOSIXTime) +import Prelude xEmpty :: Cell @@ -86,8 +87,8 @@ main :: IO () main = do - ct <- getClockTime - L.writeFile "test.xlsx" $ fromXlsx ct $ Xlsx sheets styles + pt <- getPOSIXTime + L.writeFile "test.xlsx" $ fromXlsx pt $ Xlsx sheets styles def x <- toXlsx <$> L.readFile "test.xlsx" putStrLn $ "And cell (3,2) value in list 'List' is " ++ show (x ^? xlSheets . ix "List" . wsCells . ix (3,2) . cellValue . _Just) @@ -101,4 +102,4 @@ , xText $ pack $ "column4-r" ++ show r , xDouble 42.12345 , xText "False"] - sheets = M.fromList [("List", Worksheet cols rowProps cells [])] -- wtf merges? + sheets = M.fromList [("List", Worksheet cols rowProps cells [] Nothing Nothing)] -- wtf merges? diff --git a/test/DataTest.hs b/test/DataTest.hs --- a/test/DataTest.hs +++ b/test/DataTest.hs @@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import qualified Data.IntMap as IM +import Control.Lens +import Data.ByteString.Lazy (ByteString) import Data.Map (Map) import qualified Data.Map as M -import Data.Time.Calendar -import Data.Time.LocalTime -import System.Time +import Data.Time.Clock.POSIX (POSIXTime) +import qualified Data.Vector as V import Text.XML import Text.XML.Cursor @@ -18,6 +18,7 @@ import Test.SmallCheck.Series (Positive(..)) import Codec.Xlsx +import Codec.Xlsx.Types.SharedStringTable import Codec.Xlsx.Parser.Internal @@ -29,17 +30,36 @@ testXlsx @=? toXlsx (fromXlsx testTime testXlsx) , testCase "fromRows . toRows == id" $ testCellMap @=? fromRows (toRows testCellMap) + , testCase "fromRight . parseStyleSheet . renderStyleSheet == id" $ + testStyleSheet @=? fromRight (parseStyleSheet (renderStyleSheet testStyleSheet)) , testCase "correct shared strings parsing" $ - testSharedStrings @=? testParseSharedStrings + [testSharedStringTable] @=? testParsedSharedStringTables ] testXlsx :: Xlsx -testXlsx = Xlsx sheets emptyStyles +testXlsx = Xlsx sheets minimalStyles definedNames where sheets = M.fromList [( "List1", sheet )] - sheet = Worksheet cols rowProps testCellMap [] + sheet = Worksheet cols rowProps testCellMap ranges sheetViews pageSetup rowProps = M.fromList [(1, RowProps (Just 50) (Just 3))] cols = [ColumnsWidth 1 10 15 1] + ranges = [mkRange (1,1) (1,2), mkRange (2,2) (10, 5)] + minimalStyles = renderStyleSheet minimalStyleSheet + definedNames = DefinedNames [("SampleName", Nothing, "A10:A20")] + sheetViews = Just [sheetView1, sheetView2] + sheetView1 = def & sheetViewRightToLeft .~ Just True + & sheetViewTopLeftCell .~ Just "B5" + sheetView2 = def & sheetViewType .~ Just SheetViewTypePageBreakPreview + & sheetViewWorkbookViewId .~ 5 + & sheetViewSelection .~ [ def & selectionActiveCell .~ Just "C2" + & selectionPane .~ Just PaneTypeBottomRight + , def & selectionActiveCellId .~ Just 1 + & selectionSqref .~ Just ["A3:A10","B1:G3"] + ] + pageSetup = Just $ def & pageSetupBlackAndWhite .~ Just True + & pageSetupCopies .~ Just 2 + & pageSetupErrors .~ Just PrintErrorsDash + & pageSetupPaperSize .~ Just PaperA4 testCellMap :: CellMap testCellMap = M.fromList [ ((1, 2), cd1), ((1, 5), cd2) @@ -53,16 +73,35 @@ cd4 = Cell{_cellValue=Nothing, _cellStyle=Nothing} -- shouldn't it be skipped? cd5 = cd $(CellBool True) -testTime :: ClockTime -testTime = TOD 123 567 +testTime :: POSIXTime +testTime = 123 -testSharedStrings = IM.fromAscList $ zip [0..] ["plain text", "Just example"] +fromRight :: Either a b -> b +fromRight (Right b) = b -testParseSharedStrings = parseSharedStrings $ fromDocument $ parseLBS_ def strings - where - strings = "\ - \\ - \plain text\ - \Just \ - \example\ - \" +testStyleSheet :: StyleSheet +testStyleSheet = minimalStyleSheet + +testSharedStringTable :: SharedStringTable +testSharedStringTable = SharedStringTable $ V.fromList items + where + items = [text, rich] + text = StringItemText "plain text" + rich = StringItemRich [ RichTextRun Nothing "Just " + , RichTextRun (Just props) "example" ] + props = def & runPropertiesBold .~ Just True + & runPropertiesUnderline .~ Just FontUnderlineSingle + & runPropertiesSize .~ Just 10 + & runPropertiesFont .~ Just "Arial" + & runPropertiesFontFamily .~ Just FontFamilySwiss + +testParsedSharedStringTables ::[SharedStringTable] +testParsedSharedStringTables = fromCursor . fromDocument $ parseLBS_ def testStrings + +testStrings :: ByteString +testStrings = "\ + \\ + \plain text\ + \Just \ + \example\ + \" diff --git a/xlsx.cabal b/xlsx.cabal --- a/xlsx.cabal +++ b/xlsx.cabal @@ -1,6 +1,6 @@ Name: xlsx -Version: 0.1.2 +Version: 0.2.0 Synopsis: Simple and incomplete Excel file parser/writer Description: @@ -11,8 +11,10 @@ . Format is covered by ECMA-376 standard: + . + 4th edition of the standard with the transitional schema is used for this library. Extra-source-files: - changelog + CHANGELOG.markdown Homepage: https://github.com/qrilka/xlsx @@ -24,18 +26,26 @@ Category: Codec Build-type: Simple - +Tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2 Cabal-version: >=1.10 Library Hs-source-dirs: src Exposed-modules: Codec.Xlsx - , Codec.Xlsx.Parser , Codec.Xlsx.Types - , Codec.Xlsx.Writer + , Codec.Xlsx.Types.Common + , Codec.Xlsx.Types.SharedStringTable + , Codec.Xlsx.Types.RichText + , Codec.Xlsx.Types.SheetViews + , Codec.Xlsx.Types.PageSetup + , Codec.Xlsx.Types.StyleSheet , Codec.Xlsx.Lens + , Codec.Xlsx.Parser , Codec.Xlsx.Parser.Internal + , Codec.Xlsx.Formatted + , Codec.Xlsx.Writer + , Codec.Xlsx.Writer.Internal Build-depends: base == 4.* , containers >= 0.5.0.0 @@ -51,14 +61,24 @@ , zlib >= 0.5.4.0 , utf8-string >= 0.3.7 , time >= 1.4.0.1 - , old-time >= 1.1.0.1 , old-locale >= 1.0.0.5 , data-default == 0.5.* , vector >= 0.10 + , mtl >= 2.1 , binary-search Default-Language: Haskell2010 + Other-Extensions: CPP + DeriveDataTypeable + FlexibleInstances + NoMonomorphismRestriction + OverloadedStrings + RankNTypes + RecordWildCards + TemplateHaskell + TupleSections + Executable test Hs-source-dirs: src Other-modules: Codec.Xlsx @@ -78,7 +98,6 @@ , zlib , utf8-string , time - , old-time , old-locale , data-default == 0.5.* , vector >= 0.10 @@ -92,14 +111,16 @@ Build-Depends: base, containers, time, - old-time, xlsx, xml-conduit >= 1.1.0, smallcheck, HUnit, tasty, tasty-smallcheck, - tasty-hunit + tasty-hunit, + lens, + bytestring, + vector Default-Language: Haskell2010 source-repository head