pandoc-2.13: src/Text/Pandoc/Readers/Odt/StyleReader.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Text.Pandoc.Readers.Odt.StyleReader
Copyright : Copyright (C) 2015 Martin Linnemann
License : GNU GPL, version 2 or above
Maintainer : Martin Linnemann <theCodingMarlin@googlemail.com>
Stability : alpha
Portability : portable
Reader for the style information in an odt document.
-}
module Text.Pandoc.Readers.Odt.StyleReader
( Style (..)
, StyleName
, StyleFamily (..)
, Styles (..)
, StyleProperties (..)
, TextProperties (..)
, ParaProperties (..)
, VerticalTextPosition (..)
, ListItemNumberFormat (..)
, ListLevel
, ListStyle (..)
, ListLevelStyle (..)
, ListLevelType (..)
, LengthOrPercent (..)
, lookupStyle
, getListLevelStyle
, getStyleFamily
, lookupDefaultStyle'
, lookupListStyleByName
, extendedStylePropertyChain
, readStylesAt
) where
import Control.Applicative hiding (liftA, liftA2, liftA3)
import Control.Arrow
import Data.Default
import qualified Data.Foldable as F
import Data.List (unfoldr, foldl')
import qualified Data.Map as M
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Set as S
import qualified Text.Pandoc.XML.Light as XML
import Text.Pandoc.Shared (safeRead, tshow)
import Text.Pandoc.Readers.Odt.Arrows.Utils
import Text.Pandoc.Readers.Odt.Generic.Fallible
import qualified Text.Pandoc.Readers.Odt.Generic.SetMap as SM
import Text.Pandoc.Readers.Odt.Generic.Utils
import Text.Pandoc.Readers.Odt.Generic.XMLConverter
import Text.Pandoc.Readers.Odt.Base
import Text.Pandoc.Readers.Odt.Namespaces
readStylesAt :: XML.Element -> Fallible Styles
readStylesAt e = runConverter' readAllStyles mempty e
--------------------------------------------------------------------------------
-- Reader for font declarations and font pitches
--------------------------------------------------------------------------------
-- Pandoc has no support for different font pitches. Yet knowing them can be
-- very helpful in cases where Pandoc has more semantics than OpenDocument.
-- In these cases, the pitch can help deciding as what to define a block of
-- text. So let's start with a type for font pitches:
data FontPitch = PitchVariable | PitchFixed
deriving ( Eq, Show )
instance Lookupable FontPitch where
lookupTable = [ ("variable" , PitchVariable)
, ("fixed" , PitchFixed )
]
instance Default FontPitch where
def = PitchVariable
-- The font pitch can be specified in a style directly. Normally, however,
-- it is defined in the font. That is also the specs' recommendation.
--
-- Thus, we want
type FontFaceName = Text
type FontPitches = M.Map FontFaceName FontPitch
-- To get there, the fonts have to be read and the pitches extracted.
-- But the resulting map are only needed at one later place, so it should not be
-- transported on the value level, especially as we already use a state arrow.
-- So instead, the resulting map is lifted into the state of the reader.
-- (An alternative might be ImplicitParams, but again, we already have a state.)
--
-- So the main style readers will have the types
type StyleReader a b = XMLReader FontPitches a b
-- and
type StyleReaderSafe a b = XMLReaderSafe FontPitches a b
-- respectively.
--
-- But before we can work with these, we need to define the reader that reads
-- the fonts:
-- | A reader for font pitches
fontPitchReader :: XMLReader _s _x FontPitches
fontPitchReader = executeInSub NsOffice "font-face-decls" (
withEveryL NsStyle "font-face" (liftAsSuccess (
findAttr' NsStyle "name"
&&&
lookupDefaultingAttr NsStyle "font-pitch"
))
>>?^ ( M.fromList . foldl' accumLegalPitches [] )
) `ifFailedDo` returnV (Right M.empty)
where accumLegalPitches ls (Nothing,_) = ls
accumLegalPitches ls (Just n,p) = (n,p):ls
-- | A wrapper around the font pitch reader that lifts the result into the
-- state.
readFontPitches :: StyleReader x x
readFontPitches = producingExtraState () () fontPitchReader
-- | Looking up a pitch in the state of the arrow.
--
-- The function does the following:
-- * Look for the font pitch in an attribute.
-- * If that fails, look for the font name, look up the font in the state
-- and use the pitch from there.
-- * Return the result in a Maybe
--
findPitch :: XMLReaderSafe FontPitches _x (Maybe FontPitch)
findPitch = ( lookupAttr NsStyle "font-pitch"
`ifFailedDo` findAttr NsStyle "font-name"
>>? ( keepingTheValue getExtraState
>>% M.lookup
>>^ maybeToChoice
)
)
>>> choiceToMaybe
--------------------------------------------------------------------------------
-- Definitions of main data
--------------------------------------------------------------------------------
type StyleName = Text
-- | There are two types of styles: named styles with a style family and an
-- optional style parent, and default styles for each style family,
-- defining default style properties
data Styles = Styles
{ stylesByName :: M.Map StyleName Style
, listStylesByName :: M.Map StyleName ListStyle
, defaultStyleMap :: M.Map StyleFamily StyleProperties
}
deriving ( Show )
-- Styles from a monoid under union
instance Semigroup Styles where
(Styles sBn1 dSm1 lsBn1) <> (Styles sBn2 dSm2 lsBn2)
= Styles (M.union sBn1 sBn2)
(M.union dSm1 dSm2)
(M.union lsBn1 lsBn2)
instance Monoid Styles where
mempty = Styles M.empty M.empty M.empty
mappend = (<>)
-- Not all families from the specifications are implemented, only those we need.
-- But there are none that are not mentioned here.
data StyleFamily = FaText | FaParagraph
-- | FaTable | FaTableCell | FaTableColumn | FaTableRow
-- | FaGraphic | FaDrawing | FaChart
-- | FaPresentation
-- | FaRuby
deriving ( Eq, Ord, Show )
instance Lookupable StyleFamily where
lookupTable = [ ( "text" , FaText )
, ( "paragraph" , FaParagraph )
-- , ( "table" , FaTable )
-- , ( "table-cell" , FaTableCell )
-- , ( "table-column" , FaTableColumn )
-- , ( "table-row" , FaTableRow )
-- , ( "graphic" , FaGraphic )
-- , ( "drawing-page" , FaDrawing )
-- , ( "chart" , FaChart )
-- , ( "presentation" , FaPresentation )
-- , ( "ruby" , FaRuby )
]
-- | A named style
data Style = Style { styleFamily :: Maybe StyleFamily
, styleParentName :: Maybe StyleName
, listStyle :: Maybe StyleName
, styleProperties :: StyleProperties
}
deriving ( Eq, Show )
data StyleProperties = SProps { textProperties :: Maybe TextProperties
, paraProperties :: Maybe ParaProperties
-- , tableColProperties :: Maybe TColProperties
-- , tableRowProperties :: Maybe TRowProperties
-- , tableCellProperties :: Maybe TCellProperties
-- , tableProperties :: Maybe TableProperties
-- , graphicProperties :: Maybe GraphProperties
}
deriving ( Eq, Show )
instance Default StyleProperties where
def = SProps { textProperties = Just def
, paraProperties = Just def
}
data TextProperties = PropT { isEmphasised :: Bool
, isStrong :: Bool
, pitch :: Maybe FontPitch
, verticalPosition :: VerticalTextPosition
, underline :: Maybe UnderlineMode
, strikethrough :: Maybe UnderlineMode
}
deriving ( Eq, Show )
instance Default TextProperties where
def = PropT { isEmphasised = False
, isStrong = False
, pitch = Just def
, verticalPosition = def
, underline = Nothing
, strikethrough = Nothing
}
data ParaProperties = PropP { paraNumbering :: ParaNumbering
, indentation :: LengthOrPercent
, margin_left :: LengthOrPercent
}
deriving ( Eq, Show )
instance Default ParaProperties where
def = PropP { paraNumbering = NumberingNone
, indentation = def
, margin_left = def
}
----
-- All the little data types that make up the properties
----
data VerticalTextPosition = VPosNormal | VPosSuper | VPosSub
deriving ( Eq, Show )
instance Default VerticalTextPosition where
def = VPosNormal
instance Read VerticalTextPosition where
readsPrec _ s = [ (VPosSub , s') | ("sub" , s') <- lexS ]
++ [ (VPosSuper , s') | ("super" , s') <- lexS ]
++ [ (signumToVPos n , s') | ( n , s') <- readPercent s ]
where
lexS = lex s
signumToVPos n | n < 0 = VPosSub
| n > 0 = VPosSuper
| otherwise = VPosNormal
data UnderlineMode = UnderlineModeNormal | UnderlineModeSkipWhitespace
deriving ( Eq, Show )
instance Lookupable UnderlineMode where
lookupTable = [ ( "continuous" , UnderlineModeNormal )
, ( "skip-white-space" , UnderlineModeSkipWhitespace )
]
data ParaNumbering = NumberingNone | NumberingKeep | NumberingRestart Int
deriving ( Eq, Show )
data LengthOrPercent = LengthValueMM Int | PercentValue Int
deriving ( Eq, Show )
instance Default LengthOrPercent where
def = LengthValueMM 0
instance Read LengthOrPercent where
readsPrec _ s =
[ (PercentValue percent , s' ) | (percent , s' ) <- readPercent s]
++ [ (LengthValueMM lengthMM , s'') | (length' , s' ) <- reads s
, (unit , s'') <- reads s'
, let lengthMM = estimateInMillimeter
length' unit
]
data XslUnit = XslUnitMM | XslUnitCM
| XslUnitInch
| XslUnitPoints | XslUnitPica
| XslUnitPixel
| XslUnitEM
instance Show XslUnit where
show XslUnitMM = "mm"
show XslUnitCM = "cm"
show XslUnitInch = "in"
show XslUnitPoints = "pt"
show XslUnitPica = "pc"
show XslUnitPixel = "px"
show XslUnitEM = "em"
instance Read XslUnit where
readsPrec _ "mm" = [(XslUnitMM , "")]
readsPrec _ "cm" = [(XslUnitCM , "")]
readsPrec _ "in" = [(XslUnitInch , "")]
readsPrec _ "pt" = [(XslUnitPoints , "")]
readsPrec _ "pc" = [(XslUnitPica , "")]
readsPrec _ "px" = [(XslUnitPixel , "")]
readsPrec _ "em" = [(XslUnitEM , "")]
readsPrec _ _ = []
-- | Rough conversion of measures into millimetres.
-- Pixels and em's are actually implementation dependent/relative measures,
-- so I could not really easily calculate anything exact here even if I wanted.
-- But I do not care about exactness right now, as I only use measures
-- to determine if a paragraph is "indented" or not.
estimateInMillimeter :: Int -> XslUnit -> Int
estimateInMillimeter n XslUnitMM = n
estimateInMillimeter n XslUnitCM = n * 10
estimateInMillimeter n XslUnitInch = n * 25 -- \* 25.4
estimateInMillimeter n XslUnitPoints = n `div` 3 -- \* 1/72 * 25.4
estimateInMillimeter n XslUnitPica = n * 4 -- \* 12 * 1/72 * 25.4
estimateInMillimeter n XslUnitPixel = n `div`3 -- \* 1/72 * 25.4
estimateInMillimeter n XslUnitEM = n * 7 -- \* 16 * 1/72 * 25.4
----
-- List styles
----
type ListLevel = Int
newtype ListStyle = ListStyle { levelStyles :: M.Map ListLevel ListLevelStyle
}
deriving ( Eq, Show )
--
getListLevelStyle :: ListLevel -> ListStyle -> Maybe ListLevelStyle
getListLevelStyle level ListStyle{..} =
let (lower , exactHit , _) = M.splitLookup level levelStyles
in exactHit <|> fmap fst (M.maxView lower)
-- findBy (`M.lookup` levelStyles) [level, (level-1) .. 1]
-- \^ simpler, but in general less efficient
data ListLevelStyle = ListLevelStyle { listLevelType :: ListLevelType
, listItemPrefix :: Maybe Text
, listItemSuffix :: Maybe Text
, listItemFormat :: ListItemNumberFormat
, listItemStart :: Int
}
deriving ( Eq, Ord )
instance Show ListLevelStyle where
show ListLevelStyle{..} = "<LLS|"
++ show listLevelType
++ "|"
++ maybeToString (T.unpack <$> listItemPrefix)
++ show listItemFormat
++ maybeToString (T.unpack <$> listItemSuffix)
++ ">"
where maybeToString = fromMaybe ""
data ListLevelType = LltBullet | LltImage | LltNumbered
deriving ( Eq, Ord, Show )
data ListItemNumberFormat = LinfNone
| LinfNumber
| LinfRomanLC | LinfRomanUC
| LinfAlphaLC | LinfAlphaUC
| LinfString String
deriving ( Eq, Ord )
instance Show ListItemNumberFormat where
show LinfNone = ""
show LinfNumber = "1"
show LinfRomanLC = "i"
show LinfRomanUC = "I"
show LinfAlphaLC = "a"
show LinfAlphaUC = "A"
show (LinfString s) = s
instance Default ListItemNumberFormat where
def = LinfNone
instance Read ListItemNumberFormat where
readsPrec _ "" = [(LinfNone , "")]
readsPrec _ "1" = [(LinfNumber , "")]
readsPrec _ "i" = [(LinfRomanLC , "")]
readsPrec _ "I" = [(LinfRomanUC , "")]
readsPrec _ "a" = [(LinfAlphaLC , "")]
readsPrec _ "A" = [(LinfAlphaUC , "")]
readsPrec _ s = [(LinfString s , "")]
--------------------------------------------------------------------------------
-- Readers
--
-- ...it seems like a whole lot of this should be automatically derivable
-- or at least moveable into a class. Most of this is data concealed in
-- code.
--------------------------------------------------------------------------------
--
readAllStyles :: StyleReader _x Styles
readAllStyles = ( readFontPitches
>>?! ( readAutomaticStyles
&&& readStyles ))
>>?%? chooseMax
-- all top elements are always on the same hierarchy level
--
readStyles :: StyleReader _x Styles
readStyles = executeInSub NsOffice "styles" $ liftAsSuccess
$ liftA3 Styles
( tryAll NsStyle "style" readStyle >>^ M.fromList )
( tryAll NsText "list-style" readListStyle >>^ M.fromList )
( tryAll NsStyle "default-style" readDefaultStyle >>^ M.fromList )
--
readAutomaticStyles :: StyleReader _x Styles
readAutomaticStyles = executeInSub NsOffice "automatic-styles" $ liftAsSuccess
$ liftA3 Styles
( tryAll NsStyle "style" readStyle >>^ M.fromList )
( tryAll NsText "list-style" readListStyle >>^ M.fromList )
( returnV M.empty )
--
readDefaultStyle :: StyleReader _x (StyleFamily, StyleProperties)
readDefaultStyle = lookupAttr NsStyle "family"
>>?! keepingTheValue readStyleProperties
--
readStyle :: StyleReader _x (StyleName,Style)
readStyle = findAttr NsStyle "name"
>>?! keepingTheValue
( liftA4 Style
( lookupAttr' NsStyle "family" )
( findAttr' NsStyle "parent-style-name" )
( findAttr' NsStyle "list-style-name" )
readStyleProperties
)
--
readStyleProperties :: StyleReaderSafe _x StyleProperties
readStyleProperties = liftA2 SProps
( readTextProperties >>> choiceToMaybe )
( readParaProperties >>> choiceToMaybe )
--
readTextProperties :: StyleReader _x TextProperties
readTextProperties =
executeInSub NsStyle "text-properties" $ liftAsSuccess
( liftA6 PropT
( searchAttr NsXSL_FO "font-style" False isFontEmphasised )
( searchAttr NsXSL_FO "font-weight" False isFontBold )
findPitch
( getAttr NsStyle "text-position" )
readUnderlineMode
readStrikeThroughMode
)
where isFontEmphasised = [("normal",False),("italic",True),("oblique",True)]
isFontBold = ("normal",False):("bold",True)
:map ((,True) . tshow) ([100,200..900]::[Int])
readUnderlineMode :: StyleReaderSafe _x (Maybe UnderlineMode)
readUnderlineMode = readLineMode "text-underline-mode"
"text-underline-style"
readStrikeThroughMode :: StyleReaderSafe _x (Maybe UnderlineMode)
readStrikeThroughMode = readLineMode "text-line-through-mode"
"text-line-through-style"
readLineMode :: Text -> Text -> StyleReaderSafe _x (Maybe UnderlineMode)
readLineMode modeAttr styleAttr = proc x -> do
isUL <- searchAttr NsStyle styleAttr False isLinePresent -< x
mode <- lookupAttr' NsStyle modeAttr -< x
if isUL
then case mode of
Just m -> returnA -< Just m
Nothing -> returnA -< Just UnderlineModeNormal
else returnA -< Nothing
where
isLinePresent = ("none",False) : map (,True)
[ "dash" , "dot-dash" , "dot-dot-dash" , "dotted"
, "long-dash" , "solid" , "wave"
]
--
readParaProperties :: StyleReader _x ParaProperties
readParaProperties =
executeInSub NsStyle "paragraph-properties" $ liftAsSuccess
( liftA3 PropP
( liftA2 readNumbering
( isSet' NsText "number-lines" )
( readAttr' NsText "line-number" )
)
( liftA2 readIndentation
( isSetWithDefault NsStyle "auto-text-indent" False )
( getAttr NsXSL_FO "text-indent" )
)
( getAttr NsXSL_FO "margin-left" )
)
where readNumbering (Just True) (Just n) = NumberingRestart n
readNumbering (Just True) _ = NumberingKeep
readNumbering _ _ = NumberingNone
readIndentation False indent = indent
readIndentation True _ = def
----
-- List styles
----
--
readListStyle :: StyleReader _x (StyleName, ListStyle)
readListStyle =
findAttr NsStyle "name"
>>?! keepingTheValue
( liftA ListStyle
$ liftA3 SM.union3
( readListLevelStyles NsText "list-level-style-number" LltNumbered )
( readListLevelStyles NsText "list-level-style-bullet" LltBullet )
( readListLevelStyles NsText "list-level-style-image" LltImage ) >>^ M.mapMaybe chooseMostSpecificListLevelStyle
)
--
readListLevelStyles :: Namespace -> ElementName
-> ListLevelType
-> StyleReaderSafe _x (SM.SetMap Int ListLevelStyle)
readListLevelStyles namespace elementName levelType =
tryAll namespace elementName (readListLevelStyle levelType)
>>^ SM.fromList
--
readListLevelStyle :: ListLevelType -> StyleReader _x (Int, ListLevelStyle)
readListLevelStyle levelType = readAttr NsText "level"
>>?! keepingTheValue
( liftA5 toListLevelStyle
( returnV levelType )
( findAttr' NsStyle "num-prefix" )
( findAttr' NsStyle "num-suffix" )
( getAttr NsStyle "num-format" )
( findAttrText' NsText "start-value" )
)
where
toListLevelStyle _ p s LinfNone b = ListLevelStyle LltBullet p s LinfNone (startValue b)
toListLevelStyle _ p s f@(LinfString _) b = ListLevelStyle LltBullet p s f (startValue b)
toListLevelStyle t p s f b = ListLevelStyle t p s f (startValue b)
startValue mbx = fromMaybe 1 (mbx >>= safeRead)
--
chooseMostSpecificListLevelStyle :: S.Set ListLevelStyle -> Maybe ListLevelStyle
chooseMostSpecificListLevelStyle ls = F.foldr select Nothing ls
where
select l Nothing = Just l
select ( ListLevelStyle t1 p1 s1 f1 b1 )
( Just ( ListLevelStyle t2 p2 s2 f2 _ ))
= Just $ ListLevelStyle (select' t1 t2) (p1 <|> p2) (s1 <|> s2)
(selectLinf f1 f2) b1
select' LltNumbered _ = LltNumbered
select' _ LltNumbered = LltNumbered
select' _ _ = LltBullet
selectLinf LinfNone f2 = f2
selectLinf f1 LinfNone = f1
selectLinf (LinfString _) f2 = f2
selectLinf f1 (LinfString _) = f1
selectLinf f1 _ = f1
--------------------------------------------------------------------------------
-- Tools to access style data
--------------------------------------------------------------------------------
--
lookupStyle :: StyleName -> Styles -> Maybe Style
lookupStyle name Styles{..} = M.lookup name stylesByName
--
lookupDefaultStyle' :: Styles -> StyleFamily -> StyleProperties
lookupDefaultStyle' Styles{..} family = fromMaybe def
(M.lookup family defaultStyleMap)
--
lookupListStyleByName :: StyleName -> Styles -> Maybe ListStyle
lookupListStyleByName name Styles{..} = M.lookup name listStylesByName
-- | Returns a chain of parent of the current style. The direct parent will
-- be the first element of the list, followed by its parent and so on.
-- The current style is not in the list.
parents :: Style -> Styles -> [Style]
parents style styles = unfoldr findNextParent style -- Ha!
where findNextParent Style{..}
= fmap duplicate $ (`lookupStyle` styles) =<< styleParentName
-- | Looks up the style family of the current style. Normally, every style
-- should have one. But if not, all parents are searched.
getStyleFamily :: Style -> Styles -> Maybe StyleFamily
getStyleFamily style@Style{..} styles
= styleFamily
<|> F.asum (map (`getStyleFamily` styles) $ parents style styles)
-- | Each 'Style' has certain 'StyleProperties'. But sometimes not all property
-- values are specified. Instead, a value might be inherited from a
-- parent style. This function makes this chain of inheritance
-- concrete and easily accessible by encapsulating the necessary lookups.
-- The resulting list contains the direct properties of the style as the first
-- element, the ones of the direct parent element as the next one, and so on.
--
-- Note: There should also be default properties for each style family. These
-- are @not@ contained in this list because properties inherited from
-- parent elements take precedence over default styles.
--
-- This function is primarily meant to be used through convenience wrappers.
--
stylePropertyChain :: Style -> Styles -> [StyleProperties]
stylePropertyChain style styles
= map styleProperties (style : parents style styles)
--
extendedStylePropertyChain :: [Style] -> Styles -> [StyleProperties]
extendedStylePropertyChain [] _ = []
extendedStylePropertyChain [style] styles = stylePropertyChain style styles
++ maybeToList (fmap (lookupDefaultStyle' styles) (getStyleFamily style styles))
extendedStylePropertyChain (style:trace) styles = stylePropertyChain style styles
++ extendedStylePropertyChain trace styles