{-# 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 ((<|>), optional)

import Data.Default
import qualified Data.Foldable as F
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.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

readStylesAt :: XML.Element -> Fallible Styles
readStylesAt :: Element -> Fallible Styles
readStylesAt Element
e = XMLConverter Namespace FontPitches Styles
-> FontPitches -> Element -> Fallible Styles
forall nsID extraState a.
NameSpaceID nsID =>
XMLConverter nsID extraState a
-> extraState -> Element -> Fallible a
runConverter XMLConverter Namespace FontPitches Styles
readAllStyles FontPitches
forall a. Monoid a => a
mempty Element
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 ( FontPitch -> FontPitch -> Bool
(FontPitch -> FontPitch -> Bool)
-> (FontPitch -> FontPitch -> Bool) -> Eq FontPitch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FontPitch -> FontPitch -> Bool
== :: FontPitch -> FontPitch -> Bool
$c/= :: FontPitch -> FontPitch -> Bool
/= :: FontPitch -> FontPitch -> Bool
Eq, Int -> FontPitch -> ShowS
[FontPitch] -> ShowS
FontPitch -> String
(Int -> FontPitch -> ShowS)
-> (FontPitch -> String)
-> ([FontPitch] -> ShowS)
-> Show FontPitch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FontPitch -> ShowS
showsPrec :: Int -> FontPitch -> ShowS
$cshow :: FontPitch -> String
show :: FontPitch -> String
$cshowList :: [FontPitch] -> ShowS
showList :: [FontPitch] -> ShowS
Show )

instance Lookupable FontPitch where
  lookupTable :: [(StyleName, FontPitch)]
lookupTable = [ (StyleName
"variable" , FontPitch
PitchVariable)
                , (StyleName
"fixed"    , FontPitch
PitchFixed   )
                ]

instance Default FontPitch where
  def :: FontPitch
def = FontPitch
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 is only needed at one later place, so it should not be
-- transported on the value level. Instead, it is lifted into the state of the
-- reader.
--
-- So the main style readers will have the type
type StyleReader a = XMLConverter Namespace FontPitches a
--
-- But before we can work with this, we need to define the reader that reads
-- the fonts. It is polymorphic in the extra state, since the pitches are not
-- yet available while it runs.

-- | A reader for font pitches
fontPitchReader :: XMLConverter Namespace s FontPitches
fontPitchReader :: forall s. XMLConverter Namespace s FontPitches
fontPitchReader =
  Namespace
-> StyleName
-> XMLConverter Namespace s FontPitches
-> XMLConverter Namespace s FontPitches
forall nsID extraState a.
NameSpaceID nsID =>
nsID
-> StyleName
-> XMLConverter nsID extraState a
-> XMLConverter nsID extraState a
executeInSub Namespace
NsOffice StyleName
"font-face-decls" (do
    fonts <- Namespace
-> StyleName
-> XMLConverter Namespace s (Maybe StyleName, FontPitch)
-> XMLConverter Namespace s [(Maybe StyleName, FontPitch)]
forall nsID extraState a.
NameSpaceID nsID =>
nsID
-> StyleName
-> XMLConverter nsID extraState a
-> XMLConverter nsID extraState [a]
withEveryL Namespace
NsStyle StyleName
"font-face" (XMLConverter Namespace s (Maybe StyleName, FontPitch)
 -> XMLConverter Namespace s [(Maybe StyleName, FontPitch)])
-> XMLConverter Namespace s (Maybe StyleName, FontPitch)
-> XMLConverter Namespace s [(Maybe StyleName, FontPitch)]
forall a b. (a -> b) -> a -> b
$ do
               name  <- Namespace
-> StyleName -> XMLConverter Namespace s (Maybe StyleName)
forall nsID extraState.
NameSpaceID nsID =>
nsID -> StyleName -> XMLConverter nsID extraState (Maybe StyleName)
findAttr' Namespace
NsStyle StyleName
"name"
               pitch <- lookupDefaultingAttr NsStyle "font-pitch"
               return (name, pitch)
    return $ M.fromList [ (n, p) | (Just n, p) <- fonts ])
  XMLConverter Namespace s FontPitches
-> XMLConverter Namespace s FontPitches
-> XMLConverter Namespace s FontPitches
forall a.
ExceptT () (State (XMLConverterState Namespace s)) a
-> ExceptT () (State (XMLConverterState Namespace s)) a
-> ExceptT () (State (XMLConverterState Namespace s)) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FontPitches -> XMLConverter Namespace s FontPitches
forall a. a -> ExceptT () (State (XMLConverterState Namespace s)) a
forall (m :: * -> *) a. Monad m => a -> m a
return FontPitches
forall k a. Map k a
M.empty

-- | Looking up a pitch in the extra state.
--
-- 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 :: StyleReader (Maybe FontPitch)
findPitch :: StyleReader (Maybe FontPitch)
findPitch = ExceptT
  () (State (XMLConverterState Namespace FontPitches)) FontPitch
-> StyleReader (Maybe FontPitch)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
  (ExceptT
   () (State (XMLConverterState Namespace FontPitches)) FontPitch
 -> StyleReader (Maybe FontPitch))
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) FontPitch
-> StyleReader (Maybe FontPitch)
forall a b. (a -> b) -> a -> b
$     Namespace
-> StyleName
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) FontPitch
forall nsID a extraState.
(NameSpaceID nsID, Lookupable a) =>
nsID -> StyleName -> XMLConverter nsID extraState a
lookupAttr Namespace
NsStyle StyleName
"font-pitch"
    ExceptT
  () (State (XMLConverterState Namespace FontPitches)) FontPitch
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) FontPitch
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) FontPitch
forall a.
ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do fontName <- Namespace
-> StyleName -> XMLConverter Namespace FontPitches StyleName
forall nsID extraState.
NameSpaceID nsID =>
nsID -> StyleName -> XMLConverter nsID extraState StyleName
findAttr Namespace
NsStyle StyleName
"font-name"
            pitches  <- getExtraState
            fromMaybeF $ M.lookup fontName pitches)

--------------------------------------------------------------------------------
-- 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
                          { Styles -> Map StyleName Style
stylesByName     :: M.Map StyleName   Style
                          , Styles -> Map StyleName ListStyle
listStylesByName :: M.Map StyleName   ListStyle
                          , Styles -> Map StyleFamily StyleProperties
defaultStyleMap  :: M.Map StyleFamily StyleProperties
                          }
  deriving ( Int -> Styles -> ShowS
[Styles] -> ShowS
Styles -> String
(Int -> Styles -> ShowS)
-> (Styles -> String) -> ([Styles] -> ShowS) -> Show Styles
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Styles -> ShowS
showsPrec :: Int -> Styles -> ShowS
$cshow :: Styles -> String
show :: Styles -> String
$cshowList :: [Styles] -> ShowS
showList :: [Styles] -> ShowS
Show )

-- Styles from a monoid under union
instance Semigroup Styles where
  (Styles Map StyleName Style
sBn1 Map StyleName ListStyle
dSm1 Map StyleFamily StyleProperties
lsBn1) <> :: Styles -> Styles -> Styles
<> (Styles Map StyleName Style
sBn2 Map StyleName ListStyle
dSm2 Map StyleFamily StyleProperties
lsBn2)
          = Map StyleName Style
-> Map StyleName ListStyle
-> Map StyleFamily StyleProperties
-> Styles
Styles (Map StyleName Style -> Map StyleName Style -> Map StyleName Style
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map StyleName Style
sBn1  Map StyleName Style
sBn2)
                   (Map StyleName ListStyle
-> Map StyleName ListStyle -> Map StyleName ListStyle
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map StyleName ListStyle
dSm1  Map StyleName ListStyle
dSm2)
                   (Map StyleFamily StyleProperties
-> Map StyleFamily StyleProperties
-> Map StyleFamily StyleProperties
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map StyleFamily StyleProperties
lsBn1 Map StyleFamily StyleProperties
lsBn2)
instance Monoid Styles where
  mempty :: Styles
mempty  = Map StyleName Style
-> Map StyleName ListStyle
-> Map StyleFamily StyleProperties
-> Styles
Styles Map StyleName Style
forall k a. Map k a
M.empty Map StyleName ListStyle
forall k a. Map k a
M.empty Map StyleFamily StyleProperties
forall k a. Map k a
M.empty
  mappend :: Styles -> Styles -> Styles
mappend = Styles -> Styles -> Styles
forall a. Semigroup a => a -> a -> a
(<>)

-- 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 ( StyleFamily -> StyleFamily -> Bool
(StyleFamily -> StyleFamily -> Bool)
-> (StyleFamily -> StyleFamily -> Bool) -> Eq StyleFamily
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StyleFamily -> StyleFamily -> Bool
== :: StyleFamily -> StyleFamily -> Bool
$c/= :: StyleFamily -> StyleFamily -> Bool
/= :: StyleFamily -> StyleFamily -> Bool
Eq, Eq StyleFamily
Eq StyleFamily =>
(StyleFamily -> StyleFamily -> Ordering)
-> (StyleFamily -> StyleFamily -> Bool)
-> (StyleFamily -> StyleFamily -> Bool)
-> (StyleFamily -> StyleFamily -> Bool)
-> (StyleFamily -> StyleFamily -> Bool)
-> (StyleFamily -> StyleFamily -> StyleFamily)
-> (StyleFamily -> StyleFamily -> StyleFamily)
-> Ord StyleFamily
StyleFamily -> StyleFamily -> Bool
StyleFamily -> StyleFamily -> Ordering
StyleFamily -> StyleFamily -> StyleFamily
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StyleFamily -> StyleFamily -> Ordering
compare :: StyleFamily -> StyleFamily -> Ordering
$c< :: StyleFamily -> StyleFamily -> Bool
< :: StyleFamily -> StyleFamily -> Bool
$c<= :: StyleFamily -> StyleFamily -> Bool
<= :: StyleFamily -> StyleFamily -> Bool
$c> :: StyleFamily -> StyleFamily -> Bool
> :: StyleFamily -> StyleFamily -> Bool
$c>= :: StyleFamily -> StyleFamily -> Bool
>= :: StyleFamily -> StyleFamily -> Bool
$cmax :: StyleFamily -> StyleFamily -> StyleFamily
max :: StyleFamily -> StyleFamily -> StyleFamily
$cmin :: StyleFamily -> StyleFamily -> StyleFamily
min :: StyleFamily -> StyleFamily -> StyleFamily
Ord, Int -> StyleFamily -> ShowS
[StyleFamily] -> ShowS
StyleFamily -> String
(Int -> StyleFamily -> ShowS)
-> (StyleFamily -> String)
-> ([StyleFamily] -> ShowS)
-> Show StyleFamily
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StyleFamily -> ShowS
showsPrec :: Int -> StyleFamily -> ShowS
$cshow :: StyleFamily -> String
show :: StyleFamily -> String
$cshowList :: [StyleFamily] -> ShowS
showList :: [StyleFamily] -> ShowS
Show )

