module Codec.Xlsx.Types.RichText (
RichTextRun(..)
, RunProperties(..)
, applyRunProperties
, richTextRunProperties
, richTextRunText
, runPropertiesBold
, runPropertiesCharset
, runPropertiesColor
, runPropertiesCondense
, runPropertiesExtend
, runPropertiesFontFamily
, runPropertiesItalic
, runPropertiesOutline
, runPropertiesFont
, runPropertiesScheme
, runPropertiesShadow
, runPropertiesStrikeThrough
, runPropertiesSize
, runPropertiesUnderline
, runPropertiesVertAlign
) where
import GHC.Generics (Generic)
import Control.Lens hiding (element)
import Control.Monad
import Control.DeepSeq (NFData)
import Data.Default
import Data.Maybe (catMaybes)
import Data.Text (Text)
import Text.XML
import Text.XML.Cursor
import qualified Data.Map as Map
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.StyleSheet
import Codec.Xlsx.Writer.Internal
data RichTextRun = RichTextRun {
_richTextRunProperties :: Maybe RunProperties
, _richTextRunText :: Text
}
deriving (Eq, Ord, Show, Generic)
instance NFData RichTextRun
data RunProperties = RunProperties {
_runPropertiesBold :: Maybe Bool
, _runPropertiesCharset :: Maybe Int
, _runPropertiesColor :: Maybe Color
, _runPropertiesCondense :: Maybe Bool
, _runPropertiesExtend :: Maybe Bool
, _runPropertiesFontFamily :: Maybe FontFamily
, _runPropertiesItalic :: Maybe Bool
, _runPropertiesOutline :: Maybe Bool
, _runPropertiesFont :: Maybe Text
, _runPropertiesScheme :: Maybe FontScheme
, _runPropertiesShadow :: Maybe Bool
, _runPropertiesStrikeThrough :: Maybe Bool
, _runPropertiesSize :: Maybe Double
, _runPropertiesUnderline :: Maybe FontUnderline
, _runPropertiesVertAlign :: Maybe FontVerticalAlignment
}
deriving (Eq, Ord, Show, Generic)
instance NFData RunProperties
makeLenses ''RichTextRun
makeLenses ''RunProperties
instance Default RichTextRun where
def = RichTextRun {
_richTextRunProperties = Nothing
, _richTextRunText = ""
}
instance Default RunProperties where
def = RunProperties {
_runPropertiesBold = Nothing
, _runPropertiesCharset = Nothing
, _runPropertiesColor = Nothing
, _runPropertiesCondense = Nothing
, _runPropertiesExtend = Nothing
, _runPropertiesFontFamily = Nothing
, _runPropertiesItalic = Nothing
, _runPropertiesOutline = Nothing
, _runPropertiesFont = Nothing
, _runPropertiesScheme = Nothing
, _runPropertiesShadow = Nothing
, _runPropertiesStrikeThrough = Nothing
, _runPropertiesSize = Nothing
, _runPropertiesUnderline = Nothing
, _runPropertiesVertAlign = Nothing
}
instance ToElement RichTextRun where
toElement nm RichTextRun{..} = Element {
elementName = nm
, elementAttributes = Map.empty
, elementNodes = map NodeElement . catMaybes $ [
toElement "rPr" <$> _richTextRunProperties
, Just $ elementContentPreserved "t" _richTextRunText
]
}
instance ToElement RunProperties where
toElement nm RunProperties{..} = Element {
elementName = nm
, elementAttributes = Map.empty
, elementNodes = map NodeElement . catMaybes $ [
elementValue "rFont" <$> _runPropertiesFont
, elementValue "charset" <$> _runPropertiesCharset
, elementValue "family" <$> _runPropertiesFontFamily
, elementValue "b" <$> _runPropertiesBold
, elementValue "i" <$> _runPropertiesItalic
, elementValue "strike" <$> _runPropertiesStrikeThrough
, elementValue "outline" <$> _runPropertiesOutline
, elementValue "shadow" <$> _runPropertiesShadow
, elementValue "condense" <$> _runPropertiesCondense
, elementValue "extend" <$> _runPropertiesExtend
, toElement "color" <$> _runPropertiesColor
, elementValue "sz" <$> _runPropertiesSize
, elementValue "u" <$> _runPropertiesUnderline
, elementValue "vertAlign" <$> _runPropertiesVertAlign
, elementValue "scheme" <$> _runPropertiesScheme
]
}
instance FromCursor RichTextRun where
fromCursor cur = do
_richTextRunText <- cur $/ element (n_ "t") &/ content
_richTextRunProperties <- maybeFromElement (n_ "rPr") cur
return RichTextRun{..}
instance FromXenoNode RichTextRun where
fromXenoNode root = do
(prNode, tNode) <- collectChildren root $ (,) <$> maybeChild "rPr" <*> requireChild "t"
_richTextRunProperties <- mapM fromXenoNode prNode
_richTextRunText <- contentX tNode
return RichTextRun {..}
instance FromCursor RunProperties where
fromCursor cur = do
_runPropertiesFont <- maybeElementValue (n_ "rFont") cur
_runPropertiesCharset <- maybeElementValue (n_ "charset") cur
_runPropertiesFontFamily <- maybeElementValue (n_ "family") cur
_runPropertiesBold <- maybeBoolElementValue (n_ "b") cur
_runPropertiesItalic <- maybeBoolElementValue (n_ "i") cur
_runPropertiesStrikeThrough <- maybeBoolElementValue (n_ "strike") cur
_runPropertiesOutline <- maybeBoolElementValue (n_ "outline") cur
_runPropertiesShadow <- maybeBoolElementValue (n_ "shadow") cur
_runPropertiesCondense <- maybeBoolElementValue (n_ "condense") cur
_runPropertiesExtend <- maybeBoolElementValue (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{..}
instance FromXenoNode RunProperties where
fromXenoNode root = collectChildren root $ do
_runPropertiesFont <- maybeElementVal "rFont"
_runPropertiesCharset <- maybeElementVal "charset"
_runPropertiesFontFamily <- maybeElementVal "family"
_runPropertiesBold <- maybeElementVal "b"
_runPropertiesItalic <- maybeElementVal "i"
_runPropertiesStrikeThrough <- maybeElementVal "strike"
_runPropertiesOutline <- maybeElementVal "outline"
_runPropertiesShadow <- maybeElementVal "shadow"
_runPropertiesCondense <- maybeElementVal "condense"
_runPropertiesExtend <- maybeElementVal "extend"
_runPropertiesColor <- maybeFromChild "color"
_runPropertiesSize <- maybeElementVal "sz"
_runPropertiesUnderline <- maybeElementVal "u"
_runPropertiesVertAlign <- maybeElementVal "vertAlign"
_runPropertiesScheme <- maybeElementVal "scheme"
return RunProperties{..}
#if (MIN_VERSION_base(4,11,0))
instance Semigroup RunProperties where
a <> b = RunProperties {
_runPropertiesBold = override _runPropertiesBold
, _runPropertiesCharset = override _runPropertiesCharset
, _runPropertiesColor = override _runPropertiesColor
, _runPropertiesCondense = override _runPropertiesCondense
, _runPropertiesExtend = override _runPropertiesExtend
, _runPropertiesFontFamily = override _runPropertiesFontFamily
, _runPropertiesItalic = override _runPropertiesItalic
, _runPropertiesOutline = override _runPropertiesOutline
, _runPropertiesFont = override _runPropertiesFont
, _runPropertiesScheme = override _runPropertiesScheme
, _runPropertiesShadow = override _runPropertiesShadow
, _runPropertiesStrikeThrough = override _runPropertiesStrikeThrough
, _runPropertiesSize = override _runPropertiesSize
, _runPropertiesUnderline = override _runPropertiesUnderline
, _runPropertiesVertAlign = override _runPropertiesVertAlign
}
where
override :: (RunProperties -> Maybe x) -> Maybe x
override f = f b `mplus` f a
#endif
instance Monoid RunProperties where
mempty = def
a `mappend` b = RunProperties {
_runPropertiesBold = override _runPropertiesBold
, _runPropertiesCharset = override _runPropertiesCharset
, _runPropertiesColor = override _runPropertiesColor
, _runPropertiesCondense = override _runPropertiesCondense
, _runPropertiesExtend = override _runPropertiesExtend
, _runPropertiesFontFamily = override _runPropertiesFontFamily
, _runPropertiesItalic = override _runPropertiesItalic
, _runPropertiesOutline = override _runPropertiesOutline
, _runPropertiesFont = override _runPropertiesFont
, _runPropertiesScheme = override _runPropertiesScheme
, _runPropertiesShadow = override _runPropertiesShadow
, _runPropertiesStrikeThrough = override _runPropertiesStrikeThrough
, _runPropertiesSize = override _runPropertiesSize
, _runPropertiesUnderline = override _runPropertiesUnderline
, _runPropertiesVertAlign = override _runPropertiesVertAlign
}
where
override :: (RunProperties -> Maybe x) -> Maybe x
override f = f b `mplus` f a
applyRunProperties :: RunProperties -> RichTextRun -> RichTextRun
applyRunProperties p (RichTextRun Nothing t) = RichTextRun (Just p) t
applyRunProperties p (RichTextRun (Just p') t) = RichTextRun (Just (p `mappend` p')) t