xlsx-1.1.2.1: src/Codec/Xlsx/Parser.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
-- | This module provides a function for reading .xlsx files
module Codec.Xlsx.Parser
( toXlsx
, toXlsxEither
, toXlsxFast
, toXlsxEitherFast
, ParseError(..)
, Parser
) where
import qualified "zip-archive" Codec.Archive.Zip as Zip
import Control.Applicative
import Control.Arrow (left)
import Control.Error.Safe (headErr)
import Control.Error.Util (note)
import Control.Exception (Exception)
#ifdef USE_MICROLENS
import Lens.Micro
#else
import Control.Lens hiding ((<.>), element, views)
#endif
import Control.Monad (join, void)
import Control.Monad.Except (catchError, throwError)
import Data.Bool (bool)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy as LB
import Data.ByteString.Lazy.Char8 ()
import Data.List
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Traversable
import GHC.Generics (Generic)
import Prelude hiding (sequence)
import Safe (headNote)
import System.FilePath.Posix
import Text.XML as X
import Text.XML.Cursor hiding (bool)
import qualified Xeno.DOM as Xeno
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Parser.Internal.PivotTable
import Codec.Xlsx.Types
import Codec.Xlsx.Types.Cell (formulaDataFromCursor)
import Codec.Xlsx.Types.Internal
import Codec.Xlsx.Types.Internal.CfPair
import Codec.Xlsx.Types.Internal.CommentTable as CommentTable
import Codec.Xlsx.Types.Internal.ContentTypes as ContentTypes
import Codec.Xlsx.Types.Internal.CustomProperties
as CustomProperties
import Codec.Xlsx.Types.Internal.DvPair
import Codec.Xlsx.Types.Internal.FormulaData
import Codec.Xlsx.Types.Internal.Relationships as Relationships
import Codec.Xlsx.Types.Internal.SharedStringTable
import Codec.Xlsx.Types.PivotTable.Internal
-- | Reads `Xlsx' from raw data (lazy bytestring)
toXlsx :: L.ByteString -> Xlsx
toXlsx = either (error . show) id . toXlsxEither
data ParseError = InvalidZipArchive String
| MissingFile FilePath
| InvalidFile FilePath Text
| InvalidRef FilePath RefId
| InconsistentXlsx Text
deriving (Eq, Show, Generic)
instance Exception ParseError
type Parser = Either ParseError
-- | Reads `Xlsx' from raw data (lazy bytestring) using @xeno@ library
-- using some "cheating":
--
-- * not doing 100% xml validation
-- * replacing only <https://www.w3.org/TR/REC-xml/#sec-predefined-ent predefined entities>
-- and <https://www.w3.org/TR/REC-xml/#NT-CharRef Unicode character references>
-- (without checking codepoint validity)
-- * almost not using XML namespaces
toXlsxFast :: L.ByteString -> Xlsx
toXlsxFast = either (error . show) id . toXlsxEitherFast
-- | Reads `Xlsx' from raw data (lazy bytestring), failing with 'Left' on parse error
toXlsxEither :: L.ByteString -> Parser Xlsx
toXlsxEither = toXlsxEitherBase extractSheet
-- | Fast parsing with 'Left' on parse error, see 'toXlsxFast'
toXlsxEitherFast :: L.ByteString -> Parser Xlsx
toXlsxEitherFast = toXlsxEitherBase extractSheetFast
toXlsxEitherBase ::
(Zip.Archive -> SharedStringTable -> ContentTypes -> Caches -> WorksheetFile -> Parser Worksheet)
-> L.ByteString
-> Parser Xlsx
toXlsxEitherBase parseSheet bs = do
ar <- left InvalidZipArchive $ Zip.toArchiveOrFail bs
sst <- getSharedStrings ar
contentTypes <- getContentTypes ar
(wfs, names, cacheSources, dateBase) <- readWorkbook ar
sheets <- forM wfs $ \wf -> do
sheet <- parseSheet ar sst contentTypes cacheSources wf
return . (wfName wf,) . (wsState .~ wfState wf) $ sheet
CustomProperties customPropMap <- getCustomProperties ar
return $ Xlsx sheets (getStyles ar) names customPropMap dateBase
data WorksheetFile = WorksheetFile { wfName :: Text
, wfState :: SheetState
, wfPath :: FilePath
}
deriving (Show, Generic)
type Caches = [(CacheId, (Text, CellRef, [CacheField]))]
extractSheetFast :: Zip.Archive
-> SharedStringTable
-> ContentTypes
-> Caches
-> WorksheetFile
-> Parser Worksheet
extractSheetFast ar sst contentTypes caches wf = do
file <-
note (MissingFile filePath) $
Zip.fromEntry <$> Zip.findEntryByPath filePath ar
sheetRels <- getRels ar filePath
root <-
left (\ex -> InvalidFile filePath $ T.pack (show ex)) $
Xeno.parse (LB.toStrict file)
parseWorksheet root sheetRels
where
filePath = wfPath wf
parseWorksheet :: Xeno.Node -> Relationships -> Parser Worksheet
parseWorksheet root sheetRels = do
let prefixes = nsPrefixes root
odrNs =
"http://schemas.openxmlformats.org/officeDocument/2006/relationships"
odrX = addPrefix prefixes odrNs
skip = void . maybeChild
(ws, tableIds, drawingRId, legacyDrRId) <-
liftEither . collectChildren root $ do
skip "sheetPr"
skip "dimension"
_wsSheetViews <- fmap justNonEmpty . maybeParse "sheetViews" $ \n ->
collectChildren n $ fromChildList "sheetView"
skip "sheetFormatPr"
_wsColumnsProperties <-
fmap (fromMaybe []) . maybeParse "cols" $ \n ->
collectChildren n (fromChildList "col")
(_wsRowPropertiesMap, _wsCells, _wsSharedFormulas) <-
requireAndParse "sheetData" $ \n -> do
rows <- collectChildren n $ childList "row"
collectRows <$> forM rows parseRow
skip "sheetCalcPr"
_wsProtection <- maybeFromChild "sheetProtection"
skip "protectedRanges"
skip "scenarios"
_wsAutoFilter <- maybeFromChild "autoFilter"
skip "sortState"
skip "dataConsolidate"
skip "customSheetViews"
_wsMerges <- fmap (fromMaybe []) . maybeParse "mergeCells" $ \n -> do
mCells <- collectChildren n $ childList "mergeCell"
forM mCells $ \mCell -> parseAttributes mCell $ fromAttr "ref"
_wsConditionalFormattings <-
M.fromList . map unCfPair <$> fromChildList "conditionalFormatting"
_wsDataValidations <-
fmap (fromMaybe mempty) . maybeParse "dataValidations" $ \n -> do
M.fromList . map unDvPair <$>
collectChildren n (fromChildList "dataValidation")
skip "hyperlinks"
skip "printOptions"
skip "pageMargins"
_wsPageSetup <- maybeFromChild "pageSetup"
skip "headerFooter"
skip "rowBreaks"
skip "colBreaks"
skip "customProperties"
skip "cellWatches"
skip "ignoredErrors"
skip "smartTags"
drawingRId <- maybeParse "drawing" $ \n ->
parseAttributes n $ fromAttr (odrX "id")
legacyDrRId <- maybeParse "legacyDrawing" $ \n ->
parseAttributes n $ fromAttr (odrX "id")
tableIds <- fmap (fromMaybe []) . maybeParse "tableParts" $ \n -> do
tParts <- collectChildren n $ childList "tablePart"
forM tParts $ \part ->
parseAttributes part $ fromAttr (odrX "id")
-- all explicitly assigned fields filled below
return (
Worksheet
{ _wsDrawing = Nothing
, _wsPivotTables = []
, _wsTables = []
, _wsState = wfState wf
, ..
}
, tableIds
, drawingRId
, legacyDrRId)
let commentsType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments"
commentTarget :: Maybe FilePath
commentTarget = relTarget <$> findRelByType commentsType sheetRels
legacyDrPath = fmap relTarget . flip Relationships.lookup sheetRels =<< legacyDrRId
commentsMap <-
fmap join . forM commentTarget $ getComments ar legacyDrPath
let commentCells =
M.fromList
[ (fromSingleCellRefNoting r, def { _cellComment = Just cmnt})
| (r, cmnt) <- maybe [] CommentTable.toList commentsMap
]
assignComment withCmnt noCmnt =
noCmnt & cellComment .~ (withCmnt ^. cellComment)
mergeComments = M.unionWith assignComment commentCells
tables <- forM tableIds $ \rId -> do
fp <- lookupRelPath filePath sheetRels rId
getTable ar fp
drawing <- forM drawingRId $ \dId -> do
rel <- note (InvalidRef filePath dId) $ Relationships.lookup dId sheetRels
getDrawing ar contentTypes (relTarget rel)
let ptType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/pivotTable"
pivotTables <- forM (allByType ptType sheetRels) $ \rel -> do
let ptPath = relTarget rel
bs <- note (MissingFile ptPath) $ Zip.fromEntry <$> Zip.findEntryByPath ptPath ar
note (InconsistentXlsx $ "Bad pivot table in " <> T.pack ptPath) $
parsePivotTable (flip Prelude.lookup caches) bs
return $ ws & wsTables .~ tables
& wsCells %~ mergeComments
& wsDrawing .~ drawing
& wsPivotTables .~ pivotTables
liftEither :: Either Text a -> Parser a
liftEither = left (\t -> InvalidFile filePath t)
justNonEmpty v@(Just (_:_)) = v
justNonEmpty _ = Nothing
collectRows = foldr collectRow (M.empty, M.empty, M.empty)
collectRow ::
( RowIndex
, Maybe RowProperties
, [(RowIndex, ColumnIndex, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))])
-> ( Map RowIndex RowProperties
, CellMap
, Map SharedFormulaIndex SharedFormulaOptions)
-> ( Map RowIndex RowProperties
, CellMap
, Map SharedFormulaIndex SharedFormulaOptions)
collectRow (r, mRP, rowCells) (rowMap, cellMap, sharedF) =
let (newCells0, newSharedF0) =
unzip [(((rInd, cInd), cd), shared) | (rInd, cInd, cd, shared) <- rowCells]
newCells = M.fromAscList newCells0
newSharedF = M.fromAscList $ catMaybes newSharedF0
newRowMap =
case mRP of
Just rp -> M.insert r rp rowMap
Nothing -> rowMap
in (newRowMap, cellMap <> newCells, sharedF <> newSharedF)
parseRow ::
Xeno.Node
-> Either Text ( RowIndex
, Maybe RowProperties
, [( RowIndex
, ColumnIndex
, Cell
, Maybe (SharedFormulaIndex, SharedFormulaOptions))])
parseRow row = do
(r, s, ht, cstHt, hidden) <-
parseAttributes row $
((,,,,) <$> fromAttr "r" <*> maybeAttr "s" <*> maybeAttr "ht" <*>
fromAttrDef "customHeight" False <*>
fromAttrDef "hidden" False)
let props =
RowProps
{ rowHeight =
if cstHt
then CustomHeight <$> ht
else AutomaticHeight <$> ht
, rowStyle = s
, rowHidden = hidden
}
cellNodes <- collectChildren row $ childList "c"
cells <- forM cellNodes parseCell
return
( RowIndex r
, if props == def
then Nothing
else Just props
, cells)
-- NB: According to format specification default value for cells without
-- `t` attribute is a `n` - number.
--
-- Schema part from spec (see the `CellValue` spec reference):
-- <xsd:complexType name="CT_Cell">
-- ..
-- <xsd:attribute name="t" type="ST_CellType" use="optional" default="n"/>
-- </xsd:complexType>
parseCell ::
Xeno.Node
-> Either Text ( RowIndex
, ColumnIndex
, Cell
, Maybe (SharedFormulaIndex, SharedFormulaOptions))
parseCell cell = do
(ref, s, t) <-
parseAttributes cell $
(,,) <$> fromAttr "r" <*> maybeAttr "s" <*> fromAttrDef "t" "n"
(fNode, vNode, isNode) <-
collectChildren cell $
(,,) <$> maybeChild "f" <*> maybeChild "v" <*> maybeChild "is"
let vConverted :: (FromAttrBs a) => Either Text (Maybe a)
vConverted =
case contentBs <$> vNode of
Nothing -> return Nothing
Just c -> Just <$> fromAttrBs c
mFormulaData <- mapM fromXenoNode fNode
d <-
case t of
("s" :: ByteString) -> do
si <- vConverted
case sstItem sst =<< si of
Just xlTxt -> return $ Just (xlsxTextToCellValue xlTxt)
Nothing -> throwError "bad shared string index"
"inlineStr" -> mapM (fmap xlsxTextToCellValue . fromXenoNode) isNode
"str" -> fmap CellText <$> vConverted
"n" -> fmap CellDouble <$> vConverted
"b" -> fmap CellBool <$> vConverted
"e" -> fmap CellError <$> vConverted
unexpected ->
throwError $ "unexpected cell type " <> T.pack (show unexpected)
let (r, c) = fromSingleCellRefNoting ref
f = frmdFormula <$> mFormulaData
shared = frmdShared =<< mFormulaData
return (r, c, Cell s d Nothing f, shared)
extractSheet ::
Zip.Archive
-> SharedStringTable
-> ContentTypes
-> Caches
-> WorksheetFile
-> Parser Worksheet
extractSheet ar sst contentTypes caches wf = do
let filePath = wfPath wf
file <- note (MissingFile filePath) $ Zip.fromEntry <$> Zip.findEntryByPath filePath ar
cur <- fmap fromDocument . left (\ex -> InvalidFile filePath (T.pack $ show ex)) $
parseLBS def file
sheetRels <- getRels ar filePath
-- The specification says the file should contain either 0 or 1 @sheetViews@
-- (4th edition, section 18.3.1.88, p. 1704 and definition CT_Worksheet, p. 3910)
let sheetViewList = cur $/ element (n_ "sheetViews") &/ element (n_ "sheetView") >=> fromCursor
sheetViews = case sheetViewList of
[] -> Nothing
views -> Just views
let commentsType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments"
commentTarget :: Maybe FilePath
commentTarget = relTarget <$> findRelByType commentsType sheetRels
legacyDrRId = cur $/ element (n_ "legacyDrawing") >=> fromAttribute (odr"id")
legacyDrPath = fmap relTarget . flip Relationships.lookup sheetRels =<< listToMaybe legacyDrRId
commentsMap :: Maybe CommentTable <- maybe (Right Nothing) (getComments ar legacyDrPath) commentTarget
-- Likewise, @pageSetup@ also occurs either 0 or 1 times
let pageSetup = listToMaybe $ cur $/ element (n_ "pageSetup") >=> fromCursor
cws = cur $/ element (n_ "cols") &/ element (n_ "col") >=> fromCursor
(rowProps, cells0, sharedFormulas) =
collect $ cur $/ element (n_ "sheetData") &/ element (n_ "row") >=> parseRow
parseRow ::
Cursor
-> [( RowIndex
, Maybe RowProperties
, [(RowIndex, ColumnIndex, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))])]
parseRow c = do
r <- RowIndex <$> fromAttribute "r" c
let prop = RowProps
{ rowHeight = do h <- listToMaybe $ fromAttribute "ht" c
case fromAttribute "customHeight" c of
[True] -> return $ CustomHeight h
_ -> return $ AutomaticHeight h
, rowStyle = listToMaybe $ fromAttribute "s" c
, rowHidden =
case fromAttribute "hidden" c of
[] -> False
f:_ -> f
}
return ( r
, if prop == def then Nothing else Just prop
, c $/ element (n_ "c") >=> parseCell
)
parseCell ::
Cursor
-> [(RowIndex, ColumnIndex, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))]
parseCell cell = do
ref <- fromAttribute "r" cell
let s = listToMaybe $ cell $| attribute "s" >=> decimal
-- NB: According to format specification default value for cells without
-- `t` attribute is a `n` - number.
--
-- <xsd:complexType name="CT_Cell" from spec (see the `CellValue` spec reference)>
-- ..
-- <xsd:attribute name="t" type="ST_CellType" use="optional" default="n"/>
-- </xsd:complexType>
t = fromMaybe "n" $ listToMaybe $ cell $| attribute "t"
d = listToMaybe $ extractCellValue sst t cell
mFormulaData = listToMaybe $ cell $/ element (n_ "f") >=> formulaDataFromCursor
f = fst <$> mFormulaData
shared = snd =<< mFormulaData
(r, c) = fromSingleCellRefNoting ref
comment = commentsMap >>= lookupComment ref
return (r, c, Cell s d comment f, shared)
collect = foldr collectRow (M.empty, M.empty, M.empty)
collectRow ::
( RowIndex
, Maybe RowProperties
, [(RowIndex, ColumnIndex, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))])
-> (Map RowIndex RowProperties, CellMap, Map SharedFormulaIndex SharedFormulaOptions)
-> (Map RowIndex RowProperties, CellMap, Map SharedFormulaIndex SharedFormulaOptions)
collectRow (r, mRP, rowCells) (rowMap, cellMap, sharedF) =
let (newCells0, newSharedF0) =
unzip [(((x,y),cd), shared) | (x, y, cd, shared) <- rowCells]
newCells = M.fromList newCells0
newSharedF = M.fromList $ catMaybes newSharedF0
newRowMap = case mRP of
Just rp -> M.insert r rp rowMap
Nothing -> rowMap
in (newRowMap, cellMap <> newCells, sharedF <> newSharedF)
commentCells =
M.fromList
[ (fromSingleCellRefNoting r, def {_cellComment = Just cmnt})
| (r, cmnt) <- maybe [] CommentTable.toList commentsMap
]
cells = cells0 `M.union` commentCells
mProtection = listToMaybe $ cur $/ element (n_ "sheetProtection") >=> fromCursor
mDrawingId = listToMaybe $ cur $/ element (n_ "drawing") >=> fromAttribute (odr"id")
merges = cur $/ parseMerges
parseMerges :: Cursor -> [Range]
parseMerges = element (n_ "mergeCells") &/ element (n_ "mergeCell") >=> fromAttribute "ref"
condFormtattings = M.fromList . map unCfPair $ cur $/ element (n_ "conditionalFormatting") >=> fromCursor
validations = M.fromList . map unDvPair $
cur $/ element (n_ "dataValidations") &/ element (n_ "dataValidation") >=> fromCursor
tableIds =
cur $/ element (n_ "tableParts") &/ element (n_ "tablePart") >=>
fromAttribute (odr "id")
let mAutoFilter = listToMaybe $ cur $/ element (n_ "autoFilter") >=> fromCursor
mDrawing <- case mDrawingId of
Just dId -> do
rel <- note (InvalidRef filePath dId) $ Relationships.lookup dId sheetRels
Just <$> getDrawing ar contentTypes (relTarget rel)
Nothing ->
return Nothing
let ptType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/pivotTable"
pTables <- forM (allByType ptType sheetRels) $ \rel -> do
let ptPath = relTarget rel
bs <- note (MissingFile ptPath) $ Zip.fromEntry <$> Zip.findEntryByPath ptPath ar
note (InconsistentXlsx $ "Bad pivot table in " <> T.pack ptPath) $
parsePivotTable (flip Prelude.lookup caches) bs
tables <- forM tableIds $ \rId -> do
fp <- lookupRelPath filePath sheetRels rId
getTable ar fp
return $
Worksheet
cws
rowProps
cells
mDrawing
merges
sheetViews
pageSetup
condFormtattings
validations
pTables
mAutoFilter
tables
mProtection
sharedFormulas
(wfState wf)
extractCellValue :: SharedStringTable -> Text -> Cursor -> [CellValue]
extractCellValue sst t cur
| t == "s" = do
si <- vConverted "shared string"
case sstItem sst si of
Just xlTxt -> return $ xlsxTextToCellValue xlTxt
Nothing -> fail "bad shared string index"
| t == "inlineStr" =
cur $/ element (n_ "is") >=> fmap xlsxTextToCellValue . fromCursor
| t == "str" = CellText <$> vConverted "string"
| t == "n" = CellDouble <$> vConverted "double"
| t == "b" = CellBool <$> vConverted "boolean"
| t == "e" = CellError <$> vConverted "error"
| otherwise = fail "bad cell value"
where
vConverted typeStr = do
vContent <- cur $/ element (n_ "v") >=> \c ->
return (T.concat $ c $/ content)
case fromAttrVal vContent of
Right (val, _) -> return $ val
_ -> fail $ "bad " ++ typeStr ++ " cell value"
-- | Get xml cursor from the specified file inside the zip archive.
xmlCursorOptional :: Zip.Archive -> FilePath -> Parser (Maybe Cursor)
xmlCursorOptional ar fname =
(Just <$> xmlCursorRequired ar fname) `catchError` missingToNothing
where
missingToNothing :: ParseError -> Either ParseError (Maybe a)
missingToNothing (MissingFile _) = return Nothing
missingToNothing other = throwError other
-- | Get xml cursor from the given file, failing with MissingFile if not found.
xmlCursorRequired :: Zip.Archive -> FilePath -> Parser Cursor
xmlCursorRequired ar fname = do
entry <- note (MissingFile fname) $ Zip.findEntryByPath fname ar
cur <- left (\ex -> InvalidFile fname (T.pack $ show ex)) $ parseLBS def (Zip.fromEntry entry)
return $ fromDocument cur
fromFileCursorDef ::
FromCursor a => Zip.Archive -> FilePath -> Text -> a -> Parser a
fromFileCursorDef x fp contentsDescr defVal = do
mCur <- xmlCursorOptional x fp
case mCur of
Just cur ->
headErr (InvalidFile fp $ "Couldn't parse " <> contentsDescr) $ fromCursor cur
Nothing -> return defVal
fromFileCursor :: FromCursor a => Zip.Archive -> FilePath -> Text -> Parser a
fromFileCursor x fp contentsDescr = do
cur <- xmlCursorRequired x fp
headErr (InvalidFile fp $ "Couldn't parse " <> contentsDescr) $ fromCursor cur
-- | Get shared string table
getSharedStrings :: Zip.Archive -> Parser SharedStringTable
getSharedStrings x =
fromFileCursorDef x "xl/sharedStrings.xml" "shared strings" sstEmpty
getContentTypes :: Zip.Archive -> Parser ContentTypes
getContentTypes x = fromFileCursor x "[Content_Types].xml" "content types"
getStyles :: Zip.Archive -> Styles
getStyles ar = case Zip.fromEntry <$> Zip.findEntryByPath "xl/styles.xml" ar of
Nothing -> Styles L.empty
Just xml -> Styles xml
getComments :: Zip.Archive -> Maybe FilePath -> FilePath -> Parser (Maybe CommentTable)
getComments ar drp fp = do
mCurComments <- xmlCursorOptional ar fp
mCurDr <- maybe (return Nothing) (xmlCursorOptional ar) drp
return (liftA2 hide (hidden <$> mCurDr) . listToMaybe . fromCursor =<< mCurComments)
where
hide refs (CommentTable m) = CommentTable $ foldl' hideComment m refs
hideComment m r = M.adjust (\c->c{_commentVisible = False}) r m
v nm = Name nm (Just "urn:schemas-microsoft-com:vml") Nothing
x nm = Name nm (Just "urn:schemas-microsoft-com:office:excel") Nothing
hidden :: Cursor -> [CellRef]
hidden cur = cur $/ checkElement visibleShape &/
element (x"ClientData") >=> shapeCellRef
visibleShape Element{..} = elementName == (v"shape") &&
maybe False (any ("visibility:hidden"==) . T.split (==';')) (M.lookup "style" elementAttributes)
shapeCellRef :: Cursor -> [CellRef]
shapeCellRef c = do
r0 <- c $/ element (x"Row") &/ content >=> decimal
c0 <- c $/ element (x"Column") &/ content >=> decimal
return $ singleCellRef (r0 + 1, c0 + 1)
getCustomProperties :: Zip.Archive -> Parser CustomProperties
getCustomProperties ar =
fromFileCursorDef ar "docProps/custom.xml" "custom properties" CustomProperties.empty
getDrawing :: Zip.Archive -> ContentTypes -> FilePath -> Parser Drawing
getDrawing ar contentTypes fp = do
cur <- xmlCursorRequired ar fp
drawingRels <- getRels ar fp
unresolved <- headErr (InvalidFile fp "Couldn't parse drawing") (fromCursor cur)
anchors <- forM (unresolved ^. xdrAnchors) $ resolveFileInfo drawingRels
return $ Drawing anchors
where
resolveFileInfo :: Relationships -> Anchor RefId RefId -> Parser (Anchor FileInfo ChartSpace)
resolveFileInfo rels uAnch =
case uAnch ^. anchObject of
Picture {..} -> do
let mRefId = _picBlipFill ^. bfpImageInfo
mFI <- lookupFI rels mRefId
let pic' =
Picture
{ _picMacro = _picMacro
, _picPublished = _picPublished
, _picNonVisual = _picNonVisual
, _picBlipFill = (_picBlipFill & bfpImageInfo .~ mFI)
, _picShapeProperties = _picShapeProperties
}
return uAnch {_anchObject = pic'}
Graphic nv rId tr -> do
chartPath <- lookupRelPath fp rels rId
chart <- readChart ar chartPath
return uAnch {_anchObject = Graphic nv chart tr}
lookupFI _ Nothing = return Nothing
lookupFI rels (Just rId) = do
path <- lookupRelPath fp rels rId
-- content types use paths starting with /
contentType <-
note (InvalidFile path "Missing content type") $
ContentTypes.lookup ("/" <> path) contentTypes
contents <-
Zip.fromEntry <$> note (MissingFile path) (Zip.findEntryByPath path ar)
return . Just $ FileInfo (stripMediaPrefix path) contentType contents
stripMediaPrefix :: FilePath -> FilePath
stripMediaPrefix p = fromMaybe p $ stripPrefix "xl/media/" p
readChart :: Zip.Archive -> FilePath -> Parser ChartSpace
readChart ar path = fromFileCursor ar path "chart"
-- | readWorkbook pulls the names of the sheets and the defined names
readWorkbook :: Zip.Archive -> Parser ([WorksheetFile], DefinedNames, Caches, DateBase)
readWorkbook ar = do
let wbPath = "xl/workbook.xml"
cur <- xmlCursorRequired ar wbPath
wbRels <- getRels ar wbPath
-- Specification says the 'name' is required.
let mkDefinedName :: Cursor -> [(Text, Maybe Text, Text)]
mkDefinedName c =
return
( headNote "Missing name attribute" $ attribute "name" c
, listToMaybe $ attribute "localSheetId" c
, T.concat $ c $/ content)
names =
cur $/ element (n_ "definedNames") &/ element (n_ "definedName") >=>
mkDefinedName
sheets <-
sequence $
cur $/ element (n_ "sheets") &/ element (n_ "sheet") >=>
liftA3 (worksheetFile wbPath wbRels) <$> attribute "name" <*> fromAttributeDef "state" def <*>
fromAttribute (odr "id")
let cacheRefs =
cur $/ element (n_ "pivotCaches") &/ element (n_ "pivotCache") >=>
liftA2 (,) <$> fromAttribute "cacheId" <*> fromAttribute (odr "id")
caches <-
forM cacheRefs $ \(cacheId, rId) -> do
path <- lookupRelPath wbPath wbRels rId
bs <-
note (MissingFile path) $ Zip.fromEntry <$> Zip.findEntryByPath path ar
(sheet, ref, fields0, mRecRId) <-
note (InconsistentXlsx $ "Bad pivot table cache in " <> T.pack path) $
parseCache bs
fields <- case mRecRId of
Just recId -> do
cacheRels <- getRels ar path
recsPath <- lookupRelPath path cacheRels recId
rCur <- xmlCursorRequired ar recsPath
let recs = rCur $/ element (n_ "r") >=> \cur' ->
return $ cur' $/ anyElement >=> recordValueFromNode . node
return $ fillCacheFieldsFromRecords fields0 recs
Nothing ->
return fields0
return $ (cacheId, (sheet, ref, fields))
let dateBase = bool DateBase1900 DateBase1904 . fromMaybe False . listToMaybe $
cur $/ element (n_ "workbookPr") >=> fromAttribute "date1904"
return (sheets, DefinedNames names, caches, dateBase)
getTable :: Zip.Archive -> FilePath -> Parser Table
getTable ar fp = do
cur <- xmlCursorRequired ar fp
headErr (InvalidFile fp "Couldn't parse drawing") (fromCursor cur)
worksheetFile :: FilePath -> Relationships -> Text -> SheetState -> RefId -> Parser WorksheetFile
worksheetFile parentPath wbRels name visibility rId =
WorksheetFile name visibility <$> lookupRelPath parentPath wbRels rId
getRels :: Zip.Archive -> FilePath -> Parser Relationships
getRels ar fp = do
let (dir, file) = splitFileName fp
relsPath = dir </> "_rels" </> file <.> "rels"
c <- xmlCursorOptional ar relsPath
return $ maybe Relationships.empty (setTargetsFrom fp . headNote "Missing rels" . fromCursor) c
-- According to part 2, section 7.3.4 of ECMA-376, when mapping logical item
-- names to ZIP item names we need to remove the leading slash.
--
-- Non-ASCII characters should be percent-encoded as well, but this is not
-- currently implemented.
--
-- https://ecma-international.org/publications-and-standards/standards/ecma-376/
logicalNameToZipItemName :: FilePath -> FilePath
logicalNameToZipItemName ('/' : name) = name
logicalNameToZipItemName name = name
lookupRelPath :: FilePath
-> Relationships
-> RefId
-> Either ParseError FilePath
lookupRelPath fp rels rId =
logicalNameToZipItemName . relTarget <$> note (InvalidRef fp rId) (Relationships.lookup rId rels)