instance Lookupable StyleFamily where
  lookupTable :: [(StyleName, StyleFamily)]
lookupTable = [ ( StyleName
"text"         , StyleFamily
FaText         )
                , ( StyleName
"paragraph"    , StyleFamily
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  { Style -> Maybe StyleFamily
styleFamily     :: Maybe StyleFamily
                               , Style -> Maybe StyleName
styleParentName :: Maybe StyleName
                               , Style -> Maybe StyleName
listStyle       :: Maybe StyleName
                               , Style -> StyleProperties
styleProperties :: StyleProperties
                               }
  deriving ( Style -> Style -> Bool
(Style -> Style -> Bool) -> (Style -> Style -> Bool) -> Eq Style
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Style -> Style -> Bool
== :: Style -> Style -> Bool
$c/= :: Style -> Style -> Bool
/= :: Style -> Style -> Bool
Eq, Int -> Style -> ShowS
[Style] -> ShowS
Style -> String
(Int -> Style -> ShowS)
-> (Style -> String) -> ([Style] -> ShowS) -> Show Style
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Style -> ShowS
showsPrec :: Int -> Style -> ShowS
$cshow :: Style -> String
show :: Style -> String
$cshowList :: [Style] -> ShowS
showList :: [Style] -> ShowS
Show )

data StyleProperties  = SProps { StyleProperties -> Maybe TextProperties
textProperties :: Maybe TextProperties
                               , StyleProperties -> Maybe ParaProperties
paraProperties :: Maybe ParaProperties
--                             , tableColProperties  :: Maybe TColProperties
--                             , tableRowProperties  :: Maybe TRowProperties
--                             , tableCellProperties :: Maybe TCellProperties
--                             , tableProperties     :: Maybe TableProperties
--                             , graphicProperties   :: Maybe GraphProperties
                               }
  deriving ( StyleProperties -> StyleProperties -> Bool
(StyleProperties -> StyleProperties -> Bool)
-> (StyleProperties -> StyleProperties -> Bool)
-> Eq StyleProperties
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StyleProperties -> StyleProperties -> Bool
== :: StyleProperties -> StyleProperties -> Bool
$c/= :: StyleProperties -> StyleProperties -> Bool
/= :: StyleProperties -> StyleProperties -> Bool
Eq, Int -> StyleProperties -> ShowS
[StyleProperties] -> ShowS
StyleProperties -> String
(Int -> StyleProperties -> ShowS)
-> (StyleProperties -> String)
-> ([StyleProperties] -> ShowS)
-> Show StyleProperties
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StyleProperties -> ShowS
showsPrec :: Int -> StyleProperties -> ShowS
$cshow :: StyleProperties -> String
show :: StyleProperties -> String
$cshowList :: [StyleProperties] -> ShowS
showList :: [StyleProperties] -> ShowS
Show )

instance  Default StyleProperties where
  def :: StyleProperties
def =                SProps { textProperties :: Maybe TextProperties
textProperties       = TextProperties -> Maybe TextProperties
forall a. a -> Maybe a
Just TextProperties
forall a. Default a => a
def
                               , paraProperties :: Maybe ParaProperties
paraProperties      = ParaProperties -> Maybe ParaProperties
forall a. a -> Maybe a
Just ParaProperties
forall a. Default a => a
def
                               }

data TextProperties   = PropT  { TextProperties -> Bool
isEmphasised     :: Bool
                               , TextProperties -> Bool
isStrong         :: Bool
                               , TextProperties -> Maybe FontPitch
pitch            :: Maybe FontPitch
                               , TextProperties -> VerticalTextPosition
verticalPosition :: VerticalTextPosition
                               , TextProperties -> Maybe UnderlineMode
underline        :: Maybe UnderlineMode
                               , TextProperties -> Maybe UnderlineMode
strikethrough    :: Maybe UnderlineMode
                               }
  deriving ( TextProperties -> TextProperties -> Bool
(TextProperties -> TextProperties -> Bool)
-> (TextProperties -> TextProperties -> Bool) -> Eq TextProperties
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TextProperties -> TextProperties -> Bool
== :: TextProperties -> TextProperties -> Bool
$c/= :: TextProperties -> TextProperties -> Bool
/= :: TextProperties -> TextProperties -> Bool
Eq, Int -> TextProperties -> ShowS
[TextProperties] -> ShowS
TextProperties -> String
(Int -> TextProperties -> ShowS)
-> (TextProperties -> String)
-> ([TextProperties] -> ShowS)
-> Show TextProperties
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TextProperties -> ShowS
showsPrec :: Int -> TextProperties -> ShowS
$cshow :: TextProperties -> String
show :: TextProperties -> String
$cshowList :: [TextProperties] -> ShowS
showList :: [TextProperties] -> ShowS
Show )

instance Default TextProperties where
  def :: TextProperties
def =                 PropT  { isEmphasised :: Bool
isEmphasised     = Bool
False
                               , isStrong :: Bool
isStrong         = Bool
False
                               , pitch :: Maybe FontPitch
pitch            = FontPitch -> Maybe FontPitch
forall a. a -> Maybe a
Just FontPitch
forall a. Default a => a
def
                               , verticalPosition :: VerticalTextPosition
verticalPosition = VerticalTextPosition
forall a. Default a => a
def
                               , underline :: Maybe UnderlineMode
underline        = Maybe UnderlineMode
forall a. Maybe a
Nothing
                               , strikethrough :: Maybe UnderlineMode
strikethrough    = Maybe UnderlineMode
forall a. Maybe a
Nothing
                               }

data ParaProperties   = PropP { ParaProperties -> ParaNumbering
paraNumbering :: ParaNumbering
                              , ParaProperties -> LengthOrPercent
indentation   :: LengthOrPercent
                              , ParaProperties -> LengthOrPercent
margin_left   :: LengthOrPercent
                              }
  deriving ( ParaProperties -> ParaProperties -> Bool
(ParaProperties -> ParaProperties -> Bool)
-> (ParaProperties -> ParaProperties -> Bool) -> Eq ParaProperties
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParaProperties -> ParaProperties -> Bool
== :: ParaProperties -> ParaProperties -> Bool
$c/= :: ParaProperties -> ParaProperties -> Bool
/= :: ParaProperties -> ParaProperties -> Bool
Eq, Int -> ParaProperties -> ShowS
[ParaProperties] -> ShowS
ParaProperties -> String
(Int -> ParaProperties -> ShowS)
-> (ParaProperties -> String)
-> ([ParaProperties] -> ShowS)
-> Show ParaProperties
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParaProperties -> ShowS
showsPrec :: Int -> ParaProperties -> ShowS
$cshow :: ParaProperties -> String
show :: ParaProperties -> String
$cshowList :: [ParaProperties] -> ShowS
showList :: [ParaProperties] -> ShowS
Show )

instance Default ParaProperties where
  def :: ParaProperties
def =                 PropP { paraNumbering :: ParaNumbering
paraNumbering = ParaNumbering
NumberingNone
                              , indentation :: LengthOrPercent
indentation   = LengthOrPercent
forall a. Default a => a
def
                              , margin_left :: LengthOrPercent
margin_left   = LengthOrPercent
forall a. Default a => a
def
                              }

----
-- All the little data types that make up the properties
----

data VerticalTextPosition = VPosNormal | VPosSuper | VPosSub
  deriving ( VerticalTextPosition -> VerticalTextPosition -> Bool
(VerticalTextPosition -> VerticalTextPosition -> Bool)
-> (VerticalTextPosition -> VerticalTextPosition -> Bool)
-> Eq VerticalTextPosition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VerticalTextPosition -> VerticalTextPosition -> Bool
== :: VerticalTextPosition -> VerticalTextPosition -> Bool
$c/= :: VerticalTextPosition -> VerticalTextPosition -> Bool
/= :: VerticalTextPosition -> VerticalTextPosition -> Bool
Eq, Int -> VerticalTextPosition -> ShowS
[VerticalTextPosition] -> ShowS
VerticalTextPosition -> String
(Int -> VerticalTextPosition -> ShowS)
-> (VerticalTextPosition -> String)
-> ([VerticalTextPosition] -> ShowS)
-> Show VerticalTextPosition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VerticalTextPosition -> ShowS
showsPrec :: Int -> VerticalTextPosition -> ShowS
$cshow :: VerticalTextPosition -> String
show :: VerticalTextPosition -> String
$cshowList :: [VerticalTextPosition] -> ShowS
showList :: [VerticalTextPosition] -> ShowS
Show )

instance Default VerticalTextPosition where
  def :: VerticalTextPosition
def = VerticalTextPosition
VPosNormal

instance Read VerticalTextPosition where
  readsPrec :: Int -> ReadS VerticalTextPosition
readsPrec Int
_ String
s =    [ (VerticalTextPosition
VPosSub        , String
s') | (String
"sub"   , String
s') <- [(String, String)]
lexS          ]
                  [(VerticalTextPosition, String)]
-> [(VerticalTextPosition, String)]
-> [(VerticalTextPosition, String)]
forall a. [a] -> [a] -> [a]
++ [ (VerticalTextPosition
VPosSuper      , String
s') | (String
"super" , String
s') <- [(String, String)]
lexS          ]
                  [(VerticalTextPosition, String)]
-> [(VerticalTextPosition, String)]
-> [(VerticalTextPosition, String)]
forall a. [a] -> [a] -> [a]
++ [ (Int -> VerticalTextPosition
forall {a}. (Ord a, Num a) => a -> VerticalTextPosition
signumToVPos Int
n , String
s') | (  Int
n     , String
s') <- ReadS Int
readPercent String
s ]
    where
      lexS :: [(String, String)]
lexS = ReadS String
lex String
s
      signumToVPos :: a -> VerticalTextPosition
signumToVPos a
n | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0     = VerticalTextPosition
VPosSub
                     | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0     = VerticalTextPosition
VPosSuper
                     | Bool
otherwise = VerticalTextPosition
VPosNormal

data UnderlineMode = UnderlineModeNormal | UnderlineModeSkipWhitespace
  deriving ( UnderlineMode -> UnderlineMode -> Bool
(UnderlineMode -> UnderlineMode -> Bool)
-> (UnderlineMode -> UnderlineMode -> Bool) -> Eq UnderlineMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnderlineMode -> UnderlineMode -> Bool
== :: UnderlineMode -> UnderlineMode -> Bool
$c/= :: UnderlineMode -> UnderlineMode -> Bool
/= :: UnderlineMode -> UnderlineMode -> Bool
Eq, Int -> UnderlineMode -> ShowS
[UnderlineMode] -> ShowS
UnderlineMode -> String
(Int -> UnderlineMode -> ShowS)
-> (UnderlineMode -> String)
-> ([UnderlineMode] -> ShowS)
-> Show UnderlineMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnderlineMode -> ShowS
showsPrec :: Int -> UnderlineMode -> ShowS
$cshow :: UnderlineMode -> String
show :: UnderlineMode -> String
$cshowList :: [UnderlineMode] -> ShowS
showList :: [UnderlineMode] -> ShowS
Show )

instance Lookupable UnderlineMode where
  lookupTable :: [(StyleName, UnderlineMode)]
lookupTable = [ ( StyleName
"continuous"       , UnderlineMode
UnderlineModeNormal         )
                , ( StyleName
"skip-white-space" , UnderlineMode
UnderlineModeSkipWhitespace )
                ]


data ParaNumbering = NumberingNone | NumberingKeep | NumberingRestart Int
  deriving ( ParaNumbering -> ParaNumbering -> Bool
(ParaNumbering -> ParaNumbering -> Bool)
-> (ParaNumbering -> ParaNumbering -> Bool) -> Eq ParaNumbering
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParaNumbering -> ParaNumbering -> Bool
== :: ParaNumbering -> ParaNumbering -> Bool
$c/= :: ParaNumbering -> ParaNumbering -> Bool
/= :: ParaNumbering -> ParaNumbering -> Bool
Eq, Int -> ParaNumbering -> ShowS
[ParaNumbering] -> ShowS
ParaNumbering -> String
(Int -> ParaNumbering -> ShowS)
-> (ParaNumbering -> String)
-> ([ParaNumbering] -> ShowS)
-> Show ParaNumbering
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParaNumbering -> ShowS
showsPrec :: Int -> ParaNumbering -> ShowS
$cshow :: ParaNumbering -> String
show :: ParaNumbering -> String
$cshowList :: [ParaNumbering] -> ShowS
showList :: [ParaNumbering] -> ShowS
Show )

data LengthOrPercent = LengthValueMM Int | PercentValue Int
  deriving ( LengthOrPercent -> LengthOrPercent -> Bool
(LengthOrPercent -> LengthOrPercent -> Bool)
-> (LengthOrPercent -> LengthOrPercent -> Bool)
-> Eq LengthOrPercent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LengthOrPercent -> LengthOrPercent -> Bool
== :: LengthOrPercent -> LengthOrPercent -> Bool
$c/= :: LengthOrPercent -> LengthOrPercent -> Bool
/= :: LengthOrPercent -> LengthOrPercent -> Bool
Eq, Int -> LengthOrPercent -> ShowS
[LengthOrPercent] -> ShowS
LengthOrPercent -> String
(Int -> LengthOrPercent -> ShowS)
-> (LengthOrPercent -> String)
-> ([LengthOrPercent] -> ShowS)
-> Show LengthOrPercent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LengthOrPercent -> ShowS
showsPrec :: Int -> LengthOrPercent -> ShowS
$cshow :: LengthOrPercent -> String
show :: LengthOrPercent -> String
$cshowList :: [LengthOrPercent] -> ShowS
showList :: [LengthOrPercent] -> ShowS
Show )

instance Default LengthOrPercent where
  def :: LengthOrPercent
def = Int -> LengthOrPercent
LengthValueMM Int
0

instance Read LengthOrPercent where
  readsPrec :: Int -> ReadS LengthOrPercent
readsPrec Int
_ String
s =
      [ (Int -> LengthOrPercent
PercentValue  Int
percent  , String
s' ) | (Int
percent , String
s' ) <- ReadS Int
readPercent String
s]
   [(LengthOrPercent, String)]
-> [(LengthOrPercent, String)] -> [(LengthOrPercent, String)]
forall a. [a] -> [a] -> [a]
++ [ (Int -> LengthOrPercent
LengthValueMM Int
lengthMM , String
s'') | (Double
length' , String
s' ) <- ReadS Double
forall a. Read a => ReadS a
reads String
s
                                       , (XslUnit
unit    , String
s'') <- ReadS XslUnit
forall a. Read a => ReadS a
reads String
s'
                                       , let lengthMM :: Int
lengthMM = Double -> XslUnit -> Int
estimateInMillimeter
                                                                   Double
length' XslUnit
unit
                                       ]

data XslUnit = XslUnitMM | XslUnitCM
             | XslUnitInch
             | XslUnitPoints | XslUnitPica
             | XslUnitPixel
             | XslUnitEM

instance Show XslUnit where
  show :: XslUnit -> String
show XslUnit
XslUnitMM     = String
"mm"
  show XslUnit
XslUnitCM     = String
"cm"
  show XslUnit
XslUnitInch   = String
"in"
  show XslUnit
XslUnitPoints = String
"pt"
  show XslUnit
XslUnitPica   = String
"pc"
  show XslUnit
XslUnitPixel  = String
"px"
  show XslUnit
XslUnitEM     = String
"em"

instance Read XslUnit where
  readsPrec :: Int -> ReadS XslUnit
readsPrec Int
_ String
"mm" = [(XslUnit
XslUnitMM     , String
"")]
  readsPrec Int
_ String
"cm" = [(XslUnit
XslUnitCM     , String
"")]
  readsPrec Int
_ String
"in" = [(XslUnit
XslUnitInch   , String
"")]
  readsPrec Int
_ String
"pt" = [(XslUnit
XslUnitPoints , String
"")]
  readsPrec Int
_ String
"pc" = [(XslUnit
XslUnitPica   , String
"")]
  readsPrec Int
_ String
"px" = [(XslUnit
XslUnitPixel  , String
"")]
  readsPrec Int
_ String
"em" = [(XslUnit
XslUnitEM     , String
"")]
  readsPrec Int
_  String
_   = []

-- | 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 :: Double -> XslUnit -> Int
estimateInMillimeter :: Double -> XslUnit -> Int
estimateInMillimeter Double
n XslUnit
XslUnitMM     = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
n
estimateInMillimeter Double
n XslUnit
XslUnitCM     = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
n Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
10
estimateInMillimeter Double
n XslUnit
XslUnitInch   = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
n Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
25.4
estimateInMillimeter Double
n XslUnit
XslUnitPoints = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
n Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
72) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
25.4
estimateInMillimeter Double
n XslUnit
XslUnitPica   = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
n Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
12 Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
72) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
25.4
estimateInMillimeter Double
n XslUnit
XslUnitPixel  = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
n Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
72) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
25.4
estimateInMillimeter Double
n XslUnit
XslUnitEM     = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
n Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
16 Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
72) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
25.4


----
-- List styles
----

type ListLevel = Int

newtype ListStyle = ListStyle { ListStyle -> Map Int ListLevelStyle
levelStyles :: M.Map ListLevel ListLevelStyle
                              }
  deriving ( ListStyle -> ListStyle -> Bool
(ListStyle -> ListStyle -> Bool)
-> (ListStyle -> ListStyle -> Bool) -> Eq ListStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ListStyle -> ListStyle -> Bool
== :: ListStyle -> ListStyle -> Bool
$c/= :: ListStyle -> ListStyle -> Bool
/= :: ListStyle -> ListStyle -> Bool
Eq, Int -> ListStyle -> ShowS
[ListStyle] -> ShowS
ListStyle -> String
(Int -> ListStyle -> ShowS)
-> (ListStyle -> String)
-> ([ListStyle] -> ShowS)
-> Show ListStyle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ListStyle -> ShowS
showsPrec :: Int -> ListStyle -> ShowS
$cshow :: ListStyle -> String
show :: ListStyle -> String
$cshowList :: [ListStyle] -> ShowS
showList :: [ListStyle] -> ShowS
Show )

--
getListLevelStyle :: ListLevel -> ListStyle -> Maybe ListLevelStyle
getListLevelStyle :: Int -> ListStyle -> Maybe ListLevelStyle
getListLevelStyle Int
level ListStyle{Map Int ListLevelStyle
levelStyles :: ListStyle -> Map Int ListLevelStyle
levelStyles :: Map Int ListLevelStyle
..} =
  let (Map Int ListLevelStyle
lower , Maybe ListLevelStyle
exactHit , Map Int ListLevelStyle
_) = Int
-> Map Int ListLevelStyle
-> (Map Int ListLevelStyle, Maybe ListLevelStyle,
    Map Int ListLevelStyle)
forall k a. Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a)
M.splitLookup Int
level Map Int ListLevelStyle
levelStyles
  in  Maybe ListLevelStyle
exactHit Maybe ListLevelStyle
-> Maybe ListLevelStyle -> Maybe ListLevelStyle
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((ListLevelStyle, Map Int ListLevelStyle) -> ListLevelStyle)
-> Maybe (ListLevelStyle, Map Int ListLevelStyle)
-> Maybe ListLevelStyle
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ListLevelStyle, Map Int ListLevelStyle) -> ListLevelStyle
forall a b. (a, b) -> a
fst (Map Int ListLevelStyle
-> Maybe (ListLevelStyle, Map Int ListLevelStyle)
forall k a. Map k a -> Maybe (a, Map k a)
M.maxView Map Int ListLevelStyle
lower)
  -- findBy (`M.lookup` levelStyles) [level, (level-1) .. 1]
  -- \^ simpler, but in general less efficient

data ListLevelStyle = ListLevelStyle { ListLevelStyle -> ListLevelType
listLevelType  :: ListLevelType
                                     , ListLevelStyle -> Maybe StyleName
listItemPrefix :: Maybe Text
                                     , ListLevelStyle -> Maybe StyleName
listItemSuffix :: Maybe Text
                                     , ListLevelStyle -> ListItemNumberFormat
listItemFormat :: ListItemNumberFormat
                                     , ListLevelStyle -> Int
listItemStart  :: Int
                                     }
  deriving ( ListLevelStyle -> ListLevelStyle -> Bool
(ListLevelStyle -> ListLevelStyle -> Bool)
-> (ListLevelStyle -> ListLevelStyle -> Bool) -> Eq ListLevelStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ListLevelStyle -> ListLevelStyle -> Bool
== :: ListLevelStyle -> ListLevelStyle -> Bool
$c/= :: ListLevelStyle -> ListLevelStyle -> Bool
/= :: ListLevelStyle -> ListLevelStyle -> Bool
Eq, Eq ListLevelStyle
Eq ListLevelStyle =>
(ListLevelStyle -> ListLevelStyle -> Ordering)
-> (ListLevelStyle -> ListLevelStyle -> Bool)
-> (ListLevelStyle -> ListLevelStyle -> Bool)
-> (ListLevelStyle -> ListLevelStyle -> Bool)
-> (ListLevelStyle -> ListLevelStyle -> Bool)
-> (ListLevelStyle -> ListLevelStyle -> ListLevelStyle)
-> (ListLevelStyle -> ListLevelStyle -> ListLevelStyle)
-> Ord ListLevelStyle
ListLevelStyle -> ListLevelStyle -> Bool
ListLevelStyle -> ListLevelStyle -> Ordering
ListLevelStyle -> ListLevelStyle -> ListLevelStyle
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ListLevelStyle -> ListLevelStyle -> Ordering
compare :: ListLevelStyle -> ListLevelStyle -> Ordering
$c< :: ListLevelStyle -> ListLevelStyle -> Bool
< :: ListLevelStyle -> ListLevelStyle -> Bool
$c<= :: ListLevelStyle -> ListLevelStyle -> Bool
<= :: ListLevelStyle -> ListLevelStyle -> Bool
$c> :: ListLevelStyle -> ListLevelStyle -> Bool
> :: ListLevelStyle -> ListLevelStyle -> Bool
$c>= :: ListLevelStyle -> ListLevelStyle -> Bool
>= :: ListLevelStyle -> ListLevelStyle -> Bool
$cmax :: ListLevelStyle -> ListLevelStyle -> ListLevelStyle
max :: ListLevelStyle -> ListLevelStyle -> ListLevelStyle
$cmin :: ListLevelStyle -> ListLevelStyle -> ListLevelStyle
min :: ListLevelStyle -> ListLevelStyle -> ListLevelStyle
Ord )

instance Show ListLevelStyle where
  show :: ListLevelStyle -> String
show ListLevelStyle{Int
Maybe StyleName
ListItemNumberFormat
ListLevelType
listLevelType :: ListLevelStyle -> ListLevelType
listItemPrefix :: ListLevelStyle -> Maybe StyleName
listItemSuffix :: ListLevelStyle -> Maybe StyleName
listItemFormat :: ListLevelStyle -> ListItemNumberFormat
listItemStart :: ListLevelStyle -> Int
listLevelType :: ListLevelType
listItemPrefix :: Maybe StyleName
listItemSuffix :: Maybe StyleName
listItemFormat :: ListItemNumberFormat
listItemStart :: Int
..} =    String
"<LLS|"
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ ListLevelType -> String
forall a. Show a => a -> String
show ListLevelType
listLevelType
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"|"
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
maybeToString (StyleName -> String
T.unpack (StyleName -> String) -> Maybe StyleName -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe StyleName
listItemPrefix)
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ ListItemNumberFormat -> String
forall a. Show a => a -> String
show ListItemNumberFormat
listItemFormat
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
maybeToString (StyleName -> String
T.unpack (StyleName -> String) -> Maybe StyleName -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe StyleName
listItemSuffix)
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
    where maybeToString :: Maybe String -> String
maybeToString = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
""

data ListLevelType = LltBullet | LltImage | LltNumbered
  deriving ( ListLevelType -> ListLevelType -> Bool
(ListLevelType -> ListLevelType -> Bool)
-> (ListLevelType -> ListLevelType -> Bool) -> Eq ListLevelType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ListLevelType -> ListLevelType -> Bool
== :: ListLevelType -> ListLevelType -> Bool
$c/= :: ListLevelType -> ListLevelType -> Bool
/= :: ListLevelType -> ListLevelType -> Bool
Eq, Eq ListLevelType
Eq ListLevelType =>
(ListLevelType -> ListLevelType -> Ordering)
-> (ListLevelType -> ListLevelType -> Bool)
-> (ListLevelType -> ListLevelType -> Bool)
-> (ListLevelType -> ListLevelType -> Bool)
-> (ListLevelType -> ListLevelType -> Bool)
-> (ListLevelType -> ListLevelType -> ListLevelType)
-> (ListLevelType -> ListLevelType -> ListLevelType)
-> Ord ListLevelType
ListLevelType -> ListLevelType -> Bool
ListLevelType -> ListLevelType -> Ordering
ListLevelType -> ListLevelType -> ListLevelType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ListLevelType -> ListLevelType -> Ordering
compare :: ListLevelType -> ListLevelType -> Ordering
$c< :: ListLevelType -> ListLevelType -> Bool
< :: ListLevelType -> ListLevelType -> Bool
$c<= :: ListLevelType -> ListLevelType -> Bool
<= :: ListLevelType -> ListLevelType -> Bool
$c> :: ListLevelType -> ListLevelType -> Bool
> :: ListLevelType -> ListLevelType -> Bool
$c>= :: ListLevelType -> ListLevelType -> Bool
>= :: ListLevelType -> ListLevelType -> Bool
$cmax :: ListLevelType -> ListLevelType -> ListLevelType
max :: ListLevelType -> ListLevelType -> ListLevelType
$cmin :: ListLevelType -> ListLevelType -> ListLevelType
min :: ListLevelType -> ListLevelType -> ListLevelType
Ord, Int -> ListLevelType -> ShowS
[ListLevelType] -> ShowS
ListLevelType -> String
(Int -> ListLevelType -> ShowS)
-> (ListLevelType -> String)
-> ([ListLevelType] -> ShowS)
-> Show ListLevelType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ListLevelType -> ShowS
showsPrec :: Int -> ListLevelType -> ShowS
$cshow :: ListLevelType -> String
show :: ListLevelType -> String
$cshowList :: [ListLevelType] -> ShowS
showList :: [ListLevelType] -> ShowS
Show )

data ListItemNumberFormat = LinfNone
                          | LinfNumber
                          | LinfRomanLC | LinfRomanUC
                          | LinfAlphaLC | LinfAlphaUC
                          | LinfString String
  deriving ( ListItemNumberFormat -> ListItemNumberFormat -> Bool
(ListItemNumberFormat -> ListItemNumberFormat -> Bool)
-> (ListItemNumberFormat -> ListItemNumberFormat -> Bool)
-> Eq ListItemNumberFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
== :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
$c/= :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
/= :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
Eq, Eq ListItemNumberFormat
Eq ListItemNumberFormat =>
(ListItemNumberFormat -> ListItemNumberFormat -> Ordering)
-> (ListItemNumberFormat -> ListItemNumberFormat -> Bool)
-> (ListItemNumberFormat -> ListItemNumberFormat -> Bool)
-> (ListItemNumberFormat -> ListItemNumberFormat -> Bool)
-> (ListItemNumberFormat -> ListItemNumberFormat -> Bool)
-> (ListItemNumberFormat
    -> ListItemNumberFormat -> ListItemNumberFormat)
-> (ListItemNumberFormat
    -> ListItemNumberFormat -> ListItemNumberFormat)
-> Ord ListItemNumberFormat
ListItemNumberFormat -> ListItemNumberFormat -> Bool
ListItemNumberFormat -> ListItemNumberFormat -> Ordering
ListItemNumberFormat
-> ListItemNumberFormat -> ListItemNumberFormat
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ListItemNumberFormat -> ListItemNumberFormat -> Ordering
compare :: ListItemNumberFormat -> ListItemNumberFormat -> Ordering
$c< :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
< :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
$c<= :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
<= :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
$c> :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
> :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
$c>= :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
>= :: ListItemNumberFormat -> ListItemNumberFormat -> Bool
$cmax :: ListItemNumberFormat
-> ListItemNumberFormat -> ListItemNumberFormat
max :: ListItemNumberFormat
-> ListItemNumberFormat -> ListItemNumberFormat
$cmin :: ListItemNumberFormat
-> ListItemNumberFormat -> ListItemNumberFormat
min :: ListItemNumberFormat
-> ListItemNumberFormat -> ListItemNumberFormat
Ord )

instance Show ListItemNumberFormat where
  show :: ListItemNumberFormat -> String
show  ListItemNumberFormat
LinfNone      = String
""
  show  ListItemNumberFormat
LinfNumber    = String
"1"
  show  ListItemNumberFormat
LinfRomanLC   = String
"i"
  show  ListItemNumberFormat
LinfRomanUC   = String
"I"
  show  ListItemNumberFormat
LinfAlphaLC   = String
"a"
  show  ListItemNumberFormat
LinfAlphaUC   = String
"A"
  show (LinfString String
s) =  String
s

instance Default ListItemNumberFormat where
  def :: ListItemNumberFormat
def = ListItemNumberFormat
LinfNone

instance Read ListItemNumberFormat where
  readsPrec :: Int -> ReadS ListItemNumberFormat
readsPrec Int
_ String
""  = [(ListItemNumberFormat
LinfNone     , String
"")]
  readsPrec Int
_ String
"1" = [(ListItemNumberFormat
LinfNumber   , String
"")]
  readsPrec Int
_ String
"i" = [(ListItemNumberFormat
LinfRomanLC  , String
"")]
  readsPrec Int
_ String
"I" = [(ListItemNumberFormat
LinfRomanUC  , String
"")]
  readsPrec Int
_ String
"a" = [(ListItemNumberFormat
LinfAlphaLC  , String
"")]
  readsPrec Int
_ String
"A" = [(ListItemNumberFormat
LinfAlphaUC  , String
"")]
  readsPrec Int
_  String
s  = [(String -> ListItemNumberFormat
LinfString String
s , String
"")]

--------------------------------------------------------------------------------
-- 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 Styles
readAllStyles :: XMLConverter Namespace FontPitches Styles
readAllStyles = do
  XMLConverter Namespace FontPitches FontPitches
forall s. XMLConverter Namespace s FontPitches
fontPitchReader XMLConverter Namespace FontPitches FontPitches
-> (FontPitches
    -> ExceptT () (State (XMLConverterState Namespace FontPitches)) ())
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) ()
forall a b.
ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> (a
    -> ExceptT () (State (XMLConverterState Namespace FontPitches)) b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FontPitches
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) ()
forall extraState nsID.
extraState -> XMLConverter nsID extraState ()
setExtraState
  autoStyles <- XMLConverter Namespace FontPitches Styles
-> XMLConverter Namespace FontPitches (Fallible Styles)
forall nsID extraState a.
XMLConverter nsID extraState a
-> XMLConverter nsID extraState (Fallible a)
tryC XMLConverter Namespace FontPitches Styles
readAutomaticStyles
  styles     <- tryC readStyles
  fromFallible $ chooseMax autoStyles styles
 -- all top elements are always on the same hierarchy level

--
readStyles :: StyleReader Styles
readStyles :: XMLConverter Namespace FontPitches Styles
readStyles = Namespace
-> StyleName
-> XMLConverter Namespace FontPitches Styles
-> XMLConverter Namespace FontPitches Styles
forall nsID extraState a.
NameSpaceID nsID =>
nsID
-> StyleName
-> XMLConverter nsID extraState a
-> XMLConverter nsID extraState a
executeInSub Namespace
NsOffice StyleName
"styles" (XMLConverter Namespace FontPitches Styles
 -> XMLConverter Namespace FontPitches Styles)
-> XMLConverter Namespace FontPitches Styles
-> XMLConverter Namespace FontPitches Styles
forall a b. (a -> b) -> a -> b
$
  Map StyleName Style
-> Map StyleName ListStyle
-> Map StyleFamily StyleProperties
-> Styles
Styles (Map StyleName Style
 -> Map StyleName ListStyle
 -> Map StyleFamily StyleProperties
 -> Styles)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleName Style)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleName ListStyle
      -> Map StyleFamily StyleProperties -> Styles)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(StyleName, Style)] -> Map StyleName Style
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(StyleName, Style)] -> Map StyleName Style)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     [(StyleName, Style)]
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleName Style)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespace
-> StyleName
-> XMLConverter Namespace FontPitches (StyleName, Style)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     [(StyleName, Style)]
forall nsID extraState a.
NameSpaceID nsID =>
nsID
-> StyleName
-> XMLConverter nsID extraState a
-> XMLConverter nsID extraState [a]
tryAll Namespace
NsStyle StyleName
"style"         XMLConverter Namespace FontPitches (StyleName, Style)
readStyle       )
         ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (Map StyleName ListStyle
   -> Map StyleFamily StyleProperties -> Styles)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleName ListStyle)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleFamily StyleProperties -> Styles)
