diff options
Diffstat (limited to 'src/Text/Pandoc/Readers/Odt/StyleReader.hs')
| -rw-r--r-- | src/Text/Pandoc/Readers/Odt/StyleReader.hs | 744 |
1 files changed, 0 insertions, 744 deletions
diff --git a/src/Text/Pandoc/Readers/Odt/StyleReader.hs b/src/Text/Pandoc/Readers/Odt/StyleReader.hs deleted file mode 100644 index 26ba6df82..000000000 --- a/src/Text/Pandoc/Readers/Odt/StyleReader.hs +++ /dev/null @@ -1,744 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE Arrows #-} - -{- -Copyright (C) 2015 Martin Linnemann <theCodingMarlin@googlemail.com> - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- | - 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 -, getTextProperty -, getTextProperty' -, getParaProperty -, getListStyle -, getListLevelStyle -, getStyleFamily -, lookupDefaultStyle -, lookupDefaultStyle' -, lookupListStyleByName -, getPropertyChain -, textPropertyChain -, stylePropertyChain -, stylePropertyChain' -, getStylePropertyChain -, extendedStylePropertyChain -, extendedStylePropertyChain' -, liftStyles -, readStylesAt -) where - -import Control.Arrow -import Control.Applicative hiding ( liftA, liftA2, liftA3 ) - -import qualified Data.Foldable as F -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Char ( isDigit ) -import Data.Default -import Data.List ( unfoldr ) -import Data.Maybe - -import qualified Text.XML.Light as XML - -import Text.Pandoc.Readers.Odt.Arrows.State -import Text.Pandoc.Readers.Odt.Arrows.Utils - -import Text.Pandoc.Readers.Odt.Generic.Utils -import qualified Text.Pandoc.Readers.Odt.Generic.SetMap as SM -import Text.Pandoc.Readers.Odt.Generic.Fallible -import Text.Pandoc.Readers.Odt.Generic.XMLConverter - -import Text.Pandoc.Readers.Odt.Namespaces -import Text.Pandoc.Readers.Odt.Base - - -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 specifed in a style directly. Normally, however, --- it is defined in the font. That is also the specs' recommendation. --- --- Thus, we want - -type FontFaceName = String - -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 = executeIn NsOffice "font-face-decls" ( - ( withEveryL NsStyle "font-face" $ liftAsSuccess ( - findAttr' NsStyle "name" - &&& - lookupDefaultingAttr NsStyle "font-pitch" - ) - ) - >>?^ ( M.fromList . (foldl accumLegalPitches []) ) - ) - 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 = String - --- | 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 Monoid Styles where - mempty = Styles M.empty M.empty M.empty - mappend (Styles sBn1 dSm1 lsBn1) - (Styles sBn2 dSm2 lsBn2) - = Styles (M.union sBn1 sBn2) - (M.union dSm1 dSm2) - (M.union lsBn1 lsBn2) - --- 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 millimeters. --- Pixels and em's are actually implemetation dependant/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 String - , listItemSuffix :: Maybe String - , listItemFormat :: ListItemNumberFormat - , listItemStart :: Int - } - deriving ( Eq, Ord ) - -instance Show ListLevelStyle where - show ListLevelStyle{..} = "<LLS|" - ++ (show listLevelType) - ++ "|" - ++ (maybeToString listItemPrefix) - ++ (show listItemFormat) - ++ (maybeToString 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 deriveable --- 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 = executeIn 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 = executeIn 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 = - executeIn 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).show) ([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 :: String -> String -> 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 = - executeIn 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" ) - ( findAttr' 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 (Just "") = 1 - startValue (Just v) = if all isDigit v - then read v - else 1 - startValue Nothing = 1 - --- -chooseMostSpecificListLevelStyle :: S.Set ListLevelStyle -> Maybe ListLevelStyle -chooseMostSpecificListLevelStyle ls | ls == mempty = Nothing - | otherwise = Just ( F.foldr1 select ls ) - where - select ( ListLevelStyle t1 p1 s1 f1 b1 ) - ( ListLevelStyle t2 p2 s2 f2 _ ) - = 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 :: StyleFamily -> Styles -> StyleProperties -lookupDefaultStyle family Styles{..} = fromMaybe def - (M.lookup family defaultStyleMap) - --- -lookupDefaultStyle' :: Styles -> StyleFamily -> StyleProperties -lookupDefaultStyle' Styles{..} family = fromMaybe def - (M.lookup family defaultStyleMap) - --- -getListStyle :: Style -> Styles -> Maybe ListStyle -getListStyle Style{..} styles = listStyle >>= (`lookupListStyleByName` styles) - --- -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) --- Optimizable with Data.Sequence - --- -extendedStylePropertyChain' :: [Style] -> Styles -> Maybe [StyleProperties] -extendedStylePropertyChain' [] _ = Nothing -extendedStylePropertyChain' [style] styles = Just ( - (stylePropertyChain style styles) - ++ (maybeToList (fmap (lookupDefaultStyle' styles) (getStyleFamily style styles))) - ) -extendedStylePropertyChain' (style:trace) styles = fmap ((stylePropertyChain style styles) ++) - (extendedStylePropertyChain' trace styles) - --- -stylePropertyChain' :: Styles -> Style -> [StyleProperties] -stylePropertyChain' = flip stylePropertyChain - --- -getStylePropertyChain :: StyleName -> Styles -> [StyleProperties] -getStylePropertyChain name styles = maybe [] - (`stylePropertyChain` styles) - (lookupStyle name styles) - --- -getPropertyChain :: (StyleProperties -> Maybe a) -> Style -> Styles -> [a] -getPropertyChain extract style styles = catMaybes - $ map extract - $ stylePropertyChain style styles - --- -textPropertyChain :: Style -> Styles -> [TextProperties] -textPropertyChain = getPropertyChain textProperties - --- -paraPropertyChain :: Style -> Styles -> [ParaProperties] -paraPropertyChain = getPropertyChain paraProperties - --- -getTextProperty :: (TextProperties -> a) -> Style -> Styles -> Maybe a -getTextProperty extract style styles = fmap extract - $ listToMaybe - $ textPropertyChain style styles - --- -getTextProperty' :: (TextProperties -> Maybe a) -> Style -> Styles -> Maybe a -getTextProperty' extract style styles = F.asum - $ map extract - $ textPropertyChain style styles - --- -getParaProperty :: (ParaProperties -> a) -> Style -> Styles -> Maybe a -getParaProperty extract style styles = fmap extract - $ listToMaybe - $ paraPropertyChain style styles - --- | Lifts the reader into another readers' state. -liftStyles :: (OdtConverterState s -> OdtConverterState Styles) - -> (OdtConverterState Styles -> OdtConverterState s ) - -> XMLReader s x x -liftStyles extract inject = switchState extract inject - $ convertingExtraState M.empty readAllStyles - |