diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,12 @@ +0.4.0 +----- +* implemented basic charts support with only line charts currently +* added data validation support (thanks Emil Axelsson ) +* fixed reading comments with empty author names (thanks Aleksey + Khudyakov for reporting) +* implemented basic pivot table support +* started using `hindent` to format library code + 0.3.0 ----- * implemented number formats diff --git a/src/Codec/Xlsx/Formatted.hs b/src/Codec/Xlsx/Formatted.hs --- a/src/Codec/Xlsx/Formatted.hs +++ b/src/Codec/Xlsx/Formatted.hs @@ -45,7 +45,7 @@ import Data.Traversable (mapM) import Data.Tuple (swap) import Prelude hiding (mapM) -import Safe (headNote) +import Safe (headNote, fromJustNote) #if !MIN_VERSION_base(4,8,0) import Control.Applicative @@ -278,7 +278,7 @@ if apply then prop cXf else fail "not applied" applyMerges cells = foldl' onlyTopLeft cells merges onlyTopLeft cells range = flip execState cells $ do - let ((r1, c1), (r2, c2)) = fromRange range + let ((r1, c1), (r2, c2)) = fromJustNote "fromRange" $ fromRange range nonTopLeft = tail [(r, c) | r<-[r1..r2], c<-[c1..c2]] forM_ nonTopLeft (modify . M.delete) at (r1, c1) . non def . formattedRowSpan .= (r2 - r1 +1) 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 @@ -38,14 +38,17 @@ import Text.XML.Cursor import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Parser.Internal.PivotTable import Codec.Xlsx.Types import Codec.Xlsx.Types.Internal import Codec.Xlsx.Types.Internal.CfPair import Codec.Xlsx.Types.Internal.CommentTable import Codec.Xlsx.Types.Internal.ContentTypes as ContentTypes import Codec.Xlsx.Types.Internal.CustomProperties as CustomProperties +import Codec.Xlsx.Types.Internal.DvPair import Codec.Xlsx.Types.Internal.Relationships as Relationships import Codec.Xlsx.Types.Internal.SharedStringTable +import Codec.Xlsx.Types.PivotTable.Internal -- | Reads `Xlsx' from raw data (lazy bytestring) toXlsx :: L.ByteString -> Xlsx @@ -55,6 +58,7 @@ | MissingFile FilePath | InvalidFile FilePath | InvalidRef FilePath RefId + | InconsistentXlsx Text deriving (Show, Eq) type Parser = Either ParseError @@ -65,9 +69,9 @@ ar <- left (const InvalidZipArchive) $ Zip.toArchiveOrFail bs sst <- getSharedStrings ar contentTypes <- getContentTypes ar - (wfs, names) <- readWorkbook ar + (wfs, names, cacheSources) <- readWorkbook ar sheets <- forM wfs $ \wf -> do - sheet <- extractSheet ar sst contentTypes wf + sheet <- extractSheet ar sst contentTypes cacheSources wf return (wfName wf, sheet) CustomProperties customPropMap <- getCustomProperties ar return $ Xlsx sheets (getStyles ar) names customPropMap @@ -77,12 +81,15 @@ } deriving Show +type Caches = [(CacheId, (Text, CellRef, [PivotFieldName]))] + extractSheet :: Zip.Archive -> SharedStringTable -> ContentTypes + -> Caches -> WorksheetFile -> Parser Worksheet -extractSheet ar sst contentTypes wf = do +extractSheet ar sst contentTypes caches wf = do let filePath = wfPath wf file <- note (MissingFile filePath) $ Zip.fromEntry <$> Zip.findEntryByPath filePath ar cur <- fmap fromDocument . left (\_ -> InvalidFile filePath) $ @@ -91,7 +98,7 @@ -- The specification says the file should contain either 0 or 1 @sheetViews@ -- (4th edition, section 18.3.1.88, p. 1704 and definition CT_Worksheet, p. 3910) - let sheetViewList = cur $/ element (n"sheetViews") &/ element (n"sheetView") >=> fromCursor + let sheetViewList = cur $/ element (n_ "sheetViews") &/ element (n_ "sheetView") >=> fromCursor sheetViews = case sheetViewList of [] -> Nothing views -> Just views @@ -99,17 +106,17 @@ let commentsType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments" commentTarget :: Maybe FilePath commentTarget = relTarget <$> findRelByType commentsType sheetRels - legacyDrRId = cur $/ element (n"legacyDrawing") >=> fromAttribute (odr"id") + legacyDrRId = cur $/ element (n_ "legacyDrawing") >=> fromAttribute (odr"id") legacyDrPath = fmap relTarget . flip Relationships.lookup sheetRels =<< listToMaybe legacyDrRId commentsMap :: Maybe CommentTable <- maybe (Right Nothing) (getComments ar legacyDrPath) commentTarget -- Likewise, @pageSetup@ also occurs either 0 or 1 times - let pageSetup = listToMaybe $ cur $/ element (n"pageSetup") >=> fromCursor + let pageSetup = listToMaybe $ cur $/ element (n_ "pageSetup") >=> fromCursor - cws = cur $/ element (n"cols") &/ element (n"col") >=> fromCursor + cws = cur $/ element (n_ "cols") &/ element (n_ "col") >=> fromCursor - (rowProps, cells) = collect $ cur $/ element (n"sheetData") &/ element (n"row") >=> parseRow + (rowProps, cells) = collect $ cur $/ element (n_ "sheetData") &/ element (n_ "row") >=> parseRow parseRow :: Cursor -> [(Int, Maybe RowProperties, [(Int, Int, Cell)])] parseRow c = do r <- c $| attribute "r" >=> decimal @@ -120,16 +127,16 @@ let rp = if isNothing s && isNothing ht then Nothing else Just (RowProps ht s) - return (r, rp, c $/ element (n"c") >=> parseCell) + return (r, rp, c $/ element (n_ "c") >=> parseCell) parseCell :: Cursor -> [(Int, Int, Cell)] parseCell cell = do - ref <- cell $| attribute "r" + ref <- fromAttribute "r" cell let s = listToMaybe $ cell $| attribute "s" >=> decimal t = fromMaybe "n" $ listToMaybe $ cell $| attribute "t" - d = listToMaybe $ cell $/ element (n"v") &/ content >=> extractCellValue sst t - f = listToMaybe $ cell $/ element (n"f") >=> fromCursor - (c, r) = T.span (>'9') ref + d = listToMaybe $ cell $/ element (n_ "v") &/ content >=> extractCellValue sst t + f = listToMaybe $ cell $/ element (n_ "f") >=> fromCursor + (c, r) = T.span (>'9') $ unCellRef ref comment = commentsMap >>= lookupComment ref return (int r, col2int c, Cell s d comment f) collect = foldr collectRow (M.empty, M.empty) @@ -139,15 +146,17 @@ (M.insert r h rowMap, foldr collectCell cellMap rowCells) collectCell (x, y, cd) = M.insert (x,y) cd - mDrawingId = listToMaybe $ cur $/ element (n"drawing") >=> fromAttribute (odr"id") + mDrawingId = listToMaybe $ cur $/ element (n_ "drawing") >=> fromAttribute (odr"id") merges = cur $/ parseMerges - parseMerges :: Cursor -> [Text] - parseMerges = element (n"mergeCells") &/ element (n"mergeCell") >=> parseMerge - parseMerge c = c $| attribute "ref" + parseMerges :: Cursor -> [Range] + parseMerges = element (n_ "mergeCells") &/ element (n_ "mergeCell") >=> fromAttribute "ref" - condFormtattings = M.fromList . map unCfPair $ cur $/ element (n"conditionalFormatting") >=> fromCursor + condFormtattings = M.fromList . map unCfPair $ cur $/ element (n_ "conditionalFormatting") >=> fromCursor + validations = M.fromList . map unDvPair $ + cur $/ element (n_ "dataValidations") &/ element (n_ "dataValidation") >=> fromCursor + mDrawing <- case mDrawingId of Just dId -> do rel <- note (InvalidRef filePath dId) $ Relationships.lookup dId sheetRels @@ -155,8 +164,15 @@ Nothing -> return Nothing - return $ Worksheet cws rowProps cells mDrawing merges sheetViews pageSetup condFormtattings + let ptType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/pivotTable" + pTables <- forM (allByType ptType sheetRels) $ \rel -> do + let ptPath = relTarget rel + bs <- note (MissingFile ptPath) $ Zip.fromEntry <$> Zip.findEntryByPath ptPath ar + note (InconsistentXlsx $ "Bad pivot table in " <> T.pack ptPath) $ + parsePivotTable (flip Prelude.lookup caches) bs + return $ Worksheet cws rowProps cells mDrawing merges sheetViews pageSetup condFormtattings validations pTables + extractCellValue :: SharedStringTable -> Text -> Text -> [CellValue] extractCellValue sst "s" v = case T.decimal v of @@ -223,7 +239,7 @@ shapeCellRef c = do r0 <- c $/ element (x"Row") &/ content >=> decimal c0 <- c $/ element (x"Column") &/ content >=> decimal - return $ mkCellRef (r0 + 1, c0 + 1) + return $ singleCellRef (r0 + 1, c0 + 1) getCustomProperties :: Zip.Archive -> Parser CustomProperties getCustomProperties ar = maybe CustomProperties.empty (head . fromCursor) <$> xmlCursorOptional ar "docProps/custom.xml" @@ -236,15 +252,28 @@ anchors <- forM (unresolved ^. xdrAnchors) $ resolveFileInfo drawingRels return $ Drawing anchors where - resolveFileInfo :: Relationships -> Anchor RefId -> Parser (Anchor FileInfo) - resolveFileInfo rels uAnch = case uAnch ^. anchObject of - pic@Picture{} -> do - let mRefId = pic ^. picBlipFill . bfpImageInfo - mFI <- lookupFI rels mRefId - return uAnch{ _anchObject = pic & picBlipFill . bfpImageInfo .~ mFI } + resolveFileInfo :: Relationships -> Anchor RefId RefId -> Parser (Anchor FileInfo ChartSpace) + resolveFileInfo rels uAnch = + case uAnch ^. anchObject of + Picture {..} -> do + let mRefId = _picBlipFill ^. bfpImageInfo + mFI <- lookupFI rels mRefId + let pic' = + Picture + { _picMacro = _picMacro + , _picPublished = _picPublished + , _picNonVisual = _picNonVisual + , _picBlipFill = (_picBlipFill & bfpImageInfo .~ mFI) + , _picShapeProperties = _picShapeProperties + } + return uAnch {_anchObject = pic'} + Graphic nv rId tr -> do + chartPath <- lookupRelPath fp rels rId + chart <- readChart ar chartPath + return uAnch {_anchObject = Graphic nv chart tr} lookupFI _ Nothing = return Nothing lookupFI rels (Just rId) = do - path <- relTarget <$> note (InvalidRef fp rId) (Relationships.lookup rId rels) + path <- lookupRelPath fp rels rId -- content types use paths starting with / contentType <- note (InvalidFile path) $ ContentTypes.lookup ("/" <> path) contentTypes contents <- Zip.fromEntry <$> note (MissingFile path) (Zip.findEntryByPath path ar) @@ -252,31 +281,48 @@ stripMediaPrefix :: FilePath -> FilePath stripMediaPrefix p = fromMaybe p $ stripPrefix "xl/media/" p +readChart :: Zip.Archive -> FilePath -> Parser ChartSpace +readChart ar path = head . fromCursor <$> xmlCursorRequired ar path + -- | readWorkbook pulls the names of the sheets and the defined names -readWorkbook :: Zip.Archive -> Parser ([WorksheetFile], DefinedNames) +readWorkbook :: Zip.Archive -> Parser ([WorksheetFile], DefinedNames, Caches) readWorkbook ar = do let wbPath = "xl/workbook.xml" cur <- xmlCursorRequired ar wbPath wbRels <- getRels ar wbPath - let -- 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 - ) - - names = cur $/ element (n"definedNames") &/ element (n"definedName") >=> mkDefinedName - sheets <- sequence $ - cur $/ element (n"sheets") &/ element (n"sheet") >=> - liftA2 (worksheetFile wbPath wbRels) <$> attribute "name" <*> (attribute (odr"id") &| RefId) - return (sheets, DefinedNames names) + -- Specification says the 'name' is required. + let mkDefinedName :: Cursor -> [(Text, Maybe Text, Text)] + mkDefinedName c = + return + ( head $ attribute "name" c + , listToMaybe $ attribute "localSheetId" c + , T.concat $ c $/ content) + names = + cur $/ element (n_ "definedNames") &/ element (n_ "definedName") >=> + mkDefinedName + sheets <- + sequence $ + cur $/ element (n_ "sheets") &/ element (n_ "sheet") >=> + liftA2 (worksheetFile wbPath wbRels) <$> attribute "name" <*> + fromAttribute (odr "id") + let cacheRefs = + cur $/ element (n_ "pivotCaches") &/ element (n_ "pivotCache") >=> + liftA2 (,) <$> fromAttribute "cacheId" <*> fromAttribute (odr "id") + caches <- + forM cacheRefs $ \(cacheId, rId) -> do + path <- lookupRelPath wbPath wbRels rId + bs <- + note (MissingFile path) $ Zip.fromEntry <$> Zip.findEntryByPath path ar + sources <- + note (InconsistentXlsx $ "Bad pivot table cache in " <> T.pack path) $ + parseCache bs + return (cacheId, sources) + return (sheets, DefinedNames names, caches) worksheetFile :: FilePath -> Relationships -> Text -> RefId -> Parser WorksheetFile -worksheetFile parentPath wbRels name rId = WorksheetFile name <$> path - where - path :: Parser FilePath - path = relTarget <$> note (InvalidRef parentPath rId) (Relationships.lookup rId wbRels) +worksheetFile parentPath wbRels name rId = + WorksheetFile name <$> lookupRelPath parentPath wbRels rId getRels :: Zip.Archive -> FilePath -> Parser Relationships getRels ar fp = do @@ -284,6 +330,13 @@ relsPath = dir "_rels" file <.> "rels" c <- xmlCursorOptional ar relsPath return $ maybe Relationships.empty (setTargetsFrom fp . head . fromCursor) c + +lookupRelPath :: FilePath + -> Relationships + -> RefId + -> Either ParseError FilePath +lookupRelPath fp rels rId = + relTarget <$> note (InvalidRef fp rId) (Relationships.lookup rId rels) int :: Text -> Int int = either error fst . T.decimal 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 @@ -3,16 +3,19 @@ {-# LANGUAGE OverloadedStrings #-} module Codec.Xlsx.Parser.Internal ( ParseException(..) - , n + , n_ + , nodeElNameIs , FromCursor(..) , FromAttrVal(..) , fromAttribute , fromAttributeDef , maybeAttribute + , fromElementValue , maybeElementValue , maybeElementValueDef - , maybeBoolElemValue + , maybeBoolElementValue , maybeFromElement + , contentOrEmpty , readSuccess , readFailure , invalidText @@ -40,6 +43,10 @@ instance Exception ParseException +nodeElNameIs :: Node -> Name -> Bool +nodeElNameIs (NodeElement el) name = elementName el == name +nodeElNameIs _ _ = False + class FromCursor a where fromCursor :: Cursor -> [a] @@ -50,10 +57,10 @@ fromAttrVal = readSuccess instance FromAttrVal Int where - fromAttrVal = T.decimal + fromAttrVal = T.signed T.decimal instance FromAttrVal Integer where - fromAttrVal = T.decimal + fromAttrVal = T.signed T.decimal instance FromAttrVal Double where fromAttrVal = T.rational @@ -82,6 +89,10 @@ [attr] -> Just <$> runReader fromAttrVal attr _ -> [Nothing] +fromElementValue :: FromAttrVal a => Name -> Cursor -> [a] +fromElementValue name cursor = + cursor $/ element name >=> fromAttribute "val" + maybeElementValue :: FromAttrVal a => Name -> Cursor -> [Maybe a] maybeElementValue name cursor = case cursor $/ element name of @@ -94,14 +105,20 @@ [cursor'] -> Just . fromMaybe defVal <$> maybeAttribute "val" cursor' _ -> [Nothing] -maybeBoolElemValue :: Name -> Cursor -> [Maybe Bool] -maybeBoolElemValue name cursor = maybeElementValueDef name True cursor +maybeBoolElementValue :: Name -> Cursor -> [Maybe Bool] +maybeBoolElementValue name cursor = maybeElementValueDef name True cursor maybeFromElement :: FromCursor a => Name -> Cursor -> [Maybe a] maybeFromElement name cursor = case cursor $/ element name of [cursor'] -> Just <$> fromCursor cursor' _ -> [Nothing] +contentOrEmpty :: Cursor -> [Text] +contentOrEmpty c = + case c $/ content of + [t] -> [t] + [] -> [""] + _ -> error "invalid item: more than one text node encountered" readSuccess :: a -> Either String (a, Text) readSuccess x = Right (x, T.empty) @@ -121,15 +138,15 @@ _ -> [] -- | Add sml namespace to name -n :: Text -> Name -n x = Name +n_ :: Text -> Name +n_ x = Name { nameLocalName = x , nameNamespace = Just "http://schemas.openxmlformats.org/spreadsheetml/2006/main" - , namePrefix = Nothing + , namePrefix = Just "n" } decimal :: (Monad m, Integral a) => Text -> m a -decimal t = case T.decimal t of +decimal t = case T.signed T.decimal $ t of Right (d, leftover) | T.null leftover -> return d _ -> fail $ "invalid decimal" ++ show t diff --git a/src/Codec/Xlsx/Parser/Internal/PivotTable.hs b/src/Codec/Xlsx/Parser/Internal/PivotTable.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Internal/PivotTable.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Codec.Xlsx.Parser.Internal.PivotTable ( + parsePivotTable + , parseCache +) where + +import Control.Applicative +import Data.ByteString.Lazy (ByteString) +import Data.Maybe (listToMaybe, maybeToList) +import Data.Text (Text) +import Text.XML +import Text.XML.Cursor + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.PivotTable +import Codec.Xlsx.Types.PivotTable.Internal + +parsePivotTable + :: (CacheId -> Maybe (Text, Range, [PivotFieldName])) + -> ByteString + -> Maybe PivotTable +parsePivotTable srcByCacheId bs = + listToMaybe . parse . fromDocument $ parseLBS_ def bs + where + parse cur = do + cacheId <- fromAttribute "cacheId" cur + case srcByCacheId cacheId of + Nothing -> fail "no such cache" + Just (_pvtSrcSheet, _pvtSrcRef, fieldNames) -> do + _pvtDataCaption <- attribute "dataCaption" cur + _pvtName <- attribute "name" cur + _pvtLocation <- cur $/ element (n_ "location") >=> fromAttribute "ref" + _pvtRowGrandTotals <- fromAttributeDef "rowGrandTotals" True cur + _pvtColumnGrandTotals <- fromAttributeDef "colGrandTotals" True cur + _pvtOutline <- fromAttributeDef "outline" False cur + _pvtOutlineData <- fromAttributeDef "outlineData" False cur + let nToField = zip [0 ..] fieldNames + outlines = + cur $/ element (n_ "pivotFields") &/ element (n_ "pivotField") >=> + fromAttributeDef "outline" True + _pvtFields = + [ PivotFieldInfo {_pfiName = name, _pfiOutline = outline} + | (name, outline) <- zip fieldNames outlines + ] + _pvtRowFields = + cur $/ element (n_ "rowFields") &/ element (n_ "field") >=> + fromAttribute "x" >=> fieldPosition + _pvtColumnFields = + cur $/ element (n_ "colFields") &/ element (n_ "field") >=> + fromAttribute "x" >=> fieldPosition + _pvtDataFields = + cur $/ element (n_ "dataFields") &/ element (n_ "dataField") >=> \c -> do + fld <- fromAttribute "fld" c + _dfField <- maybeToList $ lookup fld nToField + -- TOFIX + _dfName <- fromAttributeDef "name" "" c + _dfFunction <- fromAttributeDef "subtotal" ConsolidateSum c + return DataField {..} + fieldPosition :: Int -> [PositionedField] + fieldPosition (-2) = return DataPosition + fieldPosition n = + FieldPosition <$> maybeToList (lookup n nToField) + return PivotTable {..} + +parseCache :: ByteString -> Maybe (Text, CellRef, [PivotFieldName]) +parseCache bs = listToMaybe . parse . fromDocument $ parseLBS_ def bs + where + parse cur = do + (sheet, ref) <- + cur $/ element (n_ "cacheSource") &/ element (n_ "worksheetSource") >=> + liftA2 (,) <$> attribute "sheet" <*> fromAttribute "ref" + let fieldNames = + cur $/ element (n_ "cacheFields") &/ element (n_ "cacheField") >=> + fromAttribute "name" + return (sheet, ref, fieldNames) 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,7 +1,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} module Codec.Xlsx.Types ( -- * The main types Xlsx(..) @@ -15,7 +15,6 @@ , CellFormula(..) , Cell(..) , RowProperties (..) - , Range -- * Lenses -- ** Workbook , xlSheets @@ -31,6 +30,8 @@ , wsSheetViews , wsPageSetup , wsConditionalFormattings + , wsDataValidations + , wsPivotTables -- ** Cells , cellValue , cellStyle @@ -43,8 +44,6 @@ -- * Misc , simpleCellFormula , def - , mkRange - , fromRange , toRows , fromRows , module X @@ -60,9 +59,7 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (catMaybes) -import Data.Monoid ((<>)) import Data.Text (Text) -import qualified Data.Text as T import Text.XML (Element (..), parseLBS, renderLBS) import Text.XML.Cursor @@ -71,24 +68,18 @@ import Codec.Xlsx.Types.Comment as X import Codec.Xlsx.Types.Common as X import Codec.Xlsx.Types.ConditionalFormatting as X -import Codec.Xlsx.Types.Drawing as X +import Codec.Xlsx.Types.DataValidation as X +import Codec.Xlsx.Types.Drawing as X +import Codec.Xlsx.Types.Drawing.Chart as X +import Codec.Xlsx.Types.Drawing.Common as X import Codec.Xlsx.Types.PageSetup as X +import Codec.Xlsx.Types.PivotTable as X import Codec.Xlsx.Types.RichText as X import Codec.Xlsx.Types.SheetViews as X import Codec.Xlsx.Types.StyleSheet as X import Codec.Xlsx.Types.Variant as X import Codec.Xlsx.Writer.Internal --- | Cell values include text, numbers and booleans, --- standard includes date format also but actually dates --- are represented by numbers with a date format assigned --- to a cell containing it -data CellValue = CellText Text - | CellDouble Double - | CellBool Bool - | CellRich [RichTextRun] - deriving (Eq, Show) - -- | Formula for the cell. -- -- TODO: array. dataTable and shared formula types support @@ -152,25 +143,24 @@ 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 - , _wsDrawing :: Maybe Drawing -- ^ SpreadsheetML Drawing - , _wsMerges :: [Range] -- ^ list of cell merges - , _wsSheetViews :: Maybe [SheetView] - , _wsPageSetup :: Maybe PageSetup - , _wsConditionalFormattings :: Map SqRef ConditionalFormatting - } deriving (Eq, Show) + { _wsColumns :: [ColumnsWidth] -- ^ column widths + , _wsRowPropertiesMap :: Map Int RowProperties -- ^ custom row properties (height, style) map + , _wsCells :: CellMap -- ^ data mapped by (row, column) pairs + , _wsDrawing :: Maybe Drawing -- ^ SpreadsheetML Drawing + , _wsMerges :: [Range] -- ^ list of cell merges + , _wsSheetViews :: Maybe [SheetView] + , _wsPageSetup :: Maybe PageSetup + , _wsConditionalFormattings :: Map SqRef ConditionalFormatting + , _wsDataValidations :: Map SqRef DataValidation + , _wsPivotTables :: [PivotTable] + } deriving (Eq, Show) makeLenses ''Worksheet instance Default Worksheet where - def = Worksheet [] M.empty M.empty Nothing [] Nothing Nothing M.empty + def = Worksheet [] M.empty M.empty Nothing [] Nothing Nothing M.empty M.empty [] newtype Styles = Styles {unStyles :: L.ByteString} deriving (Eq, Show) @@ -256,21 +246,6 @@ fromRows rows = M.fromList $ concatMap mapRow rows where mapRow (r, cells) = map (\(c, v) -> ((r, c), v)) cells - --- | 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] - --- | reverse to 'mkRange' --- --- /Warning:/ the function isn't total and will throw an error if --- incorrect value will get passed -fromRange :: Range -> ((Int, Int), (Int, Int)) -fromRange t = case T.split (==':') t of - [from, to] -> (fromCellRef from, fromCellRef to) - _ -> error $ "invalid range " <> show t {------------------------------------------------------------------------------- Parsing diff --git a/src/Codec/Xlsx/Types/Common.hs b/src/Codec/Xlsx/Types/Common.hs --- a/src/Codec/Xlsx/Types/Common.hs +++ b/src/Codec/Xlsx/Types/Common.hs @@ -1,29 +1,38 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Codec.Xlsx.Types.Common - ( CellRef - , mkCellRef - , fromCellRef - , SqRef (..) - , XlsxText (..) - , Formula (..) - , int2col - , col2int - ) where + ( CellRef(..) + , singleCellRef + , fromSingleCellRef + , Range + , mkRange + , fromRange + , SqRef(..) + , XlsxText(..) + , Formula(..) + , CellValue(..) + , int2col + , col2int + ) where -import Control.Arrow -import Data.Char -import qualified Data.Map as Map -import Data.Text (Text) -import qualified Data.Text as T -import Data.Tuple (swap) -import Safe (fromJustNote) -import Text.XML -import Text.XML.Cursor +import Control.Arrow +import Control.Monad (guard) +import Data.Char +import Data.Ix (inRange) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as T +import Text.XML +import Text.XML.Cursor -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Types.RichText -import Codec.Xlsx.Writer.Internal +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.RichText +import Codec.Xlsx.Writer.Internal + -- | convert column number (starting from 1) to its textual form (e.g. 3 -> \"C\") int2col :: Int -> Text int2col = T.pack . reverse . map int2let . base26 @@ -41,25 +50,52 @@ where let2int c = 1 + ord c - ord 'A' --- | Excel cell reference (e.g. @E3@) +-- | Excel cell or cell range reference (e.g. @E3@) -- See 18.18.62 @ST_Ref@ (p. 2482) -type CellRef = Text +newtype CellRef = CellRef + { unCellRef :: Text + } deriving (Eq, Ord, Show) -- | 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)] +singleCellRef :: (Int, Int) -> CellRef +singleCellRef = CellRef . singleCellRefRaw +singleCellRefRaw :: (Int, Int) -> Text +singleCellRefRaw (row, col) = T.concat [int2col col, T.pack (show row)] + -- | reverse to 'mkCellRef' +fromSingleCellRef :: CellRef -> Maybe (Int, Int) +fromSingleCellRef = fromSingleCellRefRaw . unCellRef + +fromSingleCellRefRaw :: Text -> Maybe (Int, Int) +fromSingleCellRefRaw t = do + let (colT, rowT) = T.span (inRange ('A', 'Z')) t + guard $ not (T.null colT) && not (T.null rowT) && T.all isDigit rowT + row <- decimal rowT + return (row, col2int colT) + +-- | Excel range (e.g. @D13:H14@), actually store as as 'CellRef' in +-- xlsx +type Range = CellRef + +-- | Render range -- --- /Warning:/ the function isn't total and will throw an error if --- incorrect value will get passed -fromCellRef :: CellRef -> (Int, Int) -fromCellRef t = swap $ col2int *** toInt $ T.span (not . isDigit) t - where - toInt = fromJustNote "non-integer row in cell reference" . decimal +-- > mkRange (2, 4) (6, 8) == "D2:H6" +mkRange :: (Int, Int) -> (Int, Int) -> Range +mkRange fr to = CellRef $ T.concat [singleCellRefRaw fr, T.pack ":", singleCellRefRaw to] +-- | reverse to 'mkRange' +fromRange :: Range -> Maybe ((Int, Int), (Int, Int)) +fromRange r = + case T.split (== ':') (unCellRef r) of + [from, to] -> (,) <$> fromSingleCellRefRaw from <*> fromSingleCellRefRaw to + _ -> Nothing + +-- | A sequence of cell references +-- +-- See 18.18.76 "ST_Sqref (Reference Sequence)" (p.2488) newtype SqRef = SqRef [CellRef] deriving (Eq, Ord, Show) @@ -91,6 +127,18 @@ newtype Formula = Formula {unFormula :: Text} deriving (Eq, Ord, Show) + +-- | Cell values include text, numbers and booleans, +-- standard includes date format also but actually dates +-- are represented by numbers with a date format assigned +-- to a cell containing it +data CellValue + = CellText Text + | CellDouble Double + | CellBool Bool + | CellRich [RichTextRun] + deriving (Eq, Ord, Show) + {------------------------------------------------------------------------------- Parsing -------------------------------------------------------------------------------} @@ -99,12 +147,8 @@ instance FromCursor XlsxText where fromCursor cur = do let - ts = cur $/ element (n"t") >=> contentOrEmpty - contentOrEmpty c = case c $/ content of - [t] -> [t] - [] -> [""] - _ -> error "invalid item: more than one text nodes under !" - rs = cur $/ element (n"r") >=> fromCursor + ts = cur $/ element (n_ "t") >=> contentOrEmpty + rs = cur $/ element (n_ "r") >=> fromCursor case (ts,rs) of ([t], []) -> return $ XlsxText t @@ -113,8 +157,13 @@ _ -> fail "invalid item" +instance FromAttrVal CellRef where + fromAttrVal = fmap (first CellRef) . fromAttrVal + instance FromAttrVal SqRef where - fromAttrVal t = readSuccess (SqRef $ T.split (== ' ') t) + fromAttrVal t = do + rs <- mapM (fmap fst . fromAttrVal) $ T.split (== ' ') t + readSuccess $ SqRef rs -- | See @ST_Formula@, p. 3873 instance FromCursor Formula where @@ -135,10 +184,12 @@ XlsxRichText rich -> map (toElement "r") rich } --- | A sequence of cell references, space delimited. +instance ToAttrVal CellRef where + toAttrVal = toAttrVal . unCellRef + -- See 18.18.76, "ST_Sqref (Reference Sequence)", p. 2488. instance ToAttrVal SqRef where - toAttrVal (SqRef refs) = T.intercalate " " refs + toAttrVal (SqRef refs) = T.intercalate " " $ map toAttrVal refs -- | See @ST_Formula@, p. 3873 instance ToElement Formula where diff --git a/src/Codec/Xlsx/Types/ConditionalFormatting.hs b/src/Codec/Xlsx/Types/ConditionalFormatting.hs --- a/src/Codec/Xlsx/Types/ConditionalFormatting.hs +++ b/src/Codec/Xlsx/Types/ConditionalFormatting.hs @@ -179,7 +179,7 @@ return $ BeginsWith txt readCondition "cellIs" cur = do operator <- fromAttribute "operator" cur - let formulas = cur $/ element (n"formula") >=> fromCursor + let formulas = cur $/ element (n_ "formula") >=> fromCursor expr <- readOpExpression operator formulas return $ CellIs expr readCondition "containsBlanks" _ = return ContainsBlanks diff --git a/src/Codec/Xlsx/Types/DataValidation.hs b/src/Codec/Xlsx/Types/DataValidation.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/DataValidation.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +module Codec.Xlsx.Types.DataValidation where + +import Control.Lens.TH (makeLenses) +import Control.Monad ((>=>)) +import Data.Char (isSpace) +import Data.Default +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Text.XML (Node (..), Element (..)) +import Text.XML.Cursor (Cursor, ($/), element) + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Writer.Internal + +-- See 18.18.20 "ST_DataValidationOperator (Data Validation Operator)" (p. 2439/2449) +data ValidationExpression + = ValBetween Formula Formula -- ^ "Between" operator + | ValEqual Formula -- ^ "Equal to" operator + | ValGreaterThan Formula -- ^ "Greater than" operator + | ValGreaterThanOrEqual Formula -- ^ "Greater than or equal to" operator + | ValLessThan Formula -- ^ "Less than" operator + | ValLessThanOrEqual Formula -- ^ "Less than or equal to" operator + | ValNotBetween Formula Formula -- ^ "Not between" operator + | ValNotEqual Formula -- ^ "Not equal to" operator + deriving (Eq, Show) + +-- See 18.18.21 "ST_DataValidationType (Data Validation Type)" (p. 2440/2450) +data ValidationType + = ValidationTypeNone + | ValidationTypeCustom Formula + | ValidationTypeDate ValidationExpression + | ValidationTypeDecimal ValidationExpression + | ValidationTypeList [Text] + | ValidationTypeTextLength ValidationExpression + | ValidationTypeTime ValidationExpression + | ValidationTypeWhole ValidationExpression + deriving (Eq, Show) + +-- See 18.18.18 "ST_DataValidationErrorStyle (Data Validation Error Styles)" (p. 2438/2448) +data ErrorStyle + = ErrorStyleInformation + | ErrorStyleStop + | ErrorStyleWarning + deriving (Eq, Show) + +-- See 18.3.1.32 "dataValidation (Data Validation)" (p. 1614/1624) +data DataValidation = DataValidation + { _dvAllowBlank :: Bool + , _dvError :: Maybe Text + , _dvErrorStyle :: ErrorStyle + , _dvErrorTitle :: Maybe Text + , _dvPrompt :: Maybe Text + , _dvPromptTitle :: Maybe Text + , _dvShowDropDown :: Bool + , _dvShowErrorMessage :: Bool + , _dvShowInputMessage :: Bool + , _dvValidationType :: ValidationType + } deriving (Eq, Show) + +makeLenses ''DataValidation + +instance Default DataValidation where + def = DataValidation + False Nothing ErrorStyleStop Nothing Nothing Nothing False False False ValidationTypeNone + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromAttrVal ErrorStyle where + fromAttrVal "information" = readSuccess ErrorStyleInformation + fromAttrVal "stop" = readSuccess ErrorStyleStop + fromAttrVal "warning" = readSuccess ErrorStyleWarning + fromAttrVal t = invalidText "ErrorStyle" t + +instance FromCursor DataValidation where + fromCursor cur = do + _dvAllowBlank <- fromAttributeDef "allowBlank" False cur + _dvError <- maybeAttribute "error" cur + _dvErrorStyle <- fromAttributeDef "errorStyle" ErrorStyleStop cur + _dvErrorTitle <- maybeAttribute "errorTitle" cur + mop <- fromAttributeDef "operator" "between" cur + _dvPrompt <- maybeAttribute "prompt" cur + _dvPromptTitle <- maybeAttribute "promptTitle" cur + _dvShowDropDown <- fromAttributeDef "showDropDown" False cur + _dvShowErrorMessage <- fromAttributeDef "showErrorMessage" False cur + _dvShowInputMessage <- fromAttributeDef "showInputMessage" False cur + mtype <- fromAttributeDef "type" "none" cur + _dvValidationType <- readValidationType mop mtype cur + return DataValidation{..} + +readValidationType :: Text -> Text -> Cursor -> [ValidationType] +readValidationType _ "none" _ = return ValidationTypeNone +readValidationType _ "custom" cur = do + f <- fromCursor cur + return $ ValidationTypeCustom f +readValidationType _ "list" cur = do + f <- cur $/ element (n_ "formula1") >=> fromCursor + as <- readListFormula f + return $ ValidationTypeList as +readValidationType op ty cur = do + opExp <- readOpExpression2 op cur + readValidationTypeOpExp ty opExp + +readListFormula :: Formula -> [[Text]] +readListFormula (Formula f) = catMaybes [readQuotedList f] + where + readQuotedList t + | Just t' <- T.stripPrefix "\"" (T.dropAround isSpace t) + , Just t'' <- T.stripSuffix "\"" t' + = Just $ map (T.dropAround isSpace) $ T.splitOn "," t'' + | otherwise = Nothing + -- This parser expects a comma-separated list surrounded by quotation marks. + -- Spaces around the quotation marks and commas are removed, but inner spaces + -- are kept. + -- + -- The parser seems to be consistent with how Excel treats list formulas, but + -- I wasn't able to find a specification of the format. + +readOpExpression2 :: Text -> Cursor -> [ValidationExpression] +readOpExpression2 op cur + | op `elem` ["between", "notBetween"] = do + f1 <- cur $/ element (n_ "formula1") >=> fromCursor + f2 <- cur $/ element (n_ "formula2") >=> fromCursor + readValExpression op [f1,f2] +readOpExpression2 op cur = do + f <- cur $/ element (n_ "formula1") >=> fromCursor + readValExpression op [f] + +readValidationTypeOpExp :: Text -> ValidationExpression -> [ValidationType] +readValidationTypeOpExp "date" oe = [ValidationTypeDate oe] +readValidationTypeOpExp "decimal" oe = [ValidationTypeDecimal oe] +readValidationTypeOpExp "textLength" oe = [ValidationTypeTextLength oe] +readValidationTypeOpExp "time" oe = [ValidationTypeTime oe] +readValidationTypeOpExp "whole" oe = [ValidationTypeWhole oe] +readValidationTypeOpExp _ _ = [] + +readValExpression :: Text -> [Formula] -> [ValidationExpression] +readValExpression "between" [f1, f2] = [ValBetween f1 f2] +readValExpression "equal" [f] = [ValEqual f] +readValExpression "greaterThan" [f] = [ValGreaterThan f] +readValExpression "greaterThanOrEqual" [f] = [ValGreaterThanOrEqual f] +readValExpression "lessThan" [f] = [ValLessThan f] +readValExpression "lessThanOrEqual" [f] = [ValLessThanOrEqual f] +readValExpression "notBetween" [f1, f2] = [ValNotBetween f1 f2] +readValExpression "notEqual" [f] = [ValNotEqual f] +readValExpression _ _ = [] + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToAttrVal ValidationType where + toAttrVal ValidationTypeNone = "none" + toAttrVal (ValidationTypeCustom _) = "custom" + toAttrVal (ValidationTypeDate _) = "date" + toAttrVal (ValidationTypeDecimal _) = "decimal" + toAttrVal (ValidationTypeList _) = "list" + toAttrVal (ValidationTypeTextLength _) = "textLength" + toAttrVal (ValidationTypeTime _) = "time" + toAttrVal (ValidationTypeWhole _) = "whole" + +instance ToAttrVal ErrorStyle where + toAttrVal ErrorStyleInformation = "information" + toAttrVal ErrorStyleStop = "stop" + toAttrVal ErrorStyleWarning = "warning" + +instance ToElement DataValidation where + toElement nm DataValidation{..} = Element + { elementName = nm + , elementAttributes = M.fromList . catMaybes $ + [ Just $ "allowBlank" .= _dvAllowBlank + , "error" .=? _dvError + , Just $ "errorStyle" .= _dvErrorStyle + , "errorTitle" .=? _dvErrorTitle + , "operator" .=? op + , "prompt" .=? _dvPrompt + , "promptTitle" .=? _dvPromptTitle + , Just $ "showDropDown" .= _dvShowDropDown + , Just $ "showErrorMessage" .= _dvShowErrorMessage + , Just $ "showInputMessage" .= _dvShowInputMessage + , Just $ "type" .= _dvValidationType + ] + , elementNodes = catMaybes + [ fmap (NodeElement . toElement "formula1") f1 + , fmap (NodeElement . toElement "formula2") f2 + ] + } + where + opExp (o,f1',f2') = (Just o, Just f1', f2') + + op :: Maybe Text + f1,f2 :: Maybe Formula + (op,f1,f2) = case _dvValidationType of + ValidationTypeNone -> (Nothing, Nothing, Nothing) + ValidationTypeCustom f -> (Nothing, Just f, Nothing) + ValidationTypeDate f -> opExp $ viewValidationExpression f + ValidationTypeDecimal f -> opExp $ viewValidationExpression f + ValidationTypeTextLength f -> opExp $ viewValidationExpression f + ValidationTypeTime f -> opExp $ viewValidationExpression f + ValidationTypeWhole f -> opExp $ viewValidationExpression f + ValidationTypeList as -> + let f = Formula $ "\"" <> T.intercalate "," as <> "\"" + in (Nothing, Just f, Nothing) + +viewValidationExpression :: ValidationExpression -> (Text, Formula, Maybe Formula) +viewValidationExpression (ValBetween f1 f2) = ("between", f1, Just f2) +viewValidationExpression (ValEqual f) = ("equal", f, Nothing) +viewValidationExpression (ValGreaterThan f) = ("greaterThan", f, Nothing) +viewValidationExpression (ValGreaterThanOrEqual f) = ("greaterThanOrEqual", f, Nothing) +viewValidationExpression (ValLessThan f) = ("lessThan", f, Nothing) +viewValidationExpression (ValLessThanOrEqual f) = ("lessThanOrEqual", f, Nothing) +viewValidationExpression (ValNotBetween f1 f2) = ("notBetween", f1, Just f2) +viewValidationExpression (ValNotEqual f) = ("notEqual", f, Nothing) + diff --git a/src/Codec/Xlsx/Types/Drawing.hs b/src/Codec/Xlsx/Types/Drawing.hs --- a/src/Codec/Xlsx/Types/Drawing.hs +++ b/src/Codec/Xlsx/Types/Drawing.hs @@ -1,22 +1,21 @@ +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} module Codec.Xlsx.Types.Drawing where -import Control.Arrow (first) import Control.Lens.TH import Data.ByteString.Lazy (ByteString) import Data.Default import qualified Data.Map as M import Data.Maybe (catMaybes, listToMaybe) -import Data.Monoid ((<>)) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Read as T import Text.XML import Text.XML.Cursor @@ -24,7 +23,9 @@ import Control.Applicative #endif -import Codec.Xlsx.Parser.Internal hiding (n) +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Drawing.Common +import Codec.Xlsx.Types.Drawing.Chart import Codec.Xlsx.Types.Internal import Codec.Xlsx.Types.Internal.Relationships import Codec.Xlsx.Writer.Internal @@ -40,52 +41,6 @@ -- ^ image file contents } deriving (Eq, Show) --- | This simple type represents a one dimensional position or length --- --- See 20.1.10.16 "ST_Coordinate (Coordinate)" (p. 2921) -data Coordinate - = UnqCoordinate Int - -- ^ see 20.1.10.19 "ST_CoordinateUnqualified (Coordinate)" (p. 2922) - | UniversalMeasure UnitIdentifier Double - -- ^ see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793) - deriving (Eq, Show) - --- | Units used in "Universal measure" coordinates --- see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793) -data UnitIdentifier - = UnitCm -- "cm" As defined in ISO 31. - | UnitMm -- "mm" As defined in ISO 31. - | UnitIn -- "in" 1 in = 2.54 cm (informative) - | UnitPt -- "pt" 1 pt = 1/72 in (informative) - | UnitPc -- "pc" 1 pc = 12 pt (informative) - | UnitPi -- "pi" 1 pi = 12 pt (informative) - deriving (Eq, Show) - --- See @CT_Point2D@ (p. 3989) -data Point2D = Point2D - { _pt2dX :: Coordinate - , _pt2dY :: Coordinate - } deriving (Eq, Show) - -unqPoint2D :: Int -> Int -> Point2D -unqPoint2D x y = Point2D (UnqCoordinate x) (UnqCoordinate y) - --- | Positive position or length in EMUs, maximu allowed value is 27273042316900. --- see 20.1.10.41 "ST_PositiveCoordinate (Positive Coordinate)" (p. 2942) -newtype PositiveCoordinate = PositiveCoordinate Integer - deriving (Eq, Ord, Show) - --- | This simple type represents an angle in 60,000ths of a degree. --- Positive angles are clockwise (i.e., towards the positive y axis); negative --- angles are counter-clockwise (i.e., towards the negative y axis). -newtype Angle = Angle Int - deriving (Eq, Show) - -data PositiveSize2D = PositiveSize2D - { _ps2dX :: PositiveCoordinate - , _ps2dY :: PositiveCoordinate - } deriving (Eq, Show) - data Marker = Marker { _mrkCol :: Int , _mrkColOff :: Coordinate @@ -119,17 +74,19 @@ } deriving (Eq, Show) -data DrawingObject a - = Picture - { _picMacro :: Maybe Text - , _picPublished :: Bool - , _picNonVisual :: PicNonVisual - , _picBlipFill :: BlipFillProperties a - , _picShapeProperties :: ShapeProperties - -- TODO: style - } +data DrawingObject p g + = Picture { _picMacro :: Maybe Text + , _picPublished :: Bool + , _picNonVisual :: PicNonVisual + , _picBlipFill :: BlipFillProperties p + , _picShapeProperties :: ShapeProperties + -- TODO: style + } + | Graphic { _grNonVisual :: GraphNonVisual + , _grChartSpace :: g + , _grTransform :: Transform2D} -- TODO: sp, grpSp, graphicFrame, cxnSp, contentPart - deriving (Eq, Show) + deriving (Eq, Show) -- | This element is used to set certain properties related to a drawing -- element on the client spreadsheet application. @@ -145,26 +102,30 @@ } deriving (Eq, Show) data PicNonVisual = PicNonVisual - { _pnvDrawingProps :: PicDrawingNonVisual + { _pnvDrawingProps :: NonVisualDrawingProperties -- TODO: cNvPicPr - } - deriving (Eq, Show) + } deriving (Eq, Show) +data GraphNonVisual = GraphNonVisual + { _gnvDrawingProps :: NonVisualDrawingProperties + -- TODO cNvGraphicFramePr + } deriving (Eq, Show) + -- see 20.1.2.2.8 "cNvPr (Non-Visual Drawing Properties)" (p. 2731) -data PicDrawingNonVisual = PicDrawingNonVisual - { _pdnvId :: Int +data NonVisualDrawingProperties = NonVisualDrawingProperties + { _nvdpId :: Int -- ^ Specifies a unique identifier for the current -- DrawingML object within the current -- -- TODO: make ids internal and consistent by construction - , _pdnvName :: Text + , _nvdpName :: Text -- ^ Specifies the name of the object. -- Typically, this is used to store the original file -- name of a picture object. - , _pdnvDescription :: Maybe Text + , _nvdpDescription :: Maybe Text -- ^ Alternative Text for Object - , _pdnvHidden :: Bool - , _pdnvTitle :: Maybe Text + , _nvdpHidden :: Bool + , _nvdpTitle :: Maybe Text } deriving (Eq, Show) data BlipFillProperties a = BlipFillProperties @@ -181,68 +142,21 @@ | FillStretch -- TODO: srcRect deriving (Eq, Show) --- See 20.1.2.2.35 "spPr (Shape Properties)" (p. 2751) -data ShapeProperties = ShapeProperties - { _spXfrm :: Maybe Transform2D - , _spGeometry :: Maybe Geometry - , _spOutline :: Maybe LineProperties - -- TODO: bwMode, a_EG_FillProperties, a_EG_EffectProperties, scene3d, sp3d, extLst - } deriving (Eq, Show) - --- See 20.1.7.6 "xfrm (2D Transform for Individual Objects)" (p. 2849) -data Transform2D = Transform2D - { _trRot :: Angle - -- ^ Specifies the rotation of the Graphic Frame. - , _trFlipH :: Bool - -- ^ Specifies a horizontal flip. When true, this attribute defines - -- that the shape is flipped horizontally about the center of its bounding box. - , _trFlipV :: Bool - -- ^ Specifies a vertical flip. When true, this attribute defines - -- that the shape is flipped vetically about the center of its bounding box. - , _trOffset :: Maybe Point2D - -- ^ See 20.1.7.4 "off (Offset)" (p. 2847) - , _trExtents :: Maybe PositiveSize2D - -- ^ See 20.1.7.3 "ext (Extents)" (p. 2846) or - -- 20.5.2.14 "ext (Shape Extent)" (p. 3165) - } - deriving (Eq, Show) - -data Geometry - -- TODO: custGeom - = PresetGeometry - -- TODO: prst, avList - -- currently uses "rect" with empty avList - deriving (Eq, Show) - --- See 20.1.2.2.24 "ln (Outline)" (p. 2744) -data LineProperties = LineProperties - { _lnFill :: Maybe LineFill - -- TODO: w, cap, cmpd, algn, a_EG_LineDashProperties, - -- a_EG_LineJoinProperties, headEnd, tailEnd, extLst - } - deriving (Eq, Show) - -data LineFill - -- See 20.1.8.44 "noFill (No Fill)" (p. 2872) - = LineNoFill - -- TODO: solidFill, gradFill, pattFill - deriving (Eq, Show) - -- See @EG_Anchor@ (p. 4052) -data Anchor a = Anchor +data Anchor p g = Anchor { _anchAnchoring :: Anchoring - , _anchObject :: DrawingObject a + , _anchObject :: DrawingObject p g , _anchClientData :: ClientData } deriving (Eq, Show) -data GenericDrawing a = Drawing - { _xdrAnchors :: [Anchor a] +data GenericDrawing p g = Drawing + { _xdrAnchors :: [Anchor p g] } deriving (Eq, Show) -- See 20.5.2.35 "wsDr (Worksheet Drawing)" (p. 3176) -type Drawing = GenericDrawing FileInfo +type Drawing = GenericDrawing FileInfo ChartSpace -type UnresolvedDrawing = GenericDrawing RefId +type UnresolvedDrawing = GenericDrawing RefId RefId makeLenses ''Anchor makeLenses ''DrawingObject @@ -263,7 +177,7 @@ instance FromCursor UnresolvedDrawing where fromCursor cur = [Drawing $ cur $/ anyElement >=> fromCursor] -instance FromCursor (Anchor RefId) where +instance FromCursor (Anchor RefId RefId) where fromCursor cur = do _anchAnchoring <- fromCursor cur _anchObject <- cur $/ anyElement >=> fromCursor @@ -291,10 +205,6 @@ where cur = fromNode n -nodeElNameIs :: Node -> Name -> Bool -nodeElNameIs (NodeElement el) name = elementName el == name -nodeElNameIs _ _ = False - instance FromCursor Marker where fromCursor cur = do _mrkCol <- cur $/ element (xdr"col") &/ content >=> decimal @@ -303,101 +213,64 @@ _mrkRowOff <- cur $/ element (xdr"rowOff") &/ content >=> coordinate return Marker{..} -instance FromCursor (DrawingObject RefId) where +instance FromCursor (DrawingObject RefId RefId) where fromCursor = drawingObjectFromNode . node -drawingObjectFromNode :: Node -> [DrawingObject RefId] -drawingObjectFromNode n | n `nodeElNameIs` xdr "pic" = do - _picMacro <- maybeAttribute "macro" cur - _picPublished <- fromAttributeDef "fPublished" False cur - _picNonVisual <- cur $/ element (xdr"nvPicPr") >=> fromCursor - _picBlipFill <- cur $/ element (xdr"blipFill") >=> fromCursor - _picShapeProperties <- cur $/ element (xdr"spPr") >=> fromCursor - return Picture{..} - | otherwise = fail "no matching drawing object node" - where - cur = fromNode n +drawingObjectFromNode :: Node -> [DrawingObject RefId RefId] +drawingObjectFromNode n + | n `nodeElNameIs` xdr "pic" = do + _picMacro <- maybeAttribute "macro" cur + _picPublished <- fromAttributeDef "fPublished" False cur + _picNonVisual <- cur $/ element (xdr "nvPicPr") >=> fromCursor + _picBlipFill <- cur $/ element (xdr "blipFill") >=> fromCursor + _picShapeProperties <- cur $/ element (xdr "spPr") >=> fromCursor + return Picture {..} + | n `nodeElNameIs` xdr "graphicFrame" = do + _grNonVisual <- + cur $/ element (xdr "nvGraphicFramePr") >=> fromCursor + _grTransform <- cur $/ element (xdr "xfrm") >=> fromCursor + _grChartSpace <- + cur $/ element (a_ "graphic") &/ element (a_ "graphicData") &/ + element (c_ "chart") >=> fmap RefId . attribute (odr "id") + return Graphic {..} + | otherwise = fail "no matching drawing object node" + where + cur = fromNode n instance FromCursor PicNonVisual where fromCursor cur = do _pnvDrawingProps <- cur $/ element (xdr"cNvPr") >=> fromCursor return PicNonVisual{..} -instance FromCursor PicDrawingNonVisual where +instance FromCursor GraphNonVisual where + fromCursor cur = do + _gnvDrawingProps <- cur $/ element (xdr "cNvPr") >=> fromCursor + return GraphNonVisual {..} + +instance FromCursor NonVisualDrawingProperties where fromCursor cur = do - _pdnvId <- fromAttribute "id" cur - _pdnvName <- fromAttribute "name" cur - _pdnvDescription <- maybeAttribute "descr" cur - _pdnvHidden <- fromAttributeDef "hidden" False cur - _pdnvTitle <- maybeAttribute "title" cur - return PicDrawingNonVisual{..} + _nvdpId <- fromAttribute "id" cur + _nvdpName <- fromAttribute "name" cur + _nvdpDescription <- maybeAttribute "descr" cur + _nvdpHidden <- fromAttributeDef "hidden" False cur + _nvdpTitle <- maybeAttribute "title" cur + return NonVisualDrawingProperties{..} instance FromCursor (BlipFillProperties RefId) where fromCursor cur = do - let _bfpImageInfo = listToMaybe $ cur $/ element (a"blip") >=> + let _bfpImageInfo = listToMaybe $ cur $/ element (a_ "blip") >=> fmap RefId . attribute (odr"embed") _bfpFillMode = listToMaybe $ cur $/ anyElement >=> fromCursor return BlipFillProperties{..} -instance FromCursor ShapeProperties where - fromCursor cur = do - _spXfrm <- maybeFromElement (a"xfrm") cur - let _spGeometry = listToMaybe $ cur $/ anyElement >=> fromCursor - _spOutline <- maybeFromElement (a"ln") cur - return ShapeProperties{..} - instance FromCursor FillMode where fromCursor = fillModeFromNode . node fillModeFromNode :: Node -> [FillMode] -fillModeFromNode n | n `nodeElNameIs` a "stretch" = return FillStretch - | n `nodeElNameIs` a "stretch" = return FillTile +fillModeFromNode n | n `nodeElNameIs` a_ "stretch" = return FillStretch + | n `nodeElNameIs` a_ "stretch" = return FillTile | otherwise = fail "no matching fill mode node" -instance FromCursor Transform2D where - fromCursor cur = do - _trRot <- fromAttributeDef "rot" (Angle 0) cur - _trFlipH <- fromAttributeDef "flipH" False cur - _trFlipV <- fromAttributeDef "flipV" False cur - _trOffset <- maybeFromElement (a"off") cur - _trExtents <- maybeFromElement (a"ext") cur - return Transform2D{..} - -instance FromCursor Geometry where - fromCursor = geometryFromNode . node - -geometryFromNode :: Node -> [Geometry] -geometryFromNode n | n `nodeElNameIs` a "prstGeom" = - return PresetGeometry - | otherwise = fail "no matching geometry node" - -instance FromCursor LineProperties where - fromCursor cur = do - let _lnFill = listToMaybe $ cur $/ anyElement >=> fromCursor - return LineProperties{..} - -instance FromCursor ClientData where - fromCursor cur = do - _cldLcksWithSheet <- fromAttributeDef "fLocksWithSheet" True cur - _cldPrintsWithSheet <- fromAttributeDef "fPrintsWithSheet" True cur - return ClientData{..} - -instance FromCursor Point2D where - fromCursor cur = do - x <- coordinate =<< fromAttribute "x" cur - y <- coordinate =<< fromAttribute "y" cur - return $ Point2D x y - -instance FromCursor PositiveSize2D where - fromCursor cur = do - cx <- PositiveCoordinate <$> fromAttribute "cx" cur - cy <- PositiveCoordinate <$> fromAttribute "cy" cur - return $ PositiveSize2D cx cy - --- see 20.1.10.3 "ST_Angle (Angle)" (p. 2912) -instance FromAttrVal Angle where - fromAttrVal t = first Angle <$> fromAttrVal t - -- see 20.5.3.2 "ST_EditAs (Resizing Behaviors)" (p. 3177) instance FromAttrVal EditAs where fromAttrVal "absolute" = readSuccess EditAsAbsolute @@ -405,26 +278,11 @@ fromAttrVal "twoCell" = readSuccess EditAsTwoCell fromAttrVal t = invalidText "EditAs" t -instance FromCursor LineFill where - fromCursor = lineFillFromNode . node - -lineFillFromNode :: Node -> [LineFill] -lineFillFromNode n | n `nodeElNameIs` a "noFill" = return LineNoFill - | otherwise = fail "no matching line fill node" - -coordinate :: Monad m => Text -> m Coordinate -coordinate t = case T.decimal t of - Right (d, leftover) | leftover == T.empty -> - return $ UnqCoordinate d - _ -> - case T.rational t of - Right (r, "cm") -> return $ UniversalMeasure UnitCm r - Right (r, "mm") -> return $ UniversalMeasure UnitMm r - Right (r, "in") -> return $ UniversalMeasure UnitIn r - Right (r, "pt") -> return $ UniversalMeasure UnitPt r - Right (r, "pc") -> return $ UniversalMeasure UnitPc r - Right (r, "pi") -> return $ UniversalMeasure UnitPi r - _ -> fail $ "invalid coordinate: " ++ show t +instance FromCursor ClientData where + fromCursor cur = do + _cldLcksWithSheet <- fromAttributeDef "fLocksWithSheet" True cur + _cldPrintsWithSheet <- fromAttributeDef "fPrintsWithSheet" True cur + return ClientData{..} {------------------------------------------------------------------------------- Rendering @@ -442,7 +300,7 @@ map anchorToElement anchors } -anchorToElement :: Anchor RefId -> Element +anchorToElement :: Anchor RefId RefId -> Element anchorToElement Anchor{..} = el { elementNodes = elementNodes el ++ map NodeElement [ drawingObjEl, cdEl ] } @@ -473,66 +331,62 @@ , elementContent "row" (toAttrVal _mrkRow) , elementContent "rowOff" (toAttrVal _mrkRowOff)] -drawingObjToElement :: DrawingObject RefId -> Element -drawingObjToElement Picture{..} = - elementList "pic" attrs elements +drawingObjToElement :: DrawingObject RefId RefId -> Element +drawingObjToElement Picture {..} = elementList "pic" attrs elements where - attrs = catMaybes [ "macro" .=? _picMacro - , "fPublished" .=? justTrue _picPublished] - elements = [ toElement "nvPicPr" _picNonVisual - , toElement "blipFill" _picBlipFill - , toElement "spPr" _picShapeProperties ] + attrs = + catMaybes ["macro" .=? _picMacro, "fPublished" .=? justTrue _picPublished] + elements = + [ toElement "nvPicPr" _picNonVisual + , toElement "blipFill" _picBlipFill + , toElement "spPr" _picShapeProperties + ] +drawingObjToElement Graphic {..} = elementListSimple "graphicFrame" elements + where + elements = + [ toElement "nvGraphicFramePr" _grNonVisual + , toElement "xfrm" _grTransform + , graphicEl + ] + graphicEl = + elementListSimple + (a_ "graphic") + [ elementList + (a_ "graphicData") + ["uri" .= chartNs] + [leafElement (c_ "chart") [odr "id" .= _grChartSpace]] + ] instance ToElement PicNonVisual where toElement nm PicNonVisual{..} = elementListSimple nm [toElement "cNvPr" _pnvDrawingProps] -instance ToElement PicDrawingNonVisual where - toElement nm PicDrawingNonVisual{..} = +instance ToElement GraphNonVisual where + toElement nm GraphNonVisual {..} = + elementListSimple + nm + [toElement "cNvPr" _gnvDrawingProps, emptyElement "cNvGraphicFramePr"] + +instance ToElement NonVisualDrawingProperties where + toElement nm NonVisualDrawingProperties{..} = leafElement nm attrs where - attrs = [ "id" .= _pdnvId - , "name" .= _pdnvName ] ++ - catMaybes [ "descr" .=? _pdnvDescription - , "hidden" .=? justTrue _pdnvHidden - , "title" .=? _pdnvTitle ] + attrs = [ "id" .= _nvdpId + , "name" .= _nvdpName ] ++ + catMaybes [ "descr" .=? _nvdpDescription + , "hidden" .=? justTrue _nvdpHidden + , "title" .=? _nvdpTitle ] instance ToElement (BlipFillProperties RefId) where toElement nm BlipFillProperties{..} = elementListSimple nm elements where - elements = catMaybes [ (\rId -> leafElement (a"blip") [ odr "embed" .= rId ]) <$> _bfpImageInfo + elements = catMaybes [ (\rId -> leafElement (a_ "blip") [ odr "embed" .= rId ]) <$> _bfpImageInfo , fillModeToElement <$> _bfpFillMode ] fillModeToElement :: FillMode -> Element -fillModeToElement FillStretch = emptyElement (a"stretch") -fillModeToElement FillTile = emptyElement (a"stretch") - -instance ToElement ShapeProperties where - toElement nm ShapeProperties{..} = elementListSimple nm elements - where - elements = catMaybes [ toElement (a"xfrm") <$> _spXfrm - , geometryToElement <$> _spGeometry - , toElement (a"ln") <$> _spOutline ] - -instance ToElement Transform2D where - toElement nm Transform2D{..} = elementList nm attrs elements - where - attrs = catMaybes [ "rot" .=? justNonDef (Angle 0) _trRot - , "flipH" .=? justTrue _trFlipH - , "flipV" .=? justTrue _trFlipV ] - elements = catMaybes [ toElement (a"off") <$> _trOffset - , toElement (a"ext") <$> _trExtents ] - -geometryToElement :: Geometry -> Element -geometryToElement PresetGeometry = emptyElement (a"prstGeom") - -instance ToElement LineProperties where - toElement nm LineProperties{..} = - elementListSimple nm $ catMaybes [ lineFillToElement <$> _lnFill ] - -lineFillToElement :: LineFill -> Element -lineFillToElement LineNoFill = emptyElement (a"noFill") +fillModeToElement FillStretch = emptyElement (a_ "stretch") +fillModeToElement FillTile = emptyElement (a_ "stretch") instance ToElement ClientData where toElement nm ClientData{..} = leafElement nm attrs @@ -541,47 +395,10 @@ , "fPrintsWithSheet" .=? justFalse _cldPrintsWithSheet ] -instance ToElement Point2D where - toElement nm Point2D{..} = leafElement nm [ "x" .= _pt2dX - , "y" .= _pt2dY - ] - -instance ToElement PositiveSize2D where - toElement nm PositiveSize2D{..} = leafElement nm [ "cx" .= _ps2dX - , "cy" .= _ps2dY ] - -instance ToAttrVal Coordinate where - toAttrVal (UnqCoordinate x) = toAttrVal x - toAttrVal (UniversalMeasure unit x) = toAttrVal x <> unitToText unit - where - unitToText UnitCm = "cm" - unitToText UnitMm = "mm" - unitToText UnitIn = "in" - unitToText UnitPt = "pt" - unitToText UnitPc = "pc" - unitToText UnitPi = "pi" - -instance ToAttrVal PositiveCoordinate where - toAttrVal (PositiveCoordinate x) = toAttrVal x - instance ToAttrVal EditAs where toAttrVal EditAsAbsolute = "absolute" toAttrVal EditAsOneCell = "oneCell" toAttrVal EditAsTwoCell = "twoCell" - -instance ToAttrVal Angle where - toAttrVal (Angle x) = toAttrVal x - --- | Add DrawingML namespace to name -a :: Text -> Name -a x = Name - { nameLocalName = x - , nameNamespace = Just drawingNs - , namePrefix = Nothing - } - -drawingNs :: Text -drawingNs = "http://schemas.openxmlformats.org/drawingml/2006/main" -- | Add Spreadsheet DrawingML namespace to name xdr :: Text -> Name diff --git a/src/Codec/Xlsx/Types/Drawing/Chart.hs b/src/Codec/Xlsx/Types/Drawing/Chart.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Drawing/Chart.hs @@ -0,0 +1,485 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Codec.Xlsx.Types.Drawing.Chart where + +import Data.Default +import Data.Maybe (catMaybes, maybeToList) +import Data.Text (Text) +import Text.XML +import Text.XML.Cursor + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.Drawing.Common +import Codec.Xlsx.Writer.Internal + +-- | Main Chart holder, combines +-- TODO: title, autoTitleDeleted, pivotFmts +-- view3D, floor, sideWall, backWall, showDLblsOverMax, extLst +data ChartSpace = ChartSpace + { _chspTitle :: Maybe ChartTitle + , _chspCharts :: [Chart] + , _chspLegend :: Maybe Legend + , _chspPlotVisOnly :: Maybe Bool + , _chspDispBlanksAs :: Maybe DispBlanksAs + } deriving (Eq, Show) + +-- | Chart title +-- +-- TODO: layout, overlay, spPr, txPr, extLst +newtype ChartTitle = + ChartTitle TextBody + deriving (Eq, Show) + +-- | This simple type specifies the possible ways to display blanks. +-- +-- See 21.2.3.10 "ST_DispBlanksAs (Display Blanks As)" (p. 3444) +data DispBlanksAs + = DispBlanksAsGap + -- ^ Specifies that blank values shall be left as a gap. + | DispBlanksAsSpan + -- ^ Specifies that blank values shall be spanned with a line. + | DispBlanksAsZero + -- ^ Specifies that blank values shall be treated as zero. + deriving (Eq, Show) + +-- TODO: legendEntry, layout, overlay, spPr, txPr, extLst +data Legend = Legend + { _legendPos :: Maybe LegendPos + , _legendOverlay :: Maybe Bool + } deriving (Eq, Show) + +-- See 21.2.3.24 "ST_LegendPos (Legend Position)" (p. 3449) +data LegendPos + = LegendBottom + -- ^ b (Bottom) Specifies that the legend shall be drawn at the + -- bottom of the chart. + | LegendLeft + -- ^ l (Left) Specifies that the legend shall be drawn at the left + -- of the chart. + | LegendRight + -- ^ r (Right) Specifies that the legend shall be drawn at the + -- right of the chart. + | LegendTop + -- ^ t (Top) Specifies that the legend shall be drawn at the top + -- of the chart. + | LegendTopRight + -- ^ tr (Top Right) Specifies that the legend shall be drawn at + -- the top right of the chart. + deriving (Eq, Show) + +-- | Specific Chart +-- TODO: +-- areaChart, area3DChart, line3DChart, stockChart, radarChart, scatterChart, +-- pieChart, pie3DChart, doughnutChart, barChart, bar3DChart, ofPieChart, +-- surfaceChart, surface3DChart, bubbleChart +data Chart = LineChart + { _lnchGrouping :: ChartGrouping + , _lnchSeries :: [LineSeries] + , _lnchMarker :: Maybe Bool + -- ^ specifies that the marker shall be shown + , _lnchSmooth :: Maybe Bool + -- ^ specifies the line connecting the points on the chart shall be + -- smoothed using Catmull-Rom splines + } deriving (Eq, Show) + +-- | Possible groupings for a bar chart +-- +-- See 21.2.3.17 "ST_Grouping (Grouping)" (p. 3446) +data ChartGrouping + = PercentStackedGrouping + -- ^ (100% Stacked) Specifies that the chart series are drawn next to each + -- other along the value axis and scaled to total 100%. + | StackedGrouping + -- ^ (Stacked) Specifies that the chart series are drawn next to each + -- other on the value axis. + | StandardGrouping + -- ^(Standard) Specifies that the chart series are drawn on the value + -- axis. + deriving (Eq, Show) + +-- | Specifies common series options +-- TODO: spPr +-- +-- See @EG_SerShared@ (p. 4063) +data Series = Series + { _serTx :: Maybe Formula + -- ^ specifies text for a series name, without rich text formatting + -- currently only reference formula is supported + } deriving (Eq, Show) + +-- | A series on a line chart +-- +-- TODO: dPt, trendline, errBars, cat, extLst +-- +-- See @CT_LineSer@ (p. 4064) +data LineSeries = LineSeries + { _lnserShared :: Series + , _lnserMarker :: Maybe DataMarker + , _lnserDataLblProps :: Maybe DataLblProps + , _lnserVal :: Maybe Formula + -- ^ currently only reference formula is supported + , _lnserSmooth :: Maybe Bool + } deriving (Eq, Show) + +-- See @CT_Marker@ (p. 4061) +data DataMarker = DataMarker + { _dmrkSymbol :: Maybe DataMarkerSymbol + , _dmrkSize :: Maybe Int + -- ^ integer between 2 and 72, specifying a size in points + } deriving (Eq, Show) + +data DataMarkerSymbol + = DataMarkerCircle + | DataMarkerDash + | DataMarkerDiamond + | DataMarkerDot + | DataMarkerNone + | DataMarkerPicture + | DataMarkerPlus + | DataMarkerSquare + | DataMarkerStar + | DataMarkerTriangle + | DataMarkerX + | DataMarkerAuto + deriving (Eq, Show) + +-- | Settings for the data labels for an entire series or the +-- entire chart +-- +-- TODO: numFmt, spPr, txPr, dLblPos, showBubbleSize, +-- separator, showLeaderLines, leaderLines +-- See 21.2.2.49 "dLbls (Data Labels)" (p. 3384) +data DataLblProps = DataLblProps + { _dlblShowLegendKey :: Maybe Bool + , _dlblShowVal :: Maybe Bool + , _dlblShowCatName :: Maybe Bool + , _dlblShowSerName :: Maybe Bool + , _dlblShowPercent :: Maybe Bool + } deriving (Eq, Show) + +-- | Specifies the possible positions for tick marks. + +-- See 21.2.3.48 "ST_TickMark (Tick Mark)" (p. 3467) +data TickMark + = TickMarkCross + -- ^ (Cross) Specifies the tick marks shall cross the axis. + | TickMarkIn + -- ^ (Inside) Specifies the tick marks shall be inside the plot area. + | TickMarkNone + -- ^ (None) Specifies there shall be no tick marks. + | TickMarkOut + -- ^ (Outside) Specifies the tick marks shall be outside the plot area. + deriving (Eq, Show) + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromCursor ChartSpace where + fromCursor cur = do + cur' <- cur $/ element (c_ "chart") + _chspTitle <- maybeFromElement (c_ "title") cur' + let _chspCharts = + cur' $/ element (c_ "plotArea") &/ anyElement >=> chartFromNode . node + _chspLegend <- maybeFromElement (c_ "legend") cur' + _chspPlotVisOnly <- maybeBoolElementValue (c_ "plotVisOnly") cur' + _chspDispBlanksAs <- maybeElementValue (c_ "dispBlanksAs") cur' + return ChartSpace {..} + +chartFromNode :: Node -> [Chart] +chartFromNode n + | n `nodeElNameIs` (c_ "lineChart") = do + _lnchGrouping <- fromElementValue (c_ "grouping") cur + let _lnchSeries = cur $/ element (c_ "ser") >=> fromCursor + _lnchMarker <- maybeBoolElementValue (c_ "marker") cur + _lnchSmooth <- maybeBoolElementValue (c_ "smooth") cur + return LineChart {..} + | otherwise = fail "no matching chart node" + where + cur = fromNode n + +instance FromCursor LineSeries where + fromCursor cur = do + _lnserShared <- fromCursor cur + _lnserMarker <- maybeFromElement (c_ "marker") cur + _lnserDataLblProps <- maybeFromElement (c_ "dLbls") cur + _lnserVal <- + cur $/ element (c_ "val") &/ element (c_ "numRef") >=> + maybeFromElement (c_ "f") + _lnserSmooth <- maybeElementValueDef (c_ "smooth") True cur + return LineSeries {..} + +-- should we respect idx and order? +instance FromCursor Series where + fromCursor cur = do + _serTx <- + cur $/ element (c_ "tx") &/ element (c_ "strRef") >=> + maybeFromElement (c_ "f") + return Series {..} + +instance FromCursor DataMarker where + fromCursor cur = do + _dmrkSymbol <- maybeElementValue (c_ "symbol") cur + _dmrkSize <- maybeElementValue (c_ "size") cur + return DataMarker {..} + +instance FromAttrVal DataMarkerSymbol where + fromAttrVal "circle" = readSuccess DataMarkerCircle + fromAttrVal "dash" = readSuccess DataMarkerDash + fromAttrVal "diamond" = readSuccess DataMarkerDiamond + fromAttrVal "dot" = readSuccess DataMarkerDot + fromAttrVal "none" = readSuccess DataMarkerNone + fromAttrVal "picture" = readSuccess DataMarkerPicture + fromAttrVal "plus" = readSuccess DataMarkerPlus + fromAttrVal "square" = readSuccess DataMarkerSquare + fromAttrVal "star" = readSuccess DataMarkerStar + fromAttrVal "triangle" = readSuccess DataMarkerTriangle + fromAttrVal "x" = readSuccess DataMarkerX + fromAttrVal "auto" = readSuccess DataMarkerAuto + fromAttrVal t = invalidText "DataMarkerSymbol" t + +instance FromCursor DataLblProps where + fromCursor cur = do + _dlblShowLegendKey <- maybeBoolElementValue (c_ "showLegendKey") cur + _dlblShowVal <- maybeBoolElementValue (c_ "showVal") cur + _dlblShowCatName <- maybeBoolElementValue (c_ "showCatName") cur + _dlblShowSerName <- maybeBoolElementValue (c_ "showSerName") cur + _dlblShowPercent <- maybeBoolElementValue (c_ "showPercent") cur + return DataLblProps {..} + +instance FromAttrVal ChartGrouping where + fromAttrVal "percentStacked" = readSuccess PercentStackedGrouping + fromAttrVal "standard" = readSuccess StandardGrouping + fromAttrVal "stacked" = readSuccess StackedGrouping + fromAttrVal t = invalidText "ChartGrouping" t + +instance FromCursor ChartTitle where + fromCursor cur = + cur $/ element (c_ "tx") &/ element (c_ "rich") >=> fmap ChartTitle . fromCursor + +instance FromCursor Legend where + fromCursor cur = do + _legendPos <- maybeElementValue (c_ "legendPos") cur + _legendOverlay <- maybeElementValueDef (c_ "overlay") True cur + return Legend {..} + +instance FromAttrVal LegendPos where + fromAttrVal "b" = readSuccess LegendBottom + fromAttrVal "l" = readSuccess LegendLeft + fromAttrVal "r" = readSuccess LegendRight + fromAttrVal "t" = readSuccess LegendTop + fromAttrVal "tr" = readSuccess LegendTopRight + fromAttrVal t = invalidText "LegendPos" t + +instance FromAttrVal DispBlanksAs where + fromAttrVal "gap" = readSuccess DispBlanksAsGap + fromAttrVal "span" = readSuccess DispBlanksAsSpan + fromAttrVal "zero" = readSuccess DispBlanksAsZero + fromAttrVal t = invalidText "DispBlanksAs" t + +{------------------------------------------------------------------------------- + Default instances +-------------------------------------------------------------------------------} + +instance Default Legend where + def = Legend {_legendPos = Just LegendBottom, _legendOverlay = Just False} + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToDocument ChartSpace where + toDocument = + documentFromNsPrefElement "Charts generated by xlsx" chartNs (Just "c") . + toElement "chartSpace" + +instance ToElement ChartSpace where + toElement nm ChartSpace {..} = + elementListSimple nm [nonRounded, chartEl, chSpPr] + where + -- no such element gives a chart space with rounded corners + nonRounded = elementValue "roundedCorners" False + chSpPr = toElement "spPr" $ def {_spFill = Just SolidFill} + chartEl = elementListSimple "chart" elements + elements = + catMaybes + [ toElement "title" <$> _chspTitle + -- LO? + , Just $ elementValue "autoTitleDeleted" False + , Just $ elementListSimple "plotArea" areaEls + , toElement "legend" <$> _chspLegend + , elementValue "plotVisOnly" <$> _chspPlotVisOnly + , elementValue "dispBlanksAs" <$> _chspDispBlanksAs + ] + -- we reserve 2 axes - X and Y for line charts + -- this needs to be reworked when other chart types will be added + enumCharts = zip [1,3 ..] _chspCharts + charts = [chartToElement ch i (i + 1) | (i, ch) <- enumCharts] + areaEls = charts ++ valAxes ++ catAxes + catAxes = [catAxEl i (i + 1) | (i, _) <- enumCharts] + valAxes = [valAxEl (i + 1) i | (i, _) <- enumCharts] + catAxEl :: Int -> Int -> Element + catAxEl i cr = + elementListSimple "catAx" $ + [ elementValue "axId" i + , emptyElement "scaling" + , elementValue "delete" False + , elementValue "axPos" ("b" :: Text) + , elementValue "majorTickMark" TickMarkNone + , elementValue "minorTickMark" TickMarkNone + , toElement "spPr" noFill + , elementValue "crossAx" cr + , elementValue "auto" True + ] + valAxEl :: Int -> Int -> Element + valAxEl i cr = + elementListSimple "valAx" $ + [ elementValue "axId" i + , emptyElement "scaling" + , elementValue "delete" False + , elementValue "axPos" ("l" :: Text) + , gridLinesEl + , elementValue "majorTickMark" TickMarkNone + , elementValue "minorTickMark" TickMarkNone + , toElement "spPr" noFill + , elementValue "crossAx" cr + ] + noFill = + def + { _spFill = Just NoFill + , _spOutline = Just . LineProperties $ Just NoFill + } + gridLinesEl = + elementListSimple "majorGridlines" [toElement "spPr" lineFill] + lineFill = def { _spOutline = Just . LineProperties $ Just SolidFill } + +chartToElement :: Chart -> Int -> Int -> Element +chartToElement LineChart {..} cId vId = elementListSimple "lineChart" elements + where + elements = + (grouping : varyColors : series) ++ + catMaybes + [ elementValue "marker" <$> _lnchMarker + , elementValue "smooth" <$> _lnchSmooth + ] ++ + map (elementValue "axId") [cId, vId] + grouping = elementValue "grouping" _lnchGrouping + -- no element seems to be equal to varyColors=true in Excel Online + varyColors = elementValue "varyColors" False + series = [indexedSeriesEl i s | (i, s) <- zip [0 ..] _lnchSeries] + indexedSeriesEl :: Int -> LineSeries -> Element + indexedSeriesEl i s = prependI i $ toElement "ser" s + prependI i e@Element {..} = e {elementNodes = iNodes i ++ elementNodes} + iNodes i = map NodeElement [elementValue n i | n <- ["idx", "order"]] + +instance ToAttrVal ChartGrouping where + toAttrVal PercentStackedGrouping = "percentStacked" + toAttrVal StandardGrouping = "standard" + toAttrVal StackedGrouping = "stacked" + +instance ToElement LineSeries where + toElement nm LineSeries {..} = serEl + { elementNodes = elementNodes serEl ++ + map NodeElement elements } + where + serEl = toElement nm _lnserShared + elements = + catMaybes + [ toElement "marker" <$> _lnserMarker + , toElement "dLbls" <$> _lnserDataLblProps + , Just $ valEl _lnserVal + , elementValue "smooth" <$> _lnserSmooth + ] + valEl v = + elementListSimple + "val" + [elementListSimple "numRef" $ maybeToList (toElement "f" <$> v)] + +instance ToElement DataMarker where + toElement nm DataMarker {..} = elementListSimple nm elements + where + elements = + catMaybes + [ elementValue "symbol" <$> _dmrkSymbol + , elementValue "size" <$> _dmrkSize + ] + +instance ToAttrVal DataMarkerSymbol where + toAttrVal DataMarkerCircle = "circle" + toAttrVal DataMarkerDash = "dash" + toAttrVal DataMarkerDiamond = "diamond" + toAttrVal DataMarkerDot = "dot" + toAttrVal DataMarkerNone = "none" + toAttrVal DataMarkerPicture = "picture" + toAttrVal DataMarkerPlus = "plus" + toAttrVal DataMarkerSquare = "square" + toAttrVal DataMarkerStar = "star" + toAttrVal DataMarkerTriangle = "triangle" + toAttrVal DataMarkerX = "x" + toAttrVal DataMarkerAuto = "auto" + +instance ToElement DataLblProps where + toElement nm DataLblProps {..} = elementListSimple nm elements + where + elements = + catMaybes + [ elementValue "showLegendKey" <$> _dlblShowLegendKey + , elementValue "showVal" <$> _dlblShowVal + , elementValue "showCatName" <$> _dlblShowCatName + , elementValue "showSerName" <$> _dlblShowSerName + , elementValue "showPercent" <$> _dlblShowPercent + ] + +-- should we respect idx and order? +instance ToElement Series where + toElement nm Series {..} = + elementListSimple + nm + [ elementListSimple + "tx" + [elementListSimple "strRef" $ maybeToList (toElement "f" <$> _serTx)] + ] + +instance ToElement ChartTitle where + toElement nm (ChartTitle body) = + elementListSimple nm [txEl, elementValue "overlay" False] + where + txEl = elementListSimple "tx" [toElement (c_ "rich") body] + +instance ToElement Legend where + toElement nm Legend{..} = elementListSimple nm elements + where + elements = catMaybes [ elementValue "legendPos" <$> _legendPos + , elementValue "overlay" <$>_legendOverlay] + +instance ToAttrVal LegendPos where + toAttrVal LegendBottom = "b" + toAttrVal LegendLeft = "l" + toAttrVal LegendRight = "r" + toAttrVal LegendTop = "t" + toAttrVal LegendTopRight = "tr" + +instance ToAttrVal DispBlanksAs where + toAttrVal DispBlanksAsGap = "gap" + toAttrVal DispBlanksAsSpan = "span" + toAttrVal DispBlanksAsZero = "zero" + +instance ToAttrVal TickMark where + toAttrVal TickMarkCross = "cross" + toAttrVal TickMarkIn = "in" + toAttrVal TickMarkNone = "none" + toAttrVal TickMarkOut = "out" + +-- | Add chart namespace to name +c_ :: Text -> Name +c_ x = + Name {nameLocalName = x, nameNamespace = Just chartNs, namePrefix = Just "c"} + +chartNs :: Text +chartNs = "http://schemas.openxmlformats.org/drawingml/2006/chart" diff --git a/src/Codec/Xlsx/Types/Drawing/Common.hs b/src/Codec/Xlsx/Types/Drawing/Common.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Drawing/Common.hs @@ -0,0 +1,536 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Codec.Xlsx.Types.Drawing.Common where + +import Control.Arrow (first) +import Control.Monad (join) +import Data.Default +import Data.Maybe (catMaybes, listToMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Read as T +import Text.XML +import Text.XML.Cursor + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Writer.Internal + +-- | This simple type represents an angle in 60,000ths of a degree. +-- Positive angles are clockwise (i.e., towards the positive y axis); negative +-- angles are counter-clockwise (i.e., towards the negative y axis). +newtype Angle = + Angle Int + deriving (Eq, Show) + +-- | A string with rich text formatting +-- +-- TODO: horzOverflow, lIns, tIns, rIns, bIns, numCol, spcCol, rtlCol, +-- fromWordArt, forceAA, upright, compatLnSpc, prstTxWarp, +-- a_EG_TextAutofit, scene3d, a_EG_Text3D, extLst +-- +-- See @CT_TextBody@ (p. 4034) +data TextBody = TextBody + { _txbdRotation :: Angle + -- ^ Specifies the rotation that is being applied to the text within the bounding box. + , _txbdSpcFirstLastPara :: Bool + -- ^ Specifies whether the before and after paragraph spacing defined by the user is + -- to be respected. + , _txbdVertOverflow :: TextVertOverflow + -- ^ Determines whether the text can flow out of the bounding box vertically. + , _txbdVertical :: TextVertical + -- ^ Determines if the text within the given text body should be displayed vertically. + , _txbdWrap :: TextWrap + -- ^ Specifies the wrapping options to be used for this text body. + , _txbdAnchor :: TextAnchoring + -- ^ Specifies the anchoring position of the txBody within the shape. + , _txbdAnchorCenter :: Bool + -- ^ Specifies the centering of the text box. The way it works fundamentally is + -- to determine the smallest possible "bounds box" for the text and then to center + -- that "bounds box" accordingly. This is different than paragraph alignment, which + -- aligns the text within the "bounds box" for the text. + , _txbdParagraphs :: [TextParagraph] + -- ^ Paragraphs of text within the containing text body + } deriving (Eq, Show) + +-- | Text vertical overflow +-- See 20.1.10.83 "ST_TextVertOverflowType (Text Vertical Overflow)" (p. 3083) +data TextVertOverflow + = TextVertOverflowClip + -- ^ Pay attention to top and bottom barriers. Provide no indication that there is + -- text which is not visible. + | TextVertOverflowEllipsis + -- ^ Pay attention to top and bottom barriers. Use an ellipsis to denote that + -- there is text which is not visible. + | TextVertOverflow + -- ^ Overflow the text and pay no attention to top and bottom barriers. + deriving (Eq, Show) + +-- | If there is vertical text, determines what kind of vertical text is going to be used. +-- +-- See 20.1.10.82 "ST_TextVerticalType (Vertical Text Types)" (p. 3083) +data TextVertical + = TextVerticalEA + -- ^ A special version of vertical text, where some fonts are displayed as if rotated + -- by 90 degrees while some fonts (mostly East Asian) are displayed vertical. + | TextVerticalHorz + -- ^ Horizontal text. This should be default. + | TextVerticalMongolian + -- ^ A special version of vertical text, where some fonts are displayed as if rotated + -- by 90 degrees while some fonts (mostly East Asian) are displayed vertical. The + -- difference between this and the 'TextVerticalEA' is the text flows top down then + -- LEFT RIGHT, instead of RIGHT LEFT + | TextVertical + -- ^ Determines if all of the text is vertical orientation (each line is 90 degrees + -- rotated clockwise, so it goes from top to bottom; each next line is to the left + -- from the previous one). + | TextVertical270 + -- ^ Determines if all of the text is vertical orientation (each line is 270 degrees + -- rotated clockwise, so it goes from bottom to top; each next line is to the right + -- from the previous one). + | TextVerticalWordArt + -- ^ Determines if all of the text is vertical ("one letter on top of another"). + | TextVerticalWordArtRtl + -- ^ Specifies that vertical WordArt should be shown from right to left rather than + -- left to right. + deriving (Eq, Show) + +-- | Text wrapping types +-- +-- See 20.1.10.84 "ST_TextWrappingType (Text Wrapping Types)" (p. 3084) +data TextWrap + = TextWrapNone + -- ^ No wrapping occurs on this text body. Words spill out without + -- paying attention to the bounding rectangle boundaries. + | TextWrapSquare + -- ^ Determines whether we wrap words within the bounding rectangle. + deriving (Eq, Show) + +-- | This type specifies a list of available anchoring types for text. +-- +-- See 20.1.10.59 "ST_TextAnchoringType (Text Anchoring Types)" (p. 3058) +data TextAnchoring + = TextAnchoringBottom + -- ^ Anchor the text at the bottom of the bounding rectangle. + | TextAnchoringCenter + -- ^ Anchor the text at the middle of the bounding rectangle. + | TextAnchoringDistributed + -- ^ Anchor the text so that it is distributed vertically. When text is horizontal, + -- this spaces out the actual lines of text and is almost always identical in + -- behavior to 'TextAnchoringJustified' (special case: if only 1 line, then anchored + -- in middle). When text is vertical, then it distributes the letters vertically. + -- This is different than 'TextAnchoringJustified', because it always forces distribution + -- of the words, even if there are only one or two words in a line. + | TextAnchoringJustified + -- ^ Anchor the text so that it is justified vertically. When text is horizontal, + -- this spaces out the actual lines of text and is almost always identical in + -- behavior to 'TextAnchoringDistributed' (special case: if only 1 line, then anchored at + -- top). When text is vertical, then it justifies the letters vertically. This is + -- different than 'TextAnchoringDistributed' because in some cases such as very little + -- text in a line, it does not justify. + | TextAnchoringTop + -- ^ Anchor the text at the top of the bounding rectangle. + deriving (Eq, Show) + +-- See 21.1.2.2.6 "p (Text Paragraphs)" (p. 3211) +data TextParagraph = TextParagraph + { _txpaDefCharProps :: Maybe TextCharacterProperties + , _txpaRuns :: [TextRun] + } deriving (Eq, Show) + +-- | Text character properties +-- +-- TODO: kumimoji, lang, altLang, sz, strike, kern, cap, spc, +-- normalizeH, baseline, noProof, dirty, err, smtClean, smtId, +-- bmk, ln, a_EG_FillProperties, a_EG_EffectProperties, highlight, +-- a_EG_TextUnderlineLine, a_EG_TextUnderlineFill, latin, ea, cs, +-- sym, hlinkClick, hlinkMouseOver, rtl, extLst +-- +-- See @CT_TextCharacterProperties@ (p. 4039) +data TextCharacterProperties = TextCharacterProperties + { _txchBold :: Bool + , _txchItalic :: Bool + , _txchUnderline :: Bool + } deriving (Eq, Show) + +-- | Text run +-- +-- TODO: br, fld +data TextRun = RegularRun + { _txrCharProps :: Maybe TextCharacterProperties + , _txrText :: Text + } deriving (Eq, Show) + +-- | This simple type represents a one dimensional position or length +-- +-- See 20.1.10.16 "ST_Coordinate (Coordinate)" (p. 2921) +data Coordinate + = UnqCoordinate Int + -- ^ see 20.1.10.19 "ST_CoordinateUnqualified (Coordinate)" (p. 2922) + | UniversalMeasure UnitIdentifier + Double + -- ^ see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793) + deriving (Eq, Show) + +-- | Units used in "Universal measure" coordinates +-- see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793) +data UnitIdentifier + = UnitCm -- "cm" As defined in ISO 31. + | UnitMm -- "mm" As defined in ISO 31. + | UnitIn -- "in" 1 in = 2.54 cm (informative) + | UnitPt -- "pt" 1 pt = 1/72 in (informative) + | UnitPc -- "pc" 1 pc = 12 pt (informative) + | UnitPi -- "pi" 1 pi = 12 pt (informative) + deriving (Eq, Show) + +-- See @CT_Point2D@ (p. 3989) +data Point2D = Point2D + { _pt2dX :: Coordinate + , _pt2dY :: Coordinate + } deriving (Eq, Show) + +unqPoint2D :: Int -> Int -> Point2D +unqPoint2D x y = Point2D (UnqCoordinate x) (UnqCoordinate y) + +-- | Positive position or length in EMUs, maximu allowed value is 27273042316900. +-- see 20.1.10.41 "ST_PositiveCoordinate (Positive Coordinate)" (p. 2942) +newtype PositiveCoordinate = + PositiveCoordinate Integer + deriving (Eq, Ord, Show) + +data PositiveSize2D = PositiveSize2D + { _ps2dX :: PositiveCoordinate + , _ps2dY :: PositiveCoordinate + } deriving (Eq, Show) + +-- See 20.1.7.6 "xfrm (2D Transform for Individual Objects)" (p. 2849) +data Transform2D = Transform2D + { _trRot :: Angle + -- ^ Specifies the rotation of the Graphic Frame. + , _trFlipH :: Bool + -- ^ Specifies a horizontal flip. When true, this attribute defines + -- that the shape is flipped horizontally about the center of its bounding box. + , _trFlipV :: Bool + -- ^ Specifies a vertical flip. When true, this attribute defines + -- that the shape is flipped vetically about the center of its bounding box. + , _trOffset :: Maybe Point2D + -- ^ See 20.1.7.4 "off (Offset)" (p. 2847) + , _trExtents :: Maybe PositiveSize2D + -- ^ See 20.1.7.3 "ext (Extents)" (p. 2846) or + -- 20.5.2.14 "ext (Shape Extent)" (p. 3165) + } deriving (Eq, Show) + +-- TODO: custGeom +data Geometry = + PresetGeometry + -- TODO: prst, avList + -- currently uses "rect" with empty avList + deriving (Eq, Show) + +-- See 20.1.2.2.35 "spPr (Shape Properties)" (p. 2751) +data ShapeProperties = ShapeProperties + { _spXfrm :: Maybe Transform2D + , _spGeometry :: Maybe Geometry + , _spFill :: Maybe FillProperties + , _spOutline :: Maybe LineProperties + -- TODO: bwMode, a_EG_EffectProperties, scene3d, sp3d, extLst + } deriving (Eq, Show) + +-- See 20.1.2.2.24 "ln (Outline)" (p. 2744) +data LineProperties = LineProperties + { _lnFill :: Maybe FillProperties + -- TODO: w, cap, cmpd, algn, a_EG_LineDashProperties, + -- a_EG_LineJoinProperties, headEnd, tailEnd, extLst + } deriving (Eq, Show) + +-- TODO: gradFill, pattFill +data FillProperties = + NoFill + -- ^ See 20.1.8.44 "noFill (No Fill)" (p. 2872) + | SolidFill + -- ^ Solid fill + -- TODO: colors + -- See 20.1.8.54 "solidFill (Solid Fill)" (p. 2879) + deriving (Eq, Show) + +{------------------------------------------------------------------------------- + Default instances +-------------------------------------------------------------------------------} + +instance Default ShapeProperties where + def = ShapeProperties Nothing Nothing Nothing Nothing + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromCursor TextBody where + fromCursor cur = do + cur' <- cur $/ element (a_ "bodyPr") + _txbdRotation <- fromAttributeDef "rot" (Angle 0) cur' + _txbdSpcFirstLastPara <- fromAttributeDef "spcFirstLastPara" False cur' + _txbdVertOverflow <- fromAttributeDef "vertOverflow" TextVertOverflow cur' + _txbdVertical <- fromAttributeDef "vert" TextVerticalHorz cur' + _txbdWrap <- fromAttributeDef "wrap" TextWrapSquare cur' + _txbdAnchor <- fromAttributeDef "anchor" TextAnchoringTop cur' + _txbdAnchorCenter <- fromAttributeDef "anchorCtr" False cur' + let _txbdParagraphs = cur $/ element (a_ "p") >=> fromCursor + return TextBody {..} + +instance FromCursor TextParagraph where + fromCursor cur = do + let _txpaDefCharProps = + join . listToMaybe $ + cur $/ element (a_ "pPr") >=> maybeFromElement (a_ "defRPr") + _txpaRuns = cur $/ element (a_ "r") >=> fromCursor + return TextParagraph {..} + +instance FromCursor TextCharacterProperties where + fromCursor cur = do + _txchBold <- fromAttributeDef "b" False cur + _txchItalic <- fromAttributeDef "i" False cur + _txchUnderline <- fromAttributeDef "u" False cur + return TextCharacterProperties {..} + +instance FromCursor TextRun where + fromCursor cur = do + _txrCharProps <- maybeFromElement (a_ "rPr") cur + _txrText <- cur $/ element (a_ "t") &/ content + return RegularRun {..} + +-- See 20.1.10.3 "ST_Angle (Angle)" (p. 2912) +instance FromAttrVal Angle where + fromAttrVal t = first Angle <$> fromAttrVal t + +-- See 20.1.10.83 "ST_TextVertOverflowType (Text Vertical Overflow)" (p. 3083) +instance FromAttrVal TextVertOverflow where + fromAttrVal "overflow" = readSuccess TextVertOverflow + fromAttrVal "ellipsis" = readSuccess TextVertOverflowEllipsis + fromAttrVal "clip" = readSuccess TextVertOverflowClip + fromAttrVal t = invalidText "TextVertOverflow" t + +instance FromAttrVal TextVertical where + fromAttrVal "horz" = readSuccess TextVerticalHorz + fromAttrVal "vert" = readSuccess TextVertical + fromAttrVal "vert270" = readSuccess TextVertical270 + fromAttrVal "wordArtVert" = readSuccess TextVerticalWordArt + fromAttrVal "eaVert" = readSuccess TextVerticalEA + fromAttrVal "mongolianVert" = readSuccess TextVerticalMongolian + fromAttrVal "wordArtVertRtl" = readSuccess TextVerticalWordArtRtl + fromAttrVal t = invalidText "TextVertical" t + +instance FromAttrVal TextWrap where + fromAttrVal "none" = readSuccess TextWrapNone + fromAttrVal "square" = readSuccess TextWrapSquare + fromAttrVal t = invalidText "TextWrap" t + +-- See 20.1.10.59 "ST_TextAnchoringType (Text Anchoring Types)" (p. 3058) +instance FromAttrVal TextAnchoring where + fromAttrVal "t" = readSuccess TextAnchoringTop + fromAttrVal "ctr" = readSuccess TextAnchoringCenter + fromAttrVal "b" = readSuccess TextAnchoringBottom + fromAttrVal "just" = readSuccess TextAnchoringJustified + fromAttrVal "dist" = readSuccess TextAnchoringDistributed + fromAttrVal t = invalidText "TextAnchoring" t + +instance FromCursor ShapeProperties where + fromCursor cur = do + _spXfrm <- maybeFromElement (a_ "xfrm") cur + let _spGeometry = listToMaybe $ cur $/ anyElement >=> fromCursor + _spFill = listToMaybe $ cur $/ anyElement >=> fillPropsFromNode . node + _spOutline <- maybeFromElement (a_ "ln") cur + return ShapeProperties {..} + +instance FromCursor Transform2D where + fromCursor cur = do + _trRot <- fromAttributeDef "rot" (Angle 0) cur + _trFlipH <- fromAttributeDef "flipH" False cur + _trFlipV <- fromAttributeDef "flipV" False cur + _trOffset <- maybeFromElement (a_ "off") cur + _trExtents <- maybeFromElement (a_ "ext") cur + return Transform2D{..} + +instance FromCursor Geometry where + fromCursor = geometryFromNode . node + +geometryFromNode :: Node -> [Geometry] +geometryFromNode n | n `nodeElNameIs` a_ "prstGeom" = + return PresetGeometry + | otherwise = fail "no matching geometry node" + +instance FromCursor LineProperties where + fromCursor cur = do + let _lnFill = listToMaybe $ cur $/ anyElement >=> fromCursor + return LineProperties{..} + +instance FromCursor Point2D where + fromCursor cur = do + x <- coordinate =<< fromAttribute "x" cur + y <- coordinate =<< fromAttribute "y" cur + return $ Point2D x y + +instance FromCursor PositiveSize2D where + fromCursor cur = do + cx <- PositiveCoordinate <$> fromAttribute "cx" cur + cy <- PositiveCoordinate <$> fromAttribute "cy" cur + return $ PositiveSize2D cx cy + +instance FromCursor FillProperties where + fromCursor = fillPropsFromNode . node + +fillPropsFromNode :: Node -> [FillProperties] +fillPropsFromNode n | n `nodeElNameIs` a_ "noFill" = return NoFill + | n `nodeElNameIs` a_ "solidFill" = return SolidFill + | otherwise = fail "no matching line fill node" + +coordinate :: Monad m => Text -> m Coordinate +coordinate t = case T.decimal t of + Right (d, leftover) | leftover == T.empty -> + return $ UnqCoordinate d + _ -> + case T.rational t of + Right (r, "cm") -> return $ UniversalMeasure UnitCm r + Right (r, "mm") -> return $ UniversalMeasure UnitMm r + Right (r, "in") -> return $ UniversalMeasure UnitIn r + Right (r, "pt") -> return $ UniversalMeasure UnitPt r + Right (r, "pc") -> return $ UniversalMeasure UnitPc r + Right (r, "pi") -> return $ UniversalMeasure UnitPi r + _ -> fail $ "invalid coordinate: " ++ show t + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToElement TextBody where + toElement nm TextBody {..} = elementListSimple nm (bodyPr : paragraphs) + where + bodyPr = leafElement (a_ "bodyPr") bodyPrAttrs + bodyPrAttrs = + catMaybes + [ "rot" .=? justNonDef (Angle 0) _txbdRotation + , "spcFirstLastPara" .=? justTrue _txbdSpcFirstLastPara + , "vertOverflow" .=? justNonDef TextVertOverflow _txbdVertOverflow + , "vert" .=? justNonDef TextVerticalHorz _txbdVertical + , "wrap" .=? justNonDef TextWrapSquare _txbdWrap + , "anchor" .=? justNonDef TextAnchoringTop _txbdAnchor + , "anchorCtr" .=? justTrue _txbdAnchorCenter + ] + paragraphs = map (toElement (a_ "p")) _txbdParagraphs + +instance ToElement TextParagraph where + toElement nm TextParagraph {..} = elementListSimple nm elements + where + elements = + case _txpaDefCharProps of + Just props -> (defRPr props) : runs + Nothing -> runs + defRPr props = + elementListSimple (a_ "pPr") [toElement (a_ "defRPr") props] + runs = map (toElement (a_ "r")) _txpaRuns + +instance ToElement TextCharacterProperties where + toElement nm TextCharacterProperties {..} = leafElement nm attrs + where + attrs = ["b" .= _txchBold, "i" .= _txchItalic, "u" .= _txchUnderline] + +instance ToElement TextRun where + toElement nm RegularRun {..} = elementListSimple nm elements + where + elements = + catMaybes + [ toElement (a_ "rPr") <$> _txrCharProps + , Just $ elementContent (a_ "t") _txrText + ] + +instance ToAttrVal TextVertOverflow where + toAttrVal TextVertOverflow = "overflow" + toAttrVal TextVertOverflowEllipsis = "ellipsis" + toAttrVal TextVertOverflowClip = "clip" + +instance ToAttrVal TextVertical where + toAttrVal TextVerticalHorz = "horz" + toAttrVal TextVertical = "vert" + toAttrVal TextVertical270 = "vert270" + toAttrVal TextVerticalWordArt = "wordArtVert" + toAttrVal TextVerticalEA = "eaVert" + toAttrVal TextVerticalMongolian = "mongolianVert" + toAttrVal TextVerticalWordArtRtl = "wordArtVertRtl" + +instance ToAttrVal TextWrap where + toAttrVal TextWrapNone = "none" + toAttrVal TextWrapSquare = "square" + +-- See 20.1.10.59 "ST_TextAnchoringType (Text Anchoring Types)" (p. 3058) +instance ToAttrVal TextAnchoring where + toAttrVal TextAnchoringTop = "t" + toAttrVal TextAnchoringCenter = "ctr" + toAttrVal TextAnchoringBottom = "b" + toAttrVal TextAnchoringJustified = "just" + toAttrVal TextAnchoringDistributed = "dist" + +instance ToAttrVal Angle where + toAttrVal (Angle x) = toAttrVal x + +instance ToElement ShapeProperties where + toElement nm ShapeProperties{..} = elementListSimple nm elements + where + elements = catMaybes [ toElement (a_ "xfrm") <$> _spXfrm + , geometryToElement <$> _spGeometry + , fillPropsToElement <$> _spFill + , toElement (a_ "ln") <$> _spOutline ] + +instance ToElement Point2D where + toElement nm Point2D{..} = leafElement nm [ "x" .= _pt2dX + , "y" .= _pt2dY + ] + +instance ToElement PositiveSize2D where + toElement nm PositiveSize2D{..} = leafElement nm [ "cx" .= _ps2dX + , "cy" .= _ps2dY ] + +instance ToAttrVal Coordinate where + toAttrVal (UnqCoordinate x) = toAttrVal x + toAttrVal (UniversalMeasure unit x) = toAttrVal x <> unitToText unit + where + unitToText UnitCm = "cm" + unitToText UnitMm = "mm" + unitToText UnitIn = "in" + unitToText UnitPt = "pt" + unitToText UnitPc = "pc" + unitToText UnitPi = "pi" + +instance ToAttrVal PositiveCoordinate where + toAttrVal (PositiveCoordinate x) = toAttrVal x + +instance ToElement Transform2D where + toElement nm Transform2D{..} = elementList nm attrs elements + where + attrs = catMaybes [ "rot" .=? justNonDef (Angle 0) _trRot + , "flipH" .=? justTrue _trFlipH + , "flipV" .=? justTrue _trFlipV ] + elements = catMaybes [ toElement (a_ "off") <$> _trOffset + , toElement (a_ "ext") <$> _trExtents ] + +geometryToElement :: Geometry -> Element +geometryToElement PresetGeometry = emptyElement (a_ "prstGeom") + +instance ToElement LineProperties where + toElement nm LineProperties{..} = + elementListSimple nm $ catMaybes [ fillPropsToElement <$> _lnFill ] + +fillPropsToElement :: FillProperties -> Element +fillPropsToElement NoFill = emptyElement (a_ "noFill") +fillPropsToElement SolidFill = emptyElement (a_ "solidFill") + +-- | Add DrawingML namespace to name +a_ :: Text -> Name +a_ x = + Name {nameLocalName = x, nameNamespace = Just drawingNs, namePrefix = Just "a"} + +drawingNs :: Text +drawingNs = "http://schemas.openxmlformats.org/drawingml/2006/main" diff --git a/src/Codec/Xlsx/Types/Internal/CfPair.hs b/src/Codec/Xlsx/Types/Internal/CfPair.hs --- a/src/Codec/Xlsx/Types/Internal/CfPair.hs +++ b/src/Codec/Xlsx/Types/Internal/CfPair.hs @@ -21,7 +21,7 @@ instance FromCursor CfPair where fromCursor cur = do sqref <- fromAttribute "sqref" cur - let cfRules = cur $/ element (n"cfRule") >=> fromCursor + let cfRules = cur $/ element (n_ "cfRule") >=> fromCursor return $ CfPair (sqref, cfRules) instance ToElement CfPair where diff --git a/src/Codec/Xlsx/Types/Internal/CommentTable.hs b/src/Codec/Xlsx/Types/Internal/CommentTable.hs --- a/src/Codec/Xlsx/Types/Internal/CommentTable.hs +++ b/src/Codec/Xlsx/Types/Internal/CommentTable.hs @@ -45,8 +45,8 @@ where commentToEl (ref, Comment{..}) = Element { elementName = "comment" - , elementAttributes = M.fromList [ ("ref", ref) - , ("authorId", lookupAuthor _commentAuthor)] + , elementAttributes = M.fromList [ ("ref" .= ref) + , ("authorId" .= lookupAuthor _commentAuthor)] , elementNodes = [NodeElement $ toElement "text" _commentText] } lookupAuthor a = fromJustNote "author lookup" $ M.lookup a authorIds @@ -58,15 +58,15 @@ instance FromCursor CommentTable where fromCursor cur = do - let authorNames = cur $/ element (n"authors") &/ element (n"author") &/ content + let authorNames = cur $/ element (n_ "authors") &/ element (n_ "author") >=> contentOrEmpty authors = M.fromList $ zip [0..] authorNames - items = cur $/ element (n"commentList") &/ element (n"comment") >=> parseComment authors + items = cur $/ element (n_ "commentList") &/ element (n_ "comment") >=> parseComment authors return . CommentTable $ M.fromList items parseComment :: Map Int Text -> Cursor -> [(CellRef, Comment)] parseComment authors cur = do - ref <- cur $| attribute "ref" - txt <- cur $/ element (n"text") >=> fromCursor + ref <- fromAttribute "ref" cur + txt <- cur $/ element (n_ "text") >=> fromCursor authorId <- cur $| attribute "authorId" >=> decimal let author = fromJustNote "authorId" $ M.lookup authorId authors return (ref, Comment txt author True) @@ -90,7 +90,8 @@ , "" , "" ] - commentShapes = [ commentShape (fromCellRef ref) (_commentVisible cmnt) + fromRef = fromJustNote "Invalid comment ref" . fromSingleCellRef + commentShapes = [ commentShape (fromRef ref) (_commentVisible cmnt) | (ref, cmnt) <- M.toList m ] commentShape (r, c) v = LB.concat [ " Text -> FilePath -> (RefId, Relationship) -relEntry i typ trg = (RefId ("rId" <> txti i), Relationship (stdRelType typ) trg) +size :: Relationships -> Int +size = Map.size . relMap +relEntry :: RefId -> Text -> FilePath -> (RefId, Relationship) +relEntry rId typ trg = (rId, Relationship (stdRelType typ) trg) + lookup :: RefId -> Relationships -> Maybe Relationship lookup ref = Map.lookup ref . relMap @@ -68,6 +71,9 @@ findRelByType :: Text -> Relationships -> Maybe Relationship findRelByType t (Relationships m) = find ((==t) . relType) (Map.elems m) + +allByType :: Text -> Relationships -> [Relationship] +allByType t (Relationships m) = filter ((==t) . relType) (Map.elems m) {------------------------------------------------------------------------------- Rendering diff --git a/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs --- a/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs +++ b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs @@ -81,7 +81,7 @@ instance FromCursor SharedStringTable where fromCursor cur = do let - items = cur $/ element (n"si") >=> fromCursor + items = cur $/ element (n_ "si") >=> fromCursor return (SharedStringTable (V.fromList items)) {------------------------------------------------------------------------------- diff --git a/src/Codec/Xlsx/Types/PivotTable.hs b/src/Codec/Xlsx/Types/PivotTable.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/PivotTable.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Codec.Xlsx.Types.PivotTable + ( PivotTable(..) + , PivotFieldName(..) + , PivotFieldInfo(..) + , PositionedField(..) + , DataField(..) + , ConsolidateFunction(..) + ) where + +import Control.Arrow (first) +import Data.Text (Text) + +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Writer.Internal + +data PivotTable = PivotTable + { _pvtName :: Text + , _pvtDataCaption :: Text + , _pvtRowFields :: [PositionedField] + , _pvtColumnFields :: [PositionedField] + , _pvtDataFields :: [DataField] + , _pvtFields :: [PivotFieldInfo] + , _pvtRowGrandTotals :: Bool + , _pvtColumnGrandTotals :: Bool + , _pvtOutline :: Bool + , _pvtOutlineData :: Bool + , _pvtLocation :: CellRef + , _pvtSrcSheet :: Text + , _pvtSrcRef :: Range + } deriving (Eq, Show) + +data PivotFieldInfo = PivotFieldInfo + { _pfiName :: PivotFieldName + , _pfiOutline :: Bool + } deriving (Eq, Show) + +newtype PivotFieldName = + PivotFieldName Text + deriving (Eq, Ord, Show) + +data PositionedField + = DataPosition + | FieldPosition PivotFieldName + deriving (Eq, Ord, Show) + +data DataField = DataField + { _dfField :: PivotFieldName + , _dfName :: Text + , _dfFunction :: ConsolidateFunction + } deriving (Eq, Show) + +-- | Data consolidation functions specified by the user and used to +-- consolidate ranges of data +-- +-- See 18.18.17 "ST_DataConsolidateFunction (Data Consolidation +-- Functions)" (p. 2447) +data ConsolidateFunction + = ConsolidateAverage + -- ^ The average of the values. + | ConsolidateCount + -- ^ The number of data values. The Count consolidation function + -- works the same as the COUNTA worksheet function. + | ConsolidateCountNums + -- ^ The number of data values that are numbers. The Count Nums + -- consolidation function works the same as the COUNT worksheet + -- function. + | ConsolidateMaximum + -- ^ The largest value. + | ConsolidateMinimum + -- ^ The smallest value. + | ConsolidateProduct + -- ^ The product of the values. + | ConsolidateStdDev + -- ^ An estimate of the standard deviation of a population, where + -- the sample is a subset of the entire population. + | ConsolidateStdDevP + -- ^ The standard deviation of a population, where the population + -- is all of the data to be summarized. + | ConsolidateSum + -- ^ The sum of the values. + | ConsolidateVariance + -- ^ An estimate of the variance of a population, where the sample + -- is a subset of the entire population. + | ConsolidateVarP + -- ^ The variance of a population, where the population is all of + -- the data to be summarized. + deriving (Eq, Show) + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToAttrVal ConsolidateFunction where + toAttrVal ConsolidateAverage = "average" + toAttrVal ConsolidateCount = "count" + toAttrVal ConsolidateCountNums = "countNums" + toAttrVal ConsolidateMaximum = "max" + toAttrVal ConsolidateMinimum = "min" + toAttrVal ConsolidateProduct = "product" + toAttrVal ConsolidateStdDev = "stdDev" + toAttrVal ConsolidateStdDevP = "stdDevp" + toAttrVal ConsolidateSum = "sum" + toAttrVal ConsolidateVariance = "var" + toAttrVal ConsolidateVarP = "varp" + +instance ToAttrVal PivotFieldName where + toAttrVal (PivotFieldName n) = toAttrVal n + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromAttrVal ConsolidateFunction where + fromAttrVal "average" = readSuccess ConsolidateAverage + fromAttrVal "count" = readSuccess ConsolidateCount + fromAttrVal "countNums" = readSuccess ConsolidateCountNums + fromAttrVal "max" = readSuccess ConsolidateMaximum + fromAttrVal "min" = readSuccess ConsolidateMinimum + fromAttrVal "product" = readSuccess ConsolidateProduct + fromAttrVal "stdDev" = readSuccess ConsolidateStdDev + fromAttrVal "stdDevp" = readSuccess ConsolidateStdDevP + fromAttrVal "sum" = readSuccess ConsolidateSum + fromAttrVal "var" = readSuccess ConsolidateVariance + fromAttrVal "varp" = readSuccess ConsolidateVarP + fromAttrVal t = invalidText "ConsolidateFunction" t + +instance FromAttrVal PivotFieldName where + fromAttrVal = fmap (first PivotFieldName) . fromAttrVal diff --git a/src/Codec/Xlsx/Types/PivotTable/Internal.hs b/src/Codec/Xlsx/Types/PivotTable/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/PivotTable/Internal.hs @@ -0,0 +1,16 @@ +module Codec.Xlsx.Types.PivotTable.Internal ( + CacheId(..) +) where + +import Control.Arrow (first) + +import Codec.Xlsx.Parser.Internal + +newtype CacheId = CacheId Int deriving Eq + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromAttrVal CacheId where + fromAttrVal = fmap (first CacheId) . fromAttrVal diff --git a/src/Codec/Xlsx/Types/RichText.hs b/src/Codec/Xlsx/Types/RichText.hs --- a/src/Codec/Xlsx/Types/RichText.hs +++ b/src/Codec/Xlsx/Types/RichText.hs @@ -255,28 +255,28 @@ -- | See @CT_RElt@, p. 3903 instance FromCursor RichTextRun where fromCursor cur = do - _richTextRunText <- cur $/ element (n"t") &/ content - _richTextRunProperties <- maybeFromElement (n"rPr") cur + _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 + _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{..} {------------------------------------------------------------------------------- diff --git a/src/Codec/Xlsx/Types/SheetViews.hs b/src/Codec/Xlsx/Types/SheetViews.hs --- a/src/Codec/Xlsx/Types/SheetViews.hs +++ b/src/Codec/Xlsx/Types/SheetViews.hs @@ -461,8 +461,8 @@ _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 + let _sheetViewPane = listToMaybe $ cur $/ element (n_ "pane") >=> fromCursor + _sheetViewSelection = cur $/ element (n_ "selection") >=> fromCursor return SheetView{..} -- | See @CT_Pane@, p. 3913 diff --git a/src/Codec/Xlsx/Types/StyleSheet.hs b/src/Codec/Xlsx/Types/StyleSheet.hs --- a/src/Codec/Xlsx/Types/StyleSheet.hs +++ b/src/Codec/Xlsx/Types/StyleSheet.hs @@ -1359,15 +1359,15 @@ instance FromCursor StyleSheet where fromCursor cur = do let - _styleSheetFonts = cur $/ element (n"fonts") &/ element (n"font") >=> fromCursor - _styleSheetFills = cur $/ element (n"fills") &/ element (n"fill") >=> fromCursor - _styleSheetBorders = cur $/ element (n"borders") &/ element (n"border") >=> fromCursor + _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 + _styleSheetCellXfs = cur $/ element (n_ "cellXfs") &/ element (n_ "xf") >=> fromCursor -- TODO: cellStyles - _styleSheetDxfs = cur $/ element (n"dxfs") &/ element (n"dxf") >=> fromCursor + _styleSheetDxfs = cur $/ element (n_ "dxfs") &/ element (n_ "dxf") >=> fromCursor _styleSheetNumFmts = M.fromList . map unNumFmtPair $ - cur $/ element (n"numFmts")&/ element (n"numFmt") >=> fromCursor + cur $/ element (n_ "numFmts")&/ element (n_ "numFmt") >=> fromCursor -- TODO: tableStyles -- TODO: colors -- TODO: extLst @@ -1376,21 +1376,21 @@ -- | 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 <- maybeBoolElemValue (n"b") cur - _fontItalic <- maybeBoolElemValue (n"i") cur - _fontStrikeThrough<- maybeBoolElemValue (n"strike") cur - _fontOutline <- maybeBoolElemValue (n"outline") cur - _fontShadow <- maybeBoolElemValue (n"shadow") cur - _fontCondense <- maybeBoolElemValue (n"condense") cur - _fontExtend <- maybeBoolElemValue (n"extend") cur - _fontColor <- maybeFromElement (n"color") cur - _fontSize <- maybeElementValue (n"sz") cur - _fontUnderline <- maybeElementValueDef (n"u") FontUnderlineSingle cur - _fontVertAlign <- maybeElementValue (n"vertAlign") cur - _fontScheme <- maybeElementValue (n"scheme") cur + _fontName <- maybeElementValue (n_ "name") cur + _fontCharset <- maybeElementValue (n_ "charset") cur + _fontFamily <- maybeElementValue (n_ "family") cur + _fontBold <- maybeBoolElementValue (n_ "b") cur + _fontItalic <- maybeBoolElementValue (n_ "i") cur + _fontStrikeThrough<- maybeBoolElementValue (n_ "strike") cur + _fontOutline <- maybeBoolElementValue (n_ "outline") cur + _fontShadow <- maybeBoolElementValue (n_ "shadow") cur + _fontCondense <- maybeBoolElementValue (n_ "condense") cur + _fontExtend <- maybeBoolElementValue (n_ "extend") cur + _fontColor <- maybeFromElement (n_ "color") cur + _fontSize <- maybeElementValue (n_ "sz") cur + _fontUnderline <- maybeElementValueDef (n_ "u") FontUnderlineSingle cur + _fontVertAlign <- maybeElementValue (n_ "vertAlign") cur + _fontScheme <- maybeElementValue (n_ "scheme") cur return Font{..} -- | See 18.18.94 "ST_FontFamily (Font Family)" (p. 2517) @@ -1436,15 +1436,15 @@ -- | See @CT_Fill@, p. 4484 instance FromCursor Fill where fromCursor cur = do - _fillPattern <- maybeFromElement (n"patternFill") cur + _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 + _fillPatternFgColor <- maybeFromElement (n_ "fgColor") cur + _fillPatternBgColor <- maybeFromElement (n_ "bgColor") cur return FillPattern{..} instance FromAttrVal PatternType where @@ -1475,21 +1475,21 @@ _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 + _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 + _borderStyleColor <- maybeFromElement (n_ "color") cur return BorderStyle{..} instance FromAttrVal LineStyle where @@ -1512,8 +1512,8 @@ -- | See @CT_Xf@, p. 4486 instance FromCursor CellXf where fromCursor cur = do - _cellXfAlignment <- maybeFromElement (n"alignment") cur - _cellXfProtection <- maybeFromElement (n"protection") cur + _cellXfAlignment <- maybeFromElement (n_ "alignment") cur + _cellXfProtection <- maybeFromElement (n_ "protection") cur _cellXfNumFmtId <- maybeAttribute "numFmtId" cur _cellXfFontId <- maybeAttribute "fontId" cur _cellXfFillId <- maybeAttribute "fillId" cur @@ -1532,11 +1532,11 @@ -- | See @CT_Dxf@, p. 3937 instance FromCursor Dxf where fromCursor cur = do - _dxfFont <- maybeFromElement (n"font") cur - _dxfFill <- maybeFromElement (n"fill") cur - _dxfAlignment <- maybeFromElement (n"alignment") cur - _dxfBorder <- maybeFromElement (n"border") cur - _dxfProtection <- maybeFromElement (n"protection") cur + _dxfFont <- maybeFromElement (n_ "font") cur + _dxfFill <- maybeFromElement (n_ "fill") cur + _dxfAlignment <- maybeFromElement (n_ "alignment") cur + _dxfBorder <- maybeFromElement (n_ "border") cur + _dxfProtection <- maybeFromElement (n_ "protection") cur return Dxf{..} -- | See @CT_CellAlignment@, p. 4482 diff --git a/src/Codec/Xlsx/Types/Variant.hs b/src/Codec/Xlsx/Types/Variant.hs --- a/src/Codec/Xlsx/Types/Variant.hs +++ b/src/Codec/Xlsx/Types/Variant.hs @@ -9,7 +9,7 @@ import Text.XML import Text.XML.Cursor -import Codec.Xlsx.Parser.Internal hiding (n) +import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Writer.Internal data Variant 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,7 +1,7 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} -- | This module provides a function for serializing structured `Xlsx` into lazy bytestring module Codec.Xlsx.Writer ( fromXlsx @@ -10,9 +10,10 @@ import qualified Codec.Archive.Zip as Zip import Control.Arrow (second) import Control.Lens hiding (transform, (.=)) +import Control.Monad (forM) import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Char8 () -import Data.List (foldl') +import Data.List (foldl', mapAccumL) import Data.Map (Map) import Data.STRef import Control.Monad.ST @@ -42,9 +43,12 @@ import Codec.Xlsx.Types.Internal.CfPair import qualified Codec.Xlsx.Types.Internal.CommentTable as CommentTable import Codec.Xlsx.Types.Internal.CustomProperties +import Codec.Xlsx.Types.Internal.DvPair import Codec.Xlsx.Types.Internal.Relationships as Relationships hiding (lookup) import Codec.Xlsx.Types.Internal.SharedStringTable +import Codec.Xlsx.Types.PivotTable.Internal import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Writer.Internal.PivotTable -- | Writes `Xlsx' to raw data (lazy bytestring) fromXlsx :: POSIXTime -> Xlsx -> L.ByteString @@ -55,25 +59,13 @@ utcTime = posixSecondsToUTCTime pt entries = Zip.toEntry "[Content_Types].xml" t (contentTypesXml files) : map (\fd -> Zip.toEntry (fdPath fd) t (fdContents fd)) files - -- TODO: root files should be only core.xml, app.xml and workbook.xml - files = sheetFiles ++ customPropFiles ++ + files = workbookFiles ++ customPropFiles ++ [ FileData "docProps/core.xml" "application/vnd.openxmlformats-package.core-properties+xml" "metadata/core-properties" $ coreXml utcTime "xlsxwriter" , FileData "docProps/app.xml" "application/vnd.openxmlformats-officedocument.extended-properties+xml" "xtended-properties" $ appXml sheetNames - , FileData "xl/workbook.xml" - "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml" - "officeDocument" $ bookXml sheetNames (xlsx ^. xlDefinedNames) - , FileData "xl/styles.xml" - "application/vnd.openxmlformats-officedocument.spreadsheetml.styles+xml" - "styles" $ unStyles (xlsx ^. xlStyles) - , FileData "xl/sharedStrings.xml" - "application/vnd.openxmlformats-officedocument.spreadsheetml.sharedStrings+xml" - "sharedStrings" $ ssXml shared - , FileData "xl/_rels/workbook.xml.rels" - "application/vnd.openxmlformats-package.relationships+xml" "relationships" bookRelsXml , FileData "_rels/.rels" "application/vnd.openxmlformats-package.relationships+xml" "relationships" rootRelXml ] @@ -82,7 +74,7 @@ [ ("officeDocument", "xl/workbook.xml") , ("metadata/core-properties", "docProps/core.xml") , ("extended-properties", "docProps/app.xml") ] - rootRels = [ relEntry i typ trg + rootRels = [ relEntry (unsafeRefId i) typ trg | (i, (typ, trg)) <- zip [1..] rootFiles ] customProps = xlsx ^. xlCustomProperties (customPropFiles, customPropFileRels) = case M.null customProps of @@ -92,19 +84,17 @@ "custom-properties" (customPropsXml (CustomProperties customProps)) ], [ ("custom-properties", "docProps/custom.xml") ]) - bookRelsXml = renderLBS def . toDocument $ bookRels sheetCount - sheetFiles = concat $ zipWith3 singleSheetFiles [1..] sheetCells sheets + workbookFiles = bookFiles xlsx sheetNames = xlsx ^. xlSheets . to (map fst) - sheets = xlsx ^. xlSheets . to (map snd) - sheetCount = length sheets - shared = sstConstruct sheets - sheetCells = map (transformSheetData shared) sheets -singleSheetFiles :: Int -> Cells -> Worksheet -> [FileData] -singleSheetFiles n cells ws = runST $ do +singleSheetFiles :: Int -> Cells -> [FileData] -> Worksheet -> (FileData, [FileData]) +singleSheetFiles n cells pivFileDatas ws = runST $ do ref <- newSTRef 1 mCmntData <- genComments n cells ref mDrawingData <- maybe (return Nothing) (fmap Just . genDrawing n ref) (ws ^. wsDrawing) + pivRefs <- forM pivFileDatas $ \fd -> do + refId <- nextRefId ref + return (refId, fd) let sheetFilePath = "xl/worksheets/sheet" <> show n <> ".xml" sheetFile = FileData sheetFilePath "application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml" @@ -112,25 +102,26 @@ sheetXml nss = [ ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ] sheetXml= renderLBS def{rsNamespaces=nss} $ Document (Prologue [] Nothing []) root [] - root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $ + root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" Nothing $ elementListSimple "worksheet" rootEls rootEls = catMaybes $ [ elementListSimple "sheetViews" . map (toElement "sheetView") <$> ws ^. wsSheetViews , nonEmptyElListSimple "cols" . map cwEl $ ws ^. wsColumns , Just . elementListSimple "sheetData" $ sheetDataXml cells (ws ^. wsRowPropertiesMap) - ] ++ - map (Just . toElement "conditionalFormatting") cfPairs ++ - [ nonEmptyElListSimple "mergeCells" . map mergeE1 $ ws ^. wsMerges + , nonEmptyElListSimple "mergeCells" . map mergeE1 $ ws ^. wsMerges + ] ++ map (Just . toElement "conditionalFormatting") cfPairs ++ + [ Just $ countedElementList "dataValidations" $ map (toElement "dataValidation") dvPairs , toElement "pageSetup" <$> ws ^. wsPageSetup , fst3 <$> mDrawingData , fst <$> mCmntData ] cfPairs = map CfPair . M.toList $ ws ^. wsConditionalFormattings + dvPairs = map DvPair . M.toList $ ws ^. wsDataValidations cwEl cw = leafElement "col" [ ("min", txti $ cwMin cw) , ("max", txti $ cwMax cw) , ("width", txtd $ cwWidth cw) , ("style", txti $ cwStyle cw)] - mergeE1 t = leafElement "mergeCell" [("ref", t)] + mergeE1 r = leafElement "mergeCell" [("ref" .= r)] sheetRels = if null referencedFiles then [] @@ -141,13 +132,23 @@ [ relEntry i fdRelType (fdPath `relFrom` sheetFilePath) | (i, FileData{..}) <- referenced ] referenced = fromMaybe [] (snd <$> mCmntData) ++ - catMaybes [ snd3 <$> mDrawingData ] + catMaybes [ snd3 <$> mDrawingData ] ++ + pivRefs referencedFiles = map snd referenced extraFiles = maybe [] thd3 mDrawingData otherFiles = sheetRels ++ referencedFiles ++ extraFiles - return (sheetFile:otherFiles) + return (sheetFile, otherFiles) +nextRefId :: STRef s Int -> ST s RefId +nextRefId r = do + num <- readSTRef r + modifySTRef' r (+1) + return (unsafeRefId num) + +unsafeRefId :: Int -> RefId +unsafeRefId num = RefId $ "rId" <> txti num + sheetDataXml :: Cells -> Map Int RowProperties -> [Element] sheetDataXml rows rh = map rowEl rows where @@ -163,11 +164,11 @@ Just (RowProps (Just h) Nothing ) -> ([("ht", txtd h)], True,[]) _ -> ([], False,[]) cellEl r (icol, cell) = - elementList "c" (cellAttrs (mkCellRef (r, icol)) cell) + elementList "c" (cellAttrs (singleCellRef (r, icol)) cell) (catMaybes [ elementContent "v" . value <$> xlsxCellValue cell , toElement "f" <$> xlsxCellFormula cell ]) - cellAttrs ref cell = cellStyleAttr cell ++ [("r", ref), ("t", xlsxCellType cell)] + cellAttrs ref cell = cellStyleAttr cell ++ [("r" .= ref), ("t" .= xlsxCellType cell)] cellStyleAttr XlsxCell{xlsxCellStyle=Nothing} = [] cellStyleAttr XlsxCell{xlsxCellStyle=Just s} = [("s", txti s)] @@ -177,16 +178,15 @@ then do return Nothing else do - rId1 <- readSTRef ref - let rId2 = rId1 + 1 - modifySTRef' ref (+2) + rId1 <- nextRefId ref + rId2 <- nextRefId ref let el = refElement "legacyDrawing" rId2 return $ Just (el, [(rId1, commentsFile), (rId2, vmlDrawingFile)]) where comments = concatMap (\(row, rowCells) -> mapMaybe (maybeCellComment row) rowCells) cells maybeCellComment row (col, cell) = do comment <- xlsxComment cell - return (mkCellRef (row, col), comment) + return (singleCellRef (row, col), comment) commentTable = CommentTable.fromList comments commentsFile = FileData commentsPath "application/vnd.openxmlformats-officedocument.spreadsheetml.comments+xml" @@ -203,50 +203,136 @@ genDrawing :: Int -> STRef s Int -> Drawing -> ST s (Element, ReferencedFileData, [FileData]) genDrawing n ref dr = do - rId <- readSTRef ref - modifySTRef' ref (+1) - let el = refElement "drawing" rId - return (el, (rId, drawingFile), referenced) + rId <- nextRefId ref + let el = refElement "drawing" rId + return (el, (rId, drawingFile), referenced) where - drawingFilePath = "xl/drawings/drawing" <> show n <> ".xml" - drawingFile = FileData drawingFilePath - "application/vnd.openxmlformats-officedocument.drawing+xml" - "drawing" drawingXml - drawingXml = renderLBS def{rsNamespaces=nss} $ toDocument dr' - nss = [ ("xdr", "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing") - , ("a", "http://schemas.openxmlformats.org/drawingml/2006/main") - , ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ] - dr' = Drawing{ _xdrAnchors = reverse anchors' } - (anchors', images, _) = foldl' collectImage ([], [], 1) (dr ^. xdrAnchors) - collectImage :: ([Anchor RefId], [Maybe FileInfo], Int) -> Anchor FileInfo - -> ([Anchor RefId], [Maybe FileInfo], Int) - collectImage (as, fis, i) anch0 = - case anch0 ^. anchObject of - pic@Picture{} -> - let anch = anch0{_anchObject = pic & picBlipFill . bfpImageInfo ?~ RefId ("rId" <> txti i)} - fi = pic ^. picBlipFill . bfpImageInfo - in (anch:as, fi:fis, i + 1) - imageFiles = [ FileData ("xl/media/" <> _fiFilename) - _fiContentType - "image" _fiContents - | FileInfo{..} <- reverse (catMaybes images) ] - drawingRels = FileData ("xl/drawings/_rels/drawing" <> show n <> ".xml.rels") - "application/vnd.openxmlformats-package.relationships+xml" - "relationships" drawingRelsXml - drawingRelsXml = renderLBS def . toDocument . Relationships.fromList $ - [ relEntry i fdRelType (fdPath `relFrom` drawingFilePath) - | (i, FileData{..}) <- zip [1..] imageFiles ] - referenced = case images of - [] -> [] - _ -> drawingRels:imageFiles + drawingFilePath = "xl/drawings/drawing" <> show n <> ".xml" + drawingFile = FileData drawingFilePath (smlCT "drawing") "drawing" drawingXml + drawingXml = renderLBS def{rsNamespaces=nss} $ toDocument dr' + nss = [ ("xdr", "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing") + , ("a", "http://schemas.openxmlformats.org/drawingml/2006/main") + , ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ] + dr' = Drawing{ _xdrAnchors = reverse anchors' } + (anchors', images, charts, _) = foldl' collectFile ([], [], [], 1) (dr ^. xdrAnchors) + collectFile :: ([Anchor RefId RefId], [Maybe (Int, FileInfo)], [(Int, ChartSpace)], Int) + -> Anchor FileInfo ChartSpace + -> ([Anchor RefId RefId], [Maybe (Int, FileInfo)], [(Int, ChartSpace)], Int) + collectFile (as, fis, chs, i) anch0 = + case anch0 ^. anchObject of + Picture {..} -> + let fi = (i,) <$> _picBlipFill ^. bfpImageInfo + pic' = + Picture + { _picMacro = _picMacro + , _picPublished = _picPublished + , _picNonVisual = _picNonVisual + , _picBlipFill = + (_picBlipFill & bfpImageInfo ?~ RefId ("rId" <> txti i)) + , _picShapeProperties = _picShapeProperties + } + anch = anch0 {_anchObject = pic'} + in (anch : as, fi : fis, chs, i + 1) + Graphic nv ch tr -> + let gr' = Graphic nv (RefId ("rId" <> txti i)) tr + anch = anch0 {_anchObject = gr'} + in (anch : as, fis, (i, ch) : chs, i + 1) + imageFiles = + [ ( unsafeRefId i + , FileData ("xl/media/" <> _fiFilename) _fiContentType "image" _fiContents) + | (i, FileInfo {..}) <- reverse (catMaybes images) + ] + chartFiles = + [ (unsafeRefId i, genChart n k chart) + | (k, (i, chart)) <- zip [1 ..] (reverse charts) + ] + + innerFiles = imageFiles ++ chartFiles + + drawingRels = + FileData + ("xl/drawings/_rels/drawing" <> show n <> ".xml.rels") + relsCT + "relationships" + drawingRelsXml + + drawingRelsXml = + renderLBS def . toDocument . Relationships.fromList $ + map (refFileDataToRel drawingFilePath) innerFiles + + referenced = + case innerFiles of + [] -> [] + _ -> drawingRels : (map snd innerFiles) + +genChart :: Int -> Int -> ChartSpace -> FileData +genChart n i ch = FileData path contentType relType contents + where + path = "xl/charts/chart" <> show n <> "_" <> show i <> ".xml" + contentType = + "application/vnd.openxmlformats-officedocument.drawingml.chart+xml" + relType = "chart" + contents = renderLBS def {rsNamespaces = nss} $ toDocument ch + nss = + [ ("c", "http://schemas.openxmlformats.org/drawingml/2006/chart") + , ("a", "http://schemas.openxmlformats.org/drawingml/2006/main") + ] + +data PvGenerated = PvGenerated + { pvgCacheFiles :: [(CacheId, FileData)] + , pvgSheetTableFiles :: [[FileData]] + , pvgOthers :: [FileData] + } + +generatePivotFiles :: [[PivotTable]] -> PvGenerated +generatePivotFiles tables = PvGenerated cacheFiles shTableFiles others + where + cacheFiles = [cacheFile | (cacheFile, _, _) <- flatRendered] + shTableFiles = map (map (\(_, tableFile, _) -> tableFile)) rendered + others = concat [other | (_, _, other) <- flatRendered] + firstCacheId = 1 + flatRendered = concat rendered + (_, rendered) = + mapAccumL + (\c ts -> mapAccumL (\c' t -> (c' + 1, render c' t)) c ts) + firstCacheId + tables + render cacheIdRaw tbl = + let PivotTableFiles {..} = renderPivotTableFiles cacheIdRaw tbl + cacheId = CacheId cacheIdRaw + cacheIdStr = show cacheIdRaw + cachePath = + "xl/pivotCache/pivotCacheDefinition" <> cacheIdStr <> ".xml" + cacheFile = + FileData + cachePath + (smlCT "pivotCacheDefinition") + "pivotCacheDefinition" + pvtfCacheDefinition + renderRels = renderLBS def . toDocument . Relationships.fromList + tablePath = "xl/pivotTables/pivotTable" <> cacheIdStr <> ".xml" + tableFile = + FileData tablePath (smlCT "pivotTable") "pivotTable" pvtfTable + tableRels = + FileData + ("xl/pivotTables/_rels/pivotTable" <> cacheIdStr <> ".xml.rels") + relsCT + "relationships" $ + renderRels [refFileDataToRel tablePath (unsafeRefId 1, cacheFile)] + in ((cacheId, cacheFile), tableFile, [tableRels]) + data FileData = FileData { fdPath :: FilePath , fdContentType :: Text , fdRelType :: Text , fdContents :: L.ByteString } -type ReferencedFileData = (Int, FileData) +type ReferencedFileData = (RefId, FileData) +refFileDataToRel :: FilePath -> ReferencedFileData -> (RefId, Relationship) +refFileDataToRel basePath (i, FileData {..}) = + relEntry i fdRelType (fdPath `relFrom` basePath) + type Cells = [(Int, [(Int, XlsxCell)])] coreXml :: UTCTime -> Text -> L.ByteString @@ -328,34 +414,92 @@ transformValue (CellBool b) = XlsxBool b transformValue (CellRich r) = XlsxSS (sstLookupRich shared r) -bookXml :: [Text] -> DefinedNames -> L.ByteString -bookXml sheetNames (DefinedNames names) = renderLBS def $ Document (Prologue [] Nothing []) root [] - where - numNames = [(txti i, name) | (i, name) <- zip [(1::Int)..] sheetNames] +bookFiles :: Xlsx -> [FileData] +bookFiles xlsx = runST $ do + ref <- newSTRef 1 + ssRId <- nextRefId ref + let sheets = xlsx ^. xlSheets . to (map snd) + shared = sstConstruct sheets + sharedStrings = + (ssRId, FileData "xl/sharedStrings.xml" (smlCT "sharedStrings") "sharedStrings" $ + ssXml shared) + stRId <- nextRefId ref + let style = + (stRId, FileData "xl/styles.xml" (smlCT "styles") "styles" $ + unStyles (xlsx ^. xlStyles)) + let PvGenerated + {pvgCacheFiles=cacheIdFiles, + pvgOthers=pivotOtherFiles, + pvgSheetTableFiles=sheetPivotTables} = + generatePivotFiles (xlsx ^. xlSheets . to (map (^. _2 . wsPivotTables))) + sheetCells = map (transformSheetData shared) sheets + sheetInputs = zip3 sheetCells sheetPivotTables sheets + allSheetFiles <- forM (zip [1..] sheetInputs) $ \(i, (cells, pvTables, sheet)) -> do + rId <- nextRefId ref + let (sheetFile, others) = singleSheetFiles i cells pvTables sheet + return ((rId, sheetFile), others) + let sheetFiles = map fst allSheetFiles + sheetNameByRId = zip (map fst sheetFiles) (xlsx ^. xlSheets . to (map fst)) + sheetOthers = concatMap snd allSheetFiles + cacheRefFDsById <- forM cacheIdFiles $ \(cacheId, fd) -> do + refId <- nextRefId ref + return (cacheId, (refId, fd)) + let cacheRefsById = [ (cId, rId) | (cId, (rId, _)) <- cacheRefFDsById ] + cacheRefs = map snd cacheRefFDsById + bookFile = FileData "xl/workbook.xml" (smlCT "sheet.main") "officeDocument" $ + bookXml sheetNameByRId (xlsx ^. xlDefinedNames) cacheRefsById + rels = FileData "xl/_rels/workbook.xml.rels" + "application/vnd.openxmlformats-package.relationships+xml" + "relationships" relsXml + relsXml = renderLBS def . toDocument . Relationships.fromList $ + [ relEntry i fdRelType (fdPath `relFrom` "xl/workbook.xml") + | (i, FileData{..}) <- referenced ] + referenced = sharedStrings:style:sheetFiles ++ cacheRefs + otherFiles = concat [rels:(map snd referenced), pivotOtherFiles, sheetOthers] + return $ bookFile:otherFiles +bookXml :: [(RefId, Text)] + -> DefinedNames + -> [(CacheId, RefId)] + -> L.ByteString +bookXml rIdNames (DefinedNames names) cacheIdRefs = + renderLBS def $ Document (Prologue [] Nothing []) root [] + where -- 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 "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, "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" - + root = + addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" Nothing $ + Element + "workbook" + M.empty + [ nEl "bookViews" M.empty [nEl "workbookView" M.empty []] + , nEl "sheets" M.empty $ + map + (\(i, (rId, name)) -> + NodeElement $ leafElement "sheet" + [ "name" .= name + , "sheetId" .= i + , (odr "id") .= rId + ] + ) + (zip [(1::Int)..] rIdNames) + , nEl "definedNames" M.empty $ + map + (\(name, lsId, val) -> + nEl "definedName" (definedName name lsId) [NodeContent val]) + names + , NodeElement . elementListSimple "pivotCaches" $ + map pivotCacheEl cacheIdRefs + ] + pivotCacheEl (CacheId cId, refId) = + leafElement "pivotCache" ["cacheId" .= cId, (odr "id") .= refId] definedName :: Text -> Maybe Text -> Map Name Text - definedName name Nothing = M.fromList [("name", name)] - definedName name (Just lsId) = M.fromList [("name", name), ("localSheetId", lsId)] + 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 @@ -363,17 +507,10 @@ customPropsXml :: CustomProperties -> L.ByteString customPropsXml = renderLBS def . toDocument -bookRels :: Int -> Relationships -bookRels n = Relationships.fromList (sheetRels ++ [stylesRel, ssRel]) - where - sheetRels = [relEntry i "worksheet" ("worksheets/sheet" <> show i <> ".xml") | i <- [1..n]] - stylesRel = relEntry (n + 1) "styles" "styles.xml" - ssRel = relEntry (n + 2) "sharedStrings" "sharedStrings.xml" - contentTypesXml :: [FileData] -> L.ByteString contentTypesXml fds = renderLBS def $ Document (Prologue [] Nothing []) root [] where - root = addNS "http://schemas.openxmlformats.org/package/2006/content-types" $ + root = addNS "http://schemas.openxmlformats.org/package/2006/content-types" Nothing $ Element "Types" M.empty $ map (\fd -> nEl "Override" (M.fromList [("PartName", T.concat ["/", T.pack $ fdPath fd]), ("ContentType", fdContentType fd)]) []) fds @@ -403,5 +540,12 @@ nEl name attrs nodes = NodeElement $ Element name attrs nodes -- | Creates element holding reference to some linked file -refElement :: Name -> Int -> Element -refElement name rId = leafElement name [ odr "id" .= ("rId" <> txti rId) ] +refElement :: Name -> RefId -> Element +refElement name rId = leafElement name [ odr "id" .= rId ] + +smlCT :: Text -> Text +smlCT t = + "application/vnd.openxmlformats-officedocument.spreadsheetml." <> t <> "+xml" + +relsCT :: Text +relsCT = "application/vnd.openxmlformats-package.relationships+xml" diff --git a/src/Codec/Xlsx/Writer/Internal.hs b/src/Codec/Xlsx/Writer/Internal.hs --- a/src/Codec/Xlsx/Writer/Internal.hs +++ b/src/Codec/Xlsx/Writer/Internal.hs @@ -7,6 +7,7 @@ ToDocument(..) , documentFromElement , documentFromNsElement + , documentFromNsPrefElement -- * Rendering elements , ToElement(..) , countedElementList @@ -54,11 +55,16 @@ toDocument :: a -> Document documentFromElement :: Text -> Element -> Document -documentFromElement comment e = documentFromNsElement comment mainNamespace e +documentFromElement comment e = + documentFromNsElement comment mainNamespace e documentFromNsElement :: Text -> Text -> Element -> Document -documentFromNsElement comment ns e = Document { - documentRoot = addNS ns e +documentFromNsElement comment ns e = + documentFromNsPrefElement comment ns Nothing e + +documentFromNsPrefElement :: Text -> Text -> Maybe Text -> Element -> Document +documentFromNsPrefElement comment ns prefix e = Document { + documentRoot = addNS ns prefix e , documentEpilogue = [] , documentPrologue = Prologue { prologueBefore = [MiscComment comment] @@ -132,8 +138,8 @@ instance ToAttrVal Double where toAttrVal = fromString . show instance ToAttrVal Bool where - toAttrVal True = "true" - toAttrVal False = "false" + toAttrVal True = "1" + toAttrVal False = "0" elementValue :: ToAttrVal a => Name -> a -> Element elementValue nm a = Element { @@ -161,8 +167,8 @@ -- | 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{ +addNS :: Text -> Maybe Text -> Element -> Element +addNS ns prefix Element{..} = Element{ elementName = goName elementName , elementAttributes = elementAttributes , elementNodes = map goNode elementNodes @@ -175,11 +181,11 @@ Nothing -> Name{ nameLocalName = nameLocalName , nameNamespace = Just ns - , namePrefix = Nothing + , namePrefix = prefix } goNode :: Node -> Node - goNode (NodeElement e) = NodeElement $ addNS ns e + goNode (NodeElement e) = NodeElement $ addNS ns prefix e goNode n = n -- | The main namespace for Excel @@ -188,7 +194,8 @@ txtd :: Double -> Text -txtd = toStrict . toLazyText . realFloat +txtd v | v - fromInteger (floor v) == 0 = toStrict . toLazyText $ formatRealFloat Generic (Just 0) v + | otherwise = toStrict . toLazyText $ realFloat v txtb :: Bool -> Text txtb = T.toLower . T.pack . show diff --git a/src/Codec/Xlsx/Writer/Internal/PivotTable.hs b/src/Codec/Xlsx/Writer/Internal/PivotTable.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Writer/Internal/PivotTable.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Codec.Xlsx.Writer.Internal.PivotTable + ( PivotTableFiles(..) + , renderPivotTableFiles + ) where + +import Data.ByteString.Lazy (ByteString) +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Safe (fromJustNote) +import Text.XML + +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.PivotTable +import Codec.Xlsx.Writer.Internal + +data PivotTableFiles = PivotTableFiles + { pvtfTable :: ByteString + , pvtfCacheDefinition :: ByteString + } deriving (Eq, Show) + +newtype CacheField = + CacheField Text + deriving (Eq, Show) + +data CacheDefinition = CacheDefinition + { cdSourceRef :: CellRef + , cdSourceSheet :: Text + , cdFields :: [CacheField] + } deriving (Eq, Show) + +renderPivotTableFiles :: Int -> PivotTable -> PivotTableFiles +renderPivotTableFiles cacheId t = PivotTableFiles {..} + where + pvtfTable = renderLBS def $ ptDefinitionDocument cacheId t + cacheDefinition = generateCache t + pvtfCacheDefinition = renderLBS def $ toDocument cacheDefinition + +ptDefinitionDocument :: Int -> PivotTable -> Document +ptDefinitionDocument cacheId t = + documentFromElement "Pivot table generated by xlsx" $ + ptDefinitionElement "pivotTableDefinition" cacheId t + +ptDefinitionElement :: Name -> Int -> PivotTable -> Element +ptDefinitionElement nm cacheId PivotTable {..} = + elementList nm attrs elements + where + attrs = + catMaybes + [ "colGrandTotals" .=? justFalse _pvtColumnGrandTotals + , "rowGrandTotals" .=? justFalse _pvtRowGrandTotals + , "outline" .=? justTrue _pvtOutline + , "outlineData" .=? justTrue _pvtOutlineData + ] ++ + [ "name" .= _pvtName + , "dataCaption" .= _pvtDataCaption + , "cacheId" .= cacheId + , "dataOnRows" .= (DataPosition `elem` _pvtRowFields) + ] + elements = [location, pivotFields, rowFields, colFields, dataFields] + location = + leafElement + "location" + [ "ref" .= _pvtLocation + -- TODO : set proper + , "firstHeaderRow" .= (1 :: Int) + , "firstDataRow" .= (2 :: Int) + , "firstDataCol" .= (1 :: Int) + ] + name2x = M.fromList $ zip (map _pfiName _pvtFields) [0 ..] + mapFieldToX f = fromJustNote "no field" $ M.lookup f name2x + pivotFields = + elementListSimple "pivotFields" $ map pFieldEl _pvtFields + pFieldEl PivotFieldInfo{_pfiName=fName, _pfiOutline=outline} + | FieldPosition fName `elem` _pvtRowFields = + pFieldEl' fName outline ("axisRow" :: Text) + | FieldPosition fName `elem` _pvtColumnFields = + pFieldEl' fName outline ("axisCol" :: Text) + | otherwise = + leafElement + "pivotField" + [ "name" .= fName + , "dataField" .= True + , "showAll" .= False + , "outline" .= outline + ] + pFieldEl' fName outline axis = + elementList + "pivotField" + [ "name" .= fName + , "axis" .= axis + , "showAll" .= False + , "outline" .= outline + ] + [ elementListSimple "items" $ + [leafElement "item" ["t" .= ("default" :: Text)]] + ] + rowFields = + elementListSimple "rowFields" . map fieldEl $ + if length _pvtDataFields > 1 + then _pvtRowFields + else filter (/= DataPosition) _pvtRowFields + colFields = elementListSimple "colFields" $ map fieldEl _pvtColumnFields + fieldEl p = leafElement "field" ["x" .= fieldPos p] + fieldPos DataPosition = (-2) :: Int + fieldPos (FieldPosition f) = mapFieldToX f + dataFields = elementListSimple "dataFields" $ map dFieldEl _pvtDataFields + dFieldEl DataField {..} = + leafElement "dataField" $ + catMaybes + [ "name" .=? Just _dfName + , "fld" .=? Just (mapFieldToX _dfField) + , "subtotal" .=? justNonDef ConsolidateSum _dfFunction + ] + +generateCache :: PivotTable -> CacheDefinition +generateCache PivotTable {..} = + CacheDefinition + { cdSourceRef = _pvtSrcRef + , cdSourceSheet = _pvtSrcSheet + , cdFields = cachedFields + } + where + cachedFields = map (cache . _pfiName) _pvtFields + cache (PivotFieldName name) = CacheField name + +instance ToDocument CacheDefinition where + toDocument = + documentFromElement "Pivot cache definition generated by xlsx" . + toElement "pivotCacheDefinition" + +instance ToElement CacheDefinition where + toElement nm CacheDefinition {..} = elementList nm attrs elements + where + attrs = ["invalid" .= True, "refreshOnLoad" .= True] + elements = [worksheetSource, cacheFields] + worksheetSource = + elementList + "cacheSource" + ["type" .= ("worksheet" :: Text)] + [ leafElement + "worksheetSource" + ["ref" .= cdSourceRef, "sheet" .= cdSourceSheet] + ] + cacheFields = + elementListSimple "cacheFields" $ map (toElement "cacheField") cdFields + +instance ToElement CacheField where + toElement nm (CacheField fieldName) = leafElement nm ["name" .= fieldName] + diff --git a/test/DataTest.hs b/test/DataTest.hs --- a/test/DataTest.hs +++ b/test/DataTest.hs @@ -1,12 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE QuasiQuotes #-} module Main (main) where import Control.Lens import Control.Monad.State.Lazy import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as LB import Data.Map (Map) import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import qualified Data.Text as T import Data.Time.Clock.POSIX (POSIXTime) import qualified Data.Vector as V import Text.RawString.QQ @@ -25,12 +29,15 @@ import Codec.Xlsx import Codec.Xlsx.Formatted import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Parser.Internal.PivotTable import Codec.Xlsx.Types.Internal import Codec.Xlsx.Types.Internal.CommentTable import Codec.Xlsx.Types.Internal.CustomProperties as CustomProperties import Codec.Xlsx.Types.Internal.SharedStringTable +import Codec.Xlsx.Types.PivotTable.Internal import Codec.Xlsx.Types.StyleSheet import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Writer.Internal.PivotTable import Diff @@ -39,24 +46,30 @@ testGroup "Tests" [ testProperty "col2int . int2col == id" $ \(Positive i) -> i == col2int (int2col i) - , testCase "write . read == id" $ + , testCase "write . read == id" $ do + let bs = fromXlsx testTime testXlsx + LB.writeFile "data-test.xlsx" bs testXlsx @==? toXlsx (fromXlsx testTime testXlsx) , testCase "fromRows . toRows == id" $ testCellMap1 @=? fromRows (toRows testCellMap1) , testCase "fromRight . parseStyleSheet . renderStyleSheet == id" $ testStyleSheet @==? fromRight (parseStyleSheet (renderStyleSheet testStyleSheet)) , testCase "correct shared strings parsing" $ - [testSharedStringTable] @=? testParsedSharedStringTables + [testSharedStringTable] @=? parseBS testStrings , testCase "correct shared strings parsing even when one of the shared strings entry is just " $ - [testSharedStringTableWithEmpty] @=? testParsedSharedStringTablesWithEmpty + [testSharedStringTableWithEmpty] @=? parseBS testStringsWithEmpty , testCase "correct comments parsing" $ - [testCommentTable] @=? testParsedComments + [testCommentTable] @=? parseBS testComments , testCase "correct drawing parsing" $ - [testDrawing] @==? parseDrawing testDrawingFile + [testDrawing] @==? parseBS testDrawingFile , testCase "write . read == id for Drawings" $ - [testDrawing] @==? parseDrawing testWrittenDrawing + [testDrawing] @==? parseBS testWrittenDrawing + , testCase "correct chart parsing" $ + [testChartSpace] @==? parseBS testChartFile + , testCase "write . read == id for Charts" $ + [testChartSpace] @==? parseBS testWrittenChartSpace , testCase "correct custom properties parsing" $ - [testCustomProperties] @==? testParsedCustomProperties + [testCustomProperties] @==? parseBS testCustomPropertiesXml , testCase "proper results from `formatted`" $ testFormattedResult @==? testRunFormatted , testCase "formatted . toFormattedCells = id" $ do @@ -69,38 +82,89 @@ Right testXlsx @==? toXlsxEither (fromXlsx testTime testXlsx) , testCase "toXlsxEither: invalid format" $ Left InvalidZipArchive @==? toXlsxEither "this is not a valid XLSX file" + , testCase "proper pivot table rendering" $ do + let ptFiles = renderPivotTableFiles 3 testPivotTable + parseLBS_ def (pvtfTable ptFiles) @==? + stripContentSpaces (parseLBS_ def testPivotTableDefinition) + parseLBS_ def (pvtfCacheDefinition ptFiles) @==? + stripContentSpaces (parseLBS_ def testPivotCacheDefinition) + , testCase "proper pivot table parsing" $ do + let sheetName = "Sheet1" + ref = CellRef "A1:D5" + fields = + [ PivotFieldName "Color" + , PivotFieldName "Year" + , PivotFieldName "Price" + , PivotFieldName "Count" + ] + forCacheId (CacheId 3) = Just (sheetName, ref, fields) + forCacheId _ = Nothing + Just (sheetName, ref, fields) @==? parseCache testPivotCacheDefinition + Just testPivotTable @==? parsePivotTable forCacheId testPivotTableDefinition ] +parseBS :: FromCursor a => ByteString -> [a] +parseBS = fromCursor . fromDocument . parseLBS_ def + testXlsx :: Xlsx testXlsx = Xlsx sheets minimalStyles definedNames customProperties where - sheets = [("List1", sheet1), ("Another sheet", sheet2)] - sheet1 = Worksheet cols rowProps testCellMap1 drawing ranges sheetViews pageSetup cFormatting + sheets = + [("List1", sheet1), ("Another sheet", sheet2), ("with pivot table", pvSheet)] + sheet1 = Worksheet cols rowProps testCellMap1 drawing ranges sheetViews pageSetup cFormatting validations [] sheet2 = def & wsCells .~ testCellMap2 + pvSheet = sheetWithPvCells & wsPivotTables .~ [testPivotTable] + sheetWithPvCells = flip execState def $ do + forM_ (zip [1..] ["Color", "Year", "Price", "Count"]) $ \(c, n) -> + cellValueAt (1, c) ?= CellText n + cellValueAt (2, 1) ?= CellText "brown" + cellValueAt (2, 2) ?= CellDouble 2016 + cellValueAt (2, 3) ?= CellDouble 12.34 + cellValueAt (2, 4) ?= CellDouble 42 rowProps = M.fromList [(1, RowProps (Just 50) (Just 3))] cols = [ColumnsWidth 1 10 15 1] - drawing = Just $ testDrawing { _xdrAnchors = [pic] } - pic = head (testDrawing ^. xdrAnchors) & anchObject . picBlipFill . bfpImageInfo ?~ fileInfo + drawing = Just $ testDrawing { _xdrAnchors = map resolve $ _xdrAnchors testDrawing } + resolve :: Anchor RefId RefId -> Anchor FileInfo ChartSpace + resolve Anchor {..} = + let obj = + case _anchObject of + Picture {..} -> + let picBlipFill = (_picBlipFill & bfpImageInfo ?~ fileInfo) + in Picture + { _picMacro = _picMacro + , _picPublished = _picPublished + , _picNonVisual = _picNonVisual + , _picBlipFill = picBlipFill + , _picShapeProperties = _picShapeProperties + } + Graphic nv _ tr -> + Graphic nv testChartSpace tr + in Anchor + { _anchAnchoring = _anchAnchoring + , _anchObject = obj + , _anchClientData = _anchClientData + } fileInfo = FileInfo "dummy.png" "image/png" "fake contents" 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 + sheetView1 = def & sheetViewRightToLeft ?~ True + & sheetViewTopLeftCell ?~ CellRef "B5" + sheetView2 = def & sheetViewType ?~ SheetViewTypePageBreakPreview & sheetViewWorkbookViewId .~ 5 - & sheetViewSelection .~ [ def & selectionActiveCell .~ Just "C2" - & selectionPane .~ Just PaneTypeBottomRight - , def & selectionActiveCellId .~ Just 1 - & selectionSqref ?~ SqRef ["A3:A10","B1:G3"] + & sheetViewSelection .~ [ def & selectionActiveCell ?~ CellRef "C2" + & selectionPane ?~ PaneTypeBottomRight + , def & selectionActiveCellId ?~ 1 + & selectionSqref ?~ SqRef [ CellRef "A3:A10" + , CellRef "B1:G3"] ] - pageSetup = Just $ def & pageSetupBlackAndWhite .~ Just True - & pageSetupCopies .~ Just 2 - & pageSetupErrors .~ Just PrintErrorsDash - & pageSetupPaperSize .~ Just PaperA4 + pageSetup = Just $ def & pageSetupBlackAndWhite ?~ True + & pageSetupCopies ?~ 2 + & pageSetupErrors ?~ PrintErrorsDash + & pageSetupPaperSize ?~ PaperA4 customProperties = M.fromList [("some_prop", VtInt 42)] - cFormatting = M.fromList [(SqRef ["A1:B3"], rules1), (SqRef ["C1:C10"], rules2)] + cFormatting = M.fromList [(SqRef [CellRef "A1:B3"], rules1), (SqRef [CellRef "C1:C10"], rules2)] cfRule c d = CfRule { _cfrCondition = c , _cfrDxfId = Just d , _cfrPriority = topCfPriority @@ -193,15 +257,9 @@ testSharedStringTableWithEmpty = SharedStringTable $ V.fromList [XlsxText ""] -testParsedSharedStringTables ::[SharedStringTable] -testParsedSharedStringTables = fromCursor . fromDocument $ parseLBS_ def testStrings - -testParsedSharedStringTablesWithEmpty :: [SharedStringTable] -testParsedSharedStringTablesWithEmpty = fromCursor . fromDocument $ parseLBS_ def testStringsWithEmpty - testCommentTable = CommentTable $ M.fromList - [ ("D4", Comment (XlsxRichText rich) "Bob" True) - , ("A2", Comment (XlsxText "Some comment here") "CBR" True) ] + [ (CellRef "D4", Comment (XlsxRichText rich) "Bob" True) + , (CellRef "A2", Comment (XlsxText "Some comment here") "CBR" True) ] where rich = [ RichTextRun { _richTextRunProperties = @@ -220,9 +278,6 @@ & runPropertiesSize ?~ 8.0 , _richTextRunText = "Why such high expense?"}] -testParsedComments ::[CommentTable] -testParsedComments = fromCursor . fromDocument $ parseLBS_ def testComments - testStrings :: ByteString testStrings = "\ \\ @@ -271,45 +326,96 @@ |] -testDrawing = Drawing [ anchor ] +testDrawing :: UnresolvedDrawing +testDrawing = Drawing [anchor1, anchor2] where - anchor = Anchor - { _anchAnchoring = anchoring - , _anchObject = pic - , _anchClientData = def } - anchoring = TwoCellAnchor - { tcaFrom = unqMarker ( 0, 0) ( 0, 0) - , tcaTo = unqMarker (12, 320760) (33, 38160) - , tcaEditAs = EditAsAbsolute } - pic = Picture - { _picMacro = Nothing - , _picPublished = False - , _picNonVisual = nonVis - , _picBlipFill = bfProps - , _picShapeProperties = shProps } - nonVis = PicNonVisual $ PicDrawingNonVisual - { _pdnvId = 0 - , _pdnvName = "Picture 1" - , _pdnvDescription = Just "" - , _pdnvHidden = False - , _pdnvTitle = Nothing } - bfProps = BlipFillProperties - { _bfpImageInfo = Just (RefId "rId1") - , _bfpFillMode = Just FillStretch } - shProps = ShapeProperties - { _spXfrm = Just trnsfrm - , _spGeometry = Just PresetGeometry - , _spOutline = Just $ LineProperties (Just LineNoFill) } - trnsfrm = Transform2D - { _trRot = Angle 0 - , _trFlipH = False - , _trFlipV = False - , _trOffset = Just (unqPoint2D 0 0) - , _trExtents = Just (PositiveSize2D (PositiveCoordinate 10074240) - (PositiveCoordinate 5402520)) } + anchor1 = + Anchor + {_anchAnchoring = anchoring1, _anchObject = pic, _anchClientData = def} + anchoring1 = + TwoCellAnchor + { tcaFrom = unqMarker (0, 0) (0, 0) + , tcaTo = unqMarker (12, 320760) (33, 38160) + , tcaEditAs = EditAsAbsolute + } + pic = + Picture + { _picMacro = Nothing + , _picPublished = False + , _picNonVisual = nonVis1 + , _picBlipFill = bfProps + , _picShapeProperties = shProps + } + nonVis1 = + PicNonVisual $ + NonVisualDrawingProperties + { _nvdpId = 0 + , _nvdpName = "Picture 1" + , _nvdpDescription = Just "" + , _nvdpHidden = False + , _nvdpTitle = Nothing + } + bfProps = + BlipFillProperties + {_bfpImageInfo = Just (RefId "rId1"), _bfpFillMode = Just FillStretch} + shProps = + ShapeProperties + { _spXfrm = Just trnsfrm + , _spGeometry = Just PresetGeometry + , _spFill = Nothing + , _spOutline = Just $ LineProperties (Just NoFill) + } + trnsfrm = + Transform2D + { _trRot = Angle 0 + , _trFlipH = False + , _trFlipV = False + , _trOffset = Just (unqPoint2D 0 0) + , _trExtents = + Just + (PositiveSize2D + (PositiveCoordinate 10074240) + (PositiveCoordinate 5402520)) + } + anchor2 = + Anchor + { _anchAnchoring = anchoring2 + , _anchObject = graphic + , _anchClientData = def + } + anchoring2 = + TwoCellAnchor + { tcaFrom = unqMarker (0, 87840) (21, 131040) + , tcaTo = unqMarker (7, 580320) (38, 132480) + , tcaEditAs = EditAsOneCell + } + graphic = + Graphic + { _grNonVisual = nonVis2 + , _grChartSpace = RefId "rId2" + , _grTransform = transform + } + nonVis2 = GraphNonVisual $ + NonVisualDrawingProperties + { _nvdpId = 1 + , _nvdpName = "" + , _nvdpDescription = Nothing + , _nvdpHidden = False + , _nvdpTitle = Nothing + } + transform = + Transform2D + { _trRot = Angle 0 + , _trFlipH = False + , _trFlipV = False + , _trOffset = Just (unqPoint2D 0 0) + , _trExtents = + Just + (PositiveSize2D + (PositiveCoordinate 10074240) + (PositiveCoordinate 5402520)) + } -parseDrawing :: ByteString -> [UnresolvedDrawing] -parseDrawing bs = fromCursor . fromDocument $ parseLBS_ def bs testDrawingFile :: ByteString testDrawingFile = [r| @@ -334,6 +440,26 @@ + + + 087840 + 21131040 + + + 7580320 + 38132480 + + + + + + + + + + + + |] @@ -348,9 +474,6 @@ , ("prop333", VtInt 1) , ("decimal", VtDecimal 1.234) ] -testParsedCustomProperties ::[CustomProperties] -testParsedCustomProperties = fromCursor . fromDocument $ parseLBS_ def testCustomPropertiesXml - testCustomPropertiesXml :: ByteString testCustomPropertiesXml = [r| @@ -448,9 +571,9 @@ dxfs = [ def & dxfFont ?~ (def & fontUnderline ?~ FontUnderlineSingle) , def & dxfFont ?~ (def & fontStrikeThrough ?~ True) , def & dxfFont ?~ (def & fontBold ?~ True) ] - formattings = M.fromList [ (SqRef ["A1:A2", "B2:B3"], [cfRule1, cfRule2]) - , (SqRef ["C3:E10"], [cfRule1]) - , (SqRef ["F1:G10"], [cfRule3]) ] + formattings = M.fromList [ (SqRef [CellRef "A1:A2", CellRef "B2:B3"], [cfRule1, cfRule2]) + , (SqRef [CellRef "C3:E10"], [cfRule1]) + , (SqRef [CellRef "F1:G10"], [cfRule3]) ] cfRule1 = CfRule { _cfrCondition = ContainsBlanks , _cfrDxfId = Just 0 @@ -487,7 +610,241 @@ & condfmtDxf . dxfFont . non def . fontStrikeThrough ?~ True cfRule3 = def & condfmtCondition .~ CellIs (OpGreaterThan (Formula "A1")) & condfmtDxf . dxfFont . non def . fontBold ?~ True - at "A1:A2" ?= [cfRule1, cfRule2] - at "B2:B3" ?= [cfRule1, cfRule2] - at "C3:E10" ?= [cfRule1] - at "F1:G10" ?= [cfRule3] + at (CellRef "A1:A2") ?= [cfRule1, cfRule2] + at (CellRef "B2:B3") ?= [cfRule1, cfRule2] + at (CellRef "C3:E10") ?= [cfRule1] + at (CellRef "F1:G10") ?= [cfRule3] + +testChartFile :: ByteString +testChartFile = [r| + + + + + Line chart title + + + + + + + Sheet1!$A$1 + + Sheet1!$B$1:$D$1 + + + + + Sheet1!$A$2 + + Sheet1!$B$2:$D$2 + + + + + + + + + + +|] + +testChartSpace :: ChartSpace +testChartSpace = + ChartSpace + { _chspTitle = Just $ ChartTitle titleBody + , _chspCharts = charts + , _chspLegend = Nothing + , _chspPlotVisOnly = Just True + , _chspDispBlanksAs = Just DispBlanksAsGap + } + where + titleBody = + TextBody + { _txbdRotation = Angle 0 + , _txbdSpcFirstLastPara = False + , _txbdVertOverflow = TextVertOverflow + , _txbdVertical = TextVerticalHorz + , _txbdWrap = TextWrapSquare + , _txbdAnchor = TextAnchoringBottom + , _txbdAnchorCenter = False + , _txbdParagraphs = + [TextParagraph Nothing [RegularRun Nothing "Line chart title"]] + } + charts = + [ LineChart + { _lnchGrouping = StandardGrouping + , _lnchSeries = series + , _lnchMarker = Just False + , _lnchSmooth = Just False + } + ] + series = + [ LineSeries + { _lnserShared = Series . Just $ Formula "Sheet1!$A$1" + , _lnserMarker = Just markerNone + , _lnserDataLblProps = Nothing + , _lnserVal = Just $ Formula "Sheet1!$B$1:$D$1" + , _lnserSmooth = Just False + } + , LineSeries + { _lnserShared = Series . Just $ Formula "Sheet1!$A$2" + , _lnserMarker = Just markerNone + , _lnserDataLblProps = Nothing + , _lnserVal = Just $ Formula "Sheet1!$B$2:$D$2" + , _lnserSmooth = Just False + } + ] + markerNone = + DataMarker {_dmrkSymbol = Just DataMarkerNone, _dmrkSize = Nothing} + +testWrittenChartSpace :: ByteString +testWrittenChartSpace = renderLBS def{rsNamespaces=nss} $ toDocument testChartSpace + where + nss = [ ("c", "http://schemas.openxmlformats.org/drawingml/2006/chart") + , ("a", "http://schemas.openxmlformats.org/drawingml/2006/main") ] + + +validations :: Map SqRef DataValidation +validations = M.fromList + [ ( SqRef [CellRef "A1"], def + ) + , ( SqRef [CellRef "A1", CellRef "B2:C3"], def + { _dvAllowBlank = True + , _dvError = Just "incorrect data" + , _dvErrorStyle = ErrorStyleInformation + , _dvErrorTitle = Just "error title" + , _dvPrompt = Just "enter data" + , _dvPromptTitle = Just "prompt title" + , _dvShowDropDown = True + , _dvShowErrorMessage = True + , _dvShowInputMessage = True + , _dvValidationType = ValidationTypeList ["aaaa","bbbb","cccc"] + } + ) + , ( SqRef [CellRef "A6", CellRef "I2"], def + { _dvAllowBlank = False + , _dvError = Just "aaa" + , _dvErrorStyle = ErrorStyleWarning + , _dvErrorTitle = Just "bbb" + , _dvPrompt = Just "ccc" + , _dvPromptTitle = Just "ddd" + , _dvShowDropDown = False + , _dvShowErrorMessage = False + , _dvShowInputMessage = False + , _dvValidationType = ValidationTypeDecimal $ ValGreaterThan $ Formula "10" + } + ) + , ( SqRef [CellRef "A7"], def + { _dvAllowBlank = False + , _dvError = Just "aaa" + , _dvErrorStyle = ErrorStyleStop + , _dvErrorTitle = Just "bbb" + , _dvPrompt = Just "ccc" + , _dvPromptTitle = Just "ddd" + , _dvShowDropDown = False + , _dvShowErrorMessage = False + , _dvShowInputMessage = False + , _dvValidationType = ValidationTypeWhole $ ValNotBetween (Formula "10") (Formula "12") + } + ) + ] + +testPivotTable :: PivotTable +testPivotTable = + PivotTable + { _pvtName = "PivotTable1" + , _pvtDataCaption = "Values" + , _pvtLocation = CellRef "A3:D12" + , _pvtSrcRef = CellRef "A1:D5" + , _pvtSrcSheet = "Sheet1" + , _pvtRowFields = [FieldPosition colorField, DataPosition] + , _pvtColumnFields = [FieldPosition yearField] + , _pvtDataFields = + [ DataField + { _dfName = "Sum of field Price" + , _dfField = priceField + , _dfFunction = ConsolidateSum + } + , DataField + { _dfName = "Sum of field Count" + , _dfField = countField + , _dfFunction = ConsolidateSum + } + ] + , _pvtFields = + [ PivotFieldInfo colorField False + , PivotFieldInfo yearField True + , PivotFieldInfo priceField False + , PivotFieldInfo countField False + ] + , _pvtRowGrandTotals = True + , _pvtColumnGrandTotals = False + , _pvtOutline = False + , _pvtOutlineData = False + } + where + colorField = PivotFieldName "Color" + yearField = PivotFieldName "Year" + priceField = PivotFieldName "Price" + countField = PivotFieldName "Count" + +testPivotTableDefinition :: ByteString +testPivotTableDefinition = [r| + + + + + + + + + + + + + + + + + + + + + + + + +|] + +testPivotCacheDefinition :: ByteString +testPivotCacheDefinition = [r| + + + + + + + + + + + + +|] + +stripContentSpaces :: Document -> Document +stripContentSpaces doc@Document {documentRoot = root} = + doc {documentRoot = go root} + where + go e@Element {elementNodes = nodes} = + e {elementNodes = mapMaybe goNode nodes} + goNode (NodeElement el) = Just $ NodeElement (go el) + goNode t@(NodeContent txt) = + if T.strip txt == T.empty + then Nothing + else Just t + goNode other = Just $ other diff --git a/xlsx.cabal b/xlsx.cabal --- a/xlsx.cabal +++ b/xlsx.cabal @@ -1,6 +1,6 @@ Name: xlsx -Version: 0.3.0 +Version: 0.4.0 Synopsis: Simple and incomplete Excel file parser/writer Description: @@ -38,15 +38,21 @@ , Codec.Xlsx.Types.Comment , Codec.Xlsx.Types.Common , Codec.Xlsx.Types.ConditionalFormatting + , Codec.Xlsx.Types.DataValidation , Codec.Xlsx.Types.Drawing + , Codec.Xlsx.Types.Drawing.Chart + , Codec.Xlsx.Types.Drawing.Common , Codec.Xlsx.Types.Internal , Codec.Xlsx.Types.Internal.CfPair , Codec.Xlsx.Types.Internal.CommentTable , Codec.Xlsx.Types.Internal.ContentTypes , Codec.Xlsx.Types.Internal.CustomProperties + , Codec.Xlsx.Types.Internal.DvPair , Codec.Xlsx.Types.Internal.NumFmtPair , Codec.Xlsx.Types.Internal.Relationships , Codec.Xlsx.Types.Internal.SharedStringTable + , Codec.Xlsx.Types.PivotTable + , Codec.Xlsx.Types.PivotTable.Internal , Codec.Xlsx.Types.RichText , Codec.Xlsx.Types.SheetViews , Codec.Xlsx.Types.PageSetup @@ -55,9 +61,11 @@ , Codec.Xlsx.Lens , Codec.Xlsx.Parser , Codec.Xlsx.Parser.Internal + , Codec.Xlsx.Parser.Internal.PivotTable , Codec.Xlsx.Formatted , Codec.Xlsx.Writer , Codec.Xlsx.Writer.Internal + , Codec.Xlsx.Writer.Internal.PivotTable Build-depends: base == 4.* , binary-search @@ -110,6 +118,7 @@ , tasty , tasty-hunit , tasty-smallcheck + , text , time , vector , xlsx