forall a b.
ExceptT
  () (State (XMLConverterState Namespace FontPitches)) (a -> b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([(StyleName, ListStyle)] -> Map StyleName ListStyle
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(StyleName, ListStyle)] -> Map StyleName ListStyle)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     [(StyleName, ListStyle)]
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleName ListStyle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespace
-> StyleName
-> XMLConverter Namespace FontPitches (StyleName, ListStyle)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     [(StyleName, ListStyle)]
forall nsID extraState a.
NameSpaceID nsID =>
nsID
-> StyleName
-> XMLConverter nsID extraState a
-> XMLConverter nsID extraState [a]
tryAll Namespace
NsText  StyleName
"list-style"    XMLConverter Namespace FontPitches (StyleName, ListStyle)
readListStyle   )
         ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (Map StyleFamily StyleProperties -> Styles)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleFamily StyleProperties)
-> XMLConverter Namespace FontPitches Styles
forall a b.
ExceptT
  () (State (XMLConverterState Namespace FontPitches)) (a -> b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([(StyleFamily, StyleProperties)] -> Map StyleFamily StyleProperties
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(StyleFamily, StyleProperties)]
 -> Map StyleFamily StyleProperties)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     [(StyleFamily, StyleProperties)]
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleFamily StyleProperties)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespace
-> StyleName
-> XMLConverter
     Namespace FontPitches (StyleFamily, StyleProperties)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     [(StyleFamily, StyleProperties)]
forall nsID extraState a.
NameSpaceID nsID =>
nsID
-> StyleName
-> XMLConverter nsID extraState a
-> XMLConverter nsID extraState [a]
tryAll Namespace
NsStyle StyleName
"default-style" XMLConverter Namespace FontPitches (StyleFamily, StyleProperties)
readDefaultStyle)

--
readAutomaticStyles :: StyleReader Styles
readAutomaticStyles :: XMLConverter Namespace FontPitches Styles
readAutomaticStyles = Namespace
-> StyleName
-> XMLConverter Namespace FontPitches Styles
-> XMLConverter Namespace FontPitches Styles
forall nsID extraState a.
NameSpaceID nsID =>
nsID
-> StyleName
-> XMLConverter nsID extraState a
-> XMLConverter nsID extraState a
executeInSub Namespace
NsOffice StyleName
"automatic-styles" (XMLConverter Namespace FontPitches Styles
 -> XMLConverter Namespace FontPitches Styles)
-> XMLConverter Namespace FontPitches Styles
-> XMLConverter Namespace FontPitches Styles
forall a b. (a -> b) -> a -> b
$
  Map StyleName Style
-> Map StyleName ListStyle
-> Map StyleFamily StyleProperties
-> Styles
Styles (Map StyleName Style
 -> Map StyleName ListStyle
 -> Map StyleFamily StyleProperties
 -> Styles)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleName Style)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleName ListStyle
      -> Map StyleFamily StyleProperties -> Styles)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(StyleName, Style)] -> Map StyleName Style
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(StyleName, Style)] -> Map StyleName Style)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     [(StyleName, Style)]
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleName Style)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespace
-> StyleName
-> XMLConverter Namespace FontPitches (StyleName, Style)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     [(StyleName, Style)]
forall nsID extraState a.
NameSpaceID nsID =>
nsID
-> StyleName
-> XMLConverter nsID extraState a
-> XMLConverter nsID extraState [a]
tryAll Namespace
NsStyle StyleName
"style"         XMLConverter Namespace FontPitches (StyleName, Style)
readStyle       )
         ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (Map StyleName ListStyle
   -> Map StyleFamily StyleProperties -> Styles)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleName ListStyle)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleFamily StyleProperties -> Styles)
forall a b.
ExceptT
  () (State (XMLConverterState Namespace FontPitches)) (a -> b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([(StyleName, ListStyle)] -> Map StyleName ListStyle
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(StyleName, ListStyle)] -> Map StyleName ListStyle)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     [(StyleName, ListStyle)]
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleName ListStyle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespace
-> StyleName
-> XMLConverter Namespace FontPitches (StyleName, ListStyle)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     [(StyleName, ListStyle)]
forall nsID extraState a.
NameSpaceID nsID =>
nsID
-> StyleName
-> XMLConverter nsID extraState a
-> XMLConverter nsID extraState [a]
tryAll Namespace
NsText  StyleName
"list-style"    XMLConverter Namespace FontPitches (StyleName, ListStyle)
readListStyle   )
         ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (Map StyleFamily StyleProperties -> Styles)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleFamily StyleProperties)
-> XMLConverter Namespace FontPitches Styles
forall a b.
ExceptT
  () (State (XMLConverterState Namespace FontPitches)) (a -> b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map StyleFamily StyleProperties
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Map StyleFamily StyleProperties)
forall a.
a -> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map StyleFamily StyleProperties
forall k a. Map k a
M.empty

--
readDefaultStyle :: StyleReader (StyleFamily, StyleProperties)
readDefaultStyle :: XMLConverter Namespace FontPitches (StyleFamily, StyleProperties)
readDefaultStyle = (,) (StyleFamily -> StyleProperties -> (StyleFamily, StyleProperties))
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) StyleFamily
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (StyleProperties -> (StyleFamily, StyleProperties))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespace
-> StyleName
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) StyleFamily
forall nsID a extraState.
(NameSpaceID nsID, Lookupable a) =>
nsID -> StyleName -> XMLConverter nsID extraState a
lookupAttr Namespace
NsStyle StyleName
"family"
                       ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (StyleProperties -> (StyleFamily, StyleProperties))
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     StyleProperties
-> XMLConverter
     Namespace FontPitches (StyleFamily, StyleProperties)
