{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Drawing where
import Control.Arrow (first)
import Control.DeepSeq (NFData)
#ifdef USE_MICROLENS
import Lens.Micro.TH (makeLenses)
#else
import Control.Lens.TH
#endif
import Data.ByteString.Lazy (ByteString)
import Data.Default
import qualified Data.Map as M
import Data.Maybe (catMaybes, listToMaybe, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Text.XML
import Text.XML.Cursor
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Drawing.Chart
import Codec.Xlsx.Types.Drawing.Common
import Codec.Xlsx.Types.Internal
import Codec.Xlsx.Types.Internal.Relationships
import Codec.Xlsx.Writer.Internal
data FileInfo = FileInfo
{ _fiFilename :: FilePath
, _fiContentType :: Text
, _fiContents :: ByteString
} deriving (Eq, Show, Generic)
instance NFData FileInfo
data Marker = Marker
{ _mrkCol :: Int
, _mrkColOff :: Coordinate
, _mrkRow :: Int
, _mrkRowOff :: Coordinate
} deriving (Eq, Show, Generic)
instance NFData Marker
unqMarker :: (Int, Int) -> (Int, Int) -> Marker
unqMarker (col, colOff) (row, rowOff) =
Marker col (UnqCoordinate colOff) row (UnqCoordinate rowOff)
data EditAs
= EditAsTwoCell
| EditAsOneCell
| EditAsAbsolute
deriving (Eq, Show, Generic)
instance NFData EditAs
data Anchoring
= AbsoluteAnchor
{ absaPos :: Point2D
, absaExt :: PositiveSize2D
}
| OneCellAnchor
{ onecaFrom :: Marker
, onecaExt :: PositiveSize2D
}
| TwoCellAnchor
{ tcaFrom :: Marker
, tcaTo :: Marker
, tcaEditAs :: EditAs
}
deriving (Eq, Show, Generic)
instance NFData Anchoring
data DrawingObject p g
= Picture { _picMacro :: Maybe Text
, _picPublished :: Bool
, _picNonVisual :: PicNonVisual
, _picBlipFill :: BlipFillProperties p
, _picShapeProperties :: ShapeProperties
}
| Graphic { _grNonVisual :: GraphNonVisual
, _grChartSpace :: g
, _grTransform :: Transform2D}
deriving (Eq, Show, Generic)
instance (NFData p, NFData g) => NFData (DrawingObject p g)
picture :: DrawingElementId -> FileInfo -> DrawingObject FileInfo c
picture dId fi =
Picture
{ _picMacro = Nothing
, _picPublished = False
, _picNonVisual = nonVis
, _picBlipFill = bfProps
, _picShapeProperties = shProps
}
where
nonVis =
PicNonVisual $
NonVisualDrawingProperties
{ _nvdpId = dId
, _nvdpName = T.pack $ _fiFilename fi
, _nvdpDescription = Nothing
, _nvdpHidden = False
, _nvdpTitle = Nothing
}
bfProps =
BlipFillProperties
{_bfpImageInfo = Just fi, _bfpFillMode = Just FillStretch}
shProps =
ShapeProperties
{ _spXfrm = Nothing
, _spGeometry = Nothing
, _spFill = Just NoFill
, _spOutline = Just $ def {_lnFill = Just NoFill}
}
extractPictures :: Drawing -> [(Anchoring, FileInfo)]
extractPictures dr = mapMaybe maybePictureInfo $ _xdrAnchors dr
where
maybePictureInfo Anchor {..} =
case _anchObject of
Picture {..} -> (_anchAnchoring,) <$> _bfpImageInfo _picBlipFill
_ -> Nothing
data ClientData = ClientData
{ _cldLcksWithSheet :: Bool
, _cldPrintsWithSheet :: Bool
} deriving (Eq, Show, Generic)
instance NFData ClientData
data PicNonVisual = PicNonVisual
{ _pnvDrawingProps :: NonVisualDrawingProperties
} deriving (Eq, Show, Generic)
instance NFData PicNonVisual
data GraphNonVisual = GraphNonVisual
{ _gnvDrawingProps :: NonVisualDrawingProperties
} deriving (Eq, Show, Generic)
instance NFData GraphNonVisual
newtype DrawingElementId = DrawingElementId
{ unDrawingElementId :: Int
} deriving (Eq, Show, Generic)
instance NFData DrawingElementId
data NonVisualDrawingProperties = NonVisualDrawingProperties
{ _nvdpId :: DrawingElementId
, _nvdpName :: Text
, _nvdpDescription :: Maybe Text
, _nvdpHidden :: Bool
, _nvdpTitle :: Maybe Text
} deriving (Eq, Show, Generic)
instance NFData NonVisualDrawingProperties
data BlipFillProperties a = BlipFillProperties
{ _bfpImageInfo :: Maybe a
, _bfpFillMode :: Maybe FillMode
} deriving (Eq, Show, Generic)
instance NFData a => NFData (BlipFillProperties a)
data FillMode
= FillTile
| FillStretch
deriving (Eq, Show, Generic)
instance NFData FillMode
data Anchor p g = Anchor
{ _anchAnchoring :: Anchoring
, _anchObject :: DrawingObject p g
, _anchClientData :: ClientData
} deriving (Eq, Show, Generic)
instance (NFData p, NFData g) => NFData (Anchor p g)
simpleAnchorXY :: (Int, Int)
-> PositiveSize2D
-> DrawingObject p g
-> Anchor p g
simpleAnchorXY (x, y) sz obj =
Anchor
{ _anchAnchoring =
OneCellAnchor {onecaFrom = unqMarker (x, 0) (y, 0), onecaExt = sz}
, _anchObject = obj
, _anchClientData = def
}
data GenericDrawing p g = Drawing
{ _xdrAnchors :: [Anchor p g]
} deriving (Eq, Show, Generic)
instance (NFData p, NFData g) => NFData (GenericDrawing p g)
type Drawing = GenericDrawing FileInfo ChartSpace
type UnresolvedDrawing = GenericDrawing RefId RefId
makeLenses ''Anchor
makeLenses ''DrawingObject
makeLenses ''BlipFillProperties
makeLenses ''GenericDrawing
instance Default ClientData where
def = ClientData True True
instance FromCursor UnresolvedDrawing where
fromCursor cur = [Drawing $ cur $/ anyElement >=> fromCursor]
instance FromCursor (Anchor RefId RefId) where
fromCursor cur = do
_anchAnchoring <- fromCursor cur
_anchObject <- cur $/ anyElement >=> fromCursor
_anchClientData <- cur $/ element (xdr"clientData") >=> fromCursor
return Anchor{..}
instance FromCursor Anchoring where
fromCursor = anchoringFromNode . node
anchoringFromNode :: Node -> [Anchoring]
anchoringFromNode n | n `nodeElNameIs` xdr "twoCellAnchor" = do
tcaEditAs <- fromAttributeDef "editAs" EditAsTwoCell cur
tcaFrom <- cur $/ element (xdr"from") >=> fromCursor
tcaTo <- cur $/ element (xdr"to") >=> fromCursor
return TwoCellAnchor{..}
| n `nodeElNameIs` xdr "oneCellAnchor" = do
onecaFrom <- cur $/ element (xdr"from") >=> fromCursor
onecaExt <- cur $/ element (xdr"ext") >=> fromCursor
return OneCellAnchor{..}
| n `nodeElNameIs` xdr "absolueAnchor" = do
absaPos <- cur $/ element (xdr"pos") >=> fromCursor
absaExt <- cur $/ element (xdr"ext") >=> fromCursor
return AbsoluteAnchor{..}
| otherwise = fail "no matching anchoring node"
where
cur = fromNode n
instance FromCursor Marker where
fromCursor cur = do
_mrkCol <- cur $/ element (xdr"col") &/ content >=> decimal
_mrkColOff <- cur $/ element (xdr"colOff") &/ content >=> coordinate
_mrkRow <- cur $/ element (xdr"row") &/ content >=> decimal
_mrkRowOff <- cur $/ element (xdr"rowOff") &/ content >=> coordinate
return Marker{..}
instance FromCursor (DrawingObject RefId RefId) where
fromCursor = drawingObjectFromNode . node
drawingObjectFromNode :: Node -> [DrawingObject RefId RefId]
drawingObjectFromNode n
| n `nodeElNameIs` xdr "pic" = do
_picMacro <- maybeAttribute "macro" cur
_picPublished <- fromAttributeDef "fPublished" False cur
_picNonVisual <- cur $/ element (xdr "nvPicPr") >=> fromCursor
_picBlipFill <- cur $/ element (xdr "blipFill") >=> fromCursor
_picShapeProperties <- cur $/ element (xdr "spPr") >=> fromCursor
return Picture {..}
| n `nodeElNameIs` xdr "graphicFrame" = do
_grNonVisual <-
cur $/ element (xdr "nvGraphicFramePr") >=> fromCursor
_grTransform <- cur $/ element (xdr "xfrm") >=> fromCursor
_grChartSpace <-
cur $/ element (a_ "graphic") &/ element (a_ "graphicData") &/
element (c_ "chart") >=> fmap RefId . attribute (odr "id")
return Graphic {..}
| otherwise = fail "no matching drawing object node"
where
cur = fromNode n
instance FromCursor PicNonVisual where
fromCursor cur = do
_pnvDrawingProps <- cur $/ element (xdr"cNvPr") >=> fromCursor
return PicNonVisual{..}
instance FromCursor GraphNonVisual where
fromCursor cur = do
_gnvDrawingProps <- cur $/ element (xdr "cNvPr") >=> fromCursor
return GraphNonVisual {..}
instance FromCursor NonVisualDrawingProperties where
fromCursor cur = do
_nvdpId <- fromAttribute "id" cur
_nvdpName <- fromAttribute "name" cur
_nvdpDescription <- maybeAttribute "descr" cur
_nvdpHidden <- fromAttributeDef "hidden" False cur
_nvdpTitle <- maybeAttribute "title" cur
return NonVisualDrawingProperties{..}
instance FromAttrVal DrawingElementId where
fromAttrVal = fmap (first DrawingElementId) . fromAttrVal
instance FromCursor (BlipFillProperties RefId) where
fromCursor cur = do
let _bfpImageInfo = listToMaybe $ cur $/ element (a_ "blip") >=>
fmap RefId . attribute (odr"embed")
_bfpFillMode = listToMaybe $ cur $/ anyElement >=> fromCursor
return BlipFillProperties{..}
instance FromCursor FillMode where
fromCursor = fillModeFromNode . node
fillModeFromNode :: Node -> [FillMode]
fillModeFromNode n | n `nodeElNameIs` a_ "stretch" = return FillStretch
| n `nodeElNameIs` a_ "stretch" = return FillTile
| otherwise = fail "no matching fill mode node"
instance FromAttrVal EditAs where
fromAttrVal "absolute" = readSuccess EditAsAbsolute
fromAttrVal "oneCell" = readSuccess EditAsOneCell
fromAttrVal "twoCell" = readSuccess EditAsTwoCell
fromAttrVal t = invalidText "EditAs" t
instance FromCursor ClientData where
fromCursor cur = do
_cldLcksWithSheet <- fromAttributeDef "fLocksWithSheet" True cur
_cldPrintsWithSheet <- fromAttributeDef "fPrintsWithSheet" True cur
return ClientData{..}
instance ToDocument UnresolvedDrawing where
toDocument = documentFromNsElement "Drawing generated by xlsx" xlDrawingNs
. toElement "wsDr"
instance ToElement UnresolvedDrawing where
toElement nm (Drawing anchors) = Element
{ elementName = nm
, elementAttributes = M.empty
, elementNodes = map NodeElement $
map anchorToElement anchors
}
anchorToElement :: Anchor RefId RefId -> Element
anchorToElement Anchor{..} = el
{ elementNodes = elementNodes el ++
map NodeElement [ drawingObjEl, cdEl ] }
where
el = anchoringToElement _anchAnchoring
drawingObjEl = drawingObjToElement _anchObject
cdEl = toElement "clientData" _anchClientData
anchoringToElement :: Anchoring -> Element
anchoringToElement anchoring = elementList nm attrs elements
where
(nm, attrs, elements) = case anchoring of
AbsoluteAnchor{..} ->
("absoluteAnchor", [],
[ toElement "pos" absaPos, toElement "ext" absaExt ])
OneCellAnchor{..} ->
("oneCellAnchor", [],
[ toElement "from" onecaFrom, toElement "ext" onecaExt ])
TwoCellAnchor{..} ->
("twoCellAnchor", [ "editAs" .= tcaEditAs ],
[ toElement "from" tcaFrom, toElement "to" tcaTo ])
instance ToElement Marker where
toElement nm Marker{..} = elementListSimple nm elements
where
elements = [ elementContent "col" (toAttrVal _mrkCol)
, elementContent "colOff" (toAttrVal _mrkColOff)
, elementContent "row" (toAttrVal _mrkRow)
, elementContent "rowOff" (toAttrVal _mrkRowOff)]
drawingObjToElement :: DrawingObject RefId RefId -> Element
drawingObjToElement Picture {..} = elementList "pic" attrs elements
where
attrs =
catMaybes ["macro" .=? _picMacro, "fPublished" .=? justTrue _picPublished]
elements =
[ toElement "nvPicPr" _picNonVisual
, toElement "blipFill" _picBlipFill
, toElement "spPr" _picShapeProperties
]
drawingObjToElement Graphic {..} = elementListSimple "graphicFrame" elements
where
elements =
[ toElement "nvGraphicFramePr" _grNonVisual
, toElement "xfrm" _grTransform
, graphicEl
]
graphicEl =
elementListSimple
(a_ "graphic")
[ elementList
(a_ "graphicData")
["uri" .= chartNs]
[leafElement (c_ "chart") [odr "id" .= _grChartSpace]]
]
instance ToElement PicNonVisual where
toElement nm PicNonVisual {..} =
elementListSimple
nm
[toElement "cNvPr" _pnvDrawingProps, emptyElement "cNvPicPr"]
instance ToElement GraphNonVisual where
toElement nm GraphNonVisual {..} =
elementListSimple
nm
[toElement "cNvPr" _gnvDrawingProps, emptyElement "cNvGraphicFramePr"]
instance ToElement NonVisualDrawingProperties where
toElement nm NonVisualDrawingProperties{..} =
leafElement nm attrs
where
attrs = [ "id" .= _nvdpId
, "name" .= _nvdpName ] ++
catMaybes [ "descr" .=? _nvdpDescription
, "hidden" .=? justTrue _nvdpHidden
, "title" .=? _nvdpTitle ]
instance ToAttrVal DrawingElementId where
toAttrVal = toAttrVal . unDrawingElementId
instance ToElement (BlipFillProperties RefId) where
toElement nm BlipFillProperties{..} =
elementListSimple nm elements
where
elements = catMaybes [ (\rId -> leafElement (a_ "blip") [ odr "embed" .= rId ]) <$> _bfpImageInfo
, fillModeToElement <$> _bfpFillMode ]
fillModeToElement :: FillMode -> Element
fillModeToElement FillStretch = emptyElement (a_ "stretch")
fillModeToElement FillTile = emptyElement (a_ "stretch")
instance ToElement ClientData where
toElement nm ClientData{..} = leafElement nm attrs
where
attrs = catMaybes [ "fLocksWithSheet" .=? justFalse _cldLcksWithSheet
, "fPrintsWithSheet" .=? justFalse _cldPrintsWithSheet
]
instance ToAttrVal EditAs where
toAttrVal EditAsAbsolute = "absolute"
toAttrVal EditAsOneCell = "oneCell"
toAttrVal EditAsTwoCell = "twoCell"
xdr :: Text -> Name
xdr x = Name
{ nameLocalName = x
, nameNamespace = Just xlDrawingNs
, namePrefix = Nothing
}
xlDrawingNs :: Text
xlDrawingNs = "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing"