{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Drawing.Common where
import GHC.Generics (Generic)
import Control.Arrow (first)
import Control.Lens.TH
import Control.Monad (join)
import Control.Monad.Fail (MonadFail)
import Control.DeepSeq (NFData)
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
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Writer.Internal
newtype Angle =
Angle Int
deriving (Eq, Show, Generic)
instance NFData Angle
data TextBody = TextBody
{ _txbdRotation :: Angle
, _txbdSpcFirstLastPara :: Bool
, _txbdVertOverflow :: TextVertOverflow
, _txbdVertical :: TextVertical
, _txbdWrap :: TextWrap
, _txbdAnchor :: TextAnchoring
, _txbdAnchorCenter :: Bool
, _txbdParagraphs :: [TextParagraph]
} deriving (Eq, Show, Generic)
instance NFData TextBody
data TextVertOverflow
= TextVertOverflowClip
| TextVertOverflowEllipsis
| TextVertOverflow
deriving (Eq, Show, Generic)
instance NFData TextVertOverflow
data TextVertical
= TextVerticalEA
| TextVerticalHorz
| TextVerticalMongolian
| TextVertical
| TextVertical270
| TextVerticalWordArt
| TextVerticalWordArtRtl
deriving (Eq, Show, Generic)
instance NFData TextVertical
data TextWrap
= TextWrapNone
| TextWrapSquare
deriving (Eq, Show, Generic)
instance NFData TextWrap
data TextAnchoring
= TextAnchoringBottom
| TextAnchoringCenter
| TextAnchoringDistributed
| TextAnchoringJustified
| TextAnchoringTop
deriving (Eq, Show, Generic)
instance NFData TextAnchoring
data TextParagraph = TextParagraph
{ _txpaDefCharProps :: Maybe TextCharacterProperties
, _txpaRuns :: [TextRun]
} deriving (Eq, Show, Generic)
instance NFData TextParagraph
data TextCharacterProperties = TextCharacterProperties
{ _txchBold :: Bool
, _txchItalic :: Bool
, _txchUnderline :: Bool
} deriving (Eq, Show, Generic)
instance NFData TextCharacterProperties
data TextRun = RegularRun
{ _txrCharProps :: Maybe TextCharacterProperties
, _txrText :: Text
} deriving (Eq, Show, Generic)
instance NFData TextRun
data Coordinate
= UnqCoordinate Int
| UniversalMeasure UnitIdentifier
Double
deriving (Eq, Show, Generic)
instance NFData Coordinate
data UnitIdentifier
= UnitCm
| UnitMm
| UnitIn
| UnitPt
| UnitPc
| UnitPi
deriving (Eq, Show, Generic)
instance NFData UnitIdentifier
data Point2D = Point2D
{ _pt2dX :: Coordinate
, _pt2dY :: Coordinate
} deriving (Eq, Show, Generic)
instance NFData Point2D
unqPoint2D :: Int -> Int -> Point2D
unqPoint2D x y = Point2D (UnqCoordinate x) (UnqCoordinate y)
newtype PositiveCoordinate =
PositiveCoordinate Integer
deriving (Eq, Ord, Show, Generic)
instance NFData PositiveCoordinate
data PositiveSize2D = PositiveSize2D
{ _ps2dX :: PositiveCoordinate
, _ps2dY :: PositiveCoordinate
} deriving (Eq, Show, Generic)
instance NFData PositiveSize2D
positiveSize2D :: Integer -> Integer -> PositiveSize2D
positiveSize2D x y =
PositiveSize2D (PositiveCoordinate x) (PositiveCoordinate y)
cmSize2D :: Integer -> Integer -> PositiveSize2D
cmSize2D x y = positiveSize2D (cm2emu x) (cm2emu y)
cm2emu :: Integer -> Integer
cm2emu cm = 360000 * cm
data Transform2D = Transform2D
{ _trRot :: Angle
, _trFlipH :: Bool
, _trFlipV :: Bool
, _trOffset :: Maybe Point2D
, _trExtents :: Maybe PositiveSize2D
} deriving (Eq, Show, Generic)
instance NFData Transform2D
data Geometry =
PresetGeometry
deriving (Eq, Show, Generic)
instance NFData Geometry
data ShapeProperties = ShapeProperties
{ _spXfrm :: Maybe Transform2D
, _spGeometry :: Maybe Geometry
, _spFill :: Maybe FillProperties
, _spOutline :: Maybe LineProperties
} deriving (Eq, Show, Generic)
instance NFData ShapeProperties
data LineProperties = LineProperties
{ _lnFill :: Maybe FillProperties
, _lnWidth :: Int
} deriving (Eq, Show, Generic)
instance NFData LineProperties
data ColorChoice =
RgbColor Text
deriving (Eq, Show, Generic)
instance NFData ColorChoice
data FillProperties =
NoFill
| SolidFill (Maybe ColorChoice)
deriving (Eq, Show, Generic)
instance NFData FillProperties
solidRgb :: Text -> FillProperties
solidRgb t = SolidFill . Just $ RgbColor t
makeLenses ''ShapeProperties
instance Default ShapeProperties where
def = ShapeProperties Nothing Nothing Nothing Nothing
instance Default LineProperties where
def = LineProperties Nothing 0
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 {..}
instance FromAttrVal Angle where
fromAttrVal t = first Angle <$> fromAttrVal t
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
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
_lnWidth <- fromAttributeDef "w" 0 cur
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" = do
let color =
listToMaybe $ fromNode n $/ anyElement >=> colorChoiceFromNode . node
return $ SolidFill color
| otherwise = fail "no matching line fill node"
colorChoiceFromNode :: Node -> [ColorChoice]
colorChoiceFromNode n
| n `nodeElNameIs` a_ "srgbClr" = do
val <- fromAttribute "val" $ fromNode n
return $ RgbColor val
| otherwise = fail "no matching color choice node"
coordinate :: MonadFail 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 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"
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 =
leafElement (a_ "prstGeom") ["prst" .= ("rect" :: Text)]
instance ToElement LineProperties where
toElement nm LineProperties {..} = elementList nm attrs elements
where
attrs = catMaybes ["w" .=? justNonDef 0 _lnWidth]
elements = catMaybes [fillPropsToElement <$> _lnFill]
fillPropsToElement :: FillProperties -> Element
fillPropsToElement NoFill = emptyElement (a_ "noFill")
fillPropsToElement (SolidFill color) =
elementListSimple (a_ "solidFill") $ catMaybes [colorChoiceToElement <$> color]
colorChoiceToElement :: ColorChoice -> Element
colorChoiceToElement (RgbColor color) =
leafElement (a_ "srgbClr") ["val" .= color]
a_ :: Text -> Name
a_ x =
Name {nameLocalName = x, nameNamespace = Just drawingNs, namePrefix = Just "a"}
drawingNs :: Text
drawingNs = "http://schemas.openxmlformats.org/drawingml/2006/main"