forall a b.
ExceptT
  () (State (XMLConverterState Namespace FontPitches)) (a -> b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  StyleProperties
readStyleProperties

--
readStyle :: StyleReader (StyleName, Style)
readStyle :: XMLConverter Namespace FontPitches (StyleName, Style)
readStyle = do
  name  <- Namespace
-> StyleName -> XMLConverter Namespace FontPitches StyleName
forall nsID extraState.
NameSpaceID nsID =>
nsID -> StyleName -> XMLConverter nsID extraState StyleName
findAttr Namespace
NsStyle StyleName
"name"
  style <- Style <$> lookupAttr' NsStyle "family"
                 <*> findAttr'   NsStyle "parent-style-name"
                 <*> findAttr'   NsStyle "list-style-name"
                 <*> readStyleProperties
  return (name, style)

--
readStyleProperties :: StyleReader StyleProperties
readStyleProperties :: ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  StyleProperties
readStyleProperties = Maybe TextProperties -> Maybe ParaProperties -> StyleProperties
SProps (Maybe TextProperties -> Maybe ParaProperties -> StyleProperties)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Maybe TextProperties)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Maybe ParaProperties -> StyleProperties)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT
  () (State (XMLConverterState Namespace FontPitches)) TextProperties
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Maybe TextProperties)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ExceptT
  () (State (XMLConverterState Namespace FontPitches)) TextProperties
readTextProperties
                             ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (Maybe ParaProperties -> StyleProperties)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Maybe ParaProperties)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     StyleProperties
forall a b.
ExceptT
  () (State (XMLConverterState Namespace FontPitches)) (a -> b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ExceptT
  () (State (XMLConverterState Namespace FontPitches)) ParaProperties
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Maybe ParaProperties)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ExceptT
  () (State (XMLConverterState Namespace FontPitches)) ParaProperties
readParaProperties

--
readTextProperties :: StyleReader TextProperties
readTextProperties :: ExceptT
  () (State (XMLConverterState Namespace FontPitches)) TextProperties
readTextProperties =
  Namespace
-> StyleName
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) TextProperties
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) TextProperties
forall nsID extraState a.
NameSpaceID nsID =>
nsID
-> StyleName
-> XMLConverter nsID extraState a
-> XMLConverter nsID extraState a
executeInSub Namespace
NsStyle StyleName
"text-properties" (ExceptT
   () (State (XMLConverterState Namespace FontPitches)) TextProperties
 -> ExceptT
      ()
      (State (XMLConverterState Namespace FontPitches))
      TextProperties)
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) TextProperties
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) TextProperties
forall a b. (a -> b) -> a -> b
$
    Bool
-> Bool
-> Maybe FontPitch
-> VerticalTextPosition
-> Maybe UnderlineMode
-> Maybe UnderlineMode
-> TextProperties
PropT (Bool
 -> Bool
 -> Maybe FontPitch
 -> VerticalTextPosition
 -> Maybe UnderlineMode
 -> Maybe UnderlineMode
 -> TextProperties)
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) Bool
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Bool
      -> Maybe FontPitch
      -> VerticalTextPosition
      -> Maybe UnderlineMode
      -> Maybe UnderlineMode
      -> TextProperties)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespace
-> StyleName
-> Bool
-> [(StyleName, Bool)]
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) Bool
forall nsID a extraState.
NameSpaceID nsID =>
nsID
-> StyleName
-> a
-> [(StyleName, a)]
-> XMLConverter nsID extraState a
searchAttr Namespace
NsXSL_FO StyleName
"font-style"  Bool
False [(StyleName, Bool)]
isFontEmphasised
          ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (Bool
   -> Maybe FontPitch
   -> VerticalTextPosition
   -> Maybe UnderlineMode
   -> Maybe UnderlineMode
   -> TextProperties)
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) Bool
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Maybe FontPitch
      -> VerticalTextPosition
      -> Maybe UnderlineMode
      -> Maybe UnderlineMode
      -> TextProperties)
forall a b.
ExceptT
  () (State (XMLConverterState Namespace FontPitches)) (a -> b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Namespace
-> StyleName
-> Bool
-> [(StyleName, Bool)]
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) Bool
forall nsID a extraState.
NameSpaceID nsID =>
nsID
-> StyleName
-> a
-> [(StyleName, a)]
-> XMLConverter nsID extraState a
searchAttr Namespace
NsXSL_FO StyleName
"font-weight" Bool
False [(StyleName, Bool)]
isFontBold
          ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (Maybe FontPitch
   -> VerticalTextPosition
   -> Maybe UnderlineMode
   -> Maybe UnderlineMode
   -> TextProperties)
-> StyleReader (Maybe FontPitch)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (VerticalTextPosition
      -> Maybe UnderlineMode -> Maybe UnderlineMode -> TextProperties)
forall a b.
ExceptT
  () (State (XMLConverterState Namespace FontPitches)) (a -> b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StyleReader (Maybe FontPitch)
findPitch
          ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (VerticalTextPosition
   -> Maybe UnderlineMode -> Maybe UnderlineMode -> TextProperties)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     VerticalTextPosition
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Maybe UnderlineMode -> Maybe UnderlineMode -> TextProperties)
forall a b.
ExceptT
  () (State (XMLConverterState Namespace FontPitches)) (a -> b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Namespace
-> StyleName
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     VerticalTextPosition
forall nsID attrValue extraState.
(NameSpaceID nsID, Read attrValue, Default attrValue) =>
nsID -> StyleName -> XMLConverter nsID extraState attrValue
getAttr    Namespace
NsStyle  StyleName
"text-position"
          ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (Maybe UnderlineMode -> Maybe UnderlineMode -> TextProperties)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Maybe UnderlineMode)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Maybe UnderlineMode -> TextProperties)
forall a b.
ExceptT
  () (State (XMLConverterState Namespace FontPitches)) (a -> b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (Maybe UnderlineMode)
readUnderlineMode
          ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (Maybe UnderlineMode -> TextProperties)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Maybe UnderlineMode)
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) TextProperties
forall a b.
ExceptT
  () (State (XMLConverterState Namespace FontPitches)) (a -> b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (Maybe UnderlineMode)
readStrikeThroughMode
  where isFontEmphasised :: [(StyleName, Bool)]
isFontEmphasised = [(StyleName
"normal",Bool
False),(StyleName
"italic",Bool
True),(StyleName
"oblique",Bool
True)]
        -- As in CSS, `bold` is weight 700; lighter weights are not bold.
        isFontBold :: [(StyleName, Bool)]
isFontBold = (StyleName
"normal",Bool
False)(StyleName, Bool) -> [(StyleName, Bool)] -> [(StyleName, Bool)]
forall a. a -> [a] -> [a]
:(StyleName
"bold",Bool
True)
                    (StyleName, Bool) -> [(StyleName, Bool)] -> [(StyleName, Bool)]
forall a. a -> [a] -> [a]
:(Int -> (StyleName, Bool)) -> [Int] -> [(StyleName, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
w -> (Int -> StyleName
forall a. Show a => a -> StyleName
tshow Int
w, Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
700)) ([Int
100,Int
200..Int
900]::[Int])

readUnderlineMode     :: StyleReader (Maybe UnderlineMode)
readUnderlineMode :: ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (Maybe UnderlineMode)
readUnderlineMode     = StyleName
-> StyleName
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Maybe UnderlineMode)
readLineMode StyleName
"text-underline-mode"
                                     StyleName
"text-underline-style"

readStrikeThroughMode :: StyleReader (Maybe UnderlineMode)
readStrikeThroughMode :: ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (Maybe UnderlineMode)
readStrikeThroughMode = StyleName
-> StyleName
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Maybe UnderlineMode)
readLineMode StyleName
"text-line-through-mode"
                                     StyleName
"text-line-through-style"

readLineMode :: Text -> Text -> StyleReader (Maybe UnderlineMode)
readLineMode :: StyleName
-> StyleName
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Maybe UnderlineMode)
readLineMode StyleName
modeAttr StyleName
styleAttr = do
  isUL <- Namespace
-> StyleName
-> Bool
-> [(StyleName, Bool)]
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) Bool
forall nsID a extraState.
NameSpaceID nsID =>
nsID
-> StyleName
-> a
-> [(StyleName, a)]
-> XMLConverter nsID extraState a
searchAttr  Namespace
NsStyle StyleName
styleAttr Bool
False [(StyleName, Bool)]
isLinePresent
  mode <- lookupAttr' NsStyle  modeAttr
  return $ if isUL
             then mode <|> Just UnderlineModeNormal
             else Nothing
  where
    isLinePresent :: [(StyleName, Bool)]
isLinePresent = (StyleName
"none",Bool
False) (StyleName, Bool) -> [(StyleName, Bool)] -> [(StyleName, Bool)]
forall a. a -> [a] -> [a]
: (StyleName -> (StyleName, Bool))
-> [StyleName] -> [(StyleName, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (,Bool
True)
                    [ StyleName
"dash"      , StyleName
"dot-dash" , StyleName
"dot-dot-dash" , StyleName
"dotted"
                    , StyleName
"long-dash" , StyleName
"solid"    , StyleName
"wave"
                    ]

--
readParaProperties :: StyleReader ParaProperties
readParaProperties :: ExceptT
  () (State (XMLConverterState Namespace FontPitches)) ParaProperties
readParaProperties =
  Namespace
-> StyleName
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) ParaProperties
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) ParaProperties
forall nsID extraState a.
NameSpaceID nsID =>
nsID
-> StyleName
-> XMLConverter nsID extraState a
-> XMLConverter nsID extraState a
executeInSub Namespace
NsStyle StyleName
"paragraph-properties" (ExceptT
   () (State (XMLConverterState Namespace FontPitches)) ParaProperties
 -> ExceptT
      ()
      (State (XMLConverterState Namespace FontPitches))
      ParaProperties)
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) ParaProperties
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) ParaProperties
forall a b. (a -> b) -> a -> b
$
    ParaNumbering
-> LengthOrPercent -> LengthOrPercent -> ParaProperties
PropP (ParaNumbering
 -> LengthOrPercent -> LengthOrPercent -> ParaProperties)
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) ParaNumbering
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (LengthOrPercent -> LengthOrPercent -> ParaProperties)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( Maybe Bool -> Maybe Int -> ParaNumbering
readNumbering
                  (Maybe Bool -> Maybe Int -> ParaNumbering)
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) (Maybe Bool)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (Maybe Int -> ParaNumbering)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespace
-> StyleName
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) (Maybe Bool)
forall nsID extraState.
NameSpaceID nsID =>
nsID -> StyleName -> XMLConverter nsID extraState (Maybe Bool)
isSet'    Namespace
NsText StyleName
"number-lines"
                  ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (Maybe Int -> ParaNumbering)
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) (Maybe Int)
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) ParaNumbering
forall a b.
ExceptT
  () (State (XMLConverterState Namespace FontPitches)) (a -> b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Namespace
-> StyleName
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) (Maybe Int)
forall nsID attrValue extraState.
(NameSpaceID nsID, Read attrValue) =>
nsID -> StyleName -> XMLConverter nsID extraState (Maybe attrValue)
readAttr' Namespace
NsText StyleName
"line-number" )
          ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (LengthOrPercent -> LengthOrPercent -> ParaProperties)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     LengthOrPercent
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (LengthOrPercent -> ParaProperties)
forall a b.
ExceptT
  () (State (XMLConverterState Namespace FontPitches)) (a -> b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( Bool -> LengthOrPercent -> LengthOrPercent
forall {p}. Default p => Bool -> p -> p
readIndentation
                  (Bool -> LengthOrPercent -> LengthOrPercent)
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) Bool
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (LengthOrPercent -> LengthOrPercent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespace
-> StyleName
-> Bool
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) Bool
forall nsID extraState.
NameSpaceID nsID =>
nsID -> StyleName -> Bool -> XMLConverter nsID extraState Bool
isSetWithDefault Namespace
NsStyle  StyleName
"auto-text-indent" Bool
False
                  ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (LengthOrPercent -> LengthOrPercent)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     LengthOrPercent
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     LengthOrPercent
forall a b.
ExceptT
  () (State (XMLConverterState Namespace FontPitches)) (a -> b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Namespace
-> StyleName
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     LengthOrPercent
forall nsID attrValue extraState.
(NameSpaceID nsID, Read attrValue, Default attrValue) =>
nsID -> StyleName -> XMLConverter nsID extraState attrValue
getAttr          Namespace
NsXSL_FO StyleName
"text-indent" )
          ExceptT
  ()
  (State (XMLConverterState Namespace FontPitches))
  (LengthOrPercent -> ParaProperties)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     LengthOrPercent
-> ExceptT
     () (State (XMLConverterState Namespace FontPitches)) ParaProperties
forall a b.
ExceptT
  () (State (XMLConverterState Namespace FontPitches)) (a -> b)
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) a
-> ExceptT () (State (XMLConverterState Namespace FontPitches)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Namespace
-> StyleName
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     LengthOrPercent
forall nsID attrValue extraState.
(NameSpaceID nsID, Read attrValue, Default attrValue) =>
nsID -> StyleName -> XMLConverter nsID extraState attrValue
getAttr Namespace
NsXSL_FO StyleName
"margin-left"
  where readNumbering :: Maybe Bool -> Maybe Int -> ParaNumbering
readNumbering (Just Bool
True) (Just Int
n) = Int -> ParaNumbering
NumberingRestart Int
n
        readNumbering (Just Bool
True)  Maybe Int
_       = ParaNumbering
NumberingKeep
        readNumbering      Maybe Bool
_       Maybe Int
_       = ParaNumbering
NumberingNone

        readIndentation :: Bool -> p -> p
readIndentation Bool
False p
indent = p
indent
        readIndentation Bool
True  p
_      = p
forall a. Default a => a
def

----
-- List styles
----

--
readListStyle :: StyleReader (StyleName, ListStyle)
readListStyle :: XMLConverter Namespace FontPitches (StyleName, ListStyle)
readListStyle = do
  name   <- Namespace
-> StyleName -> XMLConverter Namespace FontPitches StyleName
forall nsID extraState.
NameSpaceID nsID =>
nsID -> StyleName -> XMLConverter nsID extraState StyleName
findAttr Namespace
NsStyle StyleName
"name"
  styles <- SM.union3
              <$> readListLevelStyles NsText "list-level-style-number" LltNumbered
              <*> readListLevelStyles NsText "list-level-style-bullet" LltBullet
              <*> readListLevelStyles NsText "list-level-style-image"  LltImage
  return ( name
         , ListStyle $ M.mapMaybe chooseMostSpecificListLevelStyle styles )

--
readListLevelStyles :: Namespace -> ElementName
                    -> ListLevelType
                    -> StyleReader (SM.SetMap Int ListLevelStyle)
readListLevelStyles :: Namespace
-> StyleName
-> ListLevelType
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (SetMap Int ListLevelStyle)
readListLevelStyles Namespace
namespace StyleName
elementName ListLevelType
levelType =
  [(Int, ListLevelStyle)] -> SetMap Int ListLevelStyle
forall k v. (Ord k, Ord v) => [(k, v)] -> SetMap k v
SM.fromList ([(Int, ListLevelStyle)] -> SetMap Int ListLevelStyle)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     [(Int, ListLevelStyle)]
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     (SetMap Int ListLevelStyle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespace
-> StyleName
-> XMLConverter Namespace FontPitches (Int, ListLevelStyle)
-> ExceptT
     ()
     (State (XMLConverterState Namespace FontPitches))
     [(Int, ListLevelStyle)]
forall nsID extraState a.
NameSpaceID nsID =>
nsID
-> StyleName
-> XMLConverter nsID extraState a
-> XMLConverter nsID extraState [a]
tryAll Namespace
namespace StyleName
elementName (ListLevelType
-> XMLConverter Namespace FontPitches (Int, ListLevelStyle)
readListLevelStyle ListLevelType
levelType)

--
readListLevelStyle :: ListLevelType -> StyleReader (Int, ListLevelStyle)
readListLevelStyle :: ListLevelType
-> XMLConverter Namespace FontPitches (Int, ListLevelStyle)
readListLevelStyle ListLevelType
levelType = do
  level <- Namespace -> StyleName -> XMLConverter Namespace FontPitches Int
forall nsID attrValue extraState.
(NameSpaceID nsID, Read attrValue) =>
nsID -> StyleName -> XMLConverter nsID extraState attrValue
readAttr Namespace
NsText StyleName
"level"
  style <- toListLevelStyle
             <$> findAttr' NsStyle "num-prefix"
             <*> findAttr' NsStyle "num-suffix"
             <*> getAttr   NsStyle "num-format"
             <*> findAttr' NsText  "start-value"
  return (level, style)
  where
  toListLevelStyle :: Maybe StyleName
-> Maybe StyleName
-> ListItemNumberFormat
-> Maybe StyleName
-> ListLevelStyle
toListLevelStyle Maybe StyleName
p Maybe StyleName
s ListItemNumberFormat
LinfNone Maybe StyleName
b         = ListLevelType
-> Maybe StyleName
-> Maybe StyleName
-> ListItemNumberFormat
-> Int
-> ListLevelStyle
ListLevelStyle ListLevelType
LltBullet Maybe StyleName
p Maybe StyleName
s ListItemNumberFormat
LinfNone (Maybe StyleName -> Int
forall {a}. (Num a, Read a) => Maybe StyleName -> a
startValue Maybe StyleName
b)
  toListLevelStyle Maybe StyleName
p Maybe StyleName
s f :: ListItemNumberFormat
f@(LinfString String
_) Maybe StyleName
b = ListLevelType
-> Maybe StyleName
-> Maybe StyleName
-> ListItemNumberFormat
-> Int
-> ListLevelStyle
ListLevelStyle ListLevelType
LltBullet Maybe StyleName
p Maybe StyleName
s ListItemNumberFormat
f (Maybe StyleName -> Int
forall {a}. (Num a, Read a) => Maybe StyleName -> a
startValue Maybe StyleName
b)
  toListLevelStyle Maybe StyleName
p Maybe StyleName
s ListItemNumberFormat
f Maybe StyleName
b                = ListLevelType
-> Maybe StyleName
-> Maybe StyleName
-> ListItemNumberFormat
-> Int
-> ListLevelStyle
ListLevelStyle ListLevelType
levelType Maybe StyleName
p Maybe StyleName
s ListItemNumberFormat
f (Maybe StyleName -> Int
forall {a}. (Num a, Read a) => Maybe StyleName -> a
startValue Maybe StyleName
b)
  startValue :: Maybe StyleName -> a
startValue Maybe StyleName
mbx = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
1 (Maybe StyleName
mbx Maybe StyleName -> (StyleName -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StyleName -> Maybe a
forall (m :: * -> *) a. (MonadPlus m, Read a) => StyleName -> m a
safeRead)

--
chooseMostSpecificListLevelStyle :: S.Set ListLevelStyle -> Maybe ListLevelStyle
chooseMostSpecificListLevelStyle :: Set ListLevelStyle -> Maybe ListLevelStyle
chooseMostSpecificListLevelStyle Set ListLevelStyle
ls = (ListLevelStyle -> Maybe ListLevelStyle -> Maybe ListLevelStyle)
-> Maybe ListLevelStyle
-> Set ListLevelStyle
-> Maybe ListLevelStyle
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr ListLevelStyle -> Maybe ListLevelStyle -> Maybe ListLevelStyle
select Maybe ListLevelStyle
forall a. Maybe a
Nothing Set ListLevelStyle
ls
  where
   select :: ListLevelStyle -> Maybe ListLevelStyle -> Maybe ListLevelStyle
select ListLevelStyle
l Maybe ListLevelStyle
Nothing = ListLevelStyle -> Maybe ListLevelStyle
forall a. a -> Maybe a
Just ListLevelStyle
l
   select ( ListLevelStyle ListLevelType
t1 Maybe StyleName
p1 Maybe StyleName
s1 ListItemNumberFormat
f1 Int
b1 )
          ( Just ( ListLevelStyle ListLevelType
t2 Maybe StyleName
p2 Maybe StyleName
s2 ListItemNumberFormat
f2 Int
_ ))
        =   ListLevelStyle -> Maybe ListLevelStyle
forall a. a -> Maybe a
Just (ListLevelStyle -> Maybe ListLevelStyle)
-> ListLevelStyle -> Maybe ListLevelStyle
forall a b. (a -> b) -> a -> b
$ ListLevelType
-> Maybe StyleName
-> Maybe StyleName
-> ListItemNumberFormat
-> Int
-> ListLevelStyle
ListLevelStyle (ListLevelType -> ListLevelType -> ListLevelType
select' ListLevelType
t1 ListLevelType
t2) (Maybe StyleName
p1 Maybe StyleName -> Maybe StyleName -> Maybe StyleName
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe StyleName
p2) (Maybe StyleName
s1 Maybe StyleName -> Maybe StyleName -> Maybe StyleName
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe StyleName
s2)
                                  (ListItemNumberFormat
-> ListItemNumberFormat -> ListItemNumberFormat
selectLinf ListItemNumberFormat
f1 ListItemNumberFormat
f2) Int
b1
   select' :: ListLevelType -> ListLevelType -> ListLevelType
select' ListLevelType
LltNumbered ListLevelType
_           = ListLevelType
LltNumbered
   select' ListLevelType
_           ListLevelType
LltNumbered = ListLevelType
LltNumbered
   select' ListLevelType
_           ListLevelType
_           = ListLevelType
LltBullet
   selectLinf :: ListItemNumberFormat
-> ListItemNumberFormat -> ListItemNumberFormat
selectLinf ListItemNumberFormat
LinfNone       ListItemNumberFormat
f2             = ListItemNumberFormat
f2
   selectLinf ListItemNumberFormat
f1             ListItemNumberFormat
LinfNone       = ListItemNumberFormat
f1
   selectLinf (LinfString String
_) ListItemNumberFormat
f2             = ListItemNumberFormat
f2
   selectLinf ListItemNumberFormat
f1             (LinfString String
_) = ListItemNumberFormat
f1
   selectLinf ListItemNumberFormat
f1             ListItemNumberFormat
_              = ListItemNumberFormat
f1


--------------------------------------------------------------------------------
-- Tools to access style data
--------------------------------------------------------------------------------

--
lookupStyle           :: StyleName   -> Styles -> Maybe Style
lookupStyle :: StyleName -> Styles -> Maybe Style
lookupStyle StyleName
name Styles{Map StyleName ListStyle
Map StyleName Style
Map StyleFamily StyleProperties
stylesByName :: Styles -> Map StyleName Style
listStylesByName :: Styles -> Map StyleName ListStyle
defaultStyleMap :: Styles -> Map StyleFamily StyleProperties
stylesByName :: Map StyleName Style
listStylesByName :: Map StyleName ListStyle
defaultStyleMap :: Map StyleFamily StyleProperties
..} = StyleName -> Map StyleName Style -> Maybe Style
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup StyleName
name Map StyleName Style
stylesByName

--
lookupDefaultStyle'   :: Styles -> StyleFamily -> StyleProperties
lookupDefaultStyle' :: Styles -> StyleFamily -> StyleProperties
lookupDefaultStyle' Styles{Map StyleName ListStyle
Map StyleName Style
Map StyleFamily StyleProperties
stylesByName :: Styles -> Map StyleName Style
listStylesByName :: Styles -> Map StyleName ListStyle
defaultStyleMap :: Styles -> Map StyleFamily StyleProperties
stylesByName :: Map StyleName Style
listStylesByName :: Map StyleName ListStyle
defaultStyleMap :: Map StyleFamily StyleProperties
..} StyleFamily
family = StyleProperties -> Maybe StyleProperties -> StyleProperties
forall a. a -> Maybe a -> a
fromMaybe StyleProperties
forall a. Default a => a
def
                                        (StyleFamily
-> Map StyleFamily StyleProperties -> Maybe StyleProperties
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup StyleFamily
family Map StyleFamily StyleProperties
defaultStyleMap)

--
lookupListStyleByName :: StyleName   -> Styles -> Maybe ListStyle
lookupListStyleByName :: StyleName -> Styles -> Maybe ListStyle
lookupListStyleByName StyleName
name Styles{Map StyleName ListStyle
Map StyleName Style
Map StyleFamily StyleProperties
stylesByName :: Styles -> Map StyleName Style
listStylesByName :: Styles -> Map StyleName ListStyle
defaultStyleMap :: Styles -> Map StyleFamily StyleProperties
stylesByName :: Map StyleName Style
listStylesByName :: Map StyleName ListStyle
defaultStyleMap :: Map StyleFamily StyleProperties
..} = StyleName -> Map StyleName ListStyle -> Maybe ListStyle
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup StyleName
name Map StyleName ListStyle
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.
-- Note that @style:parent-style-name@ references can be cyclic, so we
-- keep track of the names already seen to avoid looping forever.
parents               :: Style       -> Styles ->      [Style]
parents :: Style -> Styles -> [Style]
parents Style
style Styles
styles = Set StyleName -> Style -> [Style]
go Set StyleName
forall a. Set a
S.empty Style
style
  where
    go :: Set StyleName -> Style -> [Style]
go Set StyleName
seen Style{Maybe StyleName
Maybe StyleFamily
StyleProperties
styleFamily :: Style -> Maybe StyleFamily
styleParentName :: Style -> Maybe StyleName
listStyle :: Style -> Maybe StyleName
styleProperties :: Style -> StyleProperties
styleFamily :: Maybe StyleFamily
styleParentName :: Maybe StyleName
listStyle :: Maybe StyleName
styleProperties :: StyleProperties
..}
      | Just StyleName
name <- Maybe StyleName
styleParentName
      , Bool -> Bool
not (StyleName
name StyleName -> Set StyleName -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set StyleName
seen)
      , Just Style
parent <- StyleName -> Styles -> Maybe Style
lookupStyle StyleName
name Styles
styles
      = Style
parent Style -> [Style] -> [Style]
forall a. a -> [a] -> [a]
: Set StyleName -> Style -> [Style]
go (StyleName -> Set StyleName -> Set StyleName
forall a. Ord a => a -> Set a -> Set a
S.insert StyleName
name Set StyleName
seen) Style
parent
      | Bool
otherwise
      = []

-- | Looks up the style family of the current style. Normally, every style
-- should have one. But if not, all parents are searched.
-- Searching the parents recursively would repeatedly walk the same
-- chains, taking time exponential in its length; the chain is linear,
-- so we can just walk it once.
getStyleFamily        :: Style       -> Styles -> Maybe StyleFamily
getStyleFamily :: Style -> Styles -> Maybe StyleFamily
getStyleFamily Style
style Styles
styles
  = [Maybe StyleFamily] -> Maybe StyleFamily
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
F.asum ([Maybe StyleFamily] -> Maybe StyleFamily)
-> [Maybe StyleFamily] -> Maybe StyleFamily
forall a b. (a -> b) -> a -> b
$ (Style -> Maybe StyleFamily) -> [Style] -> [Maybe StyleFamily]
forall a b. (a -> b) -> [a] -> [b]
map Style -> Maybe StyleFamily
styleFamily ([Style] -> [Maybe StyleFamily]) -> [Style] -> [Maybe StyleFamily]
forall a b. (a -> b) -> a -> b
$ Style
style Style -> [Style] -> [Style]
forall a. a -> [a] -> [a]
: Style -> Styles -> [Style]
parents Style
style Styles
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 -> [StyleProperties]
stylePropertyChain Style
style Styles
styles
  = (Style -> StyleProperties) -> [Style] -> [StyleProperties]
forall a b. (a -> b) -> [a] -> [b]
map Style -> StyleProperties
styleProperties (Style
style Style -> [Style] -> [Style]
forall a. a -> [a] -> [a]
: Style -> Styles -> [Style]
parents Style
style Styles
styles)

--
extendedStylePropertyChain :: [Style] -> Styles -> [StyleProperties]
extendedStylePropertyChain :: [Style] -> Styles -> [StyleProperties]
extendedStylePropertyChain [] Styles
_ = []
extendedStylePropertyChain [Style
style]       Styles
styles =    Style -> Styles -> [StyleProperties]
stylePropertyChain Style
style Styles
styles
                                                  [StyleProperties] -> [StyleProperties] -> [StyleProperties]
forall a. [a] -> [a] -> [a]
++ Maybe StyleProperties -> [StyleProperties]
forall a. Maybe a -> [a]
maybeToList ((StyleFamily -> StyleProperties)
-> Maybe StyleFamily -> Maybe StyleProperties
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Styles -> StyleFamily -> StyleProperties
lookupDefaultStyle' Styles
styles) (Style -> Styles -> Maybe StyleFamily
getStyleFamily Style
style Styles
styles))
extendedStylePropertyChain (Style
style:[Style]
trace) Styles
styles =    Style -> Styles -> [StyleProperties]
stylePropertyChain Style
style Styles
styles
                                                  [StyleProperties] -> [StyleProperties] -> [StyleProperties]
forall a. [a] -> [a] -> [a]
++ [Style] -> Styles -> [StyleProperties]
extendedStylePropertyChain [Style]
trace Styles
styles