xlsx 0.3.0 → 0.4.0
raw patch · 28 files changed
+2812/−717 lines, 28 filesdep ~text
Dependency ranges changed: text
Files
- CHANGELOG.markdown +9/−0
- src/Codec/Xlsx/Formatted.hs +2/−2
- src/Codec/Xlsx/Parser.hs +97/−44
- src/Codec/Xlsx/Parser/Internal.hs +27/−10
- src/Codec/Xlsx/Parser/Internal/PivotTable.hs +77/−0
- src/Codec/Xlsx/Types.hs +22/−47
- src/Codec/Xlsx/Types/Common.hs +91/−40
- src/Codec/Xlsx/Types/ConditionalFormatting.hs +1/−1
- src/Codec/Xlsx/Types/DataValidation.hs +222/−0
- src/Codec/Xlsx/Types/Drawing.hs +120/−303
- src/Codec/Xlsx/Types/Drawing/Chart.hs +485/−0
- src/Codec/Xlsx/Types/Drawing/Common.hs +536/−0
- src/Codec/Xlsx/Types/Internal/CfPair.hs +1/−1
- src/Codec/Xlsx/Types/Internal/CommentTable.hs +8/−7
- src/Codec/Xlsx/Types/Internal/DvPair.hs +30/−0
- src/Codec/Xlsx/Types/Internal/Relationships.hs +8/−2
- src/Codec/Xlsx/Types/Internal/SharedStringTable.hs +1/−1
- src/Codec/Xlsx/Types/PivotTable.hs +131/−0
- src/Codec/Xlsx/Types/PivotTable/Internal.hs +16/−0
- src/Codec/Xlsx/Types/RichText.hs +17/−17
- src/Codec/Xlsx/Types/SheetViews.hs +2/−2
- src/Codec/Xlsx/Types/StyleSheet.hs +41/−41
- src/Codec/Xlsx/Types/Variant.hs +1/−1
- src/Codec/Xlsx/Writer.hs +250/−106
- src/Codec/Xlsx/Writer/Internal.hs +17/−10
- src/Codec/Xlsx/Writer/Internal/PivotTable.hs +152/−0
- test/DataTest.hs +438/−81
- xlsx.cabal +10/−1
CHANGELOG.markdown view
@@ -1,3 +1,12 @@+0.4.0+-----+* implemented basic charts support with only line charts currently+* added data validation support (thanks Emil Axelsson <emax@chalmers.se>)+* fixed reading comments with empty author names (thanks Aleksey+ Khudyakov <alexey.skladnoy@gmail.com> for reporting)+* implemented basic pivot table support+* started using `hindent` to format library code+ 0.3.0 ----- * implemented number formats
src/Codec/Xlsx/Formatted.hs view
@@ -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)
src/Codec/Xlsx/Parser.hs view
@@ -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
src/Codec/Xlsx/Parser/Internal.hs view
@@ -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
+ src/Codec/Xlsx/Parser/Internal/PivotTable.hs view
@@ -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)
src/Codec/Xlsx/Types.hs view
@@ -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
src/Codec/Xlsx/Types/Common.hs view
@@ -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 <t>!"- 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
src/Codec/Xlsx/Types/ConditionalFormatting.hs view
@@ -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
+ src/Codec/Xlsx/Types/DataValidation.hs view
@@ -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)+
src/Codec/Xlsx/Types/Drawing.hs view
@@ -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
+ src/Codec/Xlsx/Types/Drawing/Chart.hs view
@@ -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"
+ src/Codec/Xlsx/Types/Drawing/Common.hs view
@@ -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"
src/Codec/Xlsx/Types/Internal/CfPair.hs view
@@ -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
src/Codec/Xlsx/Types/Internal/CommentTable.hs view
@@ -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 @@ , "<v:path gradientshapeok=\"t\" o:connecttype=\"rect\"></v:path>" , "</v:shapetype>" ]- 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 [ "<v:shape type=\"#baloon\" "
+ src/Codec/Xlsx/Types/Internal/DvPair.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}+module Codec.Xlsx.Types.Internal.DvPair where++import qualified Data.Map as M+import Text.XML (Element (..))++import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Types.Common+import Codec.Xlsx.Types.DataValidation+import Codec.Xlsx.Writer.Internal+++-- | Internal helper type for parsing data validation records+--+-- See 18.3.1.32 "dataValidation (Data Validation)" (p. 1614/1624)+newtype DvPair = DvPair+ { unDvPair :: (SqRef, DataValidation)+ } deriving (Eq, Show)++instance FromCursor DvPair where+ fromCursor cur = do+ sqref <- fromAttribute "sqref" cur+ dv <- fromCursor cur+ return $ DvPair (sqref, dv)++instance ToElement DvPair where+ toElement nm (DvPair (sqRef,dv)) = e+ {elementAttributes = M.insert "sqref" (toAttrVal sqRef) $ elementAttributes e}+ where+ e = toElement nm dv
src/Codec/Xlsx/Types/Internal/Relationships.hs view
@@ -42,9 +42,12 @@ empty :: Relationships empty = fromList [] -relEntry :: Int -> 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
@@ -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)) {-------------------------------------------------------------------------------
+ src/Codec/Xlsx/Types/PivotTable.hs view
@@ -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
+ src/Codec/Xlsx/Types/PivotTable/Internal.hs view
@@ -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
src/Codec/Xlsx/Types/RichText.hs view
@@ -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{..} {-------------------------------------------------------------------------------
src/Codec/Xlsx/Types/SheetViews.hs view
@@ -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
src/Codec/Xlsx/Types/StyleSheet.hs view
@@ -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
src/Codec/Xlsx/Types/Variant.hs view
@@ -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
src/Codec/Xlsx/Writer.hs view
@@ -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 <https://phpexcel.codeplex.com/workitem/2935>). 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"
src/Codec/Xlsx/Writer/Internal.hs view
@@ -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
+ src/Codec/Xlsx/Writer/Internal/PivotTable.hs view
@@ -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]+
test/DataTest.hs view
@@ -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 <t/>" $- [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 = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\ \<sst xmlns=\"http://schemas.openxmlformats.org/spreadsheetml/2006/main\" count=\"2\" uniqueCount=\"2\">\@@ -271,45 +326,96 @@ </comments> |] -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 @@ </xdr:pic> <xdr:clientData/> </xdr:twoCellAnchor>+ <xdr:twoCellAnchor editAs="oneCell">+ <xdr:from>+ <xdr:col>0</xdr:col><xdr:colOff>87840</xdr:colOff>+ <xdr:row>21</xdr:row><xdr:rowOff>131040</xdr:rowOff>+ </xdr:from>+ <xdr:to>+ <xdr:col>7</xdr:col><xdr:colOff>580320</xdr:colOff>+ <xdr:row>38</xdr:row><xdr:rowOff>132480</xdr:rowOff>+ </xdr:to>+ <xdr:graphicFrame>+ <xdr:nvGraphicFramePr><xdr:cNvPr id="1" name=""/><xdr:cNvGraphicFramePr/></xdr:nvGraphicFramePr>+ <xdr:xfrm><a:off x="0" y="0"/><a:ext cx="10074240" cy="5402520"/></xdr:xfrm>+ <a:graphic>+ <a:graphicData uri="http://schemas.openxmlformats.org/drawingml/2006/chart">+ <c:chart xmlns:c="http://schemas.openxmlformats.org/drawingml/2006/chart" r:id="rId2"/>+ </a:graphicData>+ </a:graphic>+ </xdr:graphicFrame>+ <xdr:clientData/>+ </xdr:twoCellAnchor> </xdr:wsDr> |] @@ -348,9 +474,6 @@ , ("prop333", VtInt 1) , ("decimal", VtDecimal 1.234) ] -testParsedCustomProperties ::[CustomProperties]-testParsedCustomProperties = fromCursor . fromDocument $ parseLBS_ def testCustomPropertiesXml- testCustomPropertiesXml :: ByteString testCustomPropertiesXml = [r| <?xml version="1.0" encoding="UTF-8" standalone="yes"?>@@ -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|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>+<c:chartSpace xmlns:c="http://schemas.openxmlformats.org/drawingml/2006/chart" xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main" xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships">+<c:chart>+<c:title>+ <c:tx><c:rich><a:bodyPr rot="0" anchor="b"/><a:p><a:r><a:t>Line chart title</a:t></a:r></a:p></c:rich></c:tx>+</c:title>+<c:plotArea>+<c:lineChart>+<c:grouping val="standard"/>+<c:ser>+ <c:idx val="0"/><c:order val="0"/>+ <c:tx><c:strRef><c:f>Sheet1!$A$1</c:f></c:strRef></c:tx>+ <c:marker><c:symbol val="none"/></c:marker>+ <c:val><c:numRef><c:f>Sheet1!$B$1:$D$1</c:f></c:numRef></c:val>+ <c:smooth val="0"/>+</c:ser>+<c:ser>+ <c:idx val="1"/><c:order val="1"/>+ <c:tx><c:strRef><c:f>Sheet1!$A$2</c:f></c:strRef></c:tx>+ <c:marker><c:symbol val="none"/></c:marker>+ <c:val><c:numRef><c:f>Sheet1!$B$2:$D$2</c:f></c:numRef></c:val>+ <c:smooth val="0"/>+</c:ser>+<c:marker val="0"/>+<c:smooth val="0"/>+</c:lineChart>+</c:plotArea>+<c:plotVisOnly val="1"/>+<c:dispBlanksAs val="gap"/>+</c:chart>+</c:chartSpace>+|]++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|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?><!--Pivot table generated by xlsx-->+<pivotTableDefinition xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main" name="PivotTable1" cacheId="3" dataOnRows="1" colGrandTotals="0" dataCaption="Values">+ <location ref="A3:D12" firstHeaderRow="1" firstDataRow="2" firstDataCol="1"/>+ <pivotFields>+ <pivotField name="Color" axis="axisRow" showAll="0" outline="0">+ <items>+ <item t="default"/>+ </items>+ </pivotField>+ <pivotField name="Year" axis="axisCol" showAll="0" outline="1">+ <items>+ <item t="default"/>+ </items>+ </pivotField>+ <pivotField name="Price" dataField="1" showAll="0" outline="0"/>+ <pivotField name="Count" dataField="1" showAll="0" outline="0"/>+ </pivotFields>+ <rowFields><field x="0"/><field x="-2"/></rowFields>+ <colFields><field x="1"/></colFields>+ <dataFields>+ <dataField name="Sum of field Price" fld="2"/>+ <dataField name="Sum of field Count" fld="3"/>+ </dataFields>+</pivotTableDefinition>+|]++testPivotCacheDefinition :: ByteString+testPivotCacheDefinition = [r|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?><!--Pivot cache definition generated by xlsx-->+<pivotCacheDefinition xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main"+ invalid="1" refreshOnLoad="1"+ xmlns:ns="http://schemas.openxmlformats.org/officeDocument/2006/relationships">+ <cacheSource type="worksheet">+ <worksheetSource ref="A1:D5" sheet="Sheet1"/>+ </cacheSource>+ <cacheFields>+ <cacheField name="Color"/>+ <cacheField name="Year"/>+ <cacheField name="Price"/>+ <cacheField name="Count"/>+ </cacheFields>+</pivotCacheDefinition>+|]++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
xlsx.cabal view
@@ -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