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.List ( unfoldr )
import Data.Default
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
data FontPitch = PitchVariable | PitchFixed
deriving ( Eq, Show )
instance Lookupable FontPitch where
lookupTable = [ ("variable" , PitchVariable)
, ("fixed" , PitchFixed )
]
instance Default FontPitch where
def = PitchVariable
type FontFaceName = String
type FontPitches = M.Map FontFaceName FontPitch
type StyleReader a b = XMLReader FontPitches a b
type StyleReaderSafe a b = XMLReaderSafe FontPitches a b
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
readFontPitches :: StyleReader x x
readFontPitches = producingExtraState () () fontPitchReader
findPitch :: XMLReaderSafe FontPitches _x (Maybe FontPitch)
findPitch = ( lookupAttr NsStyle "font-pitch"
`ifFailedDo` findAttr NsStyle "font-name"
>>? ( keepingTheValue getExtraState
>>% M.lookup
>>^ maybeToChoice
)
)
>>> choiceToMaybe
type StyleName = String
data Styles = Styles
{ stylesByName :: M.Map StyleName Style
, listStylesByName :: M.Map StyleName ListStyle
, defaultStyleMap :: M.Map StyleFamily StyleProperties
}
deriving ( Show )
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)
data StyleFamily = FaText | FaParagraph
deriving ( Eq, Ord, Show )
instance Lookupable StyleFamily where
lookupTable = [ ( "text" , FaText )
, ( "paragraph" , FaParagraph )
]
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
}
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
}
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 _ _ = []
estimateInMillimeter :: Int -> XslUnit -> Int
estimateInMillimeter n XslUnitMM = n
estimateInMillimeter n XslUnitCM = n * 10
estimateInMillimeter n XslUnitInch = n * 25
estimateInMillimeter n XslUnitPoints = n `div` 3
estimateInMillimeter n XslUnitPica = n * 4
estimateInMillimeter n XslUnitPixel = n `div`3
estimateInMillimeter n XslUnitEM = n * 7
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)
data ListLevelStyle = ListLevelStyle { listLevelType :: ListLevelType
, listItemPrefix :: Maybe String
, listItemSuffix :: Maybe String
, listItemFormat :: ListItemNumberFormat
}
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 , "")]
readAllStyles :: StyleReader _x Styles
readAllStyles = ( readFontPitches
>>?! ( readAutomaticStyles
&&& readStyles ))
>>?%? chooseMax
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
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
( liftA4 toListLevelStyle
( returnV levelType )
( findAttr' NsStyle "num-prefix" )
( findAttr' NsStyle "num-suffix" )
( getAttr NsStyle "num-format" )
)
where
toListLevelStyle _ p s LinfNone = ListLevelStyle LltBullet p s LinfNone
toListLevelStyle _ p s f@(LinfString _) = ListLevelStyle LltBullet p s f
toListLevelStyle t p s f = ListLevelStyle t p s f
chooseMostSpecificListLevelStyle :: S.Set ListLevelStyle -> Maybe ListLevelStyle
chooseMostSpecificListLevelStyle ls | ls == mempty = Nothing
| otherwise = Just ( F.foldr1 select ls )
where
select ( ListLevelStyle t1 p1 s1 f1 )
( ListLevelStyle t2 p2 s2 f2 )
= ListLevelStyle (select' t1 t2) (p1 <|> p2) (s1 <|> s2) (selectLinf f1 f2)
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
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
parents :: Style -> Styles -> [Style]
parents style styles = unfoldr findNextParent style
where findNextParent Style{..}
= fmap duplicate $ (`lookupStyle` styles) =<< styleParentName
getStyleFamily :: Style -> Styles -> Maybe StyleFamily
getStyleFamily style@Style{..} styles
= styleFamily
<|> (F.asum $ map (`getStyleFamily` styles) $ parents style styles)
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)
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
liftStyles :: (OdtConverterState s -> OdtConverterState Styles)
-> (OdtConverterState Styles -> OdtConverterState s )
-> XMLReader s x x
liftStyles extract inject = switchState extract inject
$ convertingExtraState M.empty readAllStyles