diff options
Diffstat (limited to 'src/Text/Pandoc/Readers/Odt/StyleReader.hs')
| -rw-r--r-- | src/Text/Pandoc/Readers/Odt/StyleReader.hs | 187 |
1 files changed, 50 insertions, 137 deletions
diff --git a/src/Text/Pandoc/Readers/Odt/StyleReader.hs b/src/Text/Pandoc/Readers/Odt/StyleReader.hs index 26ba6df82..58be8e4a3 100644 --- a/src/Text/Pandoc/Readers/Odt/StyleReader.hs +++ b/src/Text/Pandoc/Readers/Odt/StyleReader.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Arrows #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + {- Copyright (C) 2015 Martin Linnemann <theCodingMarlin@googlemail.com> @@ -50,49 +49,36 @@ module Text.Pandoc.Readers.Odt.StyleReader , 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 Control.Applicative hiding (liftA, liftA2, liftA3) +import Control.Arrow -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 Data.Char (isDigit) +import Data.Default +import qualified Data.Foldable as F +import Data.List (unfoldr) +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Set as S -import qualified Text.XML.Light as XML +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.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.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.Namespaces -import Text.Pandoc.Readers.Odt.Base +import Text.Pandoc.Readers.Odt.Base +import Text.Pandoc.Readers.Odt.Namespaces readStylesAt :: XML.Element -> Fallible Styles @@ -118,7 +104,7 @@ instance Lookupable FontPitch where instance Default FontPitch where def = PitchVariable --- The font pitch can be specifed in a style directly. Normally, however, +-- 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 @@ -145,13 +131,12 @@ type StyleReaderSafe a b = XMLReaderSafe FontPitches a b -- | A reader for font pitches fontPitchReader :: XMLReader _s _x FontPitches fontPitchReader = executeIn NsOffice "font-face-decls" ( - ( withEveryL NsStyle "font-face" $ liftAsSuccess ( + withEveryL NsStyle "font-face" (liftAsSuccess ( findAttr' NsStyle "name" &&& lookupDefaultingAttr NsStyle "font-pitch" - ) - ) - >>?^ ( M.fromList . (foldl accumLegalPitches []) ) + )) + >>?^ ( M.fromList . foldl accumLegalPitches [] ) ) where accumLegalPitches ls (Nothing,_) = ls accumLegalPitches ls (Just n,p) = (n,p):ls @@ -230,15 +215,15 @@ instance Lookupable StyleFamily where ] -- | A named style -data Style = Style { styleFamily :: Maybe StyleFamily - , styleParentName :: Maybe StyleName - , listStyle :: Maybe StyleName - , styleProperties :: StyleProperties +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 +data StyleProperties = SProps { textProperties :: Maybe TextProperties + , paraProperties :: Maybe ParaProperties -- , tableColProperties :: Maybe TColProperties -- , tableRowProperties :: Maybe TRowProperties -- , tableCellProperties :: Maybe TCellProperties @@ -354,8 +339,8 @@ instance Read XslUnit where readsPrec _ "em" = [(XslUnitEM , "")] readsPrec _ _ = [] --- | Rough conversion of measures into millimeters. --- Pixels and em's are actually implemetation dependant/relative measures, +-- | Rough conversion of measures into millimetres. +-- Pixels and em's are actually implementation 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. @@ -397,11 +382,11 @@ data ListLevelStyle = ListLevelStyle { listLevelType :: ListLevelType instance Show ListLevelStyle where show ListLevelStyle{..} = "<LLS|" - ++ (show listLevelType) + ++ show listLevelType ++ "|" - ++ (maybeToString listItemPrefix) - ++ (show listItemFormat) - ++ (maybeToString listItemSuffix) + ++ maybeToString listItemPrefix + ++ show listItemFormat + ++ maybeToString listItemSuffix ++ ">" where maybeToString = fromMaybe "" @@ -439,7 +424,7 @@ instance Read ListItemNumberFormat where -------------------------------------------------------------------------------- -- Readers -- --- ...it seems like a whole lot of this should be automatically deriveable +-- ...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. -------------------------------------------------------------------------------- @@ -497,14 +482,14 @@ readTextProperties = ( liftA6 PropT ( searchAttr NsXSL_FO "font-style" False isFontEmphasised ) ( searchAttr NsXSL_FO "font-weight" False isFontBold ) - ( findPitch ) + findPitch ( getAttr NsStyle "text-position" ) - ( readUnderlineMode ) - ( readStrikeThroughMode ) + readUnderlineMode + readStrikeThroughMode ) where isFontEmphasised = [("normal",False),("italic",True),("oblique",True)] isFontBold = ("normal",False):("bold",True) - :(map ((,True).show) ([100,200..900]::[Int])) + :map ((,True).show) ([100,200..900]::[Int]) readUnderlineMode :: StyleReaderSafe _x (Maybe UnderlineMode) readUnderlineMode = readLineMode "text-underline-mode" @@ -524,7 +509,7 @@ readLineMode modeAttr styleAttr = proc x -> do Nothing -> returnA -< Just UnderlineModeNormal else returnA -< Nothing where - isLinePresent = [("none",False)] ++ map (,True) + isLinePresent = ("none",False) : map (,True) [ "dash" , "dot-dash" , "dot-dot-dash" , "dotted" , "long-dash" , "solid" , "wave" ] @@ -561,20 +546,18 @@ readListStyle = findAttr NsStyle "name" >>?! keepingTheValue ( liftA ListStyle - $ ( liftA3 SM.union3 + $ 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 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) + tryAll namespace elementName (readListLevelStyle levelType) >>^ SM.fromList - ) -- readListLevelStyle :: ListLevelType -> StyleReader _x (Int, ListLevelStyle) @@ -624,20 +607,11 @@ 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 @@ -655,7 +629,7 @@ parents style styles = unfoldr findNextParent style -- Ha! getStyleFamily :: Style -> Styles -> Maybe StyleFamily getStyleFamily style@Style{..} styles = styleFamily - <|> (F.asum $ map (`getStyleFamily` styles) $ parents style styles) + <|> 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 @@ -677,68 +651,7 @@ stylePropertyChain 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 - +extendedStylePropertyChain [style] styles = stylePropertyChain style styles + ++ maybeToList (fmap (lookupDefaultStyle' styles) (getStyleFamily style styles)) +extendedStylePropertyChain (style:trace) styles = stylePropertyChain style styles + ++ extendedStylePropertyChain trace styles |