RichText.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.RichText (
    -- * Main types
    RichTextRun(..)
  , RunProperties(..)
  , applyRunProperties
    -- * Lenses
    -- ** RichTextRun
  , richTextRunProperties
  , richTextRunText
    -- ** RunProperties
  , 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

-- | Rich Text Run
--
-- This element represents a run of rich text. A rich text run is a region of
-- text that share a common set of properties, such as formatting properties.
--
-- Section 18.4.4, "r (Rich Text Run)" (p. 1724)
data RichTextRun = RichTextRun {
    -- | This element represents a set of properties to apply to the contents of
    -- this rich text run.
    _richTextRunProperties :: Maybe RunProperties

    -- | This element represents the text content shown as part of a string.
    --
    -- NOTE: 'RichTextRun' elements with an empty text field will result in
    -- an error when opening the file in Excel.
    --
    -- Section 18.4.12, "t (Text)" (p. 1727)
  , _richTextRunText :: Text
  }
  deriving (Eq, Ord, Show, Generic)

instance NFData RichTextRun

-- | Run properties
--
-- Section 18.4.7, "rPr (Run Properties)" (p. 1725)
data RunProperties = RunProperties {
    -- | Displays characters in bold face font style.
    --
    -- Section 18.8.2, "b (Bold)" (p. 1757)
    _runPropertiesBold :: Maybe Bool

    -- | This element defines the font character set of this font.
    --
    -- Section 18.4.1, "charset (Character Set)" (p. 1721)
  , _runPropertiesCharset :: Maybe Int

    -- | One of the colors associated with the data bar or color scale.
    --
    -- Section 18.3.1.15, "color (Data Bar Color)" (p. 1608)
  , _runPropertiesColor :: Maybe Color

    -- | Macintosh compatibility setting. Represents special word/character
    -- rendering on Macintosh, when this flag is set. The effect is to condense
    -- the text (squeeze it together).
    --
    -- Section 18.8.12, "condense (Condense)" (p. 1764)
  , _runPropertiesCondense :: Maybe Bool

    -- | This element specifies a compatibility setting used for previous
    -- spreadsheet applications, resulting in special word/character rendering
    -- on those legacy applications, when this flag is set. The effect extends
    -- or stretches out the text.
    --
    -- Section 18.8.17, "extend (Extend)" (p. 1766)
  , _runPropertiesExtend :: Maybe Bool

    -- | The font family this font belongs to. A font family is a set of fonts
    -- having common stroke width and serif characteristics. This is system
    -- level font information. The font name overrides when there are
    -- conflicting values.
    --
    -- Section 18.8.18, "family (Font Family)" (p. 1766)
  , _runPropertiesFontFamily :: Maybe FontFamily

    -- | Displays characters in italic font style. The italic style is defined
    -- by the font at a system level and is not specified by ECMA-376.
    --
    -- Section 18.8.26, "i (Italic)" (p. 1773)
  , _runPropertiesItalic :: Maybe Bool

    -- | This element displays only the inner and outer borders of each
    -- character. This is very similar to Bold in behavior.
    --
    -- Section 18.4.2, "outline (Outline)" (p. 1722)
  , _runPropertiesOutline :: Maybe Bool

    -- | This element is a string representing the name of the font assigned to
    -- display this run.
    --
    -- Section 18.4.5, "rFont (Font)" (p. 1724)
  , _runPropertiesFont :: Maybe Text

    -- | Defines the font scheme, if any, to which this font belongs. When a
    -- font definition is part of a theme definition, then the font is
    -- categorized as either a major or minor font scheme component. When a new
    -- theme is chosen, every font that is part of a theme definition is updated
    -- to use the new major or minor font definition for that theme. Usually
    -- major fonts are used for styles like headings, and minor fonts are used
    -- for body and paragraph text.
    --
    -- Section 18.8.35, "scheme (Scheme)" (p. 1794)
  , _runPropertiesScheme :: Maybe FontScheme

    -- | Macintosh compatibility setting. Represents special word/character
    -- rendering on Macintosh, when this flag is set. The effect is to render a
    -- shadow behind, beneath and to the right of the text.
    --
    -- Section 18.8.36, "shadow (Shadow)" (p. 1795)
  , _runPropertiesShadow :: Maybe Bool

    -- | This element draws a strikethrough line through the horizontal middle
    -- of the text.
    --
    -- Section 18.4.10, "strike (Strike Through)" (p. 1726)
  , _runPropertiesStrikeThrough :: Maybe Bool

    -- | This element represents the point size (1/72 of an inch) of the Latin
    -- and East Asian text.
    --
    -- Section 18.4.11, "sz (Font Size)" (p. 1727)
  , _runPropertiesSize :: Maybe Double

    -- | This element represents the underline formatting style.
    --
    -- Section 18.4.13, "u (Underline)" (p. 1728)
  , _runPropertiesUnderline :: Maybe FontUnderline

    -- | This element adjusts the vertical position of the text relative to the
    -- text's default appearance for this run. It is used to get 'superscript'
    -- or 'subscript' texts, and shall reduce the font size (if a smaller size
    -- is available) accordingly.
    --
    -- Section 18.4.14, "vertAlign (Vertical Alignment)" (p. 1728)
  , _runPropertiesVertAlign :: Maybe FontVerticalAlignment
  }
  deriving (Eq, Ord, Show, Generic)

instance NFData RunProperties

{-------------------------------------------------------------------------------
  Lenses
-------------------------------------------------------------------------------}

makeLenses ''RichTextRun
makeLenses ''RunProperties

{-------------------------------------------------------------------------------
  Default instances
-------------------------------------------------------------------------------}

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
    }

{-------------------------------------------------------------------------------
  Rendering
-------------------------------------------------------------------------------}

-- | See @CT_RElt@, p. 3903
instance ToElement RichTextRun where
  toElement nm RichTextRun{..} = Element {
      elementName       = nm
    , elementAttributes = Map.empty
    , elementNodes      = map NodeElement . catMaybes $ [
          toElement "rPr" <$> _richTextRunProperties
        , Just $ elementContentPreserved "t" _richTextRunText
        ]
    }

-- | See @CT_RPrElt@, p. 3903
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
        , elementValueDef "u" FontUnderlineSingle
                                   <$> _runPropertiesUnderline
        , elementValue "vertAlign" <$> _runPropertiesVertAlign
        , elementValue "scheme"    <$> _runPropertiesScheme
        ]
    }

{-------------------------------------------------------------------------------
  Parsing
-------------------------------------------------------------------------------}

-- | See @CT_RElt@, p. 3903
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 {..}

-- | 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          <- 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     <- maybeElementValueDef (n_ "u") FontUnderlineSingle 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{..}

{-------------------------------------------------------------------------------
  Applying formatting
-------------------------------------------------------------------------------}

#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

-- | The 'Monoid' instance for 'RunProperties' is biased: later properties
-- override earlier ones.
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

-- | Apply properties to a 'RichTextRun'
--
-- If the 'RichTextRun' specifies its own properties, then these overrule the
-- properties specified here. For example, adding @bold@ to a 'RichTextRun'
-- which is already @italic@ will make the 'RichTextRun' both @bold and @italic@
-- but adding it to one that that is explicitly _not_ bold will leave the
-- 'RichTextRun' unchanged